diff --git a/DESCRIPTION b/DESCRIPTION index 4fe0ffa362..2473289204 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,7 +29,7 @@ URL: https://insightsengineering.github.io/tern/, BugReports: https://github.com/insightsengineering/tern/issues Depends: R (>= 4.4.0), - rtables (>= 0.6.13) + rtables (>= 0.6.14) Imports: broom (>= 1.0.8), car (>= 3.1-3), @@ -38,7 +38,7 @@ Imports: dplyr (>= 1.0.0), emmeans (>= 1.10.4), forcats (>= 1.0.0), - formatters (>= 0.5.11), + formatters (>= 0.5.12), ggplot2 (>= 3.5.0), grid, gridExtra (>= 2.0.0), @@ -67,6 +67,9 @@ Suggests: svglite (>= 2.1.2), testthat (>= 3.1.9), withr (>= 2.0.0) +Remotes: + insightsengineering/formatters@main, + insightsengineering/rtables@main VignetteBuilder: knitr, rmarkdown diff --git a/NEWS.md b/NEWS.md index 32f5e08253..effc1c902e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ ### Enhancements * Added `alternative` argument to `test_proportion_diff()` to allow one-sided hypothesis testing. +* Added `wh` (CMH with Wilson-Hilferty transformation) method to `test_proportion_diff()` for stratified proportion difference testing. ### Bug Fixes * Fixed bug in `tabulate_rsp_subgroups()` and `tabulate_survival_subgroups()` preventing risk difference column format specified via `control_riskdiff()` from being applied. diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 82e2192ac5..1c5f4be587 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -9,8 +9,8 @@ #' supplied via the `strata` element of the `variables` argument. #' #' @inheritParams argument_convention -#' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used -#' to calculate the p-value. +#' @param method (`string`)\cr one of `chisq`, `cmh`, `cmh_wh`, `fisher`, or `schouten`; +#' specifies the test used to calculate the p-value. #' @param .stats (`character`)\cr statistics to select for the table. #' #' Options are: ``r shQuote(get_stats("test_proportion_diff"), type = "sh")`` @@ -53,7 +53,7 @@ s_test_proportion_diff <- function(df, .ref_group, .in_ref_col, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh"), alternative = c("two.sided", "less", "greater"), ...) { method <- match.arg(method) @@ -71,7 +71,7 @@ s_test_proportion_diff <- function(df, levels = c("ref", "Not-ref") ) - if (!is.null(variables$strata) || method == "cmh") { + if (!is.null(variables$strata) || method %in% c("cmh", "cmh_wh")) { strata <- variables$strata checkmate::assert_false(is.null(strata)) strata_vars <- stats::setNames(as.list(strata), strata) @@ -82,6 +82,7 @@ s_test_proportion_diff <- function(df, tbl <- switch(method, cmh = table(grp, rsp, strata), + cmh_wh = table(grp, rsp, strata), table(grp, rsp) ) @@ -89,7 +90,8 @@ s_test_proportion_diff <- function(df, chisq = prop_chisq(tbl, alternative = alternative), cmh = prop_cmh(tbl, alternative = alternative), fisher = prop_fisher(tbl, alternative = alternative), - schouten = prop_schouten(tbl, alternative = alternative) + schouten = prop_schouten(tbl, alternative = alternative), + cmh_wh = prop_cmh(tbl, alternative = alternative, transform = "wilson_hilferty") ) } @@ -116,6 +118,7 @@ d_test_proportion_diff <- function(method, alternative = c("two.sided", "less", "schouten" = "Chi-Squared Test with Schouten Correction", "chisq" = "Chi-Squared Test", "cmh" = "Cochran-Mantel-Haenszel Test", + "cmh_wh" = "Cochran-Mantel-Haenszel Test with Wilson-Hilferty Transformation", "fisher" = "Fisher's Exact Test", stop(paste(method, "does not have a description")) ) @@ -232,7 +235,7 @@ a_test_proportion_diff <- function(df, test_proportion_diff <- function(lyt, vars, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh"), alternative = c("two.sided", "less", "greater"), var_labels = vars, na_str = default_na_str(), @@ -312,17 +315,24 @@ prop_chisq <- function(tbl, alternative = c("two.sided", "less", "greater")) { stats::prop.test(tbl, correct = FALSE, alternative = alternative)$p.value } -#' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls -#' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. +#' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test, +#' using [stats::mantelhaen.test()] internally. +#' Note that strata with less than two observations are automatically discarded. #' #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. +#' @param transform (`string`)\cr either `none` or `wilson_hilferty`; specifies whether to apply +#' the Wilson-Hilferty transformation of the chi-squared statistic. #' #' @keywords internal -prop_cmh <- function(ary, alternative = c("two.sided", "less", "greater")) { +prop_cmh <- function(ary, + alternative = c("two.sided", "less", "greater"), + transform = c("none", "wilson_hilferty")) { checkmate::assert_array(ary) checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) + alternative <- match.arg(alternative) + transform <- match.arg(transform) strata_sizes <- apply(ary, MARGIN = 3, sum) if (any(strata_sizes < 5)) { @@ -330,7 +340,23 @@ prop_cmh <- function(ary, alternative = c("two.sided", "less", "greater")) { ary <- ary[, , strata_sizes > 1] } - stats::mantelhaen.test(ary, correct = FALSE, alternative = alternative)$p.value + cmh_res <- stats::mantelhaen.test(ary, correct = FALSE, alternative = alternative) + + if (transform == "none") { + cmh_res$p.value + } else { + chisq_stat <- unname(cmh_res$statistic) + df <- unname(cmh_res$parameter) + num <- (chisq_stat / df)^(1 / 3) - (1 - 2 / (9 * df)) + denom <- sqrt(2 / (9 * df)) + wh_stat <- num / denom + + if (alternative == "two.sided") { + 2 * stats::pnorm(-abs(wh_stat)) + } else { + stats::pnorm(wh_stat, lower.tail = (alternative == "greater")) + } + } } #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction. diff --git a/inst/WORDLIST b/inst/WORDLIST index 51ecabbb36..3d728b6d29 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -17,6 +17,7 @@ Coull Forkers Haenszel Hauck +Hilferty Hoffmann Jeffreys Kaplan diff --git a/man/d_test_proportion_diff.Rd b/man/d_test_proportion_diff.Rd index ca744c6e06..eacf3efd93 100644 --- a/man/d_test_proportion_diff.Rd +++ b/man/d_test_proportion_diff.Rd @@ -7,8 +7,8 @@ d_test_proportion_diff(method, alternative = c("two.sided", "less", "greater")) } \arguments{ -\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used -to calculate the p-value.} +\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{cmh_wh}, \code{fisher}, or \code{schouten}; +specifies the test used to calculate the p-value.} \item{alternative}{(\code{string})\cr whether \code{two.sided}, or one-sided \code{less} or \code{greater} p-value should be displayed.} diff --git a/man/h_prop_diff_test.Rd b/man/h_prop_diff_test.Rd index e4e5e504bf..6515ab33f5 100644 --- a/man/h_prop_diff_test.Rd +++ b/man/h_prop_diff_test.Rd @@ -10,7 +10,11 @@ \usage{ prop_chisq(tbl, alternative = c("two.sided", "less", "greater")) -prop_cmh(ary, alternative = c("two.sided", "less", "greater")) +prop_cmh( + ary, + alternative = c("two.sided", "less", "greater"), + transform = c("none", "wilson_hilferty") +) prop_schouten(tbl, alternative = c("two.sided", "less", "greater")) @@ -24,6 +28,9 @@ should be displayed.} \item{ary}{(\code{array}, 3 dimensions)\cr array with two groups in rows, the binary response (\code{TRUE}/\code{FALSE}) in columns, and the strata in the third dimension.} + +\item{transform}{(\code{string})\cr either \code{none} or \code{wilson_hilferty}; specifies whether to apply +the Wilson-Hilferty transformation of the chi-squared statistic.} } \value{ A p-value. @@ -35,8 +42,9 @@ Helper functions to implement various tests on the difference between two propor \itemize{ \item \code{prop_chisq()}: Performs Chi-Squared test. Internally calls \code{\link[stats:prop.test]{stats::prop.test()}}. -\item \code{prop_cmh()}: Performs stratified Cochran-Mantel-Haenszel test. Internally calls -\code{\link[stats:mantelhaen.test]{stats::mantelhaen.test()}}. Note that strata with less than two observations are automatically discarded. +\item \code{prop_cmh()}: Performs stratified Cochran-Mantel-Haenszel test, +using \code{\link[stats:mantelhaen.test]{stats::mantelhaen.test()}} internally. +Note that strata with less than two observations are automatically discarded. \item \code{prop_schouten()}: Performs the Chi-Squared test with Schouten correction. diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index c3d531fbf7..085dbf0165 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -11,7 +11,7 @@ test_proportion_diff( lyt, vars, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh"), alternative = c("two.sided", "less", "greater"), var_labels = vars, na_str = default_na_str(), @@ -34,7 +34,7 @@ s_test_proportion_diff( .ref_group, .in_ref_col, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh"), alternative = c("two.sided", "less", "greater"), ... ) @@ -56,8 +56,8 @@ a_test_proportion_diff( \item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} -\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used -to calculate the p-value.} +\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{cmh_wh}, \code{fisher}, or \code{schouten}; +specifies the test used to calculate the p-value.} \item{alternative}{(\code{string})\cr whether \code{two.sided}, or one-sided \code{less} or \code{greater} p-value should be displayed.} diff --git a/tests/testthat/_snaps/test_proportion_diff.md b/tests/testthat/_snaps/test_proportion_diff.md index e42ad353b6..e958b16fc0 100644 --- a/tests/testthat/_snaps/test_proportion_diff.md +++ b/tests/testthat/_snaps/test_proportion_diff.md @@ -5,6 +5,20 @@ Output [1] 0.05653028 +--- + + Code + res_less + Output + [1] 0.9717349 + +--- + + Code + res_greater + Output + [1] 0.02826514 + # prop_cmh returns right result Code @@ -12,6 +26,20 @@ Output [1] 0.6477165 +--- + + Code + res_less + Output + [1] 0.6761418 + +--- + + Code + res_greater + Output + [1] 0.3238582 + # prop_cmh also works when there are strata with just one observation Code @@ -26,31 +54,81 @@ Output [1] 0.1109695 +--- + + Code + res_less + Output + [1] 0.9875791 + +--- + + Code + res_greater + Output + [1] 0.05548477 + # prop_schouten returns right result + c(5.71709780151386e-16, 2.71149466993128e-15, 2.3889666278922e-05, + 0.549644428899163, 0.703454844664116, 0.0152858916552256, 6.52453722516531e-06, + 0.0327322670572509, 0.000506600905337401, 8.41318893931116e-20, + 0.743034241134202, 0.0357092689206786, 7.21115471170251e-17, + 1.45670568158378e-07, 0.552926717015723, 0.0502760939221872, + 3.26072131893282e-13, 1.97467455935962e-17, 0.148159618767163, + 0.724368897795955, 6.73453970817436e-21, 1.24095498290808e-07, + 0.000115170047481382, 0.137100155156638, 0.0662187965427006, + 0.103278869004223, 0.000249113546833614, 1.40106351061449e-08, + 8.06929481327806e-10, 0.383818805598473, 0.000210009244514486, + 2.89782748092434e-08, 0.339177309250819, 8.04423918783469e-05, + 0.0742658033596529, 6.50237102665681e-06, 1.73515164584978e-06, + 7.97292519631648e-07, 0.673779281512192, 0.755929661910774, 1.34041438943676e-14, + 4.69943184727821e-07, 9.12720383190411e-05, 4.51068424702267e-11, + 0.195718524551842, 0.19948806332682, 0.0057721529577541, 0.0560084668646058, + 0.29104053765655, 0.322350844144929, 0.048093607319379, 9.68336827831432e-13, + 0.0656856504670571, 0.545615628847437, 0.642302173037625, 0.0236950615828867, + 1.50889801946692e-05, 1.01573874991605e-06, 0.0116066467015481, + 0.973570459792593, 0.331650059277109, 0.0924675432126077, NA, + 0.266287847316958, 0.0471855622246397, 3.9630338558056e-05, 6.31390056514998e-10, + 1.03425994808443e-13, 0.00916088462925696, 0.177238826615554, + 0.00310298563550831, 0.000938185285257554, 0.001313179571731, + 0.327585821520465, 0.16915719848394, 0.369032771061995, 1.73452827974862e-05, + 7.04670334226855e-13, 0.906843585080977, 0.0137996779055368, + 0.000320347934086559, 3.72276286720585e-07, 0.0131802938305678, + 3.66856133697241e-26, 0.975803811608676, 8.38383670121597e-07, + 5.84835590891316e-05, 8.84205783916123e-09, 0.106092781764247, + 0.0131897374630874, 0.443216415158973, 5.10368883112867e-06, + 0.000408252631151325, 0.0509882952700247, 0.00111899204979067, + 2.4454141800447e-15, 1.4766170428799e-08, 0.564110859931511, + 0.00531780904841515, 0.000288988027910912) + +# prop_schouten returns right result for less or greater alternative + Code - res + res_less + Output + [1] 0.9578287 + +--- + + Code + res_greater + Output + [1] 0.04217134 + +# prop_cmh with Wilson-Hilferty transformation works + + Code + res_less + Output + [1] 0.6522653 + +--- + + Code + res_greater Output - [1] 5.551115e-16 2.664535e-15 2.388967e-05 5.496444e-01 7.034548e-01 - [6] 1.528589e-02 6.524537e-06 3.273227e-02 5.066009e-04 0.000000e+00 - [11] 7.430342e-01 3.570927e-02 1.110223e-16 1.456706e-07 5.529267e-01 - [16] 5.027609e-02 3.260725e-13 0.000000e+00 1.481596e-01 7.243689e-01 - [21] 0.000000e+00 1.240955e-07 1.151700e-04 1.371002e-01 6.621880e-02 - [26] 1.032789e-01 2.491135e-04 1.401064e-08 8.069295e-10 3.838188e-01 - [31] 2.100092e-04 2.897827e-08 3.391773e-01 8.044239e-05 7.426580e-02 - [36] 6.502371e-06 1.735152e-06 7.972925e-07 6.737793e-01 7.559297e-01 - [41] 1.343370e-14 4.699432e-07 9.127204e-05 4.510681e-11 1.957185e-01 - [46] 1.994881e-01 5.772153e-03 5.600847e-02 2.910405e-01 3.223508e-01 - [51] 4.809361e-02 9.683365e-13 6.568565e-02 5.456156e-01 6.423022e-01 - [56] 2.369506e-02 1.508898e-05 1.015739e-06 1.160665e-02 9.735705e-01 - [61] 3.316501e-01 9.246754e-02 NA 2.662878e-01 4.718556e-02 - [66] 3.963034e-05 6.313901e-10 1.034728e-13 9.160885e-03 1.772388e-01 - [71] 3.102986e-03 9.381853e-04 1.313180e-03 3.275858e-01 1.691572e-01 - [76] 3.690328e-01 1.734528e-05 7.046586e-13 9.068436e-01 1.379968e-02 - [81] 3.203479e-04 3.722763e-07 1.318029e-02 0.000000e+00 9.758038e-01 - [86] 8.383837e-07 5.848356e-05 8.842058e-09 1.060928e-01 1.318974e-02 - [91] 4.432164e-01 5.103689e-06 4.082526e-04 5.098830e-02 1.118992e-03 - [96] 2.442491e-15 1.476617e-08 5.641109e-01 5.317809e-03 2.889880e-04 + [1] 0.3477347 # s_test_proportion_diff and d_test_proportion_diff return right result @@ -68,6 +146,38 @@ +# s_test_proportion_diff and d_test_proportion_diff work with less and greater alternatives + + Code + res + Output + $d + [1] "p-value (Cochran-Mantel-Haenszel Test, 1-sided, direction greater)" + + $s + $s$pval + [1] 0.6761418 + attr(,"label") + [1] "p-value (Cochran-Mantel-Haenszel Test, 1-sided, direction greater)" + + + +--- + + Code + res + Output + $d + [1] "p-value (Cochran-Mantel-Haenszel Test, 1-sided, direction less)" + + $s + $s$pval + [1] 0.3238582 + attr(,"label") + [1] "p-value (Cochran-Mantel-Haenszel Test, 1-sided, direction less)" + + + # test_proportion_diff returns right result Code @@ -77,6 +187,15 @@ ————————————————————————————————————————————————————— p-value (Cochran-Mantel-Haenszel Test) 0.6477 +# test_proportion_diff uses alternative argument + + Code + res + Output + B A + ————————————————————————————————————————————————————————————————————————————————— + p-value (Cochran-Mantel-Haenszel Test, 1-sided, direction greater) 0.6761 + # test_proportion_diff edge case: all responder by chisq Code @@ -115,3 +234,13 @@ Variable Label p-value (Cochran-Mantel-Haenszel Test) NA +# test_proportion_diff edge case: all responder by CMH with Wilson-Hilferty transformation + + Code + res + Output + B A + ——————————————————————————————————————————————————————————————————————————————————————— + Variable Label + p-value (Cochran-Mantel-Haenszel Test with Wilson-Hilferty Transformation) NA + diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index 963a67a357..bb884c48d2 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -110,7 +110,7 @@ testthat::test_that("prop_schouten returns right result", { ) res <- testthat::expect_silent(result) - testthat::expect_snapshot(res) + testthat::expect_snapshot_value(res, style = "deparse") }) testthat::test_that("prop_schouten returns right result for less or greater alternative", { @@ -138,6 +138,29 @@ testthat::test_that("prop_schouten returns right result for less or greater alte expect_equal(result_greater, result_chisq_greater, tolerance = 1e-1) }) +testthat::test_that("prop_cmh with Wilson-Hilferty transformation works", { + set.seed(1, kind = "Mersenne-Twister") + rsp <- sample(c(TRUE, FALSE), 100, TRUE) + grp <- factor(rep(c("A", "B"), each = 50)) + strata <- factor(rep(c("V", "W", "X", "Y", "Z"), each = 20)) + tbl <- table(grp, rsp, strata) + + result_less <- prop_cmh(tbl, alternative = "less", transform = "wilson_hilferty") + res_less <- testthat::expect_silent(result_less) + testthat::expect_snapshot(res_less) + + result_greater <- prop_cmh(tbl, alternative = "greater", transform = "wilson_hilferty") + res_greater <- testthat::expect_silent(result_greater) + testthat::expect_snapshot(res_greater) + + # And these results are in line with the standard CMH test. + result_cmh_less <- prop_cmh(tbl, alternative = "less") + result_cmh_greater <- prop_cmh(tbl, alternative = "greater") + + expect_equal(result_less, result_cmh_less, tolerance = 1e-1) + expect_equal(result_greater, result_cmh_greater, tolerance = 1e-1) +}) + testthat::test_that("s_test_proportion_diff and d_test_proportion_diff return right result", { set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( @@ -241,7 +264,7 @@ testthat::test_that("test_proportion_diff edge case: all responder by chisq", { split_cols_by(var = "grp", ref_group = "B", split_fun = ref_group_position("first")) %>% test_proportion_diff( vars = "rsp", - method = c("chisq", "schouten", "fisher", "cmh")[1] + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh")[1] ) %>% build_table(df = dta) @@ -259,7 +282,7 @@ testthat::test_that("test_proportion_diff edge case: all responder by schouten", split_cols_by(var = "grp", ref_group = "B", split_fun = ref_group_position("first")) %>% test_proportion_diff( vars = "rsp", - method = c("chisq", "schouten", "fisher", "cmh")[2] + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh")[2] ) %>% build_table(df = dta) @@ -279,7 +302,7 @@ testthat::test_that("test_proportion_diff edge case: all responder by fisher", { vars = "rsp", var_labels = "Variable Label", show_labels = "visible", - method = c("chisq", "schouten", "fisher", "cmh")[3] + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh")[3] ) %>% build_table(df = dta) @@ -300,7 +323,29 @@ testthat::test_that("test_proportion_diff edge case: all responder by CMH", { vars = "rsp", var_labels = "Variable Label", show_labels = "visible", - method = c("chisq", "schouten", "fisher", "cmh")[4], + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh")[4], + variables = list(strata = "strata") + ) %>% + build_table(df = dta) + + res <- testthat::expect_silent(result) + testthat::expect_snapshot(res) +}) + +testthat::test_that("test_proportion_diff edge case: all responder by CMH with Wilson-Hilferty transformation", { + dta <- data.frame( + rsp = rep(TRUE, each = 100), + grp = factor(rep(c("A", "B"), each = 50)), + strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20)) + ) + + result <- basic_table() %>% + split_cols_by(var = "grp", ref_group = "B", split_fun = ref_group_position("first")) %>% + test_proportion_diff( + vars = "rsp", + var_labels = "Variable Label", + show_labels = "visible", + method = c("chisq", "schouten", "fisher", "cmh", "cmh_wh")[5], variables = list(strata = "strata") ) %>% build_table(df = dta)