From 8e8c8d193408f9efdeb9188540bcb379b845ab40 Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Wed, 24 Sep 2025 18:56:24 -0400 Subject: [PATCH 01/12] BUG fixes margin-setting for svg printout also avoids error in cases with an NA in the std.diff column --- DESCRIPTION | 2 +- R/plot.xbal.R | 3 ++- tests/testthat/test.plot.xbal.R | 21 ++++++++++++++++++++- 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 675e5ec..5ffc78c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: RItools -Version: 0.3-5 +Version: 0.3-5.9001 Title: Randomization Inference Tools Authors@R: c(person("Jake", "Bowers", role = c("aut", "cre"), email = "jwbowers@illinois.edu"), person("Mark", "Fredrickson", role = "aut", email = "mark.m.fredrickson@gmail.com"), diff --git a/R/plot.xbal.R b/R/plot.xbal.R index 6d74b7b..7472c90 100644 --- a/R/plot.xbal.R +++ b/R/plot.xbal.R @@ -338,7 +338,8 @@ balanceplot <- function(x, par(mai = mai) } else { mar <- par("mar") - mar[2] <- max(nchar(x)) + mar[2] # assume one line per character + mar[2] <- max(nchar(rownames(x))) + # assume one line per character + mar[2] par(mar = mar) } diff --git a/tests/testthat/test.plot.xbal.R b/tests/testthat/test.plot.xbal.R index 3ff6540..a99ca6f 100644 --- a/tests/testthat/test.plot.xbal.R +++ b/tests/testthat/test.plot.xbal.R @@ -166,10 +166,29 @@ test_that("Issue 21: Cairo/pango errors when running plot.xbal", { # at the moment, I haven't found a way to capture the stderr output from the C level pango function # so, we'll just have to know that if the errors appear in the output stream during testing # we should come here to see the test case (not the best strategy) + svg(tmpo) + plot(xb) + dev.off() + file.remove(tmpo) + bt <- balanceTest(z ~ x+ y, data=data) tmpf <- tempfile() svg(tmpf) - plot(xb) + plot(bt) + dev.off() + + file.remove(tmpf) + tmpf <- tempfile() + svg(tmpf) + plot.xbal(bt, ggplot=FALSE) + dev.off() + file.remove(tmpf) + + bt$results["y", "std.diff",1] <- NA + + tmpf <- tempfile() + svg(tmpf) + plot.xbal(bt, ggplot=FALSE) dev.off() file.remove(tmpf) } From 4ef29c2926d341334bcf829b27fad5e439f80864 Mon Sep 17 00:00:00 2001 From: "Ben B. Hansen" Date: Wed, 24 Sep 2025 21:49:51 -0400 Subject: [PATCH 02/12] TST strengthen check cairo availability ... I think. To be be tested by CI but I can't confirm locally --- tests/testthat/test.plot.xbal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test.plot.xbal.R b/tests/testthat/test.plot.xbal.R index a99ca6f..5b97966 100644 --- a/tests/testthat/test.plot.xbal.R +++ b/tests/testthat/test.plot.xbal.R @@ -152,7 +152,7 @@ test_that("Generic balance plots", { test_that("Issue 21: Cairo/pango errors when running plot.xbal", { - if (capabilities()["cairo"]) { + if (capabilities()["cairo"] && nchar(grSoftVersion()["cairo"])>0) { set.seed(20130522) z <- rbinom(100, size = 1, prob = 1/2) From 78393cb830f17434999d47b1d1d06084dab85d7d Mon Sep 17 00:00:00 2001 From: "Ben B. Hansen" Date: Thu, 25 Sep 2025 21:46:16 -0400 Subject: [PATCH 03/12] DOC update news --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index 10920be..39eabac 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# RItools {NEXTVERSION} + +* Bug fix (base R plot method svg export) + # RItools 0.3-5 * Now "Depends" on the `survival` package to bring in the `strata` and `cluster` From 58069a32a65d1d1b396e31c3c06fe76ad53e9c8f Mon Sep 17 00:00:00 2001 From: "Ben B. Hansen" Date: Sat, 27 Sep 2025 17:33:00 -0400 Subject: [PATCH 04/12] BUG avoid edge case stop namely, edge case that variable names of bal plot is a length-0 vector --- R/plot.xbal.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/plot.xbal.R b/R/plot.xbal.R index 7472c90..100402e 100644 --- a/R/plot.xbal.R +++ b/R/plot.xbal.R @@ -334,11 +334,15 @@ balanceplot <- function(x, if (names(dev.cur()) != "svg") { mai <- par('mai') - mai[2] <- max(strwidth(rownames(x), units = "inches")) + mai[2] + mai[2] <- max(c(strwidth(rownames(x), units = "inches"), + 0)# avoids returning -Inf in case `x` has length 0 + ) + mai[2] par(mai = mai) } else { mar <- par("mar") - mar[2] <- max(nchar(rownames(x))) + # assume one line per character + mar[2] <- max(c(nchar(rownames(x)), + 0) # avoids returning -Inf in case `x` has length 0 + ) + # assume one line per character mar[2] par(mar = mar) } From 05bc48ccd7164a46c0b42c9c0153474fbf79f244 Mon Sep 17 00:00:00 2001 From: "Ben B. Hansen" Date: Sat, 27 Sep 2025 22:34:53 -0400 Subject: [PATCH 05/12] STY adjust svg plot left margin a crude adjustment only --- R/plot.xbal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plot.xbal.R b/R/plot.xbal.R index 100402e..44e518b 100644 --- a/R/plot.xbal.R +++ b/R/plot.xbal.R @@ -342,7 +342,7 @@ balanceplot <- function(x, mar <- par("mar") mar[2] <- max(c(nchar(rownames(x)), 0) # avoids returning -Inf in case `x` has length 0 - ) + # assume one line per character + )/2 + # assume 1/2 line per character mar[2] par(mar = mar) } From f8446bdad32bfefb4687e99d8e3f09dd290dd82a Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Fri, 24 Oct 2025 11:38:05 -0400 Subject: [PATCH 06/12] BUG In balT value, dim of tcov attribute now matches dim 1 of results As in reported balanceTest results, intercepts and not-missing indicators that only ever take the value 1 get removed. Now this is also done with the null covariance of balance comparisons that is returned invisibly as an attribute. --- R/balanceTest.R | 46 +++++++++++++++++-------------- tests/testthat/test.balanceTest.R | 11 ++++---- 2 files changed, 30 insertions(+), 27 deletions(-) diff --git a/R/balanceTest.R b/R/balanceTest.R index f12ebeb..befc4f6 100644 --- a/R/balanceTest.R +++ b/R/balanceTest.R @@ -280,7 +280,16 @@ balanceTest <- function(fmla, dimnames(descriptives)[[2]][nstats.previous + 1:2] <- c("z", "p") - # strip out summaries of not-missing indicators that only ever take the value T + inferentials <- do.call(rbind, lapply(tmp, function(s) { + data.frame(s$Msq, s$DF, pchisq(s$Msq, df = s$DF, lower.tail = FALSE)) + })) + colnames(inferentials) <- c("chisquare", "df", "p.value") + + tcovs <- lapply(tmp, function(r) { + r$tcov + }) + + # Deal with summaries of not-missing indicators that only ever take the value T nmvars <- identify_NM_vars(dimnames(descriptives)[["vars"]]) # next line assumes every "stat" not in the given list is a mean # over a group assigned to some treatment condition. @@ -293,37 +302,32 @@ balanceTest <- function(fmla, toremove <- match(nmvars[bad], dimnames(descriptives)[["vars"]]) if(length(toremove)>0){ ## if toremove=integer(0) then it drops all vars from descriptives descriptives <- descriptives[-toremove,,,drop=FALSE] - origvars <- origvars[-toremove] + tcovs <- lapply(tcovs, + function(mat){mat[-toremove, -toremove, drop=FALSE]} + ) + origvars <- origvars[-toremove] strings_to_remove <- dimnames(descriptives)[["vars"]][toremove] NMpatterns <- NMpatterns[-toremove] # names of vars that NMpatterns[ NMpatterns%in% strings_to_remove] <- "" } } - inferentials <- do.call(rbind, lapply(tmp, function(s) { - data.frame(s$Msq, s$DF, pchisq(s$Msq, df = s$DF, lower.tail = FALSE)) - })) - colnames(inferentials) <- c("chisquare", "df", "p.value") + for (s in 1L:dim(descriptives)[3]) { + descriptives[, "p", s] <- + p.adjust(descriptives[, "p", s], method = p.adjust.method) + } + attr(descriptives, "NMpatterns") <- NMpatterns + attr(descriptives, "originals") <- origvars + attr(descriptives, "term.labels") <- design@TermLabels + attr(descriptives, "include.NA.flags") <- include.NA.flags # hinting for print and plot methods - # the meat of our xbal object +# the meat of our xbal object ans$overall <- inferentials + attr(ans$overall, "tcov") <- tcovs ans$results <- descriptives - ## do p.value adjustment - for (s in 1L:dim(descriptives)[3]) - ans$results[, "p", s] <- p.adjust(ans$results[, "p", s], method = p.adjust.method) -## ans$overall[, "p.value"] <- p.adjust(ans$overall[, "p.value"], method = p.adjust.method) - - attr(ans$results, "NMpatterns") <- NMpatterns - attr(ans$results, "originals") <- origvars - attr(ans$results, "term.labels") <- design@TermLabels - attr(ans$results, "include.NA.flags") <- include.NA.flags # hinting for print and plot methods - - attr(ans$overall, "tcov") <- lapply(tmp, function(r) { - r$tcov - }) attr(ans, "fmla") <- formula(fmla) attr(ans, "report") <- report # hinting to our summary method later class(ans) <- c("balancetest", "xbal", "list") ans -} + } diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index ee827c2..f2f45d0 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -159,12 +159,11 @@ test_that("balT returns covariance of tests", { expect_equal(length(tcov), 2) - ## Developer note: to strip out entries corresponding to intercept -- which has var 0, - ## except when there's variation in unit weights and/or cluster sizes -- - ## have to filter out rows and cols named "(Intercept)", separately for each - ## entry in list tcov. (Recording while updating test that follows, `c(4,4)` --> `c(5,5)`) - expect_equal(dim(tcov[[1]]), c(5,5)) -}) + ## The intercept is removed as it has permutational var 0 in this case. + ## That variance can be positive when there's variation in unit weights + ## and/or cluster sizes; if then tcov would have another row and columm. + expect_equal(dim(tcov[[1]]), c(4,4)) + }) }) test_that("Passing post.alignment.transform, #26", { From 65d2016bcbfc81f9ca3d81fade1af1669233fd3e Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Fri, 24 Oct 2025 13:16:27 -0400 Subject: [PATCH 07/12] ENH balT tcov attribute now has dimnames --- DESCRIPTION | 2 +- R/balanceTest.R | 5 ++++- tests/testthat/test.balanceTest.R | 12 +++++++++++- 3 files changed, 16 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5ffc78c..e31613f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: RItools -Version: 0.3-5.9001 +Version: 0.3-5.9002 Title: Randomization Inference Tools Authors@R: c(person("Jake", "Bowers", role = c("aut", "cre"), email = "jwbowers@illinois.edu"), person("Mark", "Fredrickson", role = "aut", email = "mark.m.fredrickson@gmail.com"), diff --git a/R/balanceTest.R b/R/balanceTest.R index befc4f6..d47c990 100644 --- a/R/balanceTest.R +++ b/R/balanceTest.R @@ -286,7 +286,10 @@ balanceTest <- function(fmla, colnames(inferentials) <- c("chisquare", "df", "p.value") tcovs <- lapply(tmp, function(r) { - r$tcov + tcov <- r$tcov + dimnames(tcov) <- + rep(list(dimnames(descriptives)[["vars"]]),2) + tcov }) # Deal with summaries of not-missing indicators that only ever take the value T diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index f2f45d0..988a7bb 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -163,6 +163,8 @@ test_that("balT returns covariance of tests", { ## That variance can be positive when there's variation in unit weights ## and/or cluster sizes; if then tcov would have another row and columm. expect_equal(dim(tcov[[1]]), c(4,4)) + expect_equivalent(dimnames(tcov[[1]])[[1]], dimnames(res$results)[[1]]) + expect_equivalent(dimnames(tcov[[2]])[[1]], dimnames(res$results)[[1]]) }) }) @@ -436,6 +438,14 @@ test_that("Characters and factors", { btc <- balanceTest(z ~ char, data = d) btf <- balanceTest(z ~ fact, data = d) - expect_equal(dim(btc$results), dim(btf$results)) + ## removing expected difference before comparing... + attr(btc$results, "term.labels") <- + attr(btf$results, "term.labels") + expect_equal(unname(btc$results), unname(btf$results)) + expect_equal(unname(attr(btc$overall, "tcov")[["--"]]), + unname(attr(btf$overall, "tcov")[["--"]])) + ## removing another expected difference... + attr(btc$overall, "tcov")[["--"]] <- + attr(btf$overall, "tcov")[["--"]] expect_equal(btc$overall, btf$overall) }) From d4795b5a9593506be8ddc780256663d8c15ba302 Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Fri, 24 Oct 2025 15:46:02 -0400 Subject: [PATCH 08/12] STY purposes of origvars & term.labels attributes ... are now documented in balT inline comments, one test --- R/balanceTest.R | 9 ++++++--- tests/testthat/test.balanceTest.R | 21 +++++++++++++++++++++ 2 files changed, 27 insertions(+), 3 deletions(-) diff --git a/R/balanceTest.R b/R/balanceTest.R index d47c990..245e5ea 100644 --- a/R/balanceTest.R +++ b/R/balanceTest.R @@ -287,7 +287,7 @@ balanceTest <- function(fmla, tcovs <- lapply(tmp, function(r) { tcov <- r$tcov - dimnames(tcov) <- + dimnames(tcov) <- rep(list(dimnames(descriptives)[["vars"]]),2) tcov }) @@ -322,7 +322,10 @@ balanceTest <- function(fmla, attr(descriptives, "NMpatterns") <- NMpatterns attr(descriptives, "originals") <- origvars attr(descriptives, "term.labels") <- design@TermLabels - attr(descriptives, "include.NA.flags") <- include.NA.flags # hinting for print and plot methods +# Now `attr(d, "term.labels")[attr(d, "originals")]` +# associates variables to terms of fmla + attr(descriptives, "include.NA.flags") <- + include.NA.flags # hint to print and plot methods # the meat of our xbal object ans$overall <- inferentials @@ -333,4 +336,4 @@ balanceTest <- function(fmla, attr(ans, "report") <- report # hinting to our summary method later class(ans) <- c("balancetest", "xbal", "list") ans - } +} diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index 988a7bb..a1d6504 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -449,3 +449,24 @@ test_that("Characters and factors", { attr(btf$overall, "tcov")[["--"]] expect_equal(btc$overall, btf$overall) }) + +test_that("Return variable/fmla term association", { + set.seed(393911) + tmp <- sample(letters[1:3], 100, replace = TRUE) + d <- data.frame(categorical = tmp, + scalar1 = rnorm(100), + scalar2 = rnorm(100), + z = rep(c(1,0), 50), + stringsAsFactors = FALSE) + bt <- balanceTest(z ~ categorical + scalar1 + + poly(scalar2, degree=2), data = d) + originals_ <- attr(bt$results, "originals") + term.labels_ <- attr(bt$results, "term.labels") + expect_equal(term.labels_[originals_], + c(rep("categorical", length(unique(tmp))), + "scalar1", + rep("poly(scalar2, degree = 2)",2) + ) + ) + +}) From a3eb0770fbc8ec54ae87818e48fd129b7c15252a Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Fri, 24 Oct 2025 16:55:23 -0400 Subject: [PATCH 09/12] STY inline comments re balT NMpatterns attribute --- R/balanceTest.R | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/R/balanceTest.R b/R/balanceTest.R index 245e5ea..500d14b 100644 --- a/R/balanceTest.R +++ b/R/balanceTest.R @@ -250,6 +250,9 @@ balanceTest <- function(fmla, ## we wanted to allow departures from the ETT default. ## Something like `design@Sweights <- DesignWeights(aggDesign, <...>)`.) descriptives <- designToDescriptives(design, covariate.scales) + ## The notmissing indicators can't themselves be missing, so no role for + ## another notmissing indicator to record where its missingness pattern. + ## Instead we just record a blank for them: NMpatterns <- c(NMpatterns, rep("", dim(descriptives)[1]-length(NMpatterns))) # these weights govern inferential but not descriptive calculations @@ -309,9 +312,15 @@ balanceTest <- function(fmla, function(mat){mat[-toremove, -toremove, drop=FALSE]} ) origvars <- origvars[-toremove] - strings_to_remove <- dimnames(descriptives)[["vars"]][toremove] - NMpatterns <- NMpatterns[-toremove] # names of vars that - NMpatterns[ NMpatterns%in% strings_to_remove] <- "" + + ## also trim covars to NM patterns lookup table: + NMpatterns <- NMpatterns[-toremove] + ## If the NM pattern var that a covar got mapped to + ## was removed, we take the covar to have no missings + ## anywhere, and report "" as the name of its nonmissing + ## indicator variable: + strings_to_remove <- dimnames(descriptives)[["vars"]][toremove] + NMpatterns[ NMpatterns%in% strings_to_remove] <- "" } } From 9ee3b33d0548557ed6f507db555812da3083e685 Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Wed, 3 Dec 2025 14:58:20 -0500 Subject: [PATCH 10/12] Avoid stop w/ all variables are constant W/ a bit more to be done to make corresp p-vals equal NA not 1. Adding but commenting out tests for that behavior. --- DESCRIPTION | 2 +- R/utils.R | 7 ++++++- tests/testthat/test.balanceTest.R | 17 +++++++++++------ 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e31613f..73c1a2a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: RItools -Version: 0.3-5.9002 +Version: 0.3-5.9003 Title: Randomization Inference Tools Authors@R: c(person("Jake", "Bowers", role = c("aut", "cre"), email = "jwbowers@illinois.edu"), person("Mark", "Fredrickson", role = "aut", email = "mark.m.fredrickson@gmail.com"), diff --git a/R/utils.R b/R/utils.R index df21ca8..824dd1c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -375,7 +375,12 @@ XtX_pseudoinv_sqrt <- function(mat, mat.is.XtX = FALSE, tol = .Machine$double.ep if (nrow(mat) == 0 && ncol(mat) == 0) { - stop("Cannot calculate pseudoinverse: perhaps all covariates are constant (within strata)?") + warning(paste("Cannot calculate pseudoinverse:", + "perhaps all covariates are constant (within strata)?", + collapse="\\n")) + ans <- matrix(NA_real_, 0, 0) + attr(ans, "r") <- 0 + return(ans) } pst.svd <- try(svd(mat, nu=0)) diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index a1d6504..10d202b 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -411,16 +411,21 @@ test_that("Constant variables", { s = as.factor(sample(letters[1:3], 100, replace = TRUE)), z = rep(c(1,0), 50)) - ## this should be ok, no error - bt <- balanceTest(z ~ xv + xc, data = d) - + exp_na_results <- c("z", "p") + ## this should be ok, no warnings + expect_silent(bt <- balanceTest(z ~ xv + xc, data = d)) + expect_false(any(is.na(bt$results[1,exp_na_results,1]))) + ## but this gives problems - expect_error(balanceTest(z ~ xc, data = d), + expect_warning(bt2 <- balanceTest(z ~ xc, data = d), "Cannot calculate pseudoinverse") - + expect_true(all(is.na(bt2$results[1,exp_na_results,1]))) + ###expect_true(is.na(bt2$overall[1,"p.value"])) ## this too - expect_error(balanceTest(z ~ s + strata(s), data = d), + expect_warning(bt3 <- balanceTest(z ~ s + strata(s), data = d), "Cannot calculate pseudoinverse") + expect_true(all(is.na(bt3$results[,exp_na_results,"s"]))) + ###expect_true(is.na(bt3$overall["s","p.value"])) }) From d5497162a4ad8bd25f226a21eda620cb83f27b38 Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Wed, 3 Dec 2025 15:10:43 -0500 Subject: [PATCH 11/12] Constant variables again With const variables, overall p-value is now also NA --- R/Design.R | 3 +++ tests/testthat/test.balanceTest.R | 7 ++++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/R/Design.R b/R/Design.R index 0f5682c..e3f3faf 100644 --- a/R/Design.R +++ b/R/Design.R @@ -999,8 +999,11 @@ HB08 <- function(alignedcovs) { check_for_degenerate(cov_minus_.5, n_, s_) + if (!all(zero_variance)) + { mvz <- drop(crossprod(ssn[!zero_variance], cov_minus_.5)) csq <- drop(crossprod(mvz)) + } else csq <- NA_real_ DF <- ncol(cov_minus_.5) list(z = zstat, p = p, Msq = csq , DF = DF, diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index 10d202b..de05870 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -420,12 +420,13 @@ test_that("Constant variables", { expect_warning(bt2 <- balanceTest(z ~ xc, data = d), "Cannot calculate pseudoinverse") expect_true(all(is.na(bt2$results[1,exp_na_results,1]))) - ###expect_true(is.na(bt2$overall[1,"p.value"])) - ## this too + expect_true(is.na(bt2$overall[1,"p.value"])) + + ## issues here too expect_warning(bt3 <- balanceTest(z ~ s + strata(s), data = d), "Cannot calculate pseudoinverse") expect_true(all(is.na(bt3$results[,exp_na_results,"s"]))) - ###expect_true(is.na(bt3$overall["s","p.value"])) + expect_true(is.na(bt3$overall["s","p.value"])) }) From 18b0b6015657c78cab3effec57eab2e6381bbf58 Mon Sep 17 00:00:00 2001 From: Ben Hansen Date: Wed, 3 Dec 2025 17:51:42 -0500 Subject: [PATCH 12/12] Constant variables take 3 Deliver message not warning --- NEWS.md | 1 + R/utils.R | 2 +- tests/testthat/test.balanceTest.R | 8 ++++---- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 39eabac..cb28acb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,7 @@ # RItools {NEXTVERSION} * Bug fix (base R plot method svg export) +* More graceful handling in balanceTest() of the edge case of balance testing for all-constant variables, with messages not errors and p-values of NA not 1 # RItools 0.3-5 diff --git a/R/utils.R b/R/utils.R index 824dd1c..fbf3524 100644 --- a/R/utils.R +++ b/R/utils.R @@ -375,7 +375,7 @@ XtX_pseudoinv_sqrt <- function(mat, mat.is.XtX = FALSE, tol = .Machine$double.ep if (nrow(mat) == 0 && ncol(mat) == 0) { - warning(paste("Cannot calculate pseudoinverse:", + message(paste("Degenerate null covariance (rank 0 Gram matrix):", "perhaps all covariates are constant (within strata)?", collapse="\\n")) ans <- matrix(NA_real_, 0, 0) diff --git a/tests/testthat/test.balanceTest.R b/tests/testthat/test.balanceTest.R index de05870..55f99af 100644 --- a/tests/testthat/test.balanceTest.R +++ b/tests/testthat/test.balanceTest.R @@ -417,14 +417,14 @@ test_that("Constant variables", { expect_false(any(is.na(bt$results[1,exp_na_results,1]))) ## but this gives problems - expect_warning(bt2 <- balanceTest(z ~ xc, data = d), - "Cannot calculate pseudoinverse") + expect_message(bt2 <- balanceTest(z ~ xc, data = d), + "perhaps all covariates are constant") expect_true(all(is.na(bt2$results[1,exp_na_results,1]))) expect_true(is.na(bt2$overall[1,"p.value"])) ## issues here too - expect_warning(bt3 <- balanceTest(z ~ s + strata(s), data = d), - "Cannot calculate pseudoinverse") + expect_message(bt3 <- balanceTest(z ~ s + strata(s), data = d), + "perhaps all covariates are constant") expect_true(all(is.na(bt3$results[,exp_na_results,"s"]))) expect_true(is.na(bt3$overall["s","p.value"])) })