diff --git a/R/paired.R b/R/paired.R index 980eaaa..4c73c71 100644 --- a/R/paired.R +++ b/R/paired.R @@ -305,6 +305,8 @@ paired <- function(formula, data, id, na.action, subset=NULL, strata, control = bystatlist <- do.call(statfun, list(currcol, levels = xlevels, by = by.col, by.levels = by.levels, na.rm = TRUE)) bystatlist$Total <- NULL + } else if(statfun2 == "Nsigntest") { + bystatlist <- as.countpct(NA_real_) } else { for(bylev in by.levels) { @@ -346,7 +348,8 @@ paired <- function(formula, data, id, na.action, subset=NULL, strata, control = currtest <- if(nchar(specialTests[eff]) > 0) specialTests[eff] else currtest testout <- if(control$test) { eval(call(currtest, TP1.eff, TP2.eff, mcnemar.correct=control$mcnemar.correct, - signed.rank.exact = control$signed.rank.exact, signed.rank.correct = control$signed.rank.correct)) + signed.rank.exact = control$signed.rank.exact, signed.rank.correct = control$signed.rank.correct, + test.always=control$test.always)) } else notest() xList[[eff]] <- list(stats=statList, test=testout, type=vartype) diff --git a/R/paired.stat.tests.R b/R/paired.stat.tests.R index 30fbe78..ac4ccaa 100644 --- a/R/paired.stat.tests.R +++ b/R/paired.stat.tests.R @@ -1,29 +1,49 @@ -paired.t <- function(x, y, ...) { +paired.t <- function(x, y, ..., na.rm = TRUE) { if(is.Date(x) && is.Date(y)) { x <- as.integer(x) y <- as.integer(y) } + if(na.rm) { + idx <- is.na(x) | is.na(y) + x <- x[!idx] + y <- y[!idx] + } stats::t.test(x, y, paired = TRUE) } -mcnemar <- function(x, y, mcnemar.correct = TRUE, ...) +mcnemar <- function(x, y, mcnemar.correct = TRUE, ..., na.rm = TRUE) { + if(na.rm) { + idx <- is.na(x) | is.na(y) + x <- x[!idx] + y <- y[!idx] + } stats::mcnemar.test(x, y, correct = mcnemar.correct) } -signed.rank <- function(x, y, signed.rank.exact = NULL, signed.rank.correct = TRUE, ...) +signed.rank <- function(x, y, signed.rank.exact = NULL, signed.rank.correct = TRUE, ..., na.rm = TRUE) { if(is.ordered(x) && is.ordered(y)) { x <- as.integer(x) y <- as.integer(y) } + if(na.rm) { + idx <- is.na(x) | is.na(y) + x <- x[!idx] + y <- y[!idx] + } stats::wilcox.test(x, y, paired = TRUE, exact = signed.rank.exact, correct = signed.rank.correct) } -sign.test <- function(x, y, ...) +sign.test <- function(x, y, ..., na.rm = TRUE) { + if(na.rm) { + idx <- is.na(x) | is.na(y) + x <- x[!idx] + y <- y[!idx] + } stats::binom.test(c(sum(x > y), sum(x < y))) } diff --git a/R/tableby.control.R b/R/tableby.control.R index 82b475c..3a82919 100644 --- a/R/tableby.control.R +++ b/R/tableby.control.R @@ -147,7 +147,7 @@ add_tbc_stats_labels <- function(x) { mean = "Mean", sd = "SD", var = "Var", max = "Max", min = "Min", meanCI = "Mean (CI)", sum = "Sum", gmean = "Geom Mean", gsd = "Geom SD", gmeansd = "Geom Mean (Geom SD)", gmeanCI = "Geom Mean (CI)", range="Range", Npct="N (Pct)", Nevents="Events", medSurv="Median Survival", - medTime = "Median Follow-Up", medianmad="Median (MAD)", + medTime = "Median Follow-Up", medianmad="Median (MAD)", Nsigntest = "N (sign test)", overall = "Overall", total = "Total", difference = "Difference" ) nms <- setdiff(names(x), "") diff --git a/R/tableby.stats.R b/R/tableby.stats.R index 9e40e18..4283f92 100644 --- a/R/tableby.stats.R +++ b/R/tableby.stats.R @@ -247,6 +247,12 @@ gmeanCI <- function(x, na.rm=TRUE, weights = NULL, conf.level = 0.95, ...) { as.tbstat(y, parens = c("(", ")"), sep2 = ", ") } +#' @rdname tableby.stats +#' @export +Nsigntest <- function(x, na.rm = TRUE, weights = NULL, ...) { + if(is.null(weights)) weights <- rep(1, NROW(x)) + as.countpct(sum(weights*(x != 0), na.rm = na.rm)) +} ## survival stats #' @rdname tableby.stats @@ -379,7 +385,7 @@ iqr <- function(x, na.rm=TRUE, weights = NULL, ...) { #' @export Nmiss <- function(x, na.rm=TRUE, weights = NULL, ...) { if(is.null(weights)) weights <- rep(1, NROW(x)) - as.countpct(sum(weights[is.na(x)])) + as.countpct(sum(weights, na.rm = na.rm)) } ## Nmiss2 make similar, but in tableby, always keep nmiss, @@ -393,7 +399,7 @@ Nmiss2 <- Nmiss #' @export N <- function(x, na.rm=TRUE, weights = NULL, ...) { if(is.null(weights)) weights <- rep(1, NROW(x)) - as.countpct(sum(weights[!is.na(x)])) + as.countpct(sum(weights, na.rm = na.rm)) } #' @rdname tableby.stats diff --git a/tests/testthat/test_paired.R b/tests/testthat/test_paired.R index 9b06779..46df51c 100644 --- a/tests/testthat/test_paired.R +++ b/tests/testthat/test_paired.R @@ -283,4 +283,22 @@ test_that("12/27/2019: informative error when no stats are computed (#273)", { expect_error(summary(paired(tp ~ Cat, data = dat2, id = id, cat.stats = "Nmiss")), "Nothing to show for variable") }) +test_that("NAs in sign.test, plus Nsigntest (#326)", { + d <- data.frame( + tp = rep(c("Time 1", "Time 2"), times = 4), + id = c(1, 1, 2, 2, 3, 3, 4, 4), + a = c(1, 2, 2, 3, 3, 4, 5, NA) + ) + expect_identical( + capture.kable(summary(paired(tp ~ sign.test(a), id = id, data = d, numeric.stats = c("Nmiss", "meansd", "range", "Nsigntest")), text = TRUE)), + c("| | Time 1 (N=4) | Time 2 (N=4) | Difference (N=4) | p value|", + "|:----------------|:-------------:|:-------------:|:----------------:|-------:|", + "|a | | | | 0.250|", + "|- N-Miss | 4 | 4 | 4 | |", + "|- Mean (SD) | 2.750 (1.708) | 3.000 (1.000) | 1.000 (0.000) | |", + "|- Range | 1.000 - 5.000 | 2.000 - 4.000 | 1.000 - 1.000 | |", + "|- N (sign test) | NA | NA | 3 | |" + ) + ) +}) diff --git a/tests/testthat/test_tableby.R b/tests/testthat/test_tableby.R index 82a457a..1c57abb 100644 --- a/tests/testthat/test_tableby.R +++ b/tests/testthat/test_tableby.R @@ -1707,7 +1707,7 @@ test_that("wt (#321)", { }) -test_that("wt (#327)", { +test_that("medtest (#327)", { expect_identical( capture.kable(summary(tableby(sex ~ medtest(age), data = mockstudy), text = TRUE)), c("| | Male (N=916) | Female (N=583) | Total (N=1499) | p value|",