From 9574799d5c9cbb21598c98eb1d20f160d30a7c38 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Sat, 29 Aug 2026 16:23:30 +0200 Subject: [PATCH 01/40] Add new (helper) functions for proportions: assert_prop_data() and safe_2x2_table(). Modfified check_diff_prop_ci() so that is uses new assert_prop_data(). --- NAMESPACE | 2 + NEWS.md | 7 + R/prop_diff.R | 111 +++++++++++- _pkgdown.yml | 2 + man/assert_prop_data.Rd | 49 +++++ man/check_diff_prop_ci.Rd | 3 + man/safe_2x2_table.Rd | 66 +++++++ tests/testthat/test-assert_prop_data.R | 112 ++++++++++++ tests/testthat/test-safe_2x2_table.R | 242 +++++++++++++++++++++++++ 9 files changed, 588 insertions(+), 6 deletions(-) create mode 100644 man/assert_prop_data.Rd create mode 100644 man/safe_2x2_table.Rd create mode 100644 tests/testthat/test-assert_prop_data.R create mode 100644 tests/testthat/test-safe_2x2_table.R diff --git a/NAMESPACE b/NAMESPACE index 0afd85824e..725c713eba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,6 +56,7 @@ export(as.rtable) export(as_factor_keep_attributes) export(assert_df_with_factors) export(assert_df_with_variables) +export(assert_prop_data) export(assert_proportion_value) export(check_diff_prop_ci) export(clogit_with_tryCatch) @@ -290,6 +291,7 @@ export(s_summary) export(s_surv_time) export(s_surv_timepoint) export(s_test_proportion_diff) +export(safe_2x2_table) export(sas_na) export(score_occurrences) export(score_occurrences_cols) diff --git a/NEWS.md b/NEWS.md index e78982c4da..24ad98e8a2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # tern 0.9.11.9000 +### Enhancements +* Added `safe_2x2_table()` to construct 2 x 2 x k contingency tables safely. +* Added `assert_prop_data()` to validate responder, group, and optional + stratification data used in proportion analyses. + +# tern 0.9.11 + ### Enhancements * Updated `g_forest()` to support point estimates and confidence intervals stored in a single column. (#1499) diff --git a/R/prop_diff.R b/R/prop_diff.R index 3d002a607a..c65a61bbdf 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -366,6 +366,51 @@ estimate_proportion_diff <- function(lyt, ) } +#' @title Validate Data for a Proportion Analysis +#' +#' @description `r lifecycle::badge("stable")` +#' +#' Validates the data required for a proportion analysis, including responder +#' status, group assignment, and optional stratification. +#' +#' @param rsp (`logical`)\cr +#' Indicates whether each observation is a responder (`TRUE`) or a +#' non-responder (`FALSE)`. Missing values are not allowed. +#' @param grp (`factor`)\cr +#' Assigns each observation to one of two groups, such as a reference and a +#' treatment group. Must have exactly two levels and the same length as +#' rsp. Missing values are not allowed. +#' @param strata (`factor` or `NULL`)\cr +#' Defines the stratification variable. When supplied, it must have the same +#' length as rsp and must not contain missing values. +#' +#' @return +#' Invisibly returns `NULL`. An error is raised if any input does not meet +#' the required conditions. +#' +#' @examples +#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +#' strata <- factor(c("A", "A", "B", "A", "B", "B")) +#' +#' assert_prop_data(rsp, grp, strata) +#' +#' \dontrun{ +#' # An error is raised when `grp` has only one level. +#' grp <- factor(rep("X", 6)) +#' assert_prop_data(rsp, grp, strata) +#' } +#' +#' @author WW +#' +#' @export +assert_prop_data <- function(rsp, grp, strata = NULL) { + checkmate::assert_logical(rsp, any.missing = FALSE) + checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) + checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) + invisible() +} + #' Check proportion difference arguments #' #' @description `r lifecycle::badge("stable")` @@ -376,6 +421,8 @@ estimate_proportion_diff <- function(lyt, #' @inheritParams prop_diff #' @inheritParams prop_diff_wald #' +#' @seealso [assert_prop_data()] +#' #' @examples #' # example code #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. @@ -394,16 +441,68 @@ check_diff_prop_ci <- function(rsp, strata = NULL, conf_level, correct = NULL) { - checkmate::assert_logical(rsp, any.missing = FALSE) - checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) + assert_prop_data(rsp = rsp, grp = grp, strata = strata) checkmate::assert_number(conf_level, lower = 0, upper = 1) checkmate::assert_flag(correct, null.ok = TRUE) + invisible() +} - if (!is.null(strata)) { - checkmate::assert_factor(strata, len = length(rsp)) - } +#' @title Construct 2 x 2 Contingency Tables Safely +#' +#' @description `r lifecycle::badge("stable")` +#' +#' Creates a 2 x 2 contingency table of responder status by group, optionally +#' stratified by a third factor. The function validates the input vectors and +#' ensures that the responder variable contains both possible outcomes +#' (`TRUE` and `FALSE`) in the resulting table, even when one outcome is not +#' observed in the data. +#' +#' When strata is not supplied, a single 2 x 2 contingency table is returned. +#' When strata is supplied, a separate 2 x 2 contingency table is created +#' for each stratum. +#' +#' @inheritParams assert_prop_data +#' +#' @return +#' A contingency table produced by [base::table()]. +#' +#' When strata is `NULL`, a 2 x 2 table is returned, with `grp` defining the rows +#' and `rsp` defining the columns. The `rsp` dimension always contains the levels +#' `TRUE` and `FALSE`, in that order, including when one outcome is not observed. +#' +#' When `strata` is supplied, a 3-dimensional contingency table with dimensions +#' 2 x 2 x k is returned, where k is the number of levels of strata. +#' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively. +#' +#' @seealso [assert_prop_data()] +#' +#' @author WW +#' @export +#' +#' @examples +#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +#' +#' safe_2x2_table(rsp, grp) +#' +#' # The FALSE/TRUE levels are retained even when only one outcome is observed. +#' safe_2x2_table(rep(TRUE, 6), grp) +#' +#' # Stratified 2 x 2 tables +#' strata <- factor(c(rep("S1", 3), rep("S2", 3))) +#' +#' safe_2x2_table(rsp, grp, strata) +safe_2x2_table <- function(rsp, grp, strata = NULL) { + assert_prop_data(rsp = rsp, grp = grp, strata = strata) - invisible() + # Make rsp a factor to handle cases with only TRUE or only FALSE. + rsp <- factor(rsp, levels = c("TRUE", "FALSE")) + + if (is.null(strata)) { + table(grp, rsp) + } else { + table(grp, rsp, strata) + } } #' Description of method used for proportion comparison diff --git a/_pkgdown.yml b/_pkgdown.yml index d6e0e13c6f..021f8c3fd7 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -113,6 +113,8 @@ reference: - -h_xticks - -prop_diff - check_diff_prop_ci + - assert_prop_data + - safe_2x2_table - title: rtables Helper Functions desc: These functions help to work with the `rtables` package and may be diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd new file mode 100644 index 0000000000..fc88a20c35 --- /dev/null +++ b/man/assert_prop_data.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_diff.R +\name{assert_prop_data} +\alias{assert_prop_data} +\title{Validate Data for a Proportion Analysis} +\usage{ +assert_prop_data(rsp, grp, strata = NULL) +} +\arguments{ +\item{rsp}{(\code{logical})\cr +Indicates whether each observation is a responder (\code{TRUE}) or a +non-responder (\verb{FALSE)}. Missing values are not allowed.} + +\item{grp}{(\code{factor})\cr +Assigns each observation to one of two groups, such as a reference and a +treatment group. Must have exactly two levels and the same length as +rsp. Missing values are not allowed.} + +\item{strata}{(\code{factor} or \code{NULL})\cr +Defines the stratification variable. When supplied, it must have the same +length as rsp and must not contain missing values.} +} +\value{ +Invisibly returns \code{NULL}. An error is raised if any input does not meet +the required conditions. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Validates the data required for a proportion analysis, including responder +status, group assignment, and optional stratification. +} +\examples{ +rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +strata <- factor(c("A", "A", "B", "A", "B", "B")) + +assert_prop_data(rsp, grp, strata) + +\dontrun{ +# An error is raised when `grp` has only one level. +grp <- factor(rep("X", 6)) +assert_prop_data(rsp, grp, strata) +} + +} +\author{ +WW +} diff --git a/man/check_diff_prop_ci.Rd b/man/check_diff_prop_ci.Rd index 9a70768494..1f079d6cd6 100644 --- a/man/check_diff_prop_ci.Rd +++ b/man/check_diff_prop_ci.Rd @@ -38,3 +38,6 @@ dta <- data.frame( ) check_diff_prop_ci(rsp = dta[["rsp"]], grp = dta[["grp"]], conf_level = 0.95) } +\seealso{ +\code{\link[=assert_prop_data]{assert_prop_data()}} +} diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd new file mode 100644 index 0000000000..398eb8b276 --- /dev/null +++ b/man/safe_2x2_table.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_diff.R +\name{safe_2x2_table} +\alias{safe_2x2_table} +\title{Construct 2 x 2 Contingency Tables Safely} +\usage{ +safe_2x2_table(rsp, grp, strata = NULL) +} +\arguments{ +\item{rsp}{(\code{logical})\cr +Indicates whether each observation is a responder (\code{TRUE}) or a +non-responder (\verb{FALSE)}. Missing values are not allowed.} + +\item{grp}{(\code{factor})\cr +Assigns each observation to one of two groups, such as a reference and a +treatment group. Must have exactly two levels and the same length as +rsp. Missing values are not allowed.} + +\item{strata}{(\code{factor} or \code{NULL})\cr +Defines the stratification variable. When supplied, it must have the same +length as rsp and must not contain missing values.} +} +\value{ +A contingency table produced by \code{\link[base:table]{base::table()}}. + +When strata is \code{NULL}, a 2 x 2 table is returned, with \code{grp} defining the rows +and \code{rsp} defining the columns. The \code{rsp} dimension always contains the levels +\code{TRUE} and \code{FALSE}, in that order, including when one outcome is not observed. + +When \code{strata} is supplied, a 3-dimensional contingency table with dimensions +2 x 2 x k is returned, where k is the number of levels of strata. +The dimensions correspond to \code{grp}, \code{rsp}, and \code{strata}, respectively. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Creates a 2 x 2 contingency table of responder status by group, optionally +stratified by a third factor. The function validates the input vectors and +ensures that the responder variable contains both possible outcomes +(\code{TRUE} and \code{FALSE}) in the resulting table, even when one outcome is not +observed in the data. + +When strata is not supplied, a single 2 x 2 contingency table is returned. +When strata is supplied, a separate 2 x 2 contingency table is created +for each stratum. +} +\examples{ +rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +grp <- factor(c(rep("Placebo", 3), rep("X", 3))) + +safe_2x2_table(rsp, grp) + +# The FALSE/TRUE levels are retained even when only one outcome is observed. +safe_2x2_table(rep(TRUE, 6), grp) + +# Stratified 2 x 2 tables +strata <- factor(c(rep("S1", 3), rep("S2", 3))) + +safe_2x2_table(rsp, grp, strata) +} +\seealso{ +\code{\link[=assert_prop_data]{assert_prop_data()}} +} +\author{ +WW +} diff --git a/tests/testthat/test-assert_prop_data.R b/tests/testthat/test-assert_prop_data.R new file mode 100644 index 0000000000..808a445443 --- /dev/null +++ b/tests/testthat/test-assert_prop_data.R @@ -0,0 +1,112 @@ +test_that("assert_prop_data() accepts valid data", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + strata <- factor(c("A", "A", "B", "B")) + + expect_silent( + result <- assert_prop_data(rsp, grp) + ) + expect_silent( + result_strata <- assert_prop_data(rsp, grp, strata) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_prop_data() accepts a single stratum", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("X", "X", "Placebo", "Placebo")) + strata <- factor(rep("S1", 4)) + + expect_silent( + result <- assert_prop_data(rsp, grp, strata) + ) + expect_null(result) +}) + +test_that("assert_prop_data() accepts empty data with an unused stratum level", { + grp <- factor(levels = c("Placebo", "X")) + strata <- factor(levels = "S1") + + expect_silent( + result <- assert_prop_data(logical(), grp) + ) + expect_silent( + result_strata <- assert_prop_data(logical(), grp, strata) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_prop_data() accepts empty data with no strata levels", { + grp <- factor(levels = c("Placebo", "X")) + + expect_silent( + result <- assert_prop_data(logical(), grp) + ) + expect_silent( + result_strata <- assert_prop_data(logical(), grp, factor()) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_prop_data() accepts empty data without strata", { + expect_silent( + result <- assert_prop_data(logical(), factor(levels = c("Placebo", "X"))) + ) + + expect_null(result) +}) + +test_that("assert_prop_data() accepts a single observed response outcome", { + grp <- factor(c("X", "X", "Placebo")) + + # FALSE only + expect_silent(assert_prop_data(rep(FALSE, 3), grp)) + expect_null(assert_prop_data(rep(FALSE, 3), grp)) + + # TRUE only + expect_silent(assert_prop_data(rep(TRUE, 3), grp)) + expect_null(assert_prop_data(rep(TRUE, 3), grp)) +}) + +test_that("assert_prop_data() accepts unobserved group levels", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(rep("X", 4), levels = c("Placebo", "X")) + + expect_silent(assert_prop_data(rsp, grp)) + expect_null(assert_prop_data(rsp, grp)) +}) + +test_that("assert_prop_data() validates rsp", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + + expect_error(assert_prop_data(as.character(rsp), grp)) + expect_error(assert_prop_data(as.numeric(rsp), grp)) + expect_error(assert_prop_data(c(rsp[-1], NA), grp)) +}) + +test_that("assert_prop_data() validates grp", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- c("Active", "Active", "Control", "Control") + + expect_error(assert_prop_data(rsp, grp)) + expect_error(assert_prop_data(rsp, c(1, 1, 2, 2))) + expect_error(assert_prop_data(rsp, factor(rep("Active", 4)))) + expect_error(assert_prop_data(rsp, factor(c("X", "X", "P"), levels = c("X", "P", "O")))) + expect_error(assert_prop_data(rsp, factor(grp[-1]))) + expect_error(assert_prop_data(rsp, factor(c(NA, grp[-1])))) +}) + +test_that("assert_prop_data() validates strata", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + strata <- c("A", "A", "B", "B") + + expect_error(assert_prop_data(rsp, grp, strata)) + expect_error(assert_prop_data(rsp, grp, c(1, 1, 2, 2))) + expect_error(assert_prop_data(rsp, grp, strata[-1])) + expect_error(assert_prop_data(rsp, grp, c(strata[-1], NA))) +}) diff --git a/tests/testthat/test-safe_2x2_table.R b/tests/testthat/test-safe_2x2_table.R new file mode 100644 index 0000000000..96d8ee14ae --- /dev/null +++ b/tests/testthat/test-safe_2x2_table.R @@ -0,0 +1,242 @@ +test_that("safe_2x2_table() works without strata", { + set.seed(123) + n <- 100 + rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) + grp <- factor(sample(c("Placebo", "X"), n, replace = TRUE)) + + expect_silent( + result <- safe_2x2_table(rsp, grp) + ) + expected <- as.table(array( + c(26L, 31L, 20L, 23L), + dim = c(2L, 2L), + dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + )) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() works with multiple observations and strata", { + set.seed(123) + n <- 100 + rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) + grp <- factor(sample(c("Placebo", "X"), n, replace = TRUE)) + strata <- factor(sample(LETTERS[1:4], n, replace = TRUE)) + + expect_silent( + result <- safe_2x2_table(rsp, grp, strata) + ) + expected <- as.table(array( + c(6L, 9L, 9L, 8L, 8L, 6L, 5L, 5L, 5L, 5L, 4L, 5L, 7L, 11L, 2L, 5L), + dim = c(2, 2, 4), + dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = LETTERS[1:4]) + )) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() gives the same result with one stratum", { + set.seed(123) + n <- 20 + grp <- factor(sample(c("Active", "Control"), n, replace = TRUE)) + rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) + strata <- factor(rep("A", n)) + + expect_silent( + result <- safe_2x2_table(rsp, grp) + ) + expect_silent( + result_1stratum <- safe_2x2_table(rsp, grp, strata) + ) + + expect_identical(result, result_1stratum[, , 1]) +}) + +test_that("safe_2x2_table() retains unobserved response outcomes (TRUE only)", { + rsp <- rep(TRUE, 4) + grp <- factor(c("Placebo", "Placebo", "X", "X")) + strata <- factor(c("S1", "S2", "S1", "S2")) + + expect_silent( + result <- safe_2x2_table(rsp, grp) + ) + expect_silent( + result_strata <- safe_2x2_table(rsp, grp, strata) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + expected <- as.table(array(c(2L, 2L, 0L, 0L), dim = c(2L, 2L), dimnames = dimnames)) + expected_strata <- as.table(array( + c(1L, 1L, 0L, 0L, 1L, 1L, 0L, 0L), + dim = c(2L, 2L, 2L), + dimnames = c(dimnames, strata = list(c("S1", "S2"))) + )) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("safe_2x2_table() retains unobserved response outcomes (FALSE only)", { + rsp <- rep(FALSE, 4) + grp <- factor(c("Placebo", "Placebo", "X", "X")) + strata <- factor(c("S1", "S2", "S1", "S2")) + + expect_silent( + result <- safe_2x2_table(rsp, grp) + ) + expect_silent( + result_strata <- safe_2x2_table(rsp, grp, strata) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + expected <- as.table(array(c(0L, 0L, 2L, 2L), dim = c(2L, 2L), dimnames = dimnames)) + expected_strata <- as.table(array( + c(0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L), + dim = c(2L, 2L, 2L), + dimnames = c(dimnames, strata = list(c("S1", "S2"))) + )) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("safe_2x2_table() retains unobserved group levels", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(rep("X", 4), levels = c("Placebo", "X")) + strata <- factor(c("S1", "S2", "S2", "S1")) + + expect_silent( + result <- safe_2x2_table(rsp, grp) + ) + expect_silent( + result_strata <- safe_2x2_table(rsp, grp, strata) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + expected <- as.table(array(c(0L, 2L, 0L, 2L), dim = c(2L, 2L), dimnames = dimnames)) + expected_strata <- as.table(array( + c(0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L), + dim = c(2L, 2L, 2L), + dimnames = c(dimnames, strata = list(c("S1", "S2"))) + )) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("safe_2x2_table() retains unused strata levels", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("X", "X", "Placebo", "Placebo")) + strata <- factor(c("A", "A", "B", "B"), levels = c("A", "B", "Z")) + + expect_silent( + result <- safe_2x2_table(rsp, grp, strata) + ) + + expected <- as.table(array( + c(0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L), + dim = c(2L, 2L, 3L), + dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = c("A", "B", "Z")) + )) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() handles sparse contingency tables", { + rsp <- c(TRUE, TRUE, TRUE, TRUE) + grp <- factor(c("Y", "Y", "Cntrl", "Cntrl")) + strata <- factor(c("A", "A", "B", "B")) + + expect_silent( + result <- safe_2x2_table(rsp, grp, strata) + ) + + expected <- as.table(array( + c(0L, 2L, 0L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 0L), + dim = c(2L, 2L, 2L), + dimnames = list(grp = c("Cntrl", "Y"), rsp = c("TRUE", "FALSE"), strata = c("A", "B")) + )) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() handles empty data with an unused stratum level", { + grp <- factor(levels = c("Placebo", "X")) + strata <- factor(levels = "S1") + + expect_silent( + result <- safe_2x2_table(logical(), grp) + ) + expect_silent( + result_strata <- safe_2x2_table(logical(), grp, strata) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + expected <- as.table(array(c(0L, 0L, 0L, 0L), dim = c(2L, 2L), dimnames = dimnames)) + expected_strata <- as.table(array( + c(0L, 0L, 0L, 0L), + dim = c(2L, 2L, 1L), + dimnames = c(dimnames, strata = "S1") + )) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("safe_2x2_table() handles empty data with no stratum levels", { + expect_silent( + result <- safe_2x2_table( + logical(), factor(levels = c("Placebo", "X")), factor() + ) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = character()) + expected <- as.table(array(integer(), dim = c(2L, 2L, 0L), dimnames = dimnames)) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() handles empty data without strata", { + expect_silent( + result <- safe_2x2_table(logical(), factor(levels = c("Placebo", "X"))) + ) + + dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) + expected <- as.table(array(rep(0L, 4), dim = c(2L, 2L), dimnames = dimnames)) + + expect_identical(result, expected) +}) + +test_that("safe_2x2_table() validates inputs (rsp)", { + grp <- factor(c("G1", "G1", "G2", "G2")) + rsp <- c(TRUE, FALSE, TRUE, FALSE) + strata <- factor(c("A", "A", "B", "B")) + + expect_error(safe_2x2_table(as.character(rsp), grp)) + expect_error(safe_2x2_table(as.numeric(rsp), grp)) + expect_error(safe_2x2_table(c(rsp[-1], NA), grp)) +}) + +test_that("safe_2x2_table() validates inputs (grp)", { + grp <- factor(c("G1", "G1", "G2", "G2")) + rsp <- c(TRUE, FALSE, TRUE, FALSE) + strata <- factor(c("A", "A", "B", "B")) + + expect_error(safe_2x2_table(rsp, as.character(grp))) + expect_error(safe_2x2_table(rsp, as.numeric(grp))) + expect_error(safe_2x2_table(rsp, factor(rep("G1", 4)))) + expect_error(safe_2x2_table(rsp, factor(grp, levels = c("G1", "G2", "G3")))) + expect_error(safe_2x2_table(rsp, grp[-1])) + expect_error(safe_2x2_table(rsp, factor(c(NA, grp[-1])))) +}) + +test_that("safe_2x2_table() validates inputs (strata)", { + grp <- factor(c("G1", "G1", "G2", "G2")) + rsp <- c(TRUE, FALSE, TRUE, FALSE) + strata <- factor(c("A", "A", "B", "B")) + + expect_error(safe_2x2_table(rsp, grp, as.character(strata))) + expect_error(safe_2x2_table(rsp, grp, as.numeric(strata))) + expect_error(safe_2x2_table(rsp, grp, strata[-1])) + expect_error(safe_2x2_table(rsp, grp, factor(c(strata[-1], NA)))) +}) From 17965f0acd5e0d4bcdee00e655fa575ece8b7067 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Sat, 29 Aug 2026 16:52:34 +0200 Subject: [PATCH 02/40] Update man for assert_prop_data() and safe_2x2_table(). --- R/prop_diff.R | 19 +++++++++++-------- man/assert_prop_data.Rd | 4 ++-- man/safe_2x2_table.Rd | 19 +++++++++++-------- 3 files changed, 24 insertions(+), 18 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index c65a61bbdf..1dbf141f77 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -379,10 +379,10 @@ estimate_proportion_diff <- function(lyt, #' @param grp (`factor`)\cr #' Assigns each observation to one of two groups, such as a reference and a #' treatment group. Must have exactly two levels and the same length as -#' rsp. Missing values are not allowed. +#' `rsp`. Missing values are not allowed. #' @param strata (`factor` or `NULL`)\cr #' Defines the stratification variable. When supplied, it must have the same -#' length as rsp and must not contain missing values. +#' length as `rsp` and must not contain missing values. #' #' @return #' Invisibly returns `NULL`. An error is raised if any input does not meet @@ -480,16 +480,19 @@ check_diff_prop_ci <- function(rsp, #' @export #' #' @examples -#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE) +#' grp <- factor(c(rep("Placebo", 4), rep("X", 4))) +#' +#' tbl <- safe_2x2_table(rsp, grp) #' -#' safe_2x2_table(rsp, grp) +#' # Example use case: Fisher's exact test. +#' prop_fisher(tbl) #' #' # The FALSE/TRUE levels are retained even when only one outcome is observed. -#' safe_2x2_table(rep(TRUE, 6), grp) +#' safe_2x2_table(rep(TRUE, 8), grp) #' -#' # Stratified 2 x 2 tables -#' strata <- factor(c(rep("S1", 3), rep("S2", 3))) +#' # Stratified 2 x 2 tables. +#' strata <- factor(c(rep("S1", 4), rep("S2", 4))) #' #' safe_2x2_table(rsp, grp, strata) safe_2x2_table <- function(rsp, grp, strata = NULL) { diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd index fc88a20c35..37bb0eb838 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_prop_data.Rd @@ -14,11 +14,11 @@ non-responder (\verb{FALSE)}. Missing values are not allowed.} \item{grp}{(\code{factor})\cr Assigns each observation to one of two groups, such as a reference and a treatment group. Must have exactly two levels and the same length as -rsp. Missing values are not allowed.} +\code{rsp}. Missing values are not allowed.} \item{strata}{(\code{factor} or \code{NULL})\cr Defines the stratification variable. When supplied, it must have the same -length as rsp and must not contain missing values.} +length as \code{rsp} and must not contain missing values.} } \value{ Invisibly returns \code{NULL}. An error is raised if any input does not meet diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd index 398eb8b276..0a80fdcc77 100644 --- a/man/safe_2x2_table.Rd +++ b/man/safe_2x2_table.Rd @@ -14,11 +14,11 @@ non-responder (\verb{FALSE)}. Missing values are not allowed.} \item{grp}{(\code{factor})\cr Assigns each observation to one of two groups, such as a reference and a treatment group. Must have exactly two levels and the same length as -rsp. Missing values are not allowed.} +\code{rsp}. Missing values are not allowed.} \item{strata}{(\code{factor} or \code{NULL})\cr Defines the stratification variable. When supplied, it must have the same -length as rsp and must not contain missing values.} +length as \code{rsp} and must not contain missing values.} } \value{ A contingency table produced by \code{\link[base:table]{base::table()}}. @@ -45,16 +45,19 @@ When strata is supplied, a separate 2 x 2 contingency table is created for each stratum. } \examples{ -rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE) +grp <- factor(c(rep("Placebo", 4), rep("X", 4))) -safe_2x2_table(rsp, grp) +tbl <- safe_2x2_table(rsp, grp) + +# Example use case: Fisher's exact test. +prop_fisher(tbl) # The FALSE/TRUE levels are retained even when only one outcome is observed. -safe_2x2_table(rep(TRUE, 6), grp) +safe_2x2_table(rep(TRUE, 8), grp) -# Stratified 2 x 2 tables -strata <- factor(c(rep("S1", 3), rep("S2", 3))) +# Stratified 2 x 2 tables. +strata <- factor(c(rep("S1", 4), rep("S2", 4))) safe_2x2_table(rsp, grp, strata) } From 638b6702b8dbd7d80d425687f603fe3918770819 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Mon, 31 Aug 2026 12:35:40 +0200 Subject: [PATCH 03/40] assert_prop_data() should not be exported. --- NAMESPACE | 1 - R/prop_diff.R | 8 ++++---- man/assert_prop_data.Rd | 3 ++- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 725c713eba..158994ed8b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,7 +56,6 @@ export(as.rtable) export(as_factor_keep_attributes) export(assert_df_with_factors) export(assert_df_with_variables) -export(assert_prop_data) export(assert_proportion_value) export(check_diff_prop_ci) export(clogit_with_tryCatch) diff --git a/R/prop_diff.R b/R/prop_diff.R index 1dbf141f77..ed24f11beb 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -388,22 +388,22 @@ estimate_proportion_diff <- function(lyt, #' Invisibly returns `NULL`. An error is raised if any input does not meet #' the required conditions. #' +#' @author WW +#' @keywords internal +#' #' @examples +#' \dontrun{ #' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) #' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) #' strata <- factor(c("A", "A", "B", "A", "B", "B")) #' #' assert_prop_data(rsp, grp, strata) #' -#' \dontrun{ #' # An error is raised when `grp` has only one level. #' grp <- factor(rep("X", 6)) #' assert_prop_data(rsp, grp, strata) #' } #' -#' @author WW -#' -#' @export assert_prop_data <- function(rsp, grp, strata = NULL) { checkmate::assert_logical(rsp, any.missing = FALSE) checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd index 37bb0eb838..05f2c29824 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_prop_data.Rd @@ -31,13 +31,13 @@ Validates the data required for a proportion analysis, including responder status, group assignment, and optional stratification. } \examples{ +\dontrun{ rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) grp <- factor(c(rep("Placebo", 3), rep("X", 3))) strata <- factor(c("A", "A", "B", "A", "B", "B")) assert_prop_data(rsp, grp, strata) -\dontrun{ # An error is raised when `grp` has only one level. grp <- factor(rep("X", 6)) assert_prop_data(rsp, grp, strata) @@ -47,3 +47,4 @@ assert_prop_data(rsp, grp, strata) \author{ WW } +\keyword{internal} From 1ab9c5fd3cb9da0670a6dcf28ad317a8e92cfa06 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Mon, 31 Aug 2026 12:38:34 +0200 Subject: [PATCH 04/40] assert_prop_data() man update. --- R/prop_diff.R | 4 ++-- man/assert_prop_data.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index ed24f11beb..12ac55fe11 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -397,11 +397,11 @@ estimate_proportion_diff <- function(lyt, #' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) #' strata <- factor(c("A", "A", "B", "A", "B", "B")) #' -#' assert_prop_data(rsp, grp, strata) +#' tern:::assert_prop_data(rsp, grp, strata) #' #' # An error is raised when `grp` has only one level. #' grp <- factor(rep("X", 6)) -#' assert_prop_data(rsp, grp, strata) +#' tern:::assert_prop_data(rsp, grp, strata) #' } #' assert_prop_data <- function(rsp, grp, strata = NULL) { diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd index 05f2c29824..fa28677925 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_prop_data.Rd @@ -36,11 +36,11 @@ rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) grp <- factor(c(rep("Placebo", 3), rep("X", 3))) strata <- factor(c("A", "A", "B", "A", "B", "B")) -assert_prop_data(rsp, grp, strata) +tern:::assert_prop_data(rsp, grp, strata) # An error is raised when `grp` has only one level. grp <- factor(rep("X", 6)) -assert_prop_data(rsp, grp, strata) +tern:::assert_prop_data(rsp, grp, strata) } } From aac4af49c98bb17b6fef69dc29404350300e5abd Mon Sep 17 00:00:00 2001 From: Wojtek Date: Mon, 31 Aug 2026 17:13:05 +0200 Subject: [PATCH 05/40] update assert_prop_data() man page. --- R/prop_diff.R | 14 -------------- man/assert_prop_data.Rd | 14 -------------- 2 files changed, 28 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 12ac55fe11..e7202c173d 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -390,20 +390,6 @@ estimate_proportion_diff <- function(lyt, #' #' @author WW #' @keywords internal -#' -#' @examples -#' \dontrun{ -#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) -#' strata <- factor(c("A", "A", "B", "A", "B", "B")) -#' -#' tern:::assert_prop_data(rsp, grp, strata) -#' -#' # An error is raised when `grp` has only one level. -#' grp <- factor(rep("X", 6)) -#' tern:::assert_prop_data(rsp, grp, strata) -#' } -#' assert_prop_data <- function(rsp, grp, strata = NULL) { checkmate::assert_logical(rsp, any.missing = FALSE) checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd index fa28677925..322805fc32 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_prop_data.Rd @@ -29,20 +29,6 @@ the required conditions. Validates the data required for a proportion analysis, including responder status, group assignment, and optional stratification. -} -\examples{ -\dontrun{ -rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -grp <- factor(c(rep("Placebo", 3), rep("X", 3))) -strata <- factor(c("A", "A", "B", "A", "B", "B")) - -tern:::assert_prop_data(rsp, grp, strata) - -# An error is raised when `grp` has only one level. -grp <- factor(rep("X", 6)) -tern:::assert_prop_data(rsp, grp, strata) -} - } \author{ WW From cfb01b2e3adb91d6d55ec928b603aed60650a55e Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 1 Sep 2026 17:30:35 +0200 Subject: [PATCH 06/40] Export assert_prop_data(). --- NAMESPACE | 1 + R/prop_diff.R | 15 ++++++++++++++- man/assert_prop_data.Rd | 14 +++++++++++++- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 158994ed8b..725c713eba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,6 +56,7 @@ export(as.rtable) export(as_factor_keep_attributes) export(assert_df_with_factors) export(assert_df_with_variables) +export(assert_prop_data) export(assert_proportion_value) export(check_diff_prop_ci) export(clogit_with_tryCatch) diff --git a/R/prop_diff.R b/R/prop_diff.R index e7202c173d..02f48d8787 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -389,7 +389,20 @@ estimate_proportion_diff <- function(lyt, #' the required conditions. #' #' @author WW -#' @keywords internal +#' @export +#' +#' @examples +#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +#' strata <- factor(c("A", "A", "B", "A", "B", "B")) +#' +#' assert_prop_data(rsp, grp, strata) +#' +#' \dontrun{ +#' # An error is raised when `grp` has only one level. +#' grp <- factor(rep("X", 6)) +#' assert_prop_data(rsp, grp, strata) +#' } assert_prop_data <- function(rsp, grp, strata = NULL) { checkmate::assert_logical(rsp, any.missing = FALSE) checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) diff --git a/man/assert_prop_data.Rd b/man/assert_prop_data.Rd index 322805fc32..26f4cb4440 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_prop_data.Rd @@ -30,7 +30,19 @@ the required conditions. Validates the data required for a proportion analysis, including responder status, group assignment, and optional stratification. } +\examples{ +rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +strata <- factor(c("A", "A", "B", "A", "B", "B")) + +assert_prop_data(rsp, grp, strata) + +\dontrun{ +# An error is raised when `grp` has only one level. +grp <- factor(rep("X", 6)) +assert_prop_data(rsp, grp, strata) +} +} \author{ WW } -\keyword{internal} From 9961855254e1e0ac191ebe39edb501f5c3614d5f Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 2 Sep 2026 13:04:55 +0200 Subject: [PATCH 07/40] Rename assert_prop_data() to assert_proportion_data(). --- NAMESPACE | 2 +- NEWS.md | 2 +- R/prop_diff.R | 16 +-- _pkgdown.yml | 2 +- ...prop_data.Rd => assert_proportion_data.Rd} | 14 +-- man/check_diff_prop_ci.Rd | 2 +- man/safe_2x2_table.Rd | 6 +- tests/testthat/test-assert_prop_data.R | 112 ------------------ tests/testthat/test-assert_proportion_data.R | 112 ++++++++++++++++++ 9 files changed, 134 insertions(+), 134 deletions(-) rename man/{assert_prop_data.Rd => assert_proportion_data.Rd} (79%) delete mode 100644 tests/testthat/test-assert_prop_data.R create mode 100644 tests/testthat/test-assert_proportion_data.R diff --git a/NAMESPACE b/NAMESPACE index 725c713eba..2f2b55058b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,7 +56,7 @@ export(as.rtable) export(as_factor_keep_attributes) export(assert_df_with_factors) export(assert_df_with_variables) -export(assert_prop_data) +export(assert_proportion_data) export(assert_proportion_value) export(check_diff_prop_ci) export(clogit_with_tryCatch) diff --git a/NEWS.md b/NEWS.md index 24ad98e8a2..9ce998f92c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ ### Enhancements * Added `safe_2x2_table()` to construct 2 x 2 x k contingency tables safely. -* Added `assert_prop_data()` to validate responder, group, and optional +* Added `assert_proportion_data()` to validate responder, group, and optional stratification data used in proportion analyses. # tern 0.9.11 diff --git a/R/prop_diff.R b/R/prop_diff.R index 02f48d8787..0452109832 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -381,8 +381,8 @@ estimate_proportion_diff <- function(lyt, #' treatment group. Must have exactly two levels and the same length as #' `rsp`. Missing values are not allowed. #' @param strata (`factor` or `NULL`)\cr -#' Defines the stratification variable. When supplied, it must have the same -#' length as `rsp` and must not contain missing values. +#' Defines the stratification variable. If not `NULL`, it must have the same +#' length as `rsp` and must not contain any missing values. #' #' @return #' Invisibly returns `NULL`. An error is raised if any input does not meet @@ -396,14 +396,14 @@ estimate_proportion_diff <- function(lyt, #' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) #' strata <- factor(c("A", "A", "B", "A", "B", "B")) #' -#' assert_prop_data(rsp, grp, strata) +#' assert_proportion_data(rsp, grp, strata) #' #' \dontrun{ #' # An error is raised when `grp` has only one level. #' grp <- factor(rep("X", 6)) -#' assert_prop_data(rsp, grp, strata) +#' assert_proportion_data(rsp, grp, strata) #' } -assert_prop_data <- function(rsp, grp, strata = NULL) { +assert_proportion_data <- function(rsp, grp, strata = NULL) { checkmate::assert_logical(rsp, any.missing = FALSE) checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) @@ -420,7 +420,7 @@ assert_prop_data <- function(rsp, grp, strata = NULL) { #' @inheritParams prop_diff #' @inheritParams prop_diff_wald #' -#' @seealso [assert_prop_data()] +#' @seealso [assert_proportion_data()] #' #' @examples #' # example code @@ -460,7 +460,7 @@ check_diff_prop_ci <- function(rsp, #' When strata is supplied, a separate 2 x 2 contingency table is created #' for each stratum. #' -#' @inheritParams assert_prop_data +#' @inheritParams assert_proportion_data #' #' @return #' A contingency table produced by [base::table()]. @@ -473,7 +473,7 @@ check_diff_prop_ci <- function(rsp, #' 2 x 2 x k is returned, where k is the number of levels of strata. #' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively. #' -#' @seealso [assert_prop_data()] +#' @seealso [assert_proportion_data()] #' #' @author WW #' @export diff --git a/_pkgdown.yml b/_pkgdown.yml index 021f8c3fd7..a14530772a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -113,7 +113,7 @@ reference: - -h_xticks - -prop_diff - check_diff_prop_ci - - assert_prop_data + - assert_proportion_data - safe_2x2_table - title: rtables Helper Functions diff --git a/man/assert_prop_data.Rd b/man/assert_proportion_data.Rd similarity index 79% rename from man/assert_prop_data.Rd rename to man/assert_proportion_data.Rd index 26f4cb4440..212258c8d2 100644 --- a/man/assert_prop_data.Rd +++ b/man/assert_proportion_data.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/prop_diff.R -\name{assert_prop_data} -\alias{assert_prop_data} +\name{assert_proportion_data} +\alias{assert_proportion_data} \title{Validate Data for a Proportion Analysis} \usage{ -assert_prop_data(rsp, grp, strata = NULL) +assert_proportion_data(rsp, grp, strata = NULL) } \arguments{ \item{rsp}{(\code{logical})\cr @@ -17,8 +17,8 @@ treatment group. Must have exactly two levels and the same length as \code{rsp}. Missing values are not allowed.} \item{strata}{(\code{factor} or \code{NULL})\cr -Defines the stratification variable. When supplied, it must have the same -length as \code{rsp} and must not contain missing values.} +Defines the stratification variable. If not \code{NULL}, it must have the same +length as \code{rsp} and must not contain any missing values.} } \value{ Invisibly returns \code{NULL}. An error is raised if any input does not meet @@ -35,12 +35,12 @@ rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) grp <- factor(c(rep("Placebo", 3), rep("X", 3))) strata <- factor(c("A", "A", "B", "A", "B", "B")) -assert_prop_data(rsp, grp, strata) +assert_proportion_data(rsp, grp, strata) \dontrun{ # An error is raised when `grp` has only one level. grp <- factor(rep("X", 6)) -assert_prop_data(rsp, grp, strata) +assert_proportion_data(rsp, grp, strata) } } \author{ diff --git a/man/check_diff_prop_ci.Rd b/man/check_diff_prop_ci.Rd index 1f079d6cd6..b20cada35e 100644 --- a/man/check_diff_prop_ci.Rd +++ b/man/check_diff_prop_ci.Rd @@ -39,5 +39,5 @@ dta <- data.frame( check_diff_prop_ci(rsp = dta[["rsp"]], grp = dta[["grp"]], conf_level = 0.95) } \seealso{ -\code{\link[=assert_prop_data]{assert_prop_data()}} +\code{\link[=assert_proportion_data]{assert_proportion_data()}} } diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd index 0a80fdcc77..7c3e9eb92e 100644 --- a/man/safe_2x2_table.Rd +++ b/man/safe_2x2_table.Rd @@ -17,8 +17,8 @@ treatment group. Must have exactly two levels and the same length as \code{rsp}. Missing values are not allowed.} \item{strata}{(\code{factor} or \code{NULL})\cr -Defines the stratification variable. When supplied, it must have the same -length as \code{rsp} and must not contain missing values.} +Defines the stratification variable. If not \code{NULL}, it must have the same +length as \code{rsp} and must not contain any missing values.} } \value{ A contingency table produced by \code{\link[base:table]{base::table()}}. @@ -62,7 +62,7 @@ strata <- factor(c(rep("S1", 4), rep("S2", 4))) safe_2x2_table(rsp, grp, strata) } \seealso{ -\code{\link[=assert_prop_data]{assert_prop_data()}} +\code{\link[=assert_proportion_data]{assert_proportion_data()}} } \author{ WW diff --git a/tests/testthat/test-assert_prop_data.R b/tests/testthat/test-assert_prop_data.R deleted file mode 100644 index 808a445443..0000000000 --- a/tests/testthat/test-assert_prop_data.R +++ /dev/null @@ -1,112 +0,0 @@ -test_that("assert_prop_data() accepts valid data", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(c("Active", "Active", "Control", "Control")) - strata <- factor(c("A", "A", "B", "B")) - - expect_silent( - result <- assert_prop_data(rsp, grp) - ) - expect_silent( - result_strata <- assert_prop_data(rsp, grp, strata) - ) - expect_null(result) - expect_null(result_strata) -}) - -test_that("assert_prop_data() accepts a single stratum", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(c("X", "X", "Placebo", "Placebo")) - strata <- factor(rep("S1", 4)) - - expect_silent( - result <- assert_prop_data(rsp, grp, strata) - ) - expect_null(result) -}) - -test_that("assert_prop_data() accepts empty data with an unused stratum level", { - grp <- factor(levels = c("Placebo", "X")) - strata <- factor(levels = "S1") - - expect_silent( - result <- assert_prop_data(logical(), grp) - ) - expect_silent( - result_strata <- assert_prop_data(logical(), grp, strata) - ) - expect_null(result) - expect_null(result_strata) -}) - -test_that("assert_prop_data() accepts empty data with no strata levels", { - grp <- factor(levels = c("Placebo", "X")) - - expect_silent( - result <- assert_prop_data(logical(), grp) - ) - expect_silent( - result_strata <- assert_prop_data(logical(), grp, factor()) - ) - expect_null(result) - expect_null(result_strata) -}) - -test_that("assert_prop_data() accepts empty data without strata", { - expect_silent( - result <- assert_prop_data(logical(), factor(levels = c("Placebo", "X"))) - ) - - expect_null(result) -}) - -test_that("assert_prop_data() accepts a single observed response outcome", { - grp <- factor(c("X", "X", "Placebo")) - - # FALSE only - expect_silent(assert_prop_data(rep(FALSE, 3), grp)) - expect_null(assert_prop_data(rep(FALSE, 3), grp)) - - # TRUE only - expect_silent(assert_prop_data(rep(TRUE, 3), grp)) - expect_null(assert_prop_data(rep(TRUE, 3), grp)) -}) - -test_that("assert_prop_data() accepts unobserved group levels", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(rep("X", 4), levels = c("Placebo", "X")) - - expect_silent(assert_prop_data(rsp, grp)) - expect_null(assert_prop_data(rsp, grp)) -}) - -test_that("assert_prop_data() validates rsp", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(c("Active", "Active", "Control", "Control")) - - expect_error(assert_prop_data(as.character(rsp), grp)) - expect_error(assert_prop_data(as.numeric(rsp), grp)) - expect_error(assert_prop_data(c(rsp[-1], NA), grp)) -}) - -test_that("assert_prop_data() validates grp", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- c("Active", "Active", "Control", "Control") - - expect_error(assert_prop_data(rsp, grp)) - expect_error(assert_prop_data(rsp, c(1, 1, 2, 2))) - expect_error(assert_prop_data(rsp, factor(rep("Active", 4)))) - expect_error(assert_prop_data(rsp, factor(c("X", "X", "P"), levels = c("X", "P", "O")))) - expect_error(assert_prop_data(rsp, factor(grp[-1]))) - expect_error(assert_prop_data(rsp, factor(c(NA, grp[-1])))) -}) - -test_that("assert_prop_data() validates strata", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(c("Active", "Active", "Control", "Control")) - strata <- c("A", "A", "B", "B") - - expect_error(assert_prop_data(rsp, grp, strata)) - expect_error(assert_prop_data(rsp, grp, c(1, 1, 2, 2))) - expect_error(assert_prop_data(rsp, grp, strata[-1])) - expect_error(assert_prop_data(rsp, grp, c(strata[-1], NA))) -}) diff --git a/tests/testthat/test-assert_proportion_data.R b/tests/testthat/test-assert_proportion_data.R new file mode 100644 index 0000000000..e592378f3d --- /dev/null +++ b/tests/testthat/test-assert_proportion_data.R @@ -0,0 +1,112 @@ +test_that("assert_proportion_data() accepts valid data", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + strata <- factor(c("A", "A", "B", "B")) + + expect_silent( + result <- assert_proportion_data(rsp, grp) + ) + expect_silent( + result_strata <- assert_proportion_data(rsp, grp, strata) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_proportion_data() accepts a single stratum", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("X", "X", "Placebo", "Placebo")) + strata <- factor(rep("S1", 4)) + + expect_silent( + result <- assert_proportion_data(rsp, grp, strata) + ) + expect_null(result) +}) + +test_that("assert_proportion_data() accepts empty data with an unused stratum level", { + grp <- factor(levels = c("Placebo", "X")) + strata <- factor(levels = "S1") + + expect_silent( + result <- assert_proportion_data(logical(), grp) + ) + expect_silent( + result_strata <- assert_proportion_data(logical(), grp, strata) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_proportion_data() accepts empty data with no strata levels", { + grp <- factor(levels = c("Placebo", "X")) + + expect_silent( + result <- assert_proportion_data(logical(), grp) + ) + expect_silent( + result_strata <- assert_proportion_data(logical(), grp, factor()) + ) + expect_null(result) + expect_null(result_strata) +}) + +test_that("assert_proportion_data() accepts empty data without strata", { + expect_silent( + result <- assert_proportion_data(logical(), factor(levels = c("Placebo", "X"))) + ) + + expect_null(result) +}) + +test_that("assert_proportion_data() accepts a single observed response outcome", { + grp <- factor(c("X", "X", "Placebo")) + + # FALSE only + expect_silent(assert_proportion_data(rep(FALSE, 3), grp)) + expect_null(assert_proportion_data(rep(FALSE, 3), grp)) + + # TRUE only + expect_silent(assert_proportion_data(rep(TRUE, 3), grp)) + expect_null(assert_proportion_data(rep(TRUE, 3), grp)) +}) + +test_that("assert_proportion_data() accepts unobserved group levels", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(rep("X", 4), levels = c("Placebo", "X")) + + expect_silent(assert_proportion_data(rsp, grp)) + expect_null(assert_proportion_data(rsp, grp)) +}) + +test_that("assert_proportion_data() validates rsp", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + + expect_error(assert_proportion_data(as.character(rsp), grp)) + expect_error(assert_proportion_data(as.numeric(rsp), grp)) + expect_error(assert_proportion_data(c(rsp[-1], NA), grp)) +}) + +test_that("assert_proportion_data() validates grp", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- c("Active", "Active", "Control", "Control") + + expect_error(assert_proportion_data(rsp, grp)) + expect_error(assert_proportion_data(rsp, c(1, 1, 2, 2))) + expect_error(assert_proportion_data(rsp, factor(rep("Active", 4)))) + expect_error(assert_proportion_data(rsp, factor(c("X", "X", "P"), levels = c("X", "P", "O")))) + expect_error(assert_proportion_data(rsp, factor(grp[-1]))) + expect_error(assert_proportion_data(rsp, factor(c(NA, grp[-1])))) +}) + +test_that("assert_proportion_data() validates strata", { + rsp <- c(TRUE, FALSE, TRUE, FALSE) + grp <- factor(c("Active", "Active", "Control", "Control")) + strata <- c("A", "A", "B", "B") + + expect_error(assert_proportion_data(rsp, grp, strata)) + expect_error(assert_proportion_data(rsp, grp, c(1, 1, 2, 2))) + expect_error(assert_proportion_data(rsp, grp, strata[-1])) + expect_error(assert_proportion_data(rsp, grp, c(strata[-1], NA))) +}) From f2baa623e20140458881704e57135281ac52500f Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 2 Sep 2026 13:15:01 +0200 Subject: [PATCH 08/40] fixing typo (old function name) --- R/prop_diff.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 0452109832..8174c82468 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -440,7 +440,7 @@ check_diff_prop_ci <- function(rsp, strata = NULL, conf_level, correct = NULL) { - assert_prop_data(rsp = rsp, grp = grp, strata = strata) + assert_proportion_data(rsp = rsp, grp = grp, strata = strata) checkmate::assert_number(conf_level, lower = 0, upper = 1) checkmate::assert_flag(correct, null.ok = TRUE) invisible() @@ -495,7 +495,7 @@ check_diff_prop_ci <- function(rsp, #' #' safe_2x2_table(rsp, grp, strata) safe_2x2_table <- function(rsp, grp, strata = NULL) { - assert_prop_data(rsp = rsp, grp = grp, strata = strata) + assert_proportion_data(rsp = rsp, grp = grp, strata = strata) # Make rsp a factor to handle cases with only TRUE or only FALSE. rsp <- factor(rsp, levels = c("TRUE", "FALSE")) From c52708042aa37a2db335c29bfbf5f81d07ab1785 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 2 Sep 2026 14:15:11 +0200 Subject: [PATCH 09/40] Moved assert_proportion_data() to assertions. --- R/prop_diff.R | 48 ----------------------------------- R/utils_checkmate.R | 35 +++++++++++++++++++++++++ man/assert_proportion_data.Rd | 48 ----------------------------------- man/assertions.Rd | 30 ++++++++++++++++++++++ man/check_diff_prop_ci.Rd | 3 --- man/safe_2x2_table.Rd | 3 --- 6 files changed, 65 insertions(+), 102 deletions(-) delete mode 100644 man/assert_proportion_data.Rd diff --git a/R/prop_diff.R b/R/prop_diff.R index 8174c82468..67d94a76f6 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -366,50 +366,6 @@ estimate_proportion_diff <- function(lyt, ) } -#' @title Validate Data for a Proportion Analysis -#' -#' @description `r lifecycle::badge("stable")` -#' -#' Validates the data required for a proportion analysis, including responder -#' status, group assignment, and optional stratification. -#' -#' @param rsp (`logical`)\cr -#' Indicates whether each observation is a responder (`TRUE`) or a -#' non-responder (`FALSE)`. Missing values are not allowed. -#' @param grp (`factor`)\cr -#' Assigns each observation to one of two groups, such as a reference and a -#' treatment group. Must have exactly two levels and the same length as -#' `rsp`. Missing values are not allowed. -#' @param strata (`factor` or `NULL`)\cr -#' Defines the stratification variable. If not `NULL`, it must have the same -#' length as `rsp` and must not contain any missing values. -#' -#' @return -#' Invisibly returns `NULL`. An error is raised if any input does not meet -#' the required conditions. -#' -#' @author WW -#' @export -#' -#' @examples -#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) -#' strata <- factor(c("A", "A", "B", "A", "B", "B")) -#' -#' assert_proportion_data(rsp, grp, strata) -#' -#' \dontrun{ -#' # An error is raised when `grp` has only one level. -#' grp <- factor(rep("X", 6)) -#' assert_proportion_data(rsp, grp, strata) -#' } -assert_proportion_data <- function(rsp, grp, strata = NULL) { - checkmate::assert_logical(rsp, any.missing = FALSE) - checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) - checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) - invisible() -} - #' Check proportion difference arguments #' #' @description `r lifecycle::badge("stable")` @@ -420,8 +376,6 @@ assert_proportion_data <- function(rsp, grp, strata = NULL) { #' @inheritParams prop_diff #' @inheritParams prop_diff_wald #' -#' @seealso [assert_proportion_data()] -#' #' @examples #' # example code #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. @@ -473,8 +427,6 @@ check_diff_prop_ci <- function(rsp, #' 2 x 2 x k is returned, where k is the number of levels of strata. #' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively. #' -#' @seealso [assert_proportion_data()] -#' #' @author WW #' @export #' diff --git a/R/utils_checkmate.R b/R/utils_checkmate.R index a4c2711b6e..04c5d29e6a 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -180,3 +180,38 @@ assert_proportion_value <- function(x, include_boundaries = FALSE) { checkmate::assert_true(x < 1) } } + +#' @describeIn assertions +#' Validates the data required for a proportion analysis, including responder +#' status, group assignment, and optional stratification. +#' +#' @param rsp (`logical`)\cr +#' Indicates whether each observation is a responder (`TRUE`) or a +#' non-responder (`FALSE)`. Missing values are not allowed. +#' @param grp (`factor`)\cr +#' Assigns each observation to one of two groups, such as a reference and a +#' treatment group. Must have exactly two levels and the same length as +#' `rsp`. Missing values are not allowed. +#' @param strata (`factor` or `NULL`)\cr +#' Defines the stratification variable. If not `NULL`, it must have the same +#' length as `rsp` and must not contain any missing values. +#' +#' @export +#' +#' @examples +#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +#' grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +#' strata <- factor(c("A", "A", "B", "A", "B", "B")) +#' +#' assert_proportion_data(rsp, grp, strata) +#' +#' \dontrun{ +#' # An error is raised when `grp` has only one level. +#' grp <- factor(rep("X", 6)) +#' assert_proportion_data(rsp, grp, strata) +#' } +assert_proportion_data <- function(rsp, grp, strata = NULL) { + checkmate::assert_logical(rsp, any.missing = FALSE) + checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) + checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) +} diff --git a/man/assert_proportion_data.Rd b/man/assert_proportion_data.Rd deleted file mode 100644 index 212258c8d2..0000000000 --- a/man/assert_proportion_data.Rd +++ /dev/null @@ -1,48 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prop_diff.R -\name{assert_proportion_data} -\alias{assert_proportion_data} -\title{Validate Data for a Proportion Analysis} -\usage{ -assert_proportion_data(rsp, grp, strata = NULL) -} -\arguments{ -\item{rsp}{(\code{logical})\cr -Indicates whether each observation is a responder (\code{TRUE}) or a -non-responder (\verb{FALSE)}. Missing values are not allowed.} - -\item{grp}{(\code{factor})\cr -Assigns each observation to one of two groups, such as a reference and a -treatment group. Must have exactly two levels and the same length as -\code{rsp}. Missing values are not allowed.} - -\item{strata}{(\code{factor} or \code{NULL})\cr -Defines the stratification variable. If not \code{NULL}, it must have the same -length as \code{rsp} and must not contain any missing values.} -} -\value{ -Invisibly returns \code{NULL}. An error is raised if any input does not meet -the required conditions. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -Validates the data required for a proportion analysis, including responder -status, group assignment, and optional stratification. -} -\examples{ -rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) -grp <- factor(c(rep("Placebo", 3), rep("X", 3))) -strata <- factor(c("A", "A", "B", "A", "B", "B")) - -assert_proportion_data(rsp, grp, strata) - -\dontrun{ -# An error is raised when `grp` has only one level. -grp <- factor(rep("X", 6)) -assert_proportion_data(rsp, grp, strata) -} -} -\author{ -WW -} diff --git a/man/assertions.Rd b/man/assertions.Rd index df83d07c33..9e7663bfb0 100644 --- a/man/assertions.Rd +++ b/man/assertions.Rd @@ -7,6 +7,7 @@ \alias{assert_valid_factor} \alias{assert_df_with_factors} \alias{assert_proportion_value} +\alias{assert_proportion_data} \title{Additional assertions to use with \code{checkmate}} \usage{ assert_list_of_variables(x, .var.name = checkmate::vname(x), add = NULL) @@ -43,6 +44,8 @@ assert_df_with_factors( ) assert_proportion_value(x, include_boundaries = FALSE) + +assert_proportion_data(rsp, grp, strata = NULL) } \arguments{ \item{x}{(\code{any})\cr object to test.} @@ -86,6 +89,19 @@ Exact expected length of \code{x}.} \item{include_boundaries}{(\code{flag})\cr whether to include boundaries when testing for proportions.} + +\item{rsp}{(\code{logical})\cr +Indicates whether each observation is a responder (\code{TRUE}) or a +non-responder (\verb{FALSE)}. Missing values are not allowed.} + +\item{grp}{(\code{factor})\cr +Assigns each observation to one of two groups, such as a reference and a +treatment group. Must have exactly two levels and the same length as +\code{rsp}. Missing values are not allowed.} + +\item{strata}{(\code{factor} or \code{NULL})\cr +Defines the stratification variable. If not \code{NULL}, it must have the same +length as \code{rsp} and must not contain any missing values.} } \value{ Nothing if assertion passes, otherwise prints the error message. @@ -113,6 +129,9 @@ trim \code{NA} levels out of the vector list itself. \item \code{assert_proportion_value()}: Check whether \code{x} is a proportion: number between 0 and 1. +\item \code{assert_proportion_data()}: Validates the data required for a proportion analysis, including responder +status, group assignment, and optional stratification. + }} \examples{ x <- data.frame( @@ -130,5 +149,16 @@ assert_df_with_factors(x, list(a = "ARM")) assert_proportion_value(0.95) assert_proportion_value(1.0, include_boundaries = TRUE) +rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) +grp <- factor(c(rep("Placebo", 3), rep("X", 3))) +strata <- factor(c("A", "A", "B", "A", "B", "B")) + +assert_proportion_data(rsp, grp, strata) + +\dontrun{ +# An error is raised when `grp` has only one level. +grp <- factor(rep("X", 6)) +assert_proportion_data(rsp, grp, strata) +} } \keyword{internal} diff --git a/man/check_diff_prop_ci.Rd b/man/check_diff_prop_ci.Rd index b20cada35e..9a70768494 100644 --- a/man/check_diff_prop_ci.Rd +++ b/man/check_diff_prop_ci.Rd @@ -38,6 +38,3 @@ dta <- data.frame( ) check_diff_prop_ci(rsp = dta[["rsp"]], grp = dta[["grp"]], conf_level = 0.95) } -\seealso{ -\code{\link[=assert_proportion_data]{assert_proportion_data()}} -} diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd index 7c3e9eb92e..3b0a2e253f 100644 --- a/man/safe_2x2_table.Rd +++ b/man/safe_2x2_table.Rd @@ -61,9 +61,6 @@ strata <- factor(c(rep("S1", 4), rep("S2", 4))) safe_2x2_table(rsp, grp, strata) } -\seealso{ -\code{\link[=assert_proportion_data]{assert_proportion_data()}} -} \author{ WW } From d526ba0a0bedc31f43885ec1705890da8b3ae458 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 2 Sep 2026 14:41:30 +0200 Subject: [PATCH 10/40] update return update of assert_proportion_data(). --- R/utils_checkmate.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/utils_checkmate.R b/R/utils_checkmate.R index 04c5d29e6a..f5662e5dee 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -214,4 +214,5 @@ assert_proportion_data <- function(rsp, grp, strata = NULL) { checkmate::assert_logical(rsp, any.missing = FALSE) checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) + invisible() } From ed2fea44caad4c07b714d43a91d9578ab8b11d9c Mon Sep 17 00:00:00 2001 From: Melkiades <11279768+Melkiades@users.noreply.github.com> Date: Wed, 2 Sep 2026 13:50:20 +0000 Subject: [PATCH 11/40] Fix NEWS.md version boundary for released 0.9.11 The 0.9.11 heading was placed above the unreleased g_forest() entries (#1499, #1498), which pushed them into the already-released 0.9.11 section. Move the heading below those entries so they stay under the 0.9.11.9000 development version, and the released 0.9.11 section starts at the df_explicit_na() entry (#1322) that shipped in the release. --- NEWS.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 9ce998f92c..8ccb7dc2c7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,14 +4,14 @@ * Added `safe_2x2_table()` to construct 2 x 2 x k contingency tables safely. * Added `assert_proportion_data()` to validate responder, group, and optional stratification data used in proportion analyses. - -# tern 0.9.11 - -### Enhancements * Updated `g_forest()` to support point estimates and confidence intervals stored in a single column. (#1499) * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected rows from the forest plot before plotting. (#1498) + +# tern 0.9.11 + +### Enhancements * Added `factor_level_method` argument to `df_explicit_na()` to control factor level ordering when converting character or logical columns. Supported methods: `"sort_auto"` (default, locale-aware, preserves original behavior), `"sort_radix"` (byte-order / ASCII sort), and From 6e1bb2be0504b74c3a09da087e78eb7aa57baa0d Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 2 Sep 2026 19:56:53 +0200 Subject: [PATCH 12/40] update man of assert_proportion_data() and save_2x2_table(). --- R/prop_diff.R | 5 +++-- R/utils_checkmate.R | 2 +- man/assertions.Rd | 2 +- man/safe_2x2_table.Rd | 7 +++---- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 67d94a76f6..51498ff431 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -400,7 +400,7 @@ check_diff_prop_ci <- function(rsp, invisible() } -#' @title Construct 2 x 2 Contingency Tables Safely +#' Construct 2 x 2 Contingency Tables Safely #' #' @description `r lifecycle::badge("stable")` #' @@ -427,7 +427,6 @@ check_diff_prop_ci <- function(rsp, #' 2 x 2 x k is returned, where k is the number of levels of strata. #' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively. #' -#' @author WW #' @export #' #' @examples @@ -435,6 +434,7 @@ check_diff_prop_ci <- function(rsp, #' grp <- factor(c(rep("Placebo", 4), rep("X", 4))) #' #' tbl <- safe_2x2_table(rsp, grp) +#' tbl #' #' # Example use case: Fisher's exact test. #' prop_fisher(tbl) @@ -446,6 +446,7 @@ check_diff_prop_ci <- function(rsp, #' strata <- factor(c(rep("S1", 4), rep("S2", 4))) #' #' safe_2x2_table(rsp, grp, strata) +#' safe_2x2_table <- function(rsp, grp, strata = NULL) { assert_proportion_data(rsp = rsp, grp = grp, strata = strata) diff --git a/R/utils_checkmate.R b/R/utils_checkmate.R index f5662e5dee..76e974d996 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -187,7 +187,7 @@ assert_proportion_value <- function(x, include_boundaries = FALSE) { #' #' @param rsp (`logical`)\cr #' Indicates whether each observation is a responder (`TRUE`) or a -#' non-responder (`FALSE)`. Missing values are not allowed. +#' non-responder (`FALSE`). Missing values are not allowed. #' @param grp (`factor`)\cr #' Assigns each observation to one of two groups, such as a reference and a #' treatment group. Must have exactly two levels and the same length as diff --git a/man/assertions.Rd b/man/assertions.Rd index 9e7663bfb0..799767a4fe 100644 --- a/man/assertions.Rd +++ b/man/assertions.Rd @@ -92,7 +92,7 @@ for proportions.} \item{rsp}{(\code{logical})\cr Indicates whether each observation is a responder (\code{TRUE}) or a -non-responder (\verb{FALSE)}. Missing values are not allowed.} +non-responder (\code{FALSE}). Missing values are not allowed.} \item{grp}{(\code{factor})\cr Assigns each observation to one of two groups, such as a reference and a diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd index 3b0a2e253f..8071328bf3 100644 --- a/man/safe_2x2_table.Rd +++ b/man/safe_2x2_table.Rd @@ -9,7 +9,7 @@ safe_2x2_table(rsp, grp, strata = NULL) \arguments{ \item{rsp}{(\code{logical})\cr Indicates whether each observation is a responder (\code{TRUE}) or a -non-responder (\verb{FALSE)}. Missing values are not allowed.} +non-responder (\code{FALSE}). Missing values are not allowed.} \item{grp}{(\code{factor})\cr Assigns each observation to one of two groups, such as a reference and a @@ -49,6 +49,7 @@ rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE) grp <- factor(c(rep("Placebo", 4), rep("X", 4))) tbl <- safe_2x2_table(rsp, grp) +tbl # Example use case: Fisher's exact test. prop_fisher(tbl) @@ -60,7 +61,5 @@ safe_2x2_table(rep(TRUE, 8), grp) strata <- factor(c(rep("S1", 4), rep("S2", 4))) safe_2x2_table(rsp, grp, strata) -} -\author{ -WW + } From 2eb1daf74a3ed9d2e801a932edc098e83ce8091e Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 09:31:12 +0200 Subject: [PATCH 13/40] Updating s_test_proportion_diff() to use new safe_2x2_table(). Extending examples of save_2x2_table(). --- R/prop_diff.R | 23 +++++++++++++++++------ R/prop_diff_test.R | 16 +++++++--------- man/prop_diff_test.Rd | 2 +- man/safe_2x2_table.Rd | 23 +++++++++++++++++------ 4 files changed, 42 insertions(+), 22 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 51498ff431..fc5a626697 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -430,22 +430,33 @@ check_diff_prop_ci <- function(rsp, #' @export #' #' @examples -#' rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE) -#' grp <- factor(c(rep("Placebo", 4), rep("X", 4))) #' -#' tbl <- safe_2x2_table(rsp, grp) +#' set.seed(123) +#' n <- 50 +#' df <- data.frame( +#' "rsp" = sample(c(TRUE, FALSE), n, TRUE), +#' "grp" = sample(c("A", "B"), n, TRUE), +#' "f1" = sample(c("a1", "a2"), n, TRUE), +#' "f2" = sample(c("x", "y", "z"), n, TRUE), +#' stringsAsFactors = TRUE +#' ) +#' +#' tbl <- safe_2x2_table(df$rsp, df$grp) #' tbl #' #' # Example use case: Fisher's exact test. #' prop_fisher(tbl) #' #' # The FALSE/TRUE levels are retained even when only one outcome is observed. -#' safe_2x2_table(rep(TRUE, 8), grp) +#' safe_2x2_table(rep(TRUE, n), df$grp) #' #' # Stratified 2 x 2 tables. -#' strata <- factor(c(rep("S1", 4), rep("S2", 4))) +#' strata <- interaction(df$f1, df$f2) +#' tbl_strat <- safe_2x2_table(df$rsp, df$grp, strata) +#' tbl_strat #' -#' safe_2x2_table(rsp, grp, strata) +#' # Example use case: the stratified Cochran-Mantel-Haenszel test. +#' prop_cmh(tbl_strat) #' safe_2x2_table <- function(rsp, grp, strata = NULL) { assert_proportion_data(rsp = rsp, grp = grp, strata = strata) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index f36647379d..5eed213f4b 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -15,7 +15,7 @@ #' #' Options are: ``r shQuote(get_stats("test_proportion_diff"), type = "sh")`` #' -#' @seealso [h_prop_diff_test] +#' @seealso [h_prop_diff_test], [safe_2x2_table] #' #' @name prop_diff_test #' @order 1 @@ -62,10 +62,8 @@ s_test_proportion_diff <- function(df, if (!.in_ref_col) { assert_df_with_variables(df, list(rsp = .var)) assert_df_with_variables(.ref_group, list(rsp = .var)) - rsp <- factor( - c(.ref_group[[.var]], df[[.var]]), - levels = c("TRUE", "FALSE") - ) + + rsp <- c(.ref_group[[.var]], df[[.var]]) grp <- factor( rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref") @@ -81,10 +79,10 @@ s_test_proportion_diff <- function(df, } tbl <- switch(method, - cmh = table(grp, rsp, strata), - cmh_sato = table(grp, rsp, strata), - cmh_wh = table(grp, rsp, strata), - table(grp, rsp) + cmh = safe_2x2_table(grp, rsp, strata), + cmh_sato = safe_2x2_table(grp, rsp, strata), + cmh_wh = safe_2x2_table(grp, rsp, strata), + safe_2x2_table(grp, rsp) ) y$pval <- switch(method, diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index de75429d3e..cc7f2f765e 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -179,6 +179,6 @@ s_test_proportion_diff( } \seealso{ -\link{h_prop_diff_test} +\link{h_prop_diff_test}, \link{safe_2x2_table} } \keyword{internal} diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd index 8071328bf3..fe8e6d50be 100644 --- a/man/safe_2x2_table.Rd +++ b/man/safe_2x2_table.Rd @@ -45,21 +45,32 @@ When strata is supplied, a separate 2 x 2 contingency table is created for each stratum. } \examples{ -rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE) -grp <- factor(c(rep("Placebo", 4), rep("X", 4))) -tbl <- safe_2x2_table(rsp, grp) +set.seed(123) +n <- 50 +df <- data.frame( + "rsp" = sample(c(TRUE, FALSE), n, TRUE), + "grp" = sample(c("A", "B"), n, TRUE), + "f1" = sample(c("a1", "a2"), n, TRUE), + "f2" = sample(c("x", "y", "z"), n, TRUE), + stringsAsFactors = TRUE +) + +tbl <- safe_2x2_table(df$rsp, df$grp) tbl # Example use case: Fisher's exact test. prop_fisher(tbl) # The FALSE/TRUE levels are retained even when only one outcome is observed. -safe_2x2_table(rep(TRUE, 8), grp) +safe_2x2_table(rep(TRUE, n), df$grp) # Stratified 2 x 2 tables. -strata <- factor(c(rep("S1", 4), rep("S2", 4))) +strata <- interaction(df$f1, df$f2) +tbl_strat <- safe_2x2_table(df$rsp, df$grp, strata) +tbl_strat -safe_2x2_table(rsp, grp, strata) +# Example use case: the stratified Cochran-Mantel-Haenszel test. +prop_cmh(tbl_strat) } From 71ada97a7c5464cb987f13fe37dd0a96c12d8542 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 09:43:01 +0200 Subject: [PATCH 14/40] solve critical typo in s_test_proportion_diff(). --- R/prop_diff_test.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 5eed213f4b..bd26d06171 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -79,10 +79,10 @@ s_test_proportion_diff <- function(df, } tbl <- switch(method, - cmh = safe_2x2_table(grp, rsp, strata), - cmh_sato = safe_2x2_table(grp, rsp, strata), - cmh_wh = safe_2x2_table(grp, rsp, strata), - safe_2x2_table(grp, rsp) + cmh = safe_2x2_table(rsp, grp, strata), + cmh_sato = safe_2x2_table(rsp, grp, strata), + cmh_wh = safe_2x2_table(rsp, grp, strata), + safe_2x2_table(rsp, grp) ) y$pval <- switch(method, From a8241f70ce697db36ff557e220ca3b892b38bdd4 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 10:19:24 +0200 Subject: [PATCH 15/40] Cosmetic refactoring of s_test_proportion_diff(). --- R/prop_diff_test.R | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index bd26d06171..3ae7c8c1ea 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -57,11 +57,16 @@ s_test_proportion_diff <- function(df, alternative = c("two.sided", "less", "greater"), ...) { method <- match.arg(method) - y <- list(pval = numeric()) - if (!.in_ref_col) { + pval <- if (.in_ref_col) { + numeric() + } else { assert_df_with_variables(df, list(rsp = .var)) assert_df_with_variables(.ref_group, list(rsp = .var)) + checkmate::assert_list(variables, null.ok = TRUE) + if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { + checkmate::assert_false(is.null(variables$strata)) + } rsp <- c(.ref_group[[.var]], df[[.var]]) grp <- factor( @@ -69,9 +74,8 @@ s_test_proportion_diff <- function(df, levels = c("ref", "Not-ref") ) - if (!is.null(variables$strata) || method %in% c("cmh", "cmh_wh")) { - strata <- variables$strata - checkmate::assert_false(is.null(strata)) + strata <- variables$strata + if (!is.null(strata)) { strata_vars <- stats::setNames(as.list(strata), strata) assert_df_with_variables(df, strata_vars) assert_df_with_variables(.ref_group, strata_vars) @@ -85,18 +89,22 @@ s_test_proportion_diff <- function(df, safe_2x2_table(rsp, grp) ) - y$pval <- switch(method, - chisq = prop_chisq(tbl, alternative = alternative), + switch(method, cmh = prop_cmh(tbl, alternative = alternative), - fisher = prop_fisher(tbl, alternative = alternative), - schouten = prop_schouten(tbl, alternative = alternative), cmh_sato = prop_cmh(tbl, alternative = alternative, diff_se = "sato"), - cmh_wh = prop_cmh(tbl, alternative = alternative, transform = "wilson_hilferty") + cmh_wh = prop_cmh(tbl, alternative = alternative, transform = "wilson_hilferty"), + fisher = prop_fisher(tbl, alternative = alternative), + chisq = prop_chisq(tbl, alternative = alternative), + schouten = prop_schouten(tbl, alternative = alternative) ) } - y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method, alternative = alternative)) - y + list( + pval = formatters::with_label( + pval, + d_test_proportion_diff(method, alternative = alternative) + ) + ) } #' Description of the difference test between two proportions From 045547229b9fa7436e4bc67e87008332f11b16b2 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 10:22:45 +0200 Subject: [PATCH 16/40] seealso roxygen tag update for s_test_proportion_diff(). --- R/prop_diff_test.R | 2 +- man/prop_diff_test.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 3ae7c8c1ea..94e82a65f4 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -15,7 +15,7 @@ #' #' Options are: ``r shQuote(get_stats("test_proportion_diff"), type = "sh")`` #' -#' @seealso [h_prop_diff_test], [safe_2x2_table] +#' @seealso [h_prop_diff_test()], [safe_2x2_table()] #' #' @name prop_diff_test #' @order 1 diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index cc7f2f765e..9869bbed0c 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -179,6 +179,6 @@ s_test_proportion_diff( } \seealso{ -\link{h_prop_diff_test}, \link{safe_2x2_table} +\code{\link[=h_prop_diff_test]{h_prop_diff_test()}}, \code{\link[=safe_2x2_table]{safe_2x2_table()}} } \keyword{internal} From 10ce5f255fb42b6be95b202cc84146a9e4e9b5cd Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 13:51:46 +0200 Subject: [PATCH 17/40] Added: get_complete_cases() and h_prepare_2x2_table() - it replaces safe_2x2_table(). Refactored s_test_proportion_diff(). --- NAMESPACE | 3 +- NEWS.md | 6 +- R/prop_diff.R | 248 +++++++++++++++++----- R/prop_diff_test.R | 39 ++-- R/utils.R | 60 ++++++ _pkgdown.yml | 3 +- man/get_complete_cases.Rd | 46 ++++ man/h_prepare_2x2_table.Rd | 167 +++++++++++++++ man/prop_diff_test.Rd | 6 +- man/safe_2x2_table.Rd | 76 ------- tests/testthat/test-get_complete_cases.R | 98 +++++++++ tests/testthat/test-h_prepare_2x2_table.R | 75 +++++++ tests/testthat/test-safe_2x2_table.R | 242 --------------------- 13 files changed, 668 insertions(+), 401 deletions(-) create mode 100644 man/get_complete_cases.Rd create mode 100644 man/h_prepare_2x2_table.Rd delete mode 100644 man/safe_2x2_table.Rd create mode 100644 tests/testthat/test-get_complete_cases.R create mode 100644 tests/testthat/test-h_prepare_2x2_table.R delete mode 100644 tests/testthat/test-safe_2x2_table.R diff --git a/NAMESPACE b/NAMESPACE index 2f2b55058b..f660dc17cd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -148,6 +148,7 @@ export(g_km) export(g_lineplot) export(g_step) export(g_waterfall) +export(get_complete_cases) export(get_covariates) export(get_formats_from_stats) export(get_indents_from_stats) @@ -209,6 +210,7 @@ export(h_or_cont_interaction) export(h_or_interaction) export(h_pkparam_sort) export(h_ppmeans) +export(h_prepare_2x2_table) export(h_proportion_df) export(h_proportion_subgroups_df) export(h_row_counts) @@ -291,7 +293,6 @@ export(s_summary) export(s_surv_time) export(s_surv_timepoint) export(s_test_proportion_diff) -export(safe_2x2_table) export(sas_na) export(score_occurrences) export(score_occurrences_cols) diff --git a/NEWS.md b/NEWS.md index 8ccb7dc2c7..02c4303a97 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,11 @@ # tern 0.9.11.9000 ### Enhancements -* Added `safe_2x2_table()` to construct 2 x 2 x k contingency tables safely. +* Added `h_prepare_2x2_table()` to prepare contingency table(s) for proportion + analyses. (#1514) +* Added `get_complete_cases()` to remove observations containing missing values. (#1514) * Added `assert_proportion_data()` to validate responder, group, and optional - stratification data used in proportion analyses. + stratification data used in proportion analyses. (#1514). * Updated `g_forest()` to support point estimates and confidence intervals stored in a single column. (#1499) * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected diff --git a/R/prop_diff.R b/R/prop_diff.R index fc5a626697..03ead15254 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -400,75 +400,223 @@ check_diff_prop_ci <- function(rsp, invisible() } -#' Construct 2 x 2 Contingency Tables Safely -#' -#' @description `r lifecycle::badge("stable")` -#' -#' Creates a 2 x 2 contingency table of responder status by group, optionally -#' stratified by a third factor. The function validates the input vectors and -#' ensures that the responder variable contains both possible outcomes -#' (`TRUE` and `FALSE`) in the resulting table, even when one outcome is not -#' observed in the data. -#' -#' When strata is not supplied, a single 2 x 2 contingency table is returned. -#' When strata is supplied, a separate 2 x 2 contingency table is created -#' for each stratum. -#' -#' @inheritParams assert_proportion_data -#' -#' @return -#' A contingency table produced by [base::table()]. -#' -#' When strata is `NULL`, a 2 x 2 table is returned, with `grp` defining the rows -#' and `rsp` defining the columns. The `rsp` dimension always contains the levels -#' `TRUE` and `FALSE`, in that order, including when one outcome is not observed. -#' -#' When `strata` is supplied, a 3-dimensional contingency table with dimensions -#' 2 x 2 x k is returned, where k is the number of levels of strata. -#' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively. +#' Helper Function to Prepare Data for Proportion Analyses +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' Prepares response, group, and optional strata vectors, and constructs a +#' 2 x 2 contingency table for proportion-based analyses. The function extracts +#' the variables from an analysis dataset and, optionally, a reference dataset, +#' combines them into vectors suitable for downstream statistical functions, +#' and returns the resulting contingency table together with the prepared +#' vectors. +#' +#' @param df (`data.frame`)\cr +#' A data frame containing the observations for the non-reference group. +#' @param df_ref (`data.frame` or `NULL`)\cr +#' An optional data frame containing the observations for the reference group. +#' @param var (`character(1)`)\cr +#' The column name in `df` (and, if supplied, `df_ref`) specifying the +#' response variable. The response is converted to a logical vector by +#' comparing its values with `val`. +#' @param val (`character(1)` or `logical(1)`)\cr +#' The value of `df[[var]]` (and, if supplied, `df_ref[[var]]`) that defines +#' a positive response. Observations matching this value are returned as +#' `TRUE` in the `rsp` vector; all other observations are returned as `FALSE`. +#' @param strata_vars (`character` or `NULL`)\cr +#' Optional column names in `df` (and, if supplied, `df_ref`) specifying +#' the strata variables. The specified columns must all be factors. +#' @param complete_cases (`logical(1)`)\cr +#' Whether incomplete rows should be removed from `df[c(var, strata_vars)]` +#' (and, if supplied, `df_ref[c(var, strata_vars)]`). +#' This is done using [get_complete_cases()]. +#' @param quiet (`logical(1)`)\cr +#' Passed to [get_complete_cases()], controlling whether messages about +#' removed incomplete rows are displayed. +#' +#' @return A named `list` containing: +#' \describe{ +#' \item{`rsp`}{A logical vector indicating whether each observation has the +#' value specified by `val` in `df[[var]]` (and, if supplied, `df_ref`).} +#' \item{`grp`}{A factor identifying the group of each observation. The levels +#' are always `"ref"` and `"Not-ref"` (in this order), corresponding to +#' observations from `df_ref` and `df`, respectively. If `df_ref` is `NULL`, +#' all observations belong to `"Not-ref"`.} +#' \item{`strata`}{A factor defining the analysis strata when `strata_vars` is +#' supplied, or `NULL` otherwise. When multiple stratification variables are +#' supplied, their combinations, using [interaction()], are used to define +#' the strata.} +#' \item{`tbl`}{A contingency table produced by [base::table()] from `grp`, +#' `rsp` (after converting it to a factor with two levels, `"TRUE"` and +#' `"FALSE"`), and, if `strata_vars` is supplied, `strata`. +#' When `strata_vars` is `NULL`, a 2 x 2 table is returned, with `grp` +#' defining the rows and `rsp` defining the columns. +#' The `rsp` dimension always contains the levels `"TRUE"` and `"FALSE"`, in +#' that order, even when one or both response outcomes are not observed. +#' When `strata_vars` is supplied, a 3-dimensional contingency table with +#' dimensions 2 x 2 x k is returned, where k is the number of strata. +#' The dimensions correspond to `grp`, `rsp`, and `strata`, respectively.} +#' } +#' +#' @details +#' The function prepares the response, group, and optional strata variables +#' required for proportion-based analyses and constructs a safe contingency +#' table for downstream statistical functions. +#' See the proportion difference documentation [h_prop_diff] and +#' [h_prop_diff_test] for related functions. +#' +#' If `complete_cases = TRUE`, incomplete observations are removed separately +#' from `df` and `df_ref` (if supplied) before the vectors and contingency table +#' are constructed. Completeness is assessed jointly across the `var` and +#' `strata_vars` columns when `strata_vars` is supplied, and only across `var` +#' otherwise. This is performed using [get_complete_cases()]. +#' +#' The response variable specified by `var`, and optionally the strata variables +#' specified by `strata_vars`, are extracted independently from `df` and +#' `df_ref` (if supplied). The response vectors are then combined into a single +#' vector and converted to a logical vector by comparing each value with `val`, +#' such that observations matching `val` are `TRUE` and all other observations +#' are `FALSE`. +#' +#' When multiple stratification variables are provided, their combinations are +#' collapsed into a single factor using [interaction()]. This is done +#' independently for `df` and `df_ref` (if supplied), after which the resulting +#' strata vectors are combined into a single factor. +#' +#' A group factor is constructed to identify the source of each observation. +#' Observations from `df` are assigned to the `"Not-ref"` group, while +#' observations from `df_ref` are assigned to the `"ref"` group. The factor +#' always has `"ref"` and `"Not-ref"` as its levels, in this order. +#' The level order is important because proportion-difference calculations in +#' `tern` use the first level as the reference group and calculate the +#' difference as `"Not-ref"` - `"ref"`. +#' +#' The contingency table is constructed from group, response (after converting +#' it to a factor with two levels, `"TRUE"` and `"FALSE"`), and, if +#' `strata_vars` is supplied, `strata`. +#' +#' @seealso [h_prop_diff], [h_prop_diff_test], [get_complete_cases()] #' #' @export -#' #' @examples #' #' set.seed(123) -#' n <- 50 -#' df <- data.frame( +#' n <- 28 +#' dta <- data.frame( #' "rsp" = sample(c(TRUE, FALSE), n, TRUE), -#' "grp" = sample(c("A", "B"), n, TRUE), +#' "grp" = sample(c("X", "Placebo"), n, TRUE), #' "f1" = sample(c("a1", "a2"), n, TRUE), -#' "f2" = sample(c("x", "y", "z"), n, TRUE), +#' "f2" = sample(c("x", "y"), n, TRUE), #' stringsAsFactors = TRUE #' ) +#' head(dta) +#' +#' trgs <- h_prepare_2x2_table( +#' df = subset(dta, grp == "X"), +#' df_ref = subset(dta, grp == "Placebo"), +#' var = "rsp", +#' val = TRUE, +#' strata_vars = c("f1", "f2") +#' ) #' -#' tbl <- safe_2x2_table(df$rsp, df$grp) -#' tbl -#' -#' # Example use case: Fisher's exact test. -#' prop_fisher(tbl) -#' -#' # The FALSE/TRUE levels are retained even when only one outcome is observed. -#' safe_2x2_table(rep(TRUE, n), df$grp) +#' rbind( +#' subset(dta, grp == "X"), +#' subset(dta, grp == "Placebo"), +#' make.row.names = FALSE +#' ) #' -#' # Stratified 2 x 2 tables. -#' strata <- interaction(df$f1, df$f2) -#' tbl_strat <- safe_2x2_table(df$rsp, df$grp, strata) -#' tbl_strat +#' trgs$rsp +#' trgs$grp +#' trgs$strata +#' trgs$tbl #' -#' # Example use case: the stratified Cochran-Mantel-Haenszel test. -#' prop_cmh(tbl_strat) +#' # Example use case. +#' prop_diff_cmh(trgs$rsp, trgs$grp, trgs$strata) +#' prop_cmh(trgs$tbl) #' -safe_2x2_table <- function(rsp, grp, strata = NULL) { - assert_proportion_data(rsp = rsp, grp = grp, strata = strata) +#' # The FALSE/TRUE levels are retained even when only one outcome is observed. +#' dta2 <- dta +#' dta2$rsp <- TRUE +#' h_prepare_2x2_table( +#' df = subset(dta2, grp == "X"), +#' df_ref = subset(dta2, grp == "Placebo"), +#' var = "rsp", +#' val = TRUE, +#' )$tbl +h_prepare_2x2_table <- function(df, + df_ref = NULL, + var, + val, + strata_vars = NULL, + complete_cases = FALSE, + quiet = FALSE) { + checkmate::assert_data_frame(df) + checkmate::assert_data_frame(df_ref, null.ok = TRUE) + checkmate::assert_string(var) + checkmate::assert_true( + checkmate::test_string(val) || checkmate::test_flag(val) + ) + checkmate::assert_subset(var, colnames(df), empty.ok = FALSE) + if (!is.null(df_ref)) { + checkmate::assert_subset(var, colnames(df_ref), empty.ok = FALSE) + } + if (!is.null(strata_vars)) { + checkmate::assert_subset(strata_vars, colnames(df), empty.ok = FALSE) + checkmate::assert_data_frame(df[strata_vars], types = "factor") + if (!is.null(df_ref)) { + checkmate::assert_subset(strata_vars, colnames(df_ref), empty.ok = FALSE) + checkmate::assert_data_frame(df_ref[strata_vars], types = "factor") + } + } + checkmate::assert_flag(complete_cases) + checkmate::assert_flag(quiet) + + # Optionally remove incomplete cases. + if (complete_cases) { + vars <- c(var, strata_vars) + df <- get_complete_cases(df[, vars, drop = FALSE], quiet = quiet) + if (!is.null(df_ref)) { + df_ref <- get_complete_cases(df_ref[, vars, drop = FALSE], quiet = quiet) + } + } + + # NOTE: The order of group levels is important and must not be changed. + # `tern` proportion-difference functions use the first level as the + # reference group and calculate the difference as "Not-ref" - "ref". + grp_levels <- c("ref", "Not-ref") - # Make rsp a factor to handle cases with only TRUE or only FALSE. - rsp <- factor(rsp, levels = c("TRUE", "FALSE")) + # Extract response, group and strata data for non-reference group. + rsp <- df[[var]] + grp <- factor(rep(grp_levels[2], nrow(df)), levels = grp_levels) + strata <- if (!is.null(strata_vars)) { + interaction(df[strata_vars]) + } else { + NULL + } + + # Add reference group data, if supplied. + if (!is.null(df_ref)) { + rsp <- c(rsp, df_ref[[var]]) + grp <- c(grp, factor(rep(grp_levels[1], nrow(df_ref)), levels = grp_levels)) + strata <- if (!is.null(strata_vars)) { + c(strata, interaction(df_ref[strata_vars])) + } else { + NULL + } + } - if (is.null(strata)) { + rsp_logical <- rsp == val + assert_proportion_data(rsp = rsp_logical, grp = grp, strata = strata) + + # Build contingency table. + rsp <- factor(rsp_logical, levels = c("TRUE", "FALSE")) + tbl <- if (is.null(strata)) { table(grp, rsp) } else { table(grp, rsp, strata) } + + list(rsp = rsp_logical, grp = grp, strata = strata, tbl = tbl) } #' Description of method used for proportion comparison diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 94e82a65f4..6cfae548ca 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -15,7 +15,7 @@ #' #' Options are: ``r shQuote(get_stats("test_proportion_diff"), type = "sh")`` #' -#' @seealso [h_prop_diff_test()], [safe_2x2_table()] +#' @seealso [h_prop_diff_test], [h_prepare_2x2_table()] #' #' @name prop_diff_test #' @order 1 @@ -50,44 +50,31 @@ NULL #' @export s_test_proportion_diff <- function(df, .var, - .ref_group, - .in_ref_col, + .ref_group = NULL, + .in_ref_col = NULL, variables = list(strata = NULL), method = c("chisq", "schouten", "fisher", "cmh", "cmh_sato", "cmh_wh"), alternative = c("two.sided", "less", "greater"), ...) { method <- match.arg(method) - pval <- if (.in_ref_col) { + pval <- if (!is.null(.in_ref_col) && .in_ref_col) { numeric() } else { - assert_df_with_variables(df, list(rsp = .var)) - assert_df_with_variables(.ref_group, list(rsp = .var)) checkmate::assert_list(variables, null.ok = TRUE) - if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { + strata_vars <- if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { checkmate::assert_false(is.null(variables$strata)) + variables$strata + } else { + NULL } - rsp <- c(.ref_group[[.var]], df[[.var]]) - grp <- factor( - rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), - levels = c("ref", "Not-ref") - ) - - strata <- variables$strata - if (!is.null(strata)) { - strata_vars <- stats::setNames(as.list(strata), strata) - assert_df_with_variables(df, strata_vars) - assert_df_with_variables(.ref_group, strata_vars) - strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) - } - - tbl <- switch(method, - cmh = safe_2x2_table(rsp, grp, strata), - cmh_sato = safe_2x2_table(rsp, grp, strata), - cmh_wh = safe_2x2_table(rsp, grp, strata), - safe_2x2_table(rsp, grp) + prepared <- h_prepare_2x2_table( + df = df, df_ref = .ref_group, var = .var, val = TRUE, + strata_vars = strata_vars, + complete_cases = TRUE ) + tbl <- prepared$tbl switch(method, cmh = prop_cmh(tbl, alternative = alternative), diff --git a/R/utils.R b/R/utils.R index fbe1d435be..70e5f9ad45 100644 --- a/R/utils.R +++ b/R/utils.R @@ -479,3 +479,63 @@ clogit_with_tryCatch <- function(formula, data, ...) { # nolint error = function(e) stop("model not built successfully with survival::clogit") ) } + +#' Remove rows with missing values +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' Remove rows containing one or more missing values from a data frame. +#' If any rows are omitted, a warning is issued reporting the number of +#' removed rows, unless `quiet` is `TRUE`. +#' +#' @param df (`data.frame`)\cr A data frame. +#' @param quiet (`logical(1)`)\cr Whether to suppress the warning when rows with +#' missing values are omitted. +#' @param additional_message (`character(1)`)\cr A message appended to the +#' default warning. The default warning reports the number of rows removed. +#' +#' @return +#' A `data.frame` containing only complete rows. The original column structure +#' is preserved. If no rows contain missing values, `df` is returned unchanged. +#' +#' @details +#' A row is considered incomplete if at least one of its values is missing. +#' Missingness is determined using [stats::complete.cases()]. +#' +#' If one or more rows contain missing values, those rows are omitted and a +#' warning is issued reporting the number of omitted rows, unless `quiet` is +#' `TRUE`. The value of `additional_message` is appended to the warning message. +#' +#' If no rows contain missing values, `df` is returned unchanged and no warning +#' is issued. +#' +#' @export +#' +#' @examples +#' df <- data.frame(a = c(1:5, NA), b = c(NA, letters[1:5])) +#' df +#' +#' get_complete_cases(df) +#' +get_complete_cases <- function(df, quiet = FALSE, additional_message = ".") { + checkmate::assert_data_frame(df) + checkmate::assert_flag(quiet) + checkmate::assert_string(additional_message) + + is_complete <- stats::complete.cases(df) + not_complete <- !is_complete + + if (any(not_complete)) { + if (!quiet) { + warning( + sum(not_complete), + " row(s) with missing values were omitted", + additional_message, + call. = FALSE + ) + } + df[is_complete, , drop = FALSE] + } else { + df + } +} diff --git a/_pkgdown.yml b/_pkgdown.yml index a14530772a..a578424f12 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -114,7 +114,7 @@ reference: - -prop_diff - check_diff_prop_ci - assert_proportion_data - - safe_2x2_table + - h_prepare_2x2_table - title: rtables Helper Functions desc: These functions help to work with the `rtables` package and may be @@ -190,6 +190,7 @@ reference: - strata_normal_quantile - to_n - update_weights_strat_wilson + - get_complete_cases - title: Assertion Functions desc: These functions supplement those in the `checkmate` package. diff --git a/man/get_complete_cases.Rd b/man/get_complete_cases.Rd new file mode 100644 index 0000000000..8bbe1fad0f --- /dev/null +++ b/man/get_complete_cases.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_complete_cases} +\alias{get_complete_cases} +\title{Remove rows with missing values} +\usage{ +get_complete_cases(df, quiet = FALSE, additional_message = ".") +} +\arguments{ +\item{df}{(\code{data.frame})\cr A data frame.} + +\item{quiet}{(\code{logical(1)})\cr Whether to suppress the warning when rows with +missing values are omitted.} + +\item{additional_message}{(\code{character(1)})\cr A message appended to the +default warning. The default warning reports the number of rows removed.} +} +\value{ +A \code{data.frame} containing only complete rows. The original column structure +is preserved. If no rows contain missing values, \code{df} is returned unchanged. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Remove rows containing one or more missing values from a data frame. +If any rows are omitted, a warning is issued reporting the number of +removed rows, unless \code{quiet} is \code{TRUE}. +} +\details{ +A row is considered incomplete if at least one of its values is missing. +Missingness is determined using \code{\link[stats:complete.cases]{stats::complete.cases()}}. + +If one or more rows contain missing values, those rows are omitted and a +warning is issued reporting the number of omitted rows, unless \code{quiet} is +\code{TRUE}. The value of \code{additional_message} is appended to the warning message. + +If no rows contain missing values, \code{df} is returned unchanged and no warning +is issued. +} +\examples{ +df <- data.frame(a = c(1:5, NA), b = c(NA, letters[1:5])) +df + +get_complete_cases(df) + +} diff --git a/man/h_prepare_2x2_table.Rd b/man/h_prepare_2x2_table.Rd new file mode 100644 index 0000000000..7f1396a486 --- /dev/null +++ b/man/h_prepare_2x2_table.Rd @@ -0,0 +1,167 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_diff.R +\name{h_prepare_2x2_table} +\alias{h_prepare_2x2_table} +\title{Helper Function to Prepare Data for Proportion Analyses} +\usage{ +h_prepare_2x2_table( + df, + df_ref = NULL, + var, + val, + strata_vars = NULL, + complete_cases = FALSE, + quiet = FALSE +) +} +\arguments{ +\item{df}{(\code{data.frame})\cr +A data frame containing the observations for the non-reference group.} + +\item{df_ref}{(\code{data.frame} or \code{NULL})\cr +An optional data frame containing the observations for the reference group.} + +\item{var}{(\code{character(1)})\cr +The column name in \code{df} (and, if supplied, \code{df_ref}) specifying the +response variable. The response is converted to a logical vector by +comparing its values with \code{val}.} + +\item{val}{(\code{character(1)} or \code{logical(1)})\cr +The value of \code{df[[var]]} (and, if supplied, \code{df_ref[[var]]}) that defines +a positive response. Observations matching this value are returned as +\code{TRUE} in the \code{rsp} vector; all other observations are returned as \code{FALSE}.} + +\item{strata_vars}{(\code{character} or \code{NULL})\cr +Optional column names in \code{df} (and, if supplied, \code{df_ref}) specifying +the strata variables. The specified columns must all be factors.} + +\item{complete_cases}{(\code{logical(1)})\cr +Whether incomplete rows should be removed from \code{df[c(var, strata_vars)]} +(and, if supplied, \code{df_ref[c(var, strata_vars)]}). +This is done using \code{\link[=get_complete_cases]{get_complete_cases()}}.} + +\item{quiet}{(\code{logical(1)})\cr +Passed to \code{\link[=get_complete_cases]{get_complete_cases()}}, controlling whether messages about +removed incomplete rows are displayed.} +} +\value{ +A named \code{list} containing: +\describe{ +\item{\code{rsp}}{A logical vector indicating whether each observation has the +value specified by \code{val} in \code{df[[var]]} (and, if supplied, \code{df_ref}).} +\item{\code{grp}}{A factor identifying the group of each observation. The levels +are always \code{"ref"} and \code{"Not-ref"} (in this order), corresponding to +observations from \code{df_ref} and \code{df}, respectively. If \code{df_ref} is \code{NULL}, +all observations belong to \code{"Not-ref"}.} +\item{\code{strata}}{A factor defining the analysis strata when \code{strata_vars} is +supplied, or \code{NULL} otherwise. When multiple stratification variables are +supplied, their combinations, using \code{\link[=interaction]{interaction()}}, are used to define +the strata.} +\item{\code{tbl}}{A contingency table produced by \code{\link[base:table]{base::table()}} from \code{grp}, +\code{rsp} (after converting it to a factor with two levels, \code{"TRUE"} and +\code{"FALSE"}), and, if \code{strata_vars} is supplied, \code{strata}. +When \code{strata_vars} is \code{NULL}, a 2 x 2 table is returned, with \code{grp} +defining the rows and \code{rsp} defining the columns. +The \code{rsp} dimension always contains the levels \code{"TRUE"} and \code{"FALSE"}, in +that order, even when one or both response outcomes are not observed. +When \code{strata_vars} is supplied, a 3-dimensional contingency table with +dimensions 2 x 2 x k is returned, where k is the number of strata. +The dimensions correspond to \code{grp}, \code{rsp}, and \code{strata}, respectively.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Prepares response, group, and optional strata vectors, and constructs a +2 x 2 contingency table for proportion-based analyses. The function extracts +the variables from an analysis dataset and, optionally, a reference dataset, +combines them into vectors suitable for downstream statistical functions, +and returns the resulting contingency table together with the prepared +vectors. +} +\details{ +The function prepares the response, group, and optional strata variables +required for proportion-based analyses and constructs a safe contingency +table for downstream statistical functions. +See the proportion difference documentation \link{h_prop_diff} and +\link{h_prop_diff_test} for related functions. + +If \code{complete_cases = TRUE}, incomplete observations are removed separately +from \code{df} and \code{df_ref} (if supplied) before the vectors and contingency table +are constructed. Completeness is assessed jointly across the \code{var} and +\code{strata_vars} columns when \code{strata_vars} is supplied, and only across \code{var} +otherwise. This is performed using \code{\link[=get_complete_cases]{get_complete_cases()}}. + +The response variable specified by \code{var}, and optionally the strata variables +specified by \code{strata_vars}, are extracted independently from \code{df} and +\code{df_ref} (if supplied). The response vectors are then combined into a single +vector and converted to a logical vector by comparing each value with \code{val}, +such that observations matching \code{val} are \code{TRUE} and all other observations +are \code{FALSE}. + +When multiple stratification variables are provided, their combinations are +collapsed into a single factor using \code{\link[=interaction]{interaction()}}. This is done +independently for \code{df} and \code{df_ref} (if supplied), after which the resulting +strata vectors are combined into a single factor. + +A group factor is constructed to identify the source of each observation. +Observations from \code{df} are assigned to the \code{"Not-ref"} group, while +observations from \code{df_ref} are assigned to the \code{"ref"} group. The factor +always has \code{"ref"} and \code{"Not-ref"} as its levels, in this order. +The level order is important because proportion-difference calculations in +\code{tern} use the first level as the reference group and calculate the +difference as \code{"Not-ref"} - \code{"ref"}. + +The contingency table is constructed from group, response (after converting +it to a factor with two levels, \code{"TRUE"} and \code{"FALSE"}), and, if +\code{strata_vars} is supplied, \code{strata}. +} +\examples{ + +set.seed(123) +n <- 28 +dta <- data.frame( + "rsp" = sample(c(TRUE, FALSE), n, TRUE), + "grp" = sample(c("X", "Placebo"), n, TRUE), + "f1" = sample(c("a1", "a2"), n, TRUE), + "f2" = sample(c("x", "y"), n, TRUE), + stringsAsFactors = TRUE +) +head(dta) + +trgs <- h_prepare_2x2_table( + df = subset(dta, grp == "X"), + df_ref = subset(dta, grp == "Placebo"), + var = "rsp", + val = TRUE, + strata_vars = c("f1", "f2") +) + +rbind( + subset(dta, grp == "X"), + subset(dta, grp == "Placebo"), + make.row.names = FALSE +) + +trgs$rsp +trgs$grp +trgs$strata +trgs$tbl + +# Example use case. +prop_diff_cmh(trgs$rsp, trgs$grp, trgs$strata) +prop_cmh(trgs$tbl) + +# The FALSE/TRUE levels are retained even when only one outcome is observed. +dta2 <- dta +dta2$rsp <- TRUE +h_prepare_2x2_table( + df = subset(dta2, grp == "X"), + df_ref = subset(dta2, grp == "Placebo"), + var = "rsp", + val = TRUE, +)$tbl +} +\seealso{ +\link{h_prop_diff}, \link{h_prop_diff_test}, \code{\link[=get_complete_cases]{get_complete_cases()}} +} diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index 9869bbed0c..c5be4060d6 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -31,8 +31,8 @@ test_proportion_diff( s_test_proportion_diff( df, .var, - .ref_group, - .in_ref_col, + .ref_group = NULL, + .in_ref_col = NULL, variables = list(strata = NULL), method = c("chisq", "schouten", "fisher", "cmh", "cmh_sato", "cmh_wh"), alternative = c("two.sided", "less", "greater"), @@ -179,6 +179,6 @@ s_test_proportion_diff( } \seealso{ -\code{\link[=h_prop_diff_test]{h_prop_diff_test()}}, \code{\link[=safe_2x2_table]{safe_2x2_table()}} +\link{h_prop_diff_test}, \code{\link[=h_prepare_2x2_table]{h_prepare_2x2_table()}} } \keyword{internal} diff --git a/man/safe_2x2_table.Rd b/man/safe_2x2_table.Rd deleted file mode 100644 index fe8e6d50be..0000000000 --- a/man/safe_2x2_table.Rd +++ /dev/null @@ -1,76 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prop_diff.R -\name{safe_2x2_table} -\alias{safe_2x2_table} -\title{Construct 2 x 2 Contingency Tables Safely} -\usage{ -safe_2x2_table(rsp, grp, strata = NULL) -} -\arguments{ -\item{rsp}{(\code{logical})\cr -Indicates whether each observation is a responder (\code{TRUE}) or a -non-responder (\code{FALSE}). Missing values are not allowed.} - -\item{grp}{(\code{factor})\cr -Assigns each observation to one of two groups, such as a reference and a -treatment group. Must have exactly two levels and the same length as -\code{rsp}. Missing values are not allowed.} - -\item{strata}{(\code{factor} or \code{NULL})\cr -Defines the stratification variable. If not \code{NULL}, it must have the same -length as \code{rsp} and must not contain any missing values.} -} -\value{ -A contingency table produced by \code{\link[base:table]{base::table()}}. - -When strata is \code{NULL}, a 2 x 2 table is returned, with \code{grp} defining the rows -and \code{rsp} defining the columns. The \code{rsp} dimension always contains the levels -\code{TRUE} and \code{FALSE}, in that order, including when one outcome is not observed. - -When \code{strata} is supplied, a 3-dimensional contingency table with dimensions -2 x 2 x k is returned, where k is the number of levels of strata. -The dimensions correspond to \code{grp}, \code{rsp}, and \code{strata}, respectively. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -Creates a 2 x 2 contingency table of responder status by group, optionally -stratified by a third factor. The function validates the input vectors and -ensures that the responder variable contains both possible outcomes -(\code{TRUE} and \code{FALSE}) in the resulting table, even when one outcome is not -observed in the data. - -When strata is not supplied, a single 2 x 2 contingency table is returned. -When strata is supplied, a separate 2 x 2 contingency table is created -for each stratum. -} -\examples{ - -set.seed(123) -n <- 50 -df <- data.frame( - "rsp" = sample(c(TRUE, FALSE), n, TRUE), - "grp" = sample(c("A", "B"), n, TRUE), - "f1" = sample(c("a1", "a2"), n, TRUE), - "f2" = sample(c("x", "y", "z"), n, TRUE), - stringsAsFactors = TRUE -) - -tbl <- safe_2x2_table(df$rsp, df$grp) -tbl - -# Example use case: Fisher's exact test. -prop_fisher(tbl) - -# The FALSE/TRUE levels are retained even when only one outcome is observed. -safe_2x2_table(rep(TRUE, n), df$grp) - -# Stratified 2 x 2 tables. -strata <- interaction(df$f1, df$f2) -tbl_strat <- safe_2x2_table(df$rsp, df$grp, strata) -tbl_strat - -# Example use case: the stratified Cochran-Mantel-Haenszel test. -prop_cmh(tbl_strat) - -} diff --git a/tests/testthat/test-get_complete_cases.R b/tests/testthat/test-get_complete_cases.R new file mode 100644 index 0000000000..f4c274975c --- /dev/null +++ b/tests/testthat/test-get_complete_cases.R @@ -0,0 +1,98 @@ +test_that("get_complete_cases() returns data unchanged when there are no missing values", { + df <- data.frame(a = 1:3, b = letters[1:3]) + + expect_identical(get_complete_cases(df), df) +}) + +test_that("get_complete_cases() removes rows with missing values in one column", { + df <- data.frame(a = c(1, NA, 3), b = letters[1:3]) + + expect_warning( + result <- get_complete_cases(df), + "1.*omitted" + ) + + expect_identical( + result, + data.frame(a = c(1, 3), b = c("a", "c"), row.names = c(1L, 3L)) + ) +}) + +test_that("get_complete_cases() removes rows with missing values in multiple columns", { + df <- data.frame( + a = c(1, NA, 3, NA, 6), + b = c("a", "b", NA, "d", "k"), + c = c(NA, 2, 3, 4, 3) + ) + + expect_warning( + result <- get_complete_cases(df), + "4.*omitted" + ) + + expect_identical( + result, + data.frame(a = 6, b = "k", c = 3, row.names = 5L) + ) +}) + +test_that("get_complete_cases() preserves data.frame structure with one column", { + df <- data.frame(a = c(1, NA, 3)) + + expect_warning( + result <- get_complete_cases(df), + "1.*omitted" + ) + + expect_identical( + result, + data.frame(a = c(1, 3), row.names = c(1L, 3L)) + ) +}) + +test_that("get_complete_cases() removes all rows when every row contains missing values", { + df <- data.frame(a = c(1, NA, 3), b = c(NA, "b", NA)) + + expect_warning( + result <- get_complete_cases(df), + "3.*omitted" + ) + + expect_identical(result, df[0, , drop = FALSE]) +}) + +test_that("get_complete_cases() handles data.frame with no rows", { + df <- data.frame(a = integer(), b = character()) + + expect_identical(get_complete_cases(df), df) +}) + +test_that("get_complete_cases() appends additional message to warning", { + df <- data.frame(a = c(1, NA, 3), b = letters[1:3]) + + expect_warning( + result <- get_complete_cases( + df, + additional_message = "Please check the input data." + ), + "1.*omitted.*Please check the input data\\." + ) + + expect_identical( + result, + data.frame(a = c(1, 3), b = c("a", "c"), row.names = c(1L, 3L)) + ) +}) + +test_that("get_complete_cases() suppresses warning when quiet is TRUE", { + df <- data.frame(a = c(1, NA, 3), b = letters[1:3]) + + expect_no_warning( + result <- get_complete_cases(df, TRUE) + ) + + expect_identical( + result, + data.frame(a = c(1, 3), b = c("a", "c"), row.names = c(1L, 3L)) + ) +}) diff --git a/tests/testthat/test-h_prepare_2x2_table.R b/tests/testthat/test-h_prepare_2x2_table.R new file mode 100644 index 0000000000..0b87cce528 --- /dev/null +++ b/tests/testthat/test-h_prepare_2x2_table.R @@ -0,0 +1,75 @@ +test_that("h_prepare_2x2_table() works without strata", { + set.seed(123) + n <- 100 + data <- data.frame( + rsp = sample(c(TRUE, FALSE), n, replace = TRUE), + grp = factor(sample(c("Placebo", "X"), n, replace = TRUE)) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + val = TRUE + ) + ) + + grp_ref <- which(data$grp == "Placebo") + grp_nonref <- which(data$grp == "X") + + expected <- list( + rsp = data[c(grp_nonref, grp_ref), 1], + grp = factor( + c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + levels = c("ref", "Not-ref") + ), + strata = NULL, + tbl = as.table(array( + c(26L, 31L, 20L, 23L), + dim = c(2L, 2L), + dimnames = list(grp = c("ref", "Not-ref"), rsp = c("TRUE", "FALSE")) + )) + ) + + expect_identical(result, expected) +}) + +test_that("h_prepare_2x2_table() works with strata", { + set.seed(123) + n <- 100 + data <- data.frame( + rsp = sample(c(TRUE, FALSE), n, replace = TRUE), + grp = factor(sample(c("Placebo", "X"), n, replace = TRUE)), + strata = factor(sample(LETTERS[1:4], n, replace = TRUE)) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + val = TRUE, + strata_vars = "strata" + ) + ) + + grp_ref <- which(data$grp == "Placebo") + grp_nonref <- which(data$grp == "X") + + expected <- list( + rsp = data[c(grp_nonref, grp_ref), "rsp"], + grp = factor( + c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + levels = c("ref", "Not-ref") + ), + strata = factor(data[c(grp_nonref, grp_ref), "strata"]), + tbl = as.table(array( + c(6L, 9L, 9L, 8L, 8L, 6L, 5L, 5L, 5L, 5L, 4L, 5L, 7L, 11L, 2L, 5L), + dim = c(2, 2, 4), + dimnames = list(grp = c("ref", "Not-ref"), rsp = c("TRUE", "FALSE"), strata = LETTERS[1:4]) + )) + ) + + expect_identical(result, expected) +}) diff --git a/tests/testthat/test-safe_2x2_table.R b/tests/testthat/test-safe_2x2_table.R deleted file mode 100644 index 96d8ee14ae..0000000000 --- a/tests/testthat/test-safe_2x2_table.R +++ /dev/null @@ -1,242 +0,0 @@ -test_that("safe_2x2_table() works without strata", { - set.seed(123) - n <- 100 - rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) - grp <- factor(sample(c("Placebo", "X"), n, replace = TRUE)) - - expect_silent( - result <- safe_2x2_table(rsp, grp) - ) - expected <- as.table(array( - c(26L, 31L, 20L, 23L), - dim = c(2L, 2L), - dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - )) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() works with multiple observations and strata", { - set.seed(123) - n <- 100 - rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) - grp <- factor(sample(c("Placebo", "X"), n, replace = TRUE)) - strata <- factor(sample(LETTERS[1:4], n, replace = TRUE)) - - expect_silent( - result <- safe_2x2_table(rsp, grp, strata) - ) - expected <- as.table(array( - c(6L, 9L, 9L, 8L, 8L, 6L, 5L, 5L, 5L, 5L, 4L, 5L, 7L, 11L, 2L, 5L), - dim = c(2, 2, 4), - dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = LETTERS[1:4]) - )) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() gives the same result with one stratum", { - set.seed(123) - n <- 20 - grp <- factor(sample(c("Active", "Control"), n, replace = TRUE)) - rsp <- sample(c(TRUE, FALSE), n, replace = TRUE) - strata <- factor(rep("A", n)) - - expect_silent( - result <- safe_2x2_table(rsp, grp) - ) - expect_silent( - result_1stratum <- safe_2x2_table(rsp, grp, strata) - ) - - expect_identical(result, result_1stratum[, , 1]) -}) - -test_that("safe_2x2_table() retains unobserved response outcomes (TRUE only)", { - rsp <- rep(TRUE, 4) - grp <- factor(c("Placebo", "Placebo", "X", "X")) - strata <- factor(c("S1", "S2", "S1", "S2")) - - expect_silent( - result <- safe_2x2_table(rsp, grp) - ) - expect_silent( - result_strata <- safe_2x2_table(rsp, grp, strata) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - expected <- as.table(array(c(2L, 2L, 0L, 0L), dim = c(2L, 2L), dimnames = dimnames)) - expected_strata <- as.table(array( - c(1L, 1L, 0L, 0L, 1L, 1L, 0L, 0L), - dim = c(2L, 2L, 2L), - dimnames = c(dimnames, strata = list(c("S1", "S2"))) - )) - - expect_identical(result, expected) - expect_identical(result_strata, expected_strata) -}) - -test_that("safe_2x2_table() retains unobserved response outcomes (FALSE only)", { - rsp <- rep(FALSE, 4) - grp <- factor(c("Placebo", "Placebo", "X", "X")) - strata <- factor(c("S1", "S2", "S1", "S2")) - - expect_silent( - result <- safe_2x2_table(rsp, grp) - ) - expect_silent( - result_strata <- safe_2x2_table(rsp, grp, strata) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - expected <- as.table(array(c(0L, 0L, 2L, 2L), dim = c(2L, 2L), dimnames = dimnames)) - expected_strata <- as.table(array( - c(0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L), - dim = c(2L, 2L, 2L), - dimnames = c(dimnames, strata = list(c("S1", "S2"))) - )) - - expect_identical(result, expected) - expect_identical(result_strata, expected_strata) -}) - -test_that("safe_2x2_table() retains unobserved group levels", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(rep("X", 4), levels = c("Placebo", "X")) - strata <- factor(c("S1", "S2", "S2", "S1")) - - expect_silent( - result <- safe_2x2_table(rsp, grp) - ) - expect_silent( - result_strata <- safe_2x2_table(rsp, grp, strata) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - expected <- as.table(array(c(0L, 2L, 0L, 2L), dim = c(2L, 2L), dimnames = dimnames)) - expected_strata <- as.table(array( - c(0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L), - dim = c(2L, 2L, 2L), - dimnames = c(dimnames, strata = list(c("S1", "S2"))) - )) - - expect_identical(result, expected) - expect_identical(result_strata, expected_strata) -}) - -test_that("safe_2x2_table() retains unused strata levels", { - rsp <- c(TRUE, FALSE, TRUE, FALSE) - grp <- factor(c("X", "X", "Placebo", "Placebo")) - strata <- factor(c("A", "A", "B", "B"), levels = c("A", "B", "Z")) - - expect_silent( - result <- safe_2x2_table(rsp, grp, strata) - ) - - expected <- as.table(array( - c(0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L), - dim = c(2L, 2L, 3L), - dimnames = list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = c("A", "B", "Z")) - )) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() handles sparse contingency tables", { - rsp <- c(TRUE, TRUE, TRUE, TRUE) - grp <- factor(c("Y", "Y", "Cntrl", "Cntrl")) - strata <- factor(c("A", "A", "B", "B")) - - expect_silent( - result <- safe_2x2_table(rsp, grp, strata) - ) - - expected <- as.table(array( - c(0L, 2L, 0L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 0L), - dim = c(2L, 2L, 2L), - dimnames = list(grp = c("Cntrl", "Y"), rsp = c("TRUE", "FALSE"), strata = c("A", "B")) - )) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() handles empty data with an unused stratum level", { - grp <- factor(levels = c("Placebo", "X")) - strata <- factor(levels = "S1") - - expect_silent( - result <- safe_2x2_table(logical(), grp) - ) - expect_silent( - result_strata <- safe_2x2_table(logical(), grp, strata) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - expected <- as.table(array(c(0L, 0L, 0L, 0L), dim = c(2L, 2L), dimnames = dimnames)) - expected_strata <- as.table(array( - c(0L, 0L, 0L, 0L), - dim = c(2L, 2L, 1L), - dimnames = c(dimnames, strata = "S1") - )) - - expect_identical(result, expected) - expect_identical(result_strata, expected_strata) -}) - -test_that("safe_2x2_table() handles empty data with no stratum levels", { - expect_silent( - result <- safe_2x2_table( - logical(), factor(levels = c("Placebo", "X")), factor() - ) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE"), strata = character()) - expected <- as.table(array(integer(), dim = c(2L, 2L, 0L), dimnames = dimnames)) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() handles empty data without strata", { - expect_silent( - result <- safe_2x2_table(logical(), factor(levels = c("Placebo", "X"))) - ) - - dimnames <- list(grp = c("Placebo", "X"), rsp = c("TRUE", "FALSE")) - expected <- as.table(array(rep(0L, 4), dim = c(2L, 2L), dimnames = dimnames)) - - expect_identical(result, expected) -}) - -test_that("safe_2x2_table() validates inputs (rsp)", { - grp <- factor(c("G1", "G1", "G2", "G2")) - rsp <- c(TRUE, FALSE, TRUE, FALSE) - strata <- factor(c("A", "A", "B", "B")) - - expect_error(safe_2x2_table(as.character(rsp), grp)) - expect_error(safe_2x2_table(as.numeric(rsp), grp)) - expect_error(safe_2x2_table(c(rsp[-1], NA), grp)) -}) - -test_that("safe_2x2_table() validates inputs (grp)", { - grp <- factor(c("G1", "G1", "G2", "G2")) - rsp <- c(TRUE, FALSE, TRUE, FALSE) - strata <- factor(c("A", "A", "B", "B")) - - expect_error(safe_2x2_table(rsp, as.character(grp))) - expect_error(safe_2x2_table(rsp, as.numeric(grp))) - expect_error(safe_2x2_table(rsp, factor(rep("G1", 4)))) - expect_error(safe_2x2_table(rsp, factor(grp, levels = c("G1", "G2", "G3")))) - expect_error(safe_2x2_table(rsp, grp[-1])) - expect_error(safe_2x2_table(rsp, factor(c(NA, grp[-1])))) -}) - -test_that("safe_2x2_table() validates inputs (strata)", { - grp <- factor(c("G1", "G1", "G2", "G2")) - rsp <- c(TRUE, FALSE, TRUE, FALSE) - strata <- factor(c("A", "A", "B", "B")) - - expect_error(safe_2x2_table(rsp, grp, as.character(strata))) - expect_error(safe_2x2_table(rsp, grp, as.numeric(strata))) - expect_error(safe_2x2_table(rsp, grp, strata[-1])) - expect_error(safe_2x2_table(rsp, grp, factor(c(strata[-1], NA)))) -}) From b95ace9042846344edff5c646509c2e28d4637f7 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 14:37:13 +0200 Subject: [PATCH 18/40] Added the `val` argument to `s_test_proportion_diff()` --- NEWS.md | 4 ++++ R/prop_diff.R | 2 +- R/prop_diff_test.R | 8 +++++++- man/h_prepare_2x2_table.Rd | 2 +- man/prop_diff_test.Rd | 6 ++++++ 5 files changed, 19 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 02c4303a97..37c1404db2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,10 @@ stored in a single column. (#1499) * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected rows from the forest plot before plotting. (#1498) + +### Miscellaneous +* Added the `val` argument and refactored `s_test_proportion_diff()` so that it + uses the new function `h_prepare_2x2_table()`. # tern 0.9.11 diff --git a/R/prop_diff.R b/R/prop_diff.R index 03ead15254..db0d5d37a0 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -420,7 +420,7 @@ check_diff_prop_ci <- function(rsp, #' response variable. The response is converted to a logical vector by #' comparing its values with `val`. #' @param val (`character(1)` or `logical(1)`)\cr -#' The value of `df[[var]]` (and, if supplied, `df_ref[[var]]`) that defines +#' The value in `df[[var]]` (and, if supplied, in `df_ref[[var]]`) that defines #' a positive response. Observations matching this value are returned as #' `TRUE` in the `rsp` vector; all other observations are returned as `FALSE`. #' @param strata_vars (`character` or `NULL`)\cr diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 6cfae548ca..453873f976 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -23,6 +23,11 @@ NULL #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. #' +#' @param val (`character(1)` or `logical(1)`)\cr +#' the value in `df[[.var]]` (and, if supplied, in `.ref_group[[.var]]`) that +#' defines a positive response. All other observations are treated as +#' non-responses. +#' #' @return #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same. @@ -55,6 +60,7 @@ s_test_proportion_diff <- function(df, variables = list(strata = NULL), method = c("chisq", "schouten", "fisher", "cmh", "cmh_sato", "cmh_wh"), alternative = c("two.sided", "less", "greater"), + val = TRUE, ...) { method <- match.arg(method) @@ -70,7 +76,7 @@ s_test_proportion_diff <- function(df, } prepared <- h_prepare_2x2_table( - df = df, df_ref = .ref_group, var = .var, val = TRUE, + df = df, df_ref = .ref_group, var = .var, val = val, strata_vars = strata_vars, complete_cases = TRUE ) diff --git a/man/h_prepare_2x2_table.Rd b/man/h_prepare_2x2_table.Rd index 7f1396a486..dd10255b5c 100644 --- a/man/h_prepare_2x2_table.Rd +++ b/man/h_prepare_2x2_table.Rd @@ -27,7 +27,7 @@ response variable. The response is converted to a logical vector by comparing its values with \code{val}.} \item{val}{(\code{character(1)} or \code{logical(1)})\cr -The value of \code{df[[var]]} (and, if supplied, \code{df_ref[[var]]}) that defines +The value in \code{df[[var]]} (and, if supplied, in \code{df_ref[[var]]}) that defines a positive response. Observations matching this value are returned as \code{TRUE} in the \code{rsp} vector; all other observations are returned as \code{FALSE}.} diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index c5be4060d6..254d880421 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -36,6 +36,7 @@ s_test_proportion_diff( variables = list(strata = NULL), method = c("chisq", "schouten", "fisher", "cmh", "cmh_sato", "cmh_wh"), alternative = c("two.sided", "less", "greater"), + val = TRUE, ... ) @@ -105,6 +106,11 @@ by a statistics function.} \item{.ref_group}{(\code{data.frame} or \code{vector})\cr the data corresponding to the reference group.} \item{.in_ref_col}{(\code{flag})\cr \code{TRUE} when working with the reference level, \code{FALSE} otherwise.} + +\item{val}{(\code{character(1)} or \code{logical(1)})\cr +the value in \code{df[[.var]]} (and, if supplied, in \code{.ref_group[[.var]]}) that +defines a positive response. All other observations are treated as +non-responses.} } \value{ \itemize{ From 947922ee008e49ea055762db6fc76da81dfd6a91 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 14:51:04 +0200 Subject: [PATCH 19/40] cosmetic s_test_proportion_diff() update. --- R/prop_diff_test.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 453873f976..ca61235f6e 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -67,8 +67,8 @@ s_test_proportion_diff <- function(df, pval <- if (!is.null(.in_ref_col) && .in_ref_col) { numeric() } else { - checkmate::assert_list(variables, null.ok = TRUE) strata_vars <- if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { + checkmate::assert_list(variables) checkmate::assert_false(is.null(variables$strata)) variables$strata } else { From 29ab62f04a150636d4cc6aca9ce3677bd4217ff6 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 18:05:18 +0200 Subject: [PATCH 20/40] Set default value for val argument of h_prepare_2x2_table(). Add unit tests for h_prepare_2x2_table(). --- R/prop_diff.R | 16 +- man/h_prepare_2x2_table.Rd | 4 +- tests/testthat/_snaps/h_prepare_2x2_table.md | 40 ++ tests/testthat/test-h_prepare_2x2_table.R | 592 ++++++++++++++++++- tests/testthat/test-test_proportion_diff.R | 27 + 5 files changed, 666 insertions(+), 13 deletions(-) create mode 100644 tests/testthat/_snaps/h_prepare_2x2_table.md diff --git a/R/prop_diff.R b/R/prop_diff.R index db0d5d37a0..0fa4c1cfed 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -515,7 +515,6 @@ check_diff_prop_ci <- function(rsp, #' df = subset(dta, grp == "X"), #' df_ref = subset(dta, grp == "Placebo"), #' var = "rsp", -#' val = TRUE, #' strata_vars = c("f1", "f2") #' ) #' @@ -541,12 +540,11 @@ check_diff_prop_ci <- function(rsp, #' df = subset(dta2, grp == "X"), #' df_ref = subset(dta2, grp == "Placebo"), #' var = "rsp", -#' val = TRUE, #' )$tbl h_prepare_2x2_table <- function(df, df_ref = NULL, var, - val, + val = TRUE, strata_vars = NULL, complete_cases = FALSE, quiet = FALSE) { @@ -574,9 +572,17 @@ h_prepare_2x2_table <- function(df, # Optionally remove incomplete cases. if (complete_cases) { vars <- c(var, strata_vars) - df <- get_complete_cases(df[, vars, drop = FALSE], quiet = quiet) + df <- get_complete_cases( + df[, vars, drop = FALSE], + quiet = quiet, + additional_message = " from the non-reference group (df)." + ) if (!is.null(df_ref)) { - df_ref <- get_complete_cases(df_ref[, vars, drop = FALSE], quiet = quiet) + df_ref <- get_complete_cases( + df_ref[, vars, drop = FALSE], + quiet = quiet, + additional_message = " from the reference group (df_ref)." + ) } } diff --git a/man/h_prepare_2x2_table.Rd b/man/h_prepare_2x2_table.Rd index dd10255b5c..e82862544d 100644 --- a/man/h_prepare_2x2_table.Rd +++ b/man/h_prepare_2x2_table.Rd @@ -8,7 +8,7 @@ h_prepare_2x2_table( df, df_ref = NULL, var, - val, + val = TRUE, strata_vars = NULL, complete_cases = FALSE, quiet = FALSE @@ -133,7 +133,6 @@ trgs <- h_prepare_2x2_table( df = subset(dta, grp == "X"), df_ref = subset(dta, grp == "Placebo"), var = "rsp", - val = TRUE, strata_vars = c("f1", "f2") ) @@ -159,7 +158,6 @@ h_prepare_2x2_table( df = subset(dta2, grp == "X"), df_ref = subset(dta2, grp == "Placebo"), var = "rsp", - val = TRUE, )$tbl } \seealso{ diff --git a/tests/testthat/_snaps/h_prepare_2x2_table.md b/tests/testthat/_snaps/h_prepare_2x2_table.md new file mode 100644 index 0000000000..bb4957de88 --- /dev/null +++ b/tests/testthat/_snaps/h_prepare_2x2_table.md @@ -0,0 +1,40 @@ +# h_prepare_2x2_table() warns when NAs are removed and quiet = FALSE + + Code + h_prepare_2x2_table(df = subset(data, grp == "X"), df_ref = subset(data, grp == + "Placebo"), var = "rsp", strata_vars = "strata", complete_cases = TRUE, + quiet = FALSE) + Condition + Warning: + 2 row(s) with missing values were omitted from the non-reference group (df). + Warning: + 1 row(s) with missing values were omitted from the reference group (df_ref). + Output + $rsp + [1] TRUE TRUE FALSE + + $grp + [1] Not-ref ref ref + Levels: ref Not-ref + + $strata + [1] S1 S1 S2 + Levels: S1 S2 + + $tbl + , , strata = S1 + + rsp + grp TRUE FALSE + ref 1 0 + Not-ref 1 0 + + , , strata = S2 + + rsp + grp TRUE FALSE + ref 0 1 + Not-ref 0 0 + + + diff --git a/tests/testthat/test-h_prepare_2x2_table.R b/tests/testthat/test-h_prepare_2x2_table.R index 0b87cce528..431e0445ef 100644 --- a/tests/testthat/test-h_prepare_2x2_table.R +++ b/tests/testthat/test-h_prepare_2x2_table.R @@ -3,15 +3,14 @@ test_that("h_prepare_2x2_table() works without strata", { n <- 100 data <- data.frame( rsp = sample(c(TRUE, FALSE), n, replace = TRUE), - grp = factor(sample(c("Placebo", "X"), n, replace = TRUE)) + grp = sample(c("Placebo", "X"), n, replace = TRUE) ) expect_silent( result <- h_prepare_2x2_table( df = subset(data, grp == "X"), df_ref = subset(data, grp == "Placebo"), - var = "rsp", - val = TRUE + var = "rsp" ) ) @@ -40,7 +39,7 @@ test_that("h_prepare_2x2_table() works with strata", { n <- 100 data <- data.frame( rsp = sample(c(TRUE, FALSE), n, replace = TRUE), - grp = factor(sample(c("Placebo", "X"), n, replace = TRUE)), + grp = sample(c("Placebo", "X"), n, replace = TRUE), strata = factor(sample(LETTERS[1:4], n, replace = TRUE)) ) @@ -49,7 +48,6 @@ test_that("h_prepare_2x2_table() works with strata", { df = subset(data, grp == "X"), df_ref = subset(data, grp == "Placebo"), var = "rsp", - val = TRUE, strata_vars = "strata" ) ) @@ -73,3 +71,587 @@ test_that("h_prepare_2x2_table() works with strata", { expect_identical(result, expected) }) + +test_that("h_prepare_2x2_table() works with multiple strata variables", { + set.seed(123) + n <- 100 + data <- data.frame( + rsp = sample(c(TRUE, FALSE), n, replace = TRUE), + grp = sample(c("Placebo", "X"), n, replace = TRUE), + strata_1 = factor(sample(LETTERS[1:4], n, replace = TRUE)), + strata_2 = factor(sample(letters[1:2], n, replace = TRUE)) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = c("strata_1", "strata_2") + ) + ) + + grp_ref <- which(data$grp == "Placebo") + grp_nonref <- which(data$grp == "X") + + expected <- list( + rsp = data[c(grp_nonref, grp_ref), "rsp"], + grp = factor( + c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + levels = c("ref", "Not-ref") + ), + strata = interaction(data[c(grp_nonref, grp_ref), c("strata_1", "strata_2")]), + tbl = as.table(array( + c( + 5L, 5L, 3L, 4L, 4L, 4L, 2L, 2L, + 3L, 3L, 2L, 4L, 4L, 7L, 1L, 4L, + 1L, 4L, 6L, 4L, 4L, 2L, 3L, 3L, + 2L, 2L, 2L, 1L, 3L, 4L, 1L, 1L + ), + dim = c(2L, 2L, 8L), + dimnames = list( + grp = c("ref", "Not-ref"), + rsp = c("TRUE", "FALSE"), + strata = c("A.a", "B.a", "C.a", "D.a", "A.b", "B.b", "C.b", "D.b") + ) + )) + ) + + expect_identical(result, expected) +}) + +test_that("h_prepare_2x2_table() handles a custom val", { + data <- data.frame( + rsp = c("RES", "NORES", "RES", "RES", "NORES", "NORES"), + grp = c("Placebo", "X", "Placebo", "X", "X", "X"), + strata = factor(c("S1", "S2", "S1", "S2", "S2", "S1")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + val = "RES", + strata_vars = NULL + ) + ) + + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + val = "RES", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- c(FALSE, TRUE, FALSE, FALSE, TRUE, TRUE) + grp <- factor(c(rep("Not-ref", 4L), "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S2", "S2", "S2", "S1", "S1", "S1"), levels = c("S1", "S2")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("h_prepare_2x2_table() gives the same result with one stratum", { + set.seed(123) + n <- 20 + data <- data.frame( + rsp = sample(c(TRUE, FALSE), n, replace = TRUE), + grp = sample(c("Active", "Control"), n, replace = TRUE), + strata = factor(rep("A", n)) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "Active"), + df_ref = subset(data, grp == "Control"), + var = "rsp", + strata_vars = NULL + ) + ) + + expect_silent( + result_1stratum <- h_prepare_2x2_table( + df = subset(data, grp == "Active"), + df_ref = subset(data, grp == "Control"), + var = "rsp", + strata_vars = "strata" + ) + ) + + expect_identical(result[c("rsp", "grp")], result_1stratum[c("rsp", "grp")]) + expect_identical(result$tbl, result_1stratum$tbl[, , 1]) +}) + +test_that("h_prepare_2x2_table() retains unobserved response outcomes (TRUE only)", { + data <- data.frame( + rsp = rep(TRUE, 4), + grp = c("Placebo", "X", "Placebo", "X"), + strata = factor(c("S1", "S2", "S1", "S2")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = NULL + ) + ) + + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- c(TRUE, TRUE, TRUE, TRUE) + grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S2", "S2", "S1", "S1"), levels = c("S1", "S2")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("h_prepare_2x2_table() retains unobserved response outcomes (FALSE only)", { + data <- data.frame( + rsp = rep(FALSE, 4), + grp = c("Placebo", "X", "Placebo", "X"), + strata = factor(c("S1", "S2", "S1", "S2")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = NULL + ) + ) + + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- c(FALSE, FALSE, FALSE, FALSE) + grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S2", "S2", "S1", "S1"), levels = c("S1", "S2")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("h_prepare_2x2_table() handles empty and NULL df_ref", { + data <- data.frame( + rsp = c(TRUE, FALSE, TRUE, FALSE), + grp = rep("X", 4), + strata = factor(c("S1", "S2", "S2", "S1")) + ) + + # Empty df_ref. + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = NULL + ) + ) + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # df_ref is NULL. + expect_silent( + result_dfref_null <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = NULL, + var = "rsp", + strata_vars = NULL + ) + ) + expect_silent( + result_dfref_null_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = NULL, + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(rep("Not-ref", 4L), levels = c("ref", "Not-ref")) + strata <- data$strata + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) + + expect_identical(result, result_dfref_null) + expect_identical(result_strata, result_dfref_null_strata) +}) + + +test_that("h_prepare_2x2_table() retains unused strata levels", { + data <- data.frame( + rsp = c(TRUE, FALSE, TRUE, FALSE), + grp = c("X", "X", "Placebo", "Placebo"), + strata = factor(c("A", "A", "B", "B"), levels = c("A", "B", "Z")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = NULL + ) + ) + + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- data$strata + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + +test_that("h_prepare_2x2_table() handles sparse contingency tables", { + data <- data.frame( + rsp = c(TRUE, TRUE, TRUE, TRUE), + grp = c("Y", "Y", "Cntrl", "Cntrl"), + strata = factor(c("A", "A", "B", "B")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "Y"), + df_ref = subset(data, grp == "Cntrl"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- data$strata + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) +}) + +test_that("h_prepare_2x2_table() handles empty data with an unused stratum level", { + data <- data.frame( + rsp = logical(), + grp = character(), + strata = factor(levels = "S1") + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = NULL + ) + ) + + expect_silent( + result_strata <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(levels = c("ref", "Not-ref")) + strata <- data$strata + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) + expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) + expect_identical(result_strata, expected_strata) +}) + + +test_that("h_prepare_2x2_table() handles empty data with no stratum levels", { + data <- data.frame( + rsp = logical(), + grp = character(), + strata = factor() + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "Y"), + df_ref = subset(data, grp == "Cntrl"), + var = "rsp", + strata_vars = "strata" + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(levels = c("ref", "Not-ref")) + strata <- data$strata + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) +}) + +test_that("h_prepare_2x2_table() handles empty data without strata", { + data <- data.frame( + rsp = logical(), + grp = character() + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "Y"), + df_ref = subset(data, grp == "Cntrl"), + var = "rsp", + strata_vars = NULL + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(levels = c("ref", "Not-ref")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE"))) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = tbl) + + expect_identical(result, expected) +}) + +testthat::test_that("h_prepare_2x2_table() removes incomplete cases", { + data <- data.frame( + rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), + grp = factor(c("X", "X", "X", "Placebo", "Placebo", "Placebo")), + strata = factor(c("S1", "S1", NA, "S1", "S2", "S2")) + ) + + expect_silent( + result_quiet <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata", + complete_cases = TRUE, + quiet = TRUE + ) + ) + + rsp <- c(TRUE, TRUE, FALSE) + grp <- factor(c("Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S1", "S1", "S2"), levels = c("S1", "S2")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result_quiet, expected) +}) + +testthat::test_that("h_prepare_2x2_table() removes incomplete cases without strata", { + data <- data.frame( + rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), + grp = factor(c(NA, "X", "X", "Placebo", "Placebo", "Placebo")), + strata = factor(c("S1", "S1", NA, "S1", NA, "S2")) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + complete_cases = TRUE, + quiet = TRUE + ) + ) + + rsp <- c(FALSE, TRUE, FALSE) + grp <- factor(c("Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE"))) + expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = tbl) + + expect_identical(result, expected) +}) + +testthat::test_that("h_prepare_2x2_table() warns when NAs are removed and quiet = FALSE", { + data <- data.frame( + rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), + grp = factor(c("X", "X", "X", "Placebo", "Placebo", "Placebo")), + strata = factor(c("S1", "S1", NA, "S1", "S2", "S2")) + ) + + # expect_snapshot() captures warnings. + expect_snapshot( + h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = "strata", + complete_cases = TRUE, + quiet = FALSE + ) + ) + + data_no_missing <- data.frame( + rsp = c(TRUE, TRUE, FALSE, TRUE, TRUE, FALSE), + grp = factor(c("X", "X", "X", "Placebo", "Placebo", "Placebo")), + strata = factor(c("S1", "S1", "S2", "S1", "S2", "S2")) + ) + + expect_silent( + h_prepare_2x2_table( + df = subset(data_no_missing, grp == "X"), + df_ref = subset(data_no_missing, grp == "Placebo"), + var = "rsp", + strata_vars = "strata", + complete_cases = TRUE, + quiet = FALSE + ) + ) +}) + +test_that("h_prepare_2x2_table() validates that var exists in df and df_ref", { + data <- data.frame( + rsp = c(TRUE, FALSE, TRUE, FALSE), + grp = factor(c("G1", "G1", "G2", "G2")), + strata = factor(c("A", "A", "B", "B")) + ) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "wrong_var" + ), + "var" + ) +}) + +test_that("h_prepare_2x2_table() validates strata_vars in df and df_ref", { + data <- data.frame( + rsp = c(TRUE, FALSE, TRUE, FALSE), + grp = factor(c("G1", "G1", "G2", "G2")), + strata = factor(c("A", "A", "B", "B")) + ) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "rsp", + strata_vars = "wrong_strata" + ), + "strata_vars" + ) + + data$strata <- as.character(data$strata) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "rsp", + strata_vars = "strata" + ), + "strata_vars.*factor" + ) +}) + +test_that("h_prepare_2x2_table() validates val", { + data <- data.frame( + rsp = c(1L, 0L, 1L, 1L), + grp = c("G1", "G1", "G2", "G2"), + strata = factor(c("A", "A", "B", "B")) + ) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "rsp", + val = 1L, + strata_vars = "strata" + ), + "val" + ) +}) + +testthat::test_that("h_prepare_2x2_table() validates complete_cases and quiet", { + data <- data.frame( + rsp = c(TRUE, FALSE), + grp = factor(c("G1", "G2")) + ) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "rsp", + complete_cases = 1 + ), + "complete_cases" + ) + + expect_error( + h_prepare_2x2_table( + df = subset(data, grp == "G1"), + df_ref = subset(data, grp == "G2"), + var = "rsp", + quiet = 1 + ), + "quiet" + ) +}) diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index 83eb55961f..f519b8f155 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -331,6 +331,33 @@ testthat::test_that("s_test_proportion_diff and d_test_proportion_diff work with } }) +testthat::test_that("s_test_proportion_diff supports a custom response value", { + set.seed(1984, kind = "Mersenne-Twister") + dta <- data.frame( + rsp = sample(c("Y", "N"), 100, TRUE), + grp = factor(rep(c("A", "B"), each = 50)), + strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20)) + ) + + testthat::expect_silent( + result <- s_test_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = list(strata = "strata"), + method = "cmh", + val = "Y" + ) + ) + + expected <- 0.6477165 + attr(expected, "z_stat") <- 0.4569368 + attr(expected, "label") <- "p-value (Cochran-Mantel-Haenszel Test)" + + testthat::expect_equal(result, list(pval = expected), tolerance = 1e-3) +}) + testthat::test_that("test_proportion_diff returns right result", { set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( From ec171048ab82b58aebc7c8364423542a5ae1ae1b Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 8 Sep 2026 18:25:11 +0200 Subject: [PATCH 21/40] Correct lintr and add few more unit tests for h_prepare_2x2_table(). --- tests/testthat/test-h_prepare_2x2_table.R | 55 +++++++++++++++------- tests/testthat/test-test_proportion_diff.R | 2 +- 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-h_prepare_2x2_table.R b/tests/testthat/test-h_prepare_2x2_table.R index 431e0445ef..30b718cf3f 100644 --- a/tests/testthat/test-h_prepare_2x2_table.R +++ b/tests/testthat/test-h_prepare_2x2_table.R @@ -327,7 +327,8 @@ test_that("h_prepare_2x2_table() retains unused strata levels", { data <- data.frame( rsp = c(TRUE, FALSE, TRUE, FALSE), grp = c("X", "X", "Placebo", "Placebo"), - strata = factor(c("A", "A", "B", "B"), levels = c("A", "B", "Z")) + strata_1 = factor(c("A", "A", "B", "B"), levels = c("A", "B", "Z")), + strata_2 = factor(c("S1", "S2", "S1", "S2"), levels = c("S1", "S2", "XXX")) ) expect_silent( @@ -335,29 +336,18 @@ test_that("h_prepare_2x2_table() retains unused strata levels", { df = subset(data, grp == "X"), df_ref = subset(data, grp == "Placebo"), var = "rsp", - strata_vars = NULL - ) - ) - - expect_silent( - result_strata <- h_prepare_2x2_table( - df = subset(data, grp == "X"), - df_ref = subset(data, grp == "Placebo"), - var = "rsp", - strata_vars = "strata" + strata_vars = c("strata_1", "strata_2") ) ) # Expected. rsp <- data$rsp grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- data$strata + strata <- interaction(data$strata_1, data$strata_2) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) - expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) - expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) expect_identical(result, expected) - expect_identical(result_strata, expected_strata) }) test_that("h_prepare_2x2_table() handles sparse contingency tables", { @@ -428,7 +418,8 @@ test_that("h_prepare_2x2_table() handles empty data with no stratum levels", { data <- data.frame( rsp = logical(), grp = character(), - strata = factor() + strata_1 = factor(), + strata_2 = factor() ) expect_silent( @@ -436,14 +427,14 @@ test_that("h_prepare_2x2_table() handles empty data with no stratum levels", { df = subset(data, grp == "Y"), df_ref = subset(data, grp == "Cntrl"), var = "rsp", - strata_vars = "strata" + strata_vars = c("strata_1", "strata_2") ) ) # Expected. rsp <- data$rsp grp <- factor(levels = c("ref", "Not-ref")) - strata <- data$strata + strata <- data$strata_1 tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -526,6 +517,34 @@ testthat::test_that("h_prepare_2x2_table() removes incomplete cases without stra expect_identical(result, expected) }) +testthat::test_that("h_prepare_2x2_table() removes incomplete cases (all NAs)", { + data <- data.frame( + rsp = c(TRUE, NA, FALSE, NA, FALSE, NA), + grp = factor(c(NA, "X", "X", "Placebo", NA, "Placebo")), + strata_1 = factor(c("S1", "S1", NA, "S1", "S2", "S2")), + strata_2 = factor(c("G1", NA, "G2", "G1", "G2", NA)) + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "X"), + df_ref = subset(data, grp == "Placebo"), + var = "rsp", + strata_vars = c("strata_1", "strata_2"), + complete_cases = TRUE, + quiet = TRUE + ) + ) + + rsp <- logical() + grp <- factor(levels = c("ref", "Not-ref")) + strata <- factor(levels = c("S1.G1", "S2.G1", "S1.G2", "S2.G2")) + tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) + expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) + + expect_identical(result, expected) +}) + testthat::test_that("h_prepare_2x2_table() warns when NAs are removed and quiet = FALSE", { data <- data.frame( rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index f519b8f155..34f2610562 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -152,7 +152,7 @@ testthat::test_that("prop_schouten returns right result", { grp <- c(rep("A", N[1]), rep("B", N[2])) tbl <- table(grp, rsp) - if (ncol(tbl) < 2 | nrow(tbl) < 2) { + if (ncol(tbl) < 2 || nrow(tbl) < 2) { return(NA_real_) } prop_schouten(tbl) From 86534d4be1ef9bcc5c4268a39caf924d4f16dd62 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 09:57:37 +0200 Subject: [PATCH 22/40] Added the val argument and refactored s_proportion_diff() so that it uses the new function h_prepare_2x2_table(). --- NEWS.md | 2 + R/prop_diff.R | 97 ++++++++++------------ R/prop_diff_test.R | 2 +- man/prop_diff.Rd | 10 ++- tests/testthat/test-prop_diff.R | 28 +++++++ tests/testthat/test-test_proportion_diff.R | 6 +- 6 files changed, 84 insertions(+), 61 deletions(-) diff --git a/NEWS.md b/NEWS.md index 37c1404db2..eddc96f2c3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,6 +12,8 @@ rows from the forest plot before plotting. (#1498) ### Miscellaneous +* Added the `val` argument and refactored `s_proportion_diff()` so that it uses + the new function `h_prepare_2x2_table()`. * Added the `val` argument and refactored `s_test_proportion_diff()` so that it uses the new function `h_prepare_2x2_table()`. diff --git a/R/prop_diff.R b/R/prop_diff.R index 0fa4c1cfed..2eda379036 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -45,6 +45,11 @@ NULL #' @describeIn prop_diff Statistics function estimating the difference #' in terms of responder proportion. #' +#' @param val (`character(1)` or `logical(1)`)\cr +#' the value in `df[[.var]]` (and, if supplied, in `.ref_group[[.var]]`) that +#' defines a positive response. All other observations are treated as +#' non-responses. +#' #' @return #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. #' Depending on the method used, also the standard error of the difference `se_diff` is @@ -78,8 +83,8 @@ NULL #' @export s_proportion_diff <- function(df, .var, - .ref_group, - .in_ref_col, + .ref_group = NULL, + .in_ref_col = NULL, variables = list(strata = NULL), conf_level = 0.95, method = c( @@ -88,82 +93,67 @@ s_proportion_diff <- function(df, "strat_newcombe", "strat_newcombecc", "uncond_exact_diff" ), weights_method = "cmh", + val = TRUE, ...) { + checkmate::assert_list(variables) + method <- match.arg(method) - if ( - is.null(variables$strata) && - checkmate::test_subset(method, c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc")) - ) { + + strat_anl_methods <- c( + "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" + ) + + if (is.null(variables$strata) && checkmate::test_subset(method, strat_anl_methods)) { stop(paste( "When performing an unstratified analysis, methods", "'cmh', 'cmh_sato', 'cmh_mn', 'strat_newcombe', and 'strat_newcombecc' are not", "permitted. Please choose a different method." )) } - if (!is.null(variables$strata) && identical(method, "uncond_exact_diff")) { + + if (!is.null(variables$strata) && method == "uncond_exact_diff") { stop( "Method 'uncond_exact_diff' is only available for unstratified analyses. Please choose a different method." ) } - y <- list(diff = numeric(), diff_ci = numeric()) - - if (!.in_ref_col) { - rsp <- c(.ref_group[[.var]], df[[.var]]) - grp <- factor( - rep( - c("ref", "Not-ref"), - c(nrow(.ref_group), nrow(df)) - ), - levels = c("ref", "Not-ref") - ) - - if (!is.null(variables$strata)) { - strata_colnames <- variables$strata - checkmate::assert_character(strata_colnames, null.ok = FALSE) - strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) - assert_df_with_variables(df, strata_vars) - assert_df_with_variables(.ref_group, strata_vars) - - # Merging interaction strata for reference group rows data and remaining - strata <- c( - interaction(.ref_group[strata_colnames]), - interaction(df[strata_colnames]) - ) - strata <- as.factor(strata) - } + if (is.null(.in_ref_col) || .in_ref_col) { + y <- list(diff = numeric(), diff_ci = numeric()) + } else { + prepared <- h_prepare_2x2_table( + df = df, df_ref = .ref_group, var = .var, val = val, + strata_vars = variables$strata, + complete_cases = TRUE + ) + rsp <- prepared$rsp + grp <- prepared$grp + strata <- prepared$strata - # Defining the std way to calculate weights for strat_newcombe - if (!is.null(variables$weights_method)) { - weights_method <- variables$weights_method + # Defining the std way to calculate weights for strat_newcombe. + weights_method <- if (!is.null(variables$weights_method)) { + variables$weights_method } else { - weights_method <- "cmh" + "cmh" } - y_stats_from_cmh <- c("diff", "diff_ci", "se_diff") + cmh_stats <- c("diff", "diff_ci", "se_diff") y <- switch(method, "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE), "ha" = prop_diff_ha(rsp, grp, conf_level), "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), - "strat_newcombe" = prop_diff_strat_nc(rsp, - grp, - strata, - weights_method, - conf_level, + "strat_newcombe" = prop_diff_strat_nc( + rsp, grp, strata, weights_method, conf_level, correct = FALSE ), - "strat_newcombecc" = prop_diff_strat_nc(rsp, - grp, - strata, - weights_method, - conf_level, + "strat_newcombecc" = prop_diff_strat_nc( + rsp, grp, strata, weights_method, conf_level, correct = TRUE ), - "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "standard")[y_stats_from_cmh], - "cmh_sato" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "sato")[y_stats_from_cmh], - "cmh_mn" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "miettinen_nurminen")[y_stats_from_cmh], + "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "standard")[cmh_stats], + "cmh_sato" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "sato")[cmh_stats], + "cmh_mn" = prop_diff_cmh(rsp, grp, strata, conf_level, diff_se = "miettinen_nurminen")[cmh_stats], "uncond_exact_diff" = prop_diff_uncond_exact(rsp, grp, conf_level) ) @@ -175,10 +165,7 @@ s_proportion_diff <- function(df, } attr(y$diff, "label") <- "Difference in Response rate (%)" - attr(y$diff_ci, "label") <- d_proportion_diff( - conf_level, method, - long = FALSE - ) + attr(y$diff_ci, "label") <- d_proportion_diff(conf_level, method, long = FALSE) if (!is.null(y$se_diff)) { attr(y$se_diff, "label") <- paste0("Standard Error of Difference in Response rate (%)") } diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index ca61235f6e..3df345313a 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -64,7 +64,7 @@ s_test_proportion_diff <- function(df, ...) { method <- match.arg(method) - pval <- if (!is.null(.in_ref_col) && .in_ref_col) { + pval <- if (is.null(.in_ref_col) || .in_ref_col) { numeric() } else { strata_vars <- if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index fc31e622e3..16829fbdd2 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -33,13 +33,14 @@ estimate_proportion_diff( s_proportion_diff( df, .var, - .ref_group, - .in_ref_col, + .ref_group = NULL, + .in_ref_col = NULL, variables = list(strata = NULL), conf_level = 0.95, method = c("waldcc", "wald", "cmh", "cmh_sato", "cmh_mn", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc", "uncond_exact_diff"), weights_method = "cmh", + val = TRUE, ... ) @@ -110,6 +111,11 @@ by a statistics function.} \item{.ref_group}{(\code{data.frame} or \code{vector})\cr the data corresponding to the reference group.} \item{.in_ref_col}{(\code{flag})\cr \code{TRUE} when working with the reference level, \code{FALSE} otherwise.} + +\item{val}{(\code{character(1)} or \code{logical(1)})\cr +the value in \code{df[[.var]]} (and, if supplied, in \code{.ref_group[[.var]]}) that +defines a positive response. All other observations are treated as +non-responses.} } \value{ \itemize{ diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index d9c89f17ea..bd0e7ef33e 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -710,6 +710,34 @@ testthat::test_that("s_proportion_diff rejects uncond_exact_diff with strata", { ) }) +test_that("s_proportion_diff supports a custom response value", { + set.seed(1984, kind = "Mersenne-Twister") + dta <- data.frame( + rsp = sample(c("Y", "N"), 100, TRUE), + grp = factor(rep(c("A", "B"), each = 50)), + strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20)) + ) + + expect_silent( + result <- s_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = list(strata = "strata"), + method = "cmh", + val = "Y" + ) + ) + + expect_equal(as.numeric(result$diff), 10, tolerance = 1e-2) + expect_identical(attr(result$diff, "label"), "Difference in Response rate (%)") + expect_equal(as.numeric(result$diff_ci), c(-31.57711, 51.57711), tolerance = 1e-2) + expect_identical(attr(result$diff_ci, "label"), "95% CI (CMH, without correction)") + expect_equal(as.numeric(result$se_diff), 21.2132, tolerance = 1e-2) + expect_identical(attr(result$se_diff, "label"), "Standard Error of Difference in Response rate (%)") +}) + testthat::test_that("check_diff_prop_ci is silent with healthy input", { # "Mid" case: 3/4 respond in group A, 1/2 respond in group B. rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index 34f2610562..3565685035 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -331,7 +331,7 @@ testthat::test_that("s_test_proportion_diff and d_test_proportion_diff work with } }) -testthat::test_that("s_test_proportion_diff supports a custom response value", { +test_that("s_test_proportion_diff supports a custom response value", { set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( rsp = sample(c("Y", "N"), 100, TRUE), @@ -339,7 +339,7 @@ testthat::test_that("s_test_proportion_diff supports a custom response value", { strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20)) ) - testthat::expect_silent( + expect_silent( result <- s_test_proportion_diff( df = subset(dta, grp == "A"), .var = "rsp", @@ -355,7 +355,7 @@ testthat::test_that("s_test_proportion_diff supports a custom response value", { attr(expected, "z_stat") <- 0.4569368 attr(expected, "label") <- "p-value (Cochran-Mantel-Haenszel Test)" - testthat::expect_equal(result, list(pval = expected), tolerance = 1e-3) + expect_equal(result, list(pval = expected), tolerance = 1e-3) }) testthat::test_that("test_proportion_diff returns right result", { From fbec52c12a38e04292d3253b2a1025e465e3a00d Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 10:40:57 +0200 Subject: [PATCH 23/40] minor implementation change of h_prepare_2x2_table() - merge df_ref with df (in this order, not the opposite). --- R/prop_diff.R | 6 +- tests/testthat/_snaps/h_prepare_2x2_table.md | 6 +- tests/testthat/test-h_prepare_2x2_table.R | 62 ++++++++++---------- 3 files changed, 38 insertions(+), 36 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 2eda379036..f35b9e650a 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -589,10 +589,10 @@ h_prepare_2x2_table <- function(df, # Add reference group data, if supplied. if (!is.null(df_ref)) { - rsp <- c(rsp, df_ref[[var]]) - grp <- c(grp, factor(rep(grp_levels[1], nrow(df_ref)), levels = grp_levels)) + rsp <- c(df_ref[[var]], rsp) + grp <- c(factor(rep(grp_levels[1], nrow(df_ref)), levels = grp_levels), grp) strata <- if (!is.null(strata_vars)) { - c(strata, interaction(df_ref[strata_vars])) + c(interaction(df_ref[strata_vars]), strata) } else { NULL } diff --git a/tests/testthat/_snaps/h_prepare_2x2_table.md b/tests/testthat/_snaps/h_prepare_2x2_table.md index bb4957de88..19aa6981aa 100644 --- a/tests/testthat/_snaps/h_prepare_2x2_table.md +++ b/tests/testthat/_snaps/h_prepare_2x2_table.md @@ -11,14 +11,14 @@ 1 row(s) with missing values were omitted from the reference group (df_ref). Output $rsp - [1] TRUE TRUE FALSE + [1] TRUE FALSE TRUE $grp - [1] Not-ref ref ref + [1] ref ref Not-ref Levels: ref Not-ref $strata - [1] S1 S1 S2 + [1] S1 S2 S1 Levels: S1 S2 $tbl diff --git a/tests/testthat/test-h_prepare_2x2_table.R b/tests/testthat/test-h_prepare_2x2_table.R index 30b718cf3f..b74acfeb29 100644 --- a/tests/testthat/test-h_prepare_2x2_table.R +++ b/tests/testthat/test-h_prepare_2x2_table.R @@ -18,9 +18,9 @@ test_that("h_prepare_2x2_table() works without strata", { grp_nonref <- which(data$grp == "X") expected <- list( - rsp = data[c(grp_nonref, grp_ref), 1], + rsp = data[c(grp_ref, grp_nonref), 1], grp = factor( - c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), levels = c("ref", "Not-ref") ), strata = NULL, @@ -56,12 +56,12 @@ test_that("h_prepare_2x2_table() works with strata", { grp_nonref <- which(data$grp == "X") expected <- list( - rsp = data[c(grp_nonref, grp_ref), "rsp"], + rsp = data[c(grp_ref, grp_nonref), "rsp"], grp = factor( - c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), levels = c("ref", "Not-ref") ), - strata = factor(data[c(grp_nonref, grp_ref), "strata"]), + strata = factor(data[c(grp_ref, grp_nonref), "strata"]), tbl = as.table(array( c(6L, 9L, 9L, 8L, 8L, 6L, 5L, 5L, 5L, 5L, 4L, 5L, 7L, 11L, 2L, 5L), dim = c(2, 2, 4), @@ -95,12 +95,12 @@ test_that("h_prepare_2x2_table() works with multiple strata variables", { grp_nonref <- which(data$grp == "X") expected <- list( - rsp = data[c(grp_nonref, grp_ref), "rsp"], + rsp = data[c(grp_ref, grp_nonref), "rsp"], grp = factor( - c(rep("Not-ref", length(grp_nonref)), rep("ref", length(grp_ref))), + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), levels = c("ref", "Not-ref") ), - strata = interaction(data[c(grp_nonref, grp_ref), c("strata_1", "strata_2")]), + strata = interaction(data[c(grp_ref, grp_nonref), c("strata_1", "strata_2")]), tbl = as.table(array( c( 5L, 5L, 3L, 4L, 4L, 4L, 2L, 2L, @@ -148,9 +148,9 @@ test_that("h_prepare_2x2_table() handles a custom val", { ) # Expected. - rsp <- c(FALSE, TRUE, FALSE, FALSE, TRUE, TRUE) - grp <- factor(c(rep("Not-ref", 4L), "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- factor(c("S2", "S2", "S2", "S1", "S1", "S1"), levels = c("S1", "S2")) + rsp <- c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE) + grp <- factor(c("ref", "ref", rep("Not-ref", 4L)), levels = c("ref", "Not-ref")) + strata <- factor(c("S1", "S1", "S2", "S2", "S2", "S1"), levels = c("S1", "S2")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -217,8 +217,8 @@ test_that("h_prepare_2x2_table() retains unobserved response outcomes (TRUE only # Expected. rsp <- c(TRUE, TRUE, TRUE, TRUE) - grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- factor(c("S2", "S2", "S1", "S1"), levels = c("S1", "S2")) + grp <- factor(c("ref", "ref", "Not-ref", "Not-ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S1", "S1", "S2", "S2"), levels = c("S1", "S2")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -254,8 +254,8 @@ test_that("h_prepare_2x2_table() retains unobserved response outcomes (FALSE onl # Expected. rsp <- c(FALSE, FALSE, FALSE, FALSE) - grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- factor(c("S2", "S2", "S1", "S1"), levels = c("S1", "S2")) + grp <- factor(c("ref", "ref", "Not-ref", "Not-ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S1", "S1", "S2", "S2"), levels = c("S1", "S2")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = margin.table(tbl, 1:2)) expected_strata <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -342,8 +342,11 @@ test_that("h_prepare_2x2_table() retains unused strata levels", { # Expected. rsp <- data$rsp - grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- interaction(data$strata_1, data$strata_2) + grp <- factor(c("ref", "ref", "Not-ref", "Not-ref"), levels = c("ref", "Not-ref")) + strata <- factor( + c("B.S1", "B.S2", "A.S1", "A.S2"), + levels = c("A.S1", "B.S1", "Z.S1", "A.S2", "B.S2", "Z.S2", "A.XXX", "B.XXX", "Z.XXX") + ) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -368,8 +371,8 @@ test_that("h_prepare_2x2_table() handles sparse contingency tables", { # Expected. rsp <- data$rsp - grp <- factor(c("Not-ref", "Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- data$strata + grp <- factor(c("ref", "ref", "Not-ref", "Not-ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("B", "B", "A", "A")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) @@ -413,7 +416,6 @@ test_that("h_prepare_2x2_table() handles empty data with an unused stratum level expect_identical(result_strata, expected_strata) }) - test_that("h_prepare_2x2_table() handles empty data with no stratum levels", { data <- data.frame( rsp = logical(), @@ -465,7 +467,7 @@ test_that("h_prepare_2x2_table() handles empty data without strata", { expect_identical(result, expected) }) -testthat::test_that("h_prepare_2x2_table() removes incomplete cases", { +test_that("h_prepare_2x2_table() removes incomplete cases", { data <- data.frame( rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), grp = factor(c("X", "X", "X", "Placebo", "Placebo", "Placebo")), @@ -483,16 +485,16 @@ testthat::test_that("h_prepare_2x2_table() removes incomplete cases", { ) ) - rsp <- c(TRUE, TRUE, FALSE) - grp <- factor(c("Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) - strata <- factor(c("S1", "S1", "S2"), levels = c("S1", "S2")) + rsp <- c(TRUE, FALSE, TRUE) + grp <- factor(c("ref", "ref", "Not-ref"), levels = c("ref", "Not-ref")) + strata <- factor(c("S1", "S2", "S1"), levels = c("S1", "S2")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE")), strata = strata) expected <- list(rsp = rsp, grp = grp, strata = strata, tbl = tbl) expect_identical(result_quiet, expected) }) -testthat::test_that("h_prepare_2x2_table() removes incomplete cases without strata", { +test_that("h_prepare_2x2_table() removes incomplete cases without strata", { data <- data.frame( rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), grp = factor(c(NA, "X", "X", "Placebo", "Placebo", "Placebo")), @@ -509,15 +511,15 @@ testthat::test_that("h_prepare_2x2_table() removes incomplete cases without stra ) ) - rsp <- c(FALSE, TRUE, FALSE) - grp <- factor(c("Not-ref", "ref", "ref"), levels = c("ref", "Not-ref")) + rsp <- c(TRUE, FALSE, FALSE) + grp <- factor(c("ref", "ref", "Not-ref"), levels = c("ref", "Not-ref")) tbl <- table(grp, rsp = factor(rsp, levels = c("TRUE", "FALSE"))) expected <- list(rsp = rsp, grp = grp, strata = NULL, tbl = tbl) expect_identical(result, expected) }) -testthat::test_that("h_prepare_2x2_table() removes incomplete cases (all NAs)", { +test_that("h_prepare_2x2_table() removes incomplete cases (all NAs)", { data <- data.frame( rsp = c(TRUE, NA, FALSE, NA, FALSE, NA), grp = factor(c(NA, "X", "X", "Placebo", NA, "Placebo")), @@ -545,7 +547,7 @@ testthat::test_that("h_prepare_2x2_table() removes incomplete cases (all NAs)", expect_identical(result, expected) }) -testthat::test_that("h_prepare_2x2_table() warns when NAs are removed and quiet = FALSE", { +test_that("h_prepare_2x2_table() warns when NAs are removed and quiet = FALSE", { data <- data.frame( rsp = c(TRUE, NA, FALSE, TRUE, NA, FALSE), grp = factor(c("X", "X", "X", "Placebo", "Placebo", "Placebo")), @@ -648,7 +650,7 @@ test_that("h_prepare_2x2_table() validates val", { ) }) -testthat::test_that("h_prepare_2x2_table() validates complete_cases and quiet", { +test_that("h_prepare_2x2_table() validates complete_cases and quiet", { data <- data.frame( rsp = c(TRUE, FALSE), grp = factor(c("G1", "G2")) From fa8ad401ff88afebb6ec3a58c3597740012a9cef Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 10:52:15 +0200 Subject: [PATCH 24/40] Cosmetic update of the code comment for h_prepare_2x2_table(). --- R/prop_diff.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index f35b9e650a..5b0abe192b 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -578,7 +578,7 @@ h_prepare_2x2_table <- function(df, # reference group and calculate the difference as "Not-ref" - "ref". grp_levels <- c("ref", "Not-ref") - # Extract response, group and strata data for non-reference group. + # Extract response, group, and strata data for the non-reference group. rsp <- df[[var]] grp <- factor(rep(grp_levels[2], nrow(df)), levels = grp_levels) strata <- if (!is.null(strata_vars)) { @@ -587,7 +587,7 @@ h_prepare_2x2_table <- function(df, NULL } - # Add reference group data, if supplied. + # Prepend reference group data, if supplied. We want the reference group first. if (!is.null(df_ref)) { rsp <- c(df_ref[[var]], rsp) grp <- c(factor(rep(grp_levels[1], nrow(df_ref)), levels = grp_levels), grp) From 6d37d49344d58ca988735efb8540c099c19a80f3 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 11:10:22 +0200 Subject: [PATCH 25/40] Add seealso roxygen tag for s_proportion_diff(). --- R/prop_diff.R | 2 ++ man/prop_diff.Rd | 2 ++ 2 files changed, 4 insertions(+) diff --git a/R/prop_diff.R b/R/prop_diff.R index 5b0abe192b..3423a38a99 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -59,6 +59,8 @@ NULL #' and `"strat_newcombecc"` are not permitted. For stratified analysis, method #' `"uncond_exact_diff"` is not permitted. #' +#' @seealso [h_prepare_2x2_table()] +#' #' @examples #' s_proportion_diff( #' df = subset(dta, grp == "A"), diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index 16829fbdd2..c101d08cad 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -236,4 +236,6 @@ a_proportion_diff( } \seealso{ \code{\link[=d_proportion_diff]{d_proportion_diff()}} + +\code{\link[=h_prepare_2x2_table]{h_prepare_2x2_table()}} } From 62888afa65cf5f572b9b19e8a2b3a15b7b00d408 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 17:27:02 +0200 Subject: [PATCH 26/40] Added better assertions for s_proportion_diff() and s_test_proportion_diff. --- R/prop_diff.R | 47 +++++++++++++++++++++++++++------------------- R/prop_diff_test.R | 33 +++++++++++++++++++++++++------- 2 files changed, 54 insertions(+), 26 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 3423a38a99..661080afe9 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -97,31 +97,40 @@ s_proportion_diff <- function(df, weights_method = "cmh", val = TRUE, ...) { - checkmate::assert_list(variables) + checkmate::assert_data_frame(df) + checkmate::assert_string(.var) + checkmate::assert_subset(.var, colnames(df), empty.ok = FALSE) + checkmate::assert_data_frame(.ref_group, null.ok = TRUE) + checkmate::assert_flag(.in_ref_col, null.ok = TRUE) + checkmate::assert_list(variables, null.ok = TRUE) + assert_proportion_value(conf_level) + checkmate::assert_character(method) + checkmate::assert_atomic(val) method <- match.arg(method) - strat_anl_methods <- c( - "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" - ) - - if (is.null(variables$strata) && checkmate::test_subset(method, strat_anl_methods)) { - stop(paste( - "When performing an unstratified analysis, methods", - "'cmh', 'cmh_sato', 'cmh_mn', 'strat_newcombe', and 'strat_newcombecc' are not", - "permitted. Please choose a different method." - )) - } - - if (!is.null(variables$strata) && method == "uncond_exact_diff") { - stop( - "Method 'uncond_exact_diff' is only available for unstratified analyses. Please choose a different method." - ) - } - if (is.null(.in_ref_col) || .in_ref_col) { y <- list(diff = numeric(), diff_ci = numeric()) } else { + checkmate::assert_false(is.null(.ref_group)) + + is_stratified_method <- method %in% c( + "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" + ) + + if (is_stratified_method && is.null(variables$strata)) { + stop(paste0( + "Method '", method, "' requires stratified data; ", "`variables$strata` must not be NULL." + )) + } + + if (!is_stratified_method && !is.null(variables$strata)) { + stop(paste0( + "Method '", method, "' is an unstratified method, but `variables$strata` was provided. ", + "You cannot specify a stratification variable with this method." + )) + } + prepared <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, strata_vars = variables$strata, diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 3df345313a..3016ad7d30 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -62,22 +62,41 @@ s_test_proportion_diff <- function(df, alternative = c("two.sided", "less", "greater"), val = TRUE, ...) { + checkmate::assert_data_frame(df) + checkmate::assert_string(.var) + checkmate::assert_subset(.var, colnames(df), empty.ok = FALSE) + checkmate::assert_data_frame(.ref_group, null.ok = TRUE) + checkmate::assert_flag(.in_ref_col, null.ok = TRUE) + checkmate::assert_list(variables, null.ok = TRUE) + checkmate::assert_character(method) + checkmate::assert_subset(alternative, c("two.sided", "less", "greater"), empty.ok = FALSE) + checkmate::assert_atomic(val) + method <- match.arg(method) pval <- if (is.null(.in_ref_col) || .in_ref_col) { numeric() } else { - strata_vars <- if (method %in% c("cmh", "cmh_sato", "cmh_wh")) { - checkmate::assert_list(variables) - checkmate::assert_false(is.null(variables$strata)) - variables$strata - } else { - NULL + checkmate::assert_false(is.null(.ref_group)) + + is_stratified_test <- method %in% c("cmh", "cmh_sato", "cmh_wh") + + if (is_stratified_test && is.null(variables$strata)) { + stop(paste0( + "Test '", method, "' requires stratified data; ", "`variables$strata` must not be NULL." + )) + } + + if (!is_stratified_test && !is.null(variables$strata)) { + stop(paste0( + "Test '", method, "' is an unstratified test, but `variables$strata` was provided. ", + "You cannot specify a stratification variable with this method." + )) } prepared <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, - strata_vars = strata_vars, + strata_vars = variables$strata, complete_cases = TRUE ) tbl <- prepared$tbl From 73b8955744864f33ad886ba2cef916c30edb48b5 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 17:35:54 +0200 Subject: [PATCH 27/40] Added unit tests for new some assertions for s_test_proportion_diff() and s_proportion_diff() --- tests/testthat/test-prop_diff.R | 42 ++++++++++++++++++++++ tests/testthat/test-test_proportion_diff.R | 42 ++++++++++++++++++++++ 2 files changed, 84 insertions(+) diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index bd0e7ef33e..3e613ed6b9 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -738,6 +738,48 @@ test_that("s_proportion_diff supports a custom response value", { expect_identical(attr(result$se_diff, "label"), "Standard Error of Difference in Response rate (%)") }) +test_that("s_proportion_diff errors when stratified method is chosen without strata", { + dta <- data.frame( + rsp = sample(c("Y", "N"), 10, TRUE), + grp = factor(rep(c("A", "B"), each = 5)), + strata = factor(c("V", "W", "X", "Y", "Z")) + ) + + expect_error( + result <- s_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = NULL, + method = "cmh", + val = "Y" + ), + "strata" + ) +}) + +test_that("s_proportion_diff errors when strata are provided with a non-stratified method", { + dta <- data.frame( + rsp = sample(c("Y", "N"), 10, TRUE), + grp = factor(rep(c("A", "B"), each = 5)), + strata = factor(c("V", "W", "X", "Y", "Z")) + ) + + expect_error( + result <- s_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = list(strata = "strata"), + method = "uncond_exact_diff", + val = "Y" + ), + "strata" + ) +}) + testthat::test_that("check_diff_prop_ci is silent with healthy input", { # "Mid" case: 3/4 respond in group A, 1/2 respond in group B. rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index 3565685035..e98dbd07f3 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -358,6 +358,48 @@ test_that("s_test_proportion_diff supports a custom response value", { expect_equal(result, list(pval = expected), tolerance = 1e-3) }) +test_that("s_test_proportion_diff errors when stratified method is chosen without strata", { + dta <- data.frame( + rsp = sample(c("Y", "N"), 10, TRUE), + grp = factor(rep(c("A", "B"), each = 5)), + strata = factor(c("V", "W", "X", "Y", "Z")) + ) + + expect_error( + result <- s_test_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = NULL, + method = "cmh", + val = "Y" + ), + "strata" + ) +}) + +test_that("s_test_proportion_diff errors when strata are provided with a non-stratified method", { + dta <- data.frame( + rsp = sample(c("Y", "N"), 10, TRUE), + grp = factor(rep(c("A", "B"), each = 5)), + strata = factor(c("V", "W", "X", "Y", "Z")) + ) + + expect_error( + result <- s_test_proportion_diff( + df = subset(dta, grp == "A"), + .var = "rsp", + .ref_group = subset(dta, grp == "B"), + .in_ref_col = FALSE, + variables = list(strata = "strata"), + method = "fisher", + val = "Y" + ), + "strata" + ) +}) + testthat::test_that("test_proportion_diff returns right result", { set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( From b4c675a49e2887d8ccd694506a5daa316af354ed Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 17:50:48 +0200 Subject: [PATCH 28/40] Minor unit test update for s_proportion_diff(). --- tests/testthat/test-prop_diff.R | 6 +++--- tests/testthat/test-test_proportion_diff.R | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index 3e613ed6b9..692a4ef02e 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -706,7 +706,7 @@ testthat::test_that("s_proportion_diff rejects uncond_exact_diff with strata", { conf_level = 0.95, method = "uncond_exact_diff" ), - "only available for unstratified analyses" + "strat" ) }) @@ -755,7 +755,7 @@ test_that("s_proportion_diff errors when stratified method is chosen without str method = "cmh", val = "Y" ), - "strata" + "strat" ) }) @@ -776,7 +776,7 @@ test_that("s_proportion_diff errors when strata are provided with a non-stratifi method = "uncond_exact_diff", val = "Y" ), - "strata" + "strat" ) }) diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index e98dbd07f3..27e9a384de 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -375,7 +375,7 @@ test_that("s_test_proportion_diff errors when stratified method is chosen withou method = "cmh", val = "Y" ), - "strata" + "strat" ) }) @@ -396,7 +396,7 @@ test_that("s_test_proportion_diff errors when strata are provided with a non-str method = "fisher", val = "Y" ), - "strata" + "strat" ) }) From c713d24f87eae2c76bc2a91552fc1396b7622e36 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 23:08:23 +0200 Subject: [PATCH 29/40] Added new assert_stratification_compatibility() function (with unit tests). Added unit test for assert_proportion_data(). --- R/prop_diff.R | 20 +--- R/prop_diff_test.R | 20 +--- R/utils_checkmate.R | 45 +++++++ man/assertions.Rd | 19 ++- tests/testthat/test-prop_diff.R | 22 ---- tests/testthat/test-utils_checkmate.R | 163 ++++++++++++++++++++++++++ 6 files changed, 233 insertions(+), 56 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 661080afe9..2abb62ea78 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -113,24 +113,12 @@ s_proportion_diff <- function(df, y <- list(diff = numeric(), diff_ci = numeric()) } else { checkmate::assert_false(is.null(.ref_group)) - - is_stratified_method <- method %in% c( - "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" + assert_stratification_compatibility( + method = method, + stratified_methods = c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc"), + strata = variables$strata ) - if (is_stratified_method && is.null(variables$strata)) { - stop(paste0( - "Method '", method, "' requires stratified data; ", "`variables$strata` must not be NULL." - )) - } - - if (!is_stratified_method && !is.null(variables$strata)) { - stop(paste0( - "Method '", method, "' is an unstratified method, but `variables$strata` was provided. ", - "You cannot specify a stratification variable with this method." - )) - } - prepared <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, strata_vars = variables$strata, diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 3016ad7d30..11fbc686b5 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -78,21 +78,11 @@ s_test_proportion_diff <- function(df, numeric() } else { checkmate::assert_false(is.null(.ref_group)) - - is_stratified_test <- method %in% c("cmh", "cmh_sato", "cmh_wh") - - if (is_stratified_test && is.null(variables$strata)) { - stop(paste0( - "Test '", method, "' requires stratified data; ", "`variables$strata` must not be NULL." - )) - } - - if (!is_stratified_test && !is.null(variables$strata)) { - stop(paste0( - "Test '", method, "' is an unstratified test, but `variables$strata` was provided. ", - "You cannot specify a stratification variable with this method." - )) - } + assert_stratification_compatibility( + method = method, + stratified_methods = c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc"), + strata = variables$strata + ) prepared <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, diff --git a/R/utils_checkmate.R b/R/utils_checkmate.R index 76e974d996..d2bae31f21 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -216,3 +216,48 @@ assert_proportion_data <- function(rsp, grp, strata = NULL) { checkmate::assert_factor(strata, len = length(rsp), any.missing = FALSE, null.ok = TRUE) invisible() } + +#' @describeIn assertions +#' Assert compatibility between a method and stratification. +#' Checks that the selected method is compatible with the presence or absence +#' of stratification variables. Methods included in `stratified_methods` require +#' at least one variable defining the strata, while unstratified methods must +#' not use stratification variables. +#' +#' @param method (`character(1)`)\cr Specifies the statistical method. +#' @param stratified_methods (`character`)\cr Names of the methods that require +#' stratified data. +#' @param strata (`character` or `NULL`)\cr Names of the variables defining the +#' strata, or `NULL` if no stratification is used. +#' +#' @keywords internal +assert_stratification_compatibility <- function(method, stratified_methods, strata) { + checkmate::assert_string(method) + checkmate::assert_character(stratified_methods) + checkmate::assert_character(strata, null.ok = TRUE) + + is_stratified <- method %in% stratified_methods + is_strata_provided <- !is.null(strata) + + # Stratified method. + if (is_stratified && !is_strata_provided) { + stop( + paste0( + "Method '", method, + "' requires stratified data; the variable defining the strata must not be NULL." + ) + ) + } + + # Unstratified method. + if (!is_stratified && is_strata_provided) { + stop( + paste0( + "Method '", method, + "' is an unstratified method, but a variable defining the strata was specified. ", + "You cannot specify a stratification variable with this method." + ) + ) + } + invisible() +} diff --git a/man/assertions.Rd b/man/assertions.Rd index 799767a4fe..40bf2536fb 100644 --- a/man/assertions.Rd +++ b/man/assertions.Rd @@ -8,6 +8,7 @@ \alias{assert_df_with_factors} \alias{assert_proportion_value} \alias{assert_proportion_data} +\alias{assert_stratification_compatibility} \title{Additional assertions to use with \code{checkmate}} \usage{ assert_list_of_variables(x, .var.name = checkmate::vname(x), add = NULL) @@ -46,6 +47,8 @@ assert_df_with_factors( assert_proportion_value(x, include_boundaries = FALSE) assert_proportion_data(rsp, grp, strata = NULL) + +assert_stratification_compatibility(method, stratified_methods, strata) } \arguments{ \item{x}{(\code{any})\cr object to test.} @@ -99,9 +102,13 @@ Assigns each observation to one of two groups, such as a reference and a treatment group. Must have exactly two levels and the same length as \code{rsp}. Missing values are not allowed.} -\item{strata}{(\code{factor} or \code{NULL})\cr -Defines the stratification variable. If not \code{NULL}, it must have the same -length as \code{rsp} and must not contain any missing values.} +\item{strata}{(\code{character} or \code{NULL})\cr Names of the variables defining the +strata, or \code{NULL} if no stratification is used.} + +\item{method}{(\code{character(1)})\cr Specifies the statistical method.} + +\item{stratified_methods}{(\code{character})\cr Names of the methods that require +stratified data.} } \value{ Nothing if assertion passes, otherwise prints the error message. @@ -132,6 +139,12 @@ trim \code{NA} levels out of the vector list itself. \item \code{assert_proportion_data()}: Validates the data required for a proportion analysis, including responder status, group assignment, and optional stratification. +\item \code{assert_stratification_compatibility()}: Assert compatibility between a method and stratification. +Checks that the selected method is compatible with the presence or absence +of stratification variables. Methods included in \code{stratified_methods} require +at least one variable defining the strata, while unstratified methods must +not use stratification variables. + }} \examples{ x <- data.frame( diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index 692a4ef02e..717563adfa 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -688,28 +688,6 @@ testthat::test_that("s_proportion_diff works with uncond_exact_diff", { expect_identical(attr(result$diff_ci, "label"), "95% CI (Unconditional exact)") }) -testthat::test_that("s_proportion_diff rejects uncond_exact_diff with strata", { - dta <- data.frame( - rsp = c(TRUE, FALSE, TRUE, FALSE), - grp = c("A", "A", "B", "B"), - strata = c("S1", "S2", "S1", "S2"), - stringsAsFactors = FALSE - ) - - expect_error( - s_proportion_diff( - df = subset(dta, grp == "A"), - .var = "rsp", - .ref_group = subset(dta, grp == "B"), - .in_ref_col = FALSE, - variables = list(strata = "strata"), - conf_level = 0.95, - method = "uncond_exact_diff" - ), - "strat" - ) -}) - test_that("s_proportion_diff supports a custom response value", { set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( diff --git a/tests/testthat/test-utils_checkmate.R b/tests/testthat/test-utils_checkmate.R index d7a8be9c6d..c36569d1b2 100644 --- a/tests/testthat/test-utils_checkmate.R +++ b/tests/testthat/test-utils_checkmate.R @@ -148,3 +148,166 @@ testthat::test_that("assert_proportion_value fails with wrong input", { testthat::expect_error(assert_proportion_value("abc")) testthat::expect_error(assert_proportion_value(c(0.4, 0.3))) }) + +# assert_proportion_data ---- + +test_that("assert_proportion_data is silent with healthy input", { + rsp <- c(TRUE, FALSE) + grp <- factor(c("g1", "g2")) + + expect_silent( + assert_proportion_data(rsp, grp, factor(c("s1", "s2"))) + ) + expect_silent( + assert_proportion_data(rsp, grp, factor(c("g1", "g2"))) + ) + expect_silent( + assert_proportion_data( + FALSE, factor("g1", levels = c("g1", "g2")), factor("s1", levels = c("s1", "s2")) + ) + ) + expect_silent( + assert_proportion_data(TRUE, factor("g1", levels = c("g1", "g2")), NULL) + ) + expect_silent( + assert_proportion_data(rsp, grp, factor(c("s1", "s1"))) + ) + expect_silent( + assert_proportion_data(rsp, grp, factor(c("s1", "s1"), levels = c("s1", "s2", "s3"))) + ) +}) + +test_that("assert_proportion_data fails with wrong input (rsp)", { + rsp <- c(TRUE, FALSE) + grp <- factor(c("g1", "g2")) + strata <- factor(c("s1", "s2")) + + expect_error( + assert_proportion_data(NULL, factor(levels = c("g1", "g2")), factor(levels = c("s1", "s2"))) + ) + expect_error( + assert_proportion_data(c("Y", "N"), grp, strata) + ) + expect_error( + assert_proportion_data(c(TRUE, NA), grp, strata) + ) + expect_error( + assert_proportion_data(c("Y", "N"), grp) + ) +}) + +test_that("assert_proportion_data fails with wrong input (grp)", { + rsp <- c(TRUE, FALSE) + grp <- factor(c("g1", "g2")) + strata <- factor(c("s1", "s2")) + + expect_error( + assert_proportion_data(logical(), NULL, factor(levels = c("s1", "s2"))) + ) + expect_error( + assert_proportion_data(rsp, c("g1", "g2"), strata) + ) + expect_error( + assert_proportion_data(rsp, factor("g1", levels = c("g1", "g2")), strata) + ) + expect_error( + assert_proportion_data(rsp, factor(c("g1", "g2", "g2", "g2"), levels = c("g1", "g2")), strata) + ) + expect_error( + assert_proportion_data(rsp, factor(c("g1", NA), levels = c("g1", "g2")), strata) + ) + expect_error( + assert_proportion_data(rsp, factor(c("g1", "g1")), strata) + ) + expect_error( + assert_proportion_data(TRUE, factor("g1"), factor("s1", levels = c("s1", "s2"))) + ) + expect_error( + assert_proportion_data(rsp, factor(c("g1", "g2"), levels = c("g1", "g2", "g3")), strata) + ) +}) + +test_that("assert_proportion_data fails with wrong input (strata)", { + rsp <- c(TRUE, FALSE) + grp <- factor(c("g1", "g2")) + strata <- factor(c("s1", "s2")) + + expect_error( + assert_proportion_data(rsp, grp, c("s1", "s2")) + ) + expect_error( + assert_proportion_data(rsp, grp, factor("s1", levels = c("s1", "s2"))) + ) + expect_error( + assert_proportion_data(rsp, grp, factor(c("s1", "s2", "s2", "s2"), levels = c("s1", "s2"))) + ) + expect_error( + assert_proportion_data(rsp, grp, factor(c("s1", NA), levels = c("s1", "s2"))) + ) +}) + +# assert_stratification_compatibility ---- + +test_that("assert_stratification_compatibility is silent with healthy input", { + expect_silent( + assert_stratification_compatibility("cmh", c("cmh", "cmh_sato"), "Region1") + ) + expect_silent( + assert_stratification_compatibility("fisher", c("cmh", "cmh_sato"), NULL) + ) +}) + +test_that("assert_stratification_compatibility fails with wrong input", { + # method + expect_error( + assert_stratification_compatibility(NULL, c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility(character(), c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility("", c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility(TRUE, c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility(1L, c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility(c("cmh", "fisher"), c("cmh", "cmh_sato"), "Region1") + ) + # stratified_methods + expect_error( + assert_stratification_compatibility("fisher", NULL, "Region1") + ) + expect_error( + assert_stratification_compatibility("fisher", character(), "Region1") + ) + expect_error( + assert_stratification_compatibility("fisher", "", "Region1") + ) + expect_error( + assert_stratification_compatibility("fisher", TRUE, "Region1") + ) + expect_error( + assert_stratification_compatibility("fisher", 1L, "Region1") + ) + # strata + expect_error( + assert_stratification_compatibility("fisher", c("cmh", "cmh_sato"), "") + ) + expect_error( + assert_stratification_compatibility("fisher", c("cmh", "cmh_sato"), FALSE) + ) + expect_error( + assert_stratification_compatibility("fisher", c("cmh", "cmh_sato"), 2) + ) + # combination + expect_error( + assert_stratification_compatibility("fisher", c("cmh", "cmh_sato"), "Region1") + ) + expect_error( + assert_stratification_compatibility("cmh", c("cmh", "cmh_sato"), NULL) + ) +}) From 08694b29873b515b6ca015c462ce8947d394f3ad Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 23:13:10 +0200 Subject: [PATCH 30/40] s_proportion_diff() cosmetic update. --- R/prop_diff.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 2abb62ea78..c8c72914cd 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -92,7 +92,8 @@ s_proportion_diff <- function(df, method = c( "waldcc", "wald", "cmh", "cmh_sato", "cmh_mn", "ha", "newcombe", "newcombecc", - "strat_newcombe", "strat_newcombecc", "uncond_exact_diff" + "strat_newcombe", "strat_newcombecc", + "uncond_exact_diff" ), weights_method = "cmh", val = TRUE, From 37cd5371858c10f0dd8cddc72e23d970449ce7f3 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 9 Sep 2026 23:30:32 +0200 Subject: [PATCH 31/40] s_test_proportion_diff() important assertion update. --- R/prop_diff_test.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 11fbc686b5..6851703a4f 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -80,7 +80,7 @@ s_test_proportion_diff <- function(df, checkmate::assert_false(is.null(.ref_group)) assert_stratification_compatibility( method = method, - stratified_methods = c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc"), + stratified_methods = c("cmh", "cmh_sato", "cmh_wh"), strata = variables$strata ) From ee1e8924f11797b074de789ef80b91d0fbedd797 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 00:00:48 +0200 Subject: [PATCH 32/40] Cosmetic update h_prepare_2x2_table(). --- R/prop_diff.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/prop_diff.R b/R/prop_diff.R index c8c72914cd..532ff5943c 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -599,6 +599,7 @@ h_prepare_2x2_table <- function(df, } rsp_logical <- rsp == val + assert_proportion_data(rsp = rsp_logical, grp = grp, strata = strata) # Build contingency table. From 88a3bc6b1291bf1e2b1e790961a0f4cba70bcdd8 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 09:53:53 +0200 Subject: [PATCH 33/40] Solves issue #1521. --- R/prop_diff.R | 28 ++++++++++++---------------- man/h_prop_diff.Rd | 7 +++++-- man/prop_diff.Rd | 11 +++++++---- 3 files changed, 24 insertions(+), 22 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 532ff5943c..21a8b2c33d 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -95,7 +95,7 @@ s_proportion_diff <- function(df, "strat_newcombe", "strat_newcombecc", "uncond_exact_diff" ), - weights_method = "cmh", + weights_method = c("cmh", "wilson_h"), val = TRUE, ...) { checkmate::assert_data_frame(df) @@ -106,6 +106,7 @@ s_proportion_diff <- function(df, checkmate::assert_list(variables, null.ok = TRUE) assert_proportion_value(conf_level) checkmate::assert_character(method) + checkmate::assert_character(weights_method) checkmate::assert_atomic(val) method <- match.arg(method) @@ -129,13 +130,6 @@ s_proportion_diff <- function(df, grp <- prepared$grp strata <- prepared$strata - # Defining the std way to calculate weights for strat_newcombe. - weights_method <- if (!is.null(variables$weights_method)) { - variables$weights_method - } else { - "cmh" - } - cmh_stats <- c("diff", "diff_ci", "se_diff") y <- switch(method, "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), @@ -299,7 +293,7 @@ estimate_proportion_diff <- function(lyt, "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc", "uncond_exact_diff" ), - weights_method = "cmh", + weights_method = c("cmh", "wilson_h"), var_labels = vars, na_str = default_na_str(), nested = TRUE, @@ -1071,8 +1065,11 @@ h_miettinen_nurminen_var_est <- function(n1, n2, x1, x2, diff_par) { #' (see [prop_diff_cmh()]). #' #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. -#' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` -#' and directs the way weights are estimated. +#' @param weights_method (`string`)\cr method used to estimate the weights for +#' stratified Newcombe method. +#' Must be either `"cmh"` or `"wilson_h"`. `"cmh"` uses weights derived from +#' the Cochran-Mantel-Haenszel method, while `"wilson_h"` uses the heuristic +#' weights proposed by [prop_strat_wilson()]. #' #' @examples #' # Stratified Newcombe confidence interval @@ -1117,18 +1114,17 @@ prop_diff_strat_nc <- function(rsp, warning("Less than 5 observations in some strata.") } - rsp_by_grp <- split(rsp, f = grp) - strata_by_grp <- split(strata, f = grp) - # Finding the weights - weights <- if (identical(weights_method, "cmh")) { + weights <- if (weights_method == "cmh") { prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights - } else if (identical(weights_method, "wilson_h")) { + } else if (weights_method == "wilson_h") { prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights } weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 # Calculating lower (`l`) and upper (`u`) confidence bounds per group. + rsp_by_grp <- split(rsp, f = grp) + strata_by_grp <- split(strata, f = grp) strat_wilson_by_grp <- Map( prop_strat_wilson, rsp = rsp_by_grp, diff --git a/man/h_prop_diff.Rd b/man/h_prop_diff.Rd index 343ee80f90..8305fce438 100644 --- a/man/h_prop_diff.Rd +++ b/man/h_prop_diff.Rd @@ -64,8 +64,11 @@ group, response, and strata. The second dimension (response) should have names \item{strata}{(\code{factor})\cr variable with one level per stratum and same length as \code{rsp}.} -\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} -and directs the way weights are estimated.} +\item{weights_method}{(\code{string})\cr method used to estimate the weights for +stratified Newcombe method. +Must be either \code{"cmh"} or \code{"wilson_h"}. \code{"cmh"} uses weights derived from +the Cochran-Mantel-Haenszel method, while \code{"wilson_h"} uses the heuristic +weights proposed by \code{\link[=prop_strat_wilson]{prop_strat_wilson()}}.} } \value{ A named \code{list} of elements \code{diff} (proportion difference) and \code{diff_ci} diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index c101d08cad..0cbc70c10a 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -14,7 +14,7 @@ estimate_proportion_diff( conf_level = 0.95, method = c("waldcc", "wald", "cmh", "cmh_sato", "cmh_mn", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc", "uncond_exact_diff"), - weights_method = "cmh", + weights_method = c("cmh", "wilson_h"), var_labels = vars, na_str = default_na_str(), nested = TRUE, @@ -39,7 +39,7 @@ s_proportion_diff( conf_level = 0.95, method = c("waldcc", "wald", "cmh", "cmh_sato", "cmh_mn", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc", "uncond_exact_diff"), - weights_method = "cmh", + weights_method = c("cmh", "wilson_h"), val = TRUE, ... ) @@ -65,8 +65,11 @@ a_proportion_diff( \item{method}{(\code{string})\cr the method used for the confidence interval estimation.} -\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} -and directs the way weights are estimated.} +\item{weights_method}{(\code{string})\cr method used to estimate the weights for +stratified Newcombe method. +Must be either \code{"cmh"} or \code{"wilson_h"}. \code{"cmh"} uses weights derived from +the Cochran-Mantel-Haenszel method, while \code{"wilson_h"} uses the heuristic +weights proposed by \code{\link[=prop_strat_wilson]{prop_strat_wilson()}}.} \item{var_labels}{(\code{character})\cr variable labels.} From 177a5829036ed017d5c0052e775b42bfbc2d5aa4 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 09:59:21 +0200 Subject: [PATCH 34/40] Cosmetic update to s_proportion_diff(). --- R/prop_diff.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 21a8b2c33d..c70be44534 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -117,7 +117,9 @@ s_proportion_diff <- function(df, checkmate::assert_false(is.null(.ref_group)) assert_stratification_compatibility( method = method, - stratified_methods = c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc"), + stratified_methods = c( + "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" + ), strata = variables$strata ) From 69b3ae608ea0eefa5533f1f498a1f22177db11ca Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 10:03:32 +0200 Subject: [PATCH 35/40] Cosmetic chnage for s_test_proportion_diff(). --- R/prop_diff_test.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 6851703a4f..719ea6fc46 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -58,7 +58,10 @@ s_test_proportion_diff <- function(df, .ref_group = NULL, .in_ref_col = NULL, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh", "cmh_sato", "cmh_wh"), + method = c( + "chisq", "schouten", "fisher", + "cmh", "cmh_sato", "cmh_wh" + ), alternative = c("two.sided", "less", "greater"), val = TRUE, ...) { From ce07a3b043bf6fba765f50e283dbda7346675446 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 13:20:02 +0200 Subject: [PATCH 36/40] Adressing PR review about weights_method. --- NEWS.md | 4 ++++ R/prop_diff.R | 1 - R/prop_diff_test.R | 1 - tests/testthat/test-prop_diff.R | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4af8a18dbd..b6a66feb95 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,10 @@ * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected rows from the forest plot before plotting. (#1498) +### Bug Fixes +* Fixed an issue in `s_proportion_diff()` where the `weights_method` argument + was ignored. (#1521) + ### Miscellaneous * Added the `val` argument and refactored `s_proportion_diff()` so that it uses the new function `h_prepare_2x2_table()`. diff --git a/R/prop_diff.R b/R/prop_diff.R index c70be44534..97c370f32b 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -105,7 +105,6 @@ s_proportion_diff <- function(df, checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) assert_proportion_value(conf_level) - checkmate::assert_character(method) checkmate::assert_character(weights_method) checkmate::assert_atomic(val) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 719ea6fc46..4f49eeb382 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -71,7 +71,6 @@ s_test_proportion_diff <- function(df, checkmate::assert_data_frame(.ref_group, null.ok = TRUE) checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) - checkmate::assert_character(method) checkmate::assert_subset(alternative, c("two.sided", "less", "greater"), empty.ok = FALSE) checkmate::assert_atomic(val) diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index 717563adfa..b1244e8c64 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -737,7 +737,7 @@ test_that("s_proportion_diff errors when stratified method is chosen without str ) }) -test_that("s_proportion_diff errors when strata are provided with a non-stratified method", { +test_that("s_proportion_diff errors when strata are provided with the non-stratified method `uncond_exact_diff`", { dta <- data.frame( rsp = sample(c("Y", "N"), 10, TRUE), grp = factor(rep(c("A", "B"), each = 5)), From 22ed590b2381a9d5c395dcf8c65c5780be08e24e Mon Sep 17 00:00:00 2001 From: Wojtek Date: Thu, 10 Sep 2026 16:02:59 +0200 Subject: [PATCH 37/40] Removed assertions for some variables that are passed untouched into downstream functions. --- R/prop_diff.R | 2 -- R/prop_diff_test.R | 1 - 2 files changed, 3 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 97c370f32b..67e2c5d0c5 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -104,8 +104,6 @@ s_proportion_diff <- function(df, checkmate::assert_data_frame(.ref_group, null.ok = TRUE) checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) - assert_proportion_value(conf_level) - checkmate::assert_character(weights_method) checkmate::assert_atomic(val) method <- match.arg(method) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 4f49eeb382..a2acd7c974 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -71,7 +71,6 @@ s_test_proportion_diff <- function(df, checkmate::assert_data_frame(.ref_group, null.ok = TRUE) checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) - checkmate::assert_subset(alternative, c("two.sided", "less", "greater"), empty.ok = FALSE) checkmate::assert_atomic(val) method <- match.arg(method) From d246751875bb0cf7aa04d76ed57a522ebb9ac0d1 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Tue, 15 Sep 2026 09:49:46 +0200 Subject: [PATCH 38/40] Renamed 2 variables in s_test_proportion_diff() and s_proportion_diff(). --- R/prop_diff.R | 8 ++++---- R/prop_diff_test.R | 16 ++++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 10562f6513..321737c9d7 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -120,14 +120,14 @@ s_proportion_diff <- function(df, strata = variables$strata ) - prepared <- h_prepare_2x2_table( + rsp_list <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, strata_vars = variables$strata, complete_cases = TRUE ) - rsp <- prepared$rsp - grp <- prepared$grp - strata <- prepared$strata + rsp <- rsp_list$rsp + grp <- rsp_list$grp + strata <- rsp_list$strata cmh_stats <- c("diff", "diff_ci", "se_diff") y <- switch(method, diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index fc2418a753..b935637574 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -85,20 +85,20 @@ s_test_proportion_diff <- function(df, strata = variables$strata ) - prepared <- h_prepare_2x2_table( + rsp_list <- h_prepare_2x2_table( df = df, df_ref = .ref_group, var = .var, val = val, strata_vars = variables$strata, complete_cases = TRUE ) - tbl <- prepared$tbl + rsp_tbl <- rsp_list$tbl switch(method, - cmh = prop_cmh(tbl, alternative = alternative), - cmh_sato = prop_cmh(tbl, alternative = alternative, diff_se = "sato"), - cmh_wh = prop_cmh(tbl, alternative = alternative, transform = "wilson_hilferty"), - fisher = prop_fisher(tbl, alternative = alternative), - chisq = prop_chisq(tbl, alternative = alternative), - schouten = prop_schouten(tbl, alternative = alternative) + cmh = prop_cmh(rsp_tbl, alternative = alternative), + cmh_sato = prop_cmh(rsp_tbl, alternative = alternative, diff_se = "sato"), + cmh_wh = prop_cmh(rsp_tbl, alternative = alternative, transform = "wilson_hilferty"), + fisher = prop_fisher(rsp_tbl, alternative = alternative), + chisq = prop_chisq(rsp_tbl, alternative = alternative), + schouten = prop_schouten(rsp_tbl, alternative = alternative) ) } From 0e3bf2ce4a943e36558877efe81bb3aac50d79ff Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 16 Sep 2026 12:39:32 +0200 Subject: [PATCH 39/40] Adressed PR review suggestions for s_test_proportion_diff(), s_proportion_diff() and related helpers. --- NEWS.md | 10 +++++++++- R/prop_diff.R | 5 ++++- R/prop_diff_test.R | 2 +- R/utils_checkmate.R | 8 ++++---- _pkgdown.yml | 1 - man/assertions.Rd | 10 +++++++--- 6 files changed, 25 insertions(+), 11 deletions(-) diff --git a/NEWS.md b/NEWS.md index ca7b74b37a..0d9c6706da 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,9 +18,17 @@ ### Bug Fixes * Fixed an issue in `s_proportion_diff()` where the `weights_method` argument - was ignored. (#1521) + was ignored. The `variables` argument, if supplied, can now only contain the + `strata` element. Other elements, including `weights_method`, are no longer + supported. Previously, `variables$weights_method` could unintentionally + override the `weights_method` argument due to a bug. (#1521) ### Miscellaneous +* Updated `s_proportion_diff()` and `s_test_proportion_diff()` so that strata + variables, if supplied, must be factors. Character-type strata variables are + no longer supported. (#1514) +* Updated `s_proportion_diff()` and `s_test_proportion_diff()` to throw an error + when strata variable(s) are provided but an unstratified method is chosen. (#1514) * Added the `val` argument and refactored `s_proportion_diff()` so that it uses the new function `h_prepare_2x2_table()`. * Added the `val` argument and refactored `s_test_proportion_diff()` so that it diff --git a/R/prop_diff.R b/R/prop_diff.R index 321737c9d7..1157a1af05 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -104,6 +104,9 @@ s_proportion_diff <- function(df, checkmate::assert_data_frame(.ref_group, null.ok = TRUE) checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) + if (!is.null(variables)) { + checkmate::assert_set_equal(names(variables), "strata") + } checkmate::assert_atomic(val) method <- match.arg(method) @@ -117,7 +120,7 @@ s_proportion_diff <- function(df, stratified_methods = c( "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" ), - strata = variables$strata + strata_vars = variables$strata ) rsp_list <- h_prepare_2x2_table( diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index b935637574..86129e9aac 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -82,7 +82,7 @@ s_test_proportion_diff <- function(df, assert_stratification_compatibility( method = method, stratified_methods = c("cmh", "cmh_sato", "cmh_wh"), - strata = variables$strata + strata_vars = variables$strata ) rsp_list <- h_prepare_2x2_table( diff --git a/R/utils_checkmate.R b/R/utils_checkmate.R index d2bae31f21..a51c8661c8 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -227,17 +227,17 @@ assert_proportion_data <- function(rsp, grp, strata = NULL) { #' @param method (`character(1)`)\cr Specifies the statistical method. #' @param stratified_methods (`character`)\cr Names of the methods that require #' stratified data. -#' @param strata (`character` or `NULL`)\cr Names of the variables defining the +#' @param strata_vars (`character` or `NULL`)\cr Names of the variables defining the #' strata, or `NULL` if no stratification is used. #' #' @keywords internal -assert_stratification_compatibility <- function(method, stratified_methods, strata) { +assert_stratification_compatibility <- function(method, stratified_methods, strata_vars) { checkmate::assert_string(method) checkmate::assert_character(stratified_methods) - checkmate::assert_character(strata, null.ok = TRUE) + checkmate::assert_character(strata_vars, null.ok = TRUE) is_stratified <- method %in% stratified_methods - is_strata_provided <- !is.null(strata) + is_strata_provided <- !is.null(strata_vars) # Stratified method. if (is_stratified && !is_strata_provided) { diff --git a/_pkgdown.yml b/_pkgdown.yml index a578424f12..084bb388c8 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -113,7 +113,6 @@ reference: - -h_xticks - -prop_diff - check_diff_prop_ci - - assert_proportion_data - h_prepare_2x2_table - title: rtables Helper Functions diff --git a/man/assertions.Rd b/man/assertions.Rd index 40bf2536fb..d978df41f7 100644 --- a/man/assertions.Rd +++ b/man/assertions.Rd @@ -48,7 +48,7 @@ assert_proportion_value(x, include_boundaries = FALSE) assert_proportion_data(rsp, grp, strata = NULL) -assert_stratification_compatibility(method, stratified_methods, strata) +assert_stratification_compatibility(method, stratified_methods, strata_vars) } \arguments{ \item{x}{(\code{any})\cr object to test.} @@ -102,13 +102,17 @@ Assigns each observation to one of two groups, such as a reference and a treatment group. Must have exactly two levels and the same length as \code{rsp}. Missing values are not allowed.} -\item{strata}{(\code{character} or \code{NULL})\cr Names of the variables defining the -strata, or \code{NULL} if no stratification is used.} +\item{strata}{(\code{factor} or \code{NULL})\cr +Defines the stratification variable. If not \code{NULL}, it must have the same +length as \code{rsp} and must not contain any missing values.} \item{method}{(\code{character(1)})\cr Specifies the statistical method.} \item{stratified_methods}{(\code{character})\cr Names of the methods that require stratified data.} + +\item{strata_vars}{(\code{character} or \code{NULL})\cr Names of the variables defining the +strata, or \code{NULL} if no stratification is used.} } \value{ Nothing if assertion passes, otherwise prints the error message. From 463eaeacfc21e58d8f0256b713c21b32c4b87c41 Mon Sep 17 00:00:00 2001 From: Wojtek Date: Wed, 16 Sep 2026 22:37:37 +0200 Subject: [PATCH 40/40] added assertion for variables in s_test_proportion_diff(). --- R/prop_diff_test.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 948f6a37f9..c208256e49 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -71,6 +71,9 @@ s_test_proportion_diff <- function(df, checkmate::assert_data_frame(.ref_group, null.ok = TRUE) checkmate::assert_flag(.in_ref_col, null.ok = TRUE) checkmate::assert_list(variables, null.ok = TRUE) + if (!is.null(variables)) { + checkmate::assert_set_equal(names(variables), "strata") + } checkmate::assert_atomic(val) method <- match.arg(method)