diff --git a/NAMESPACE b/NAMESPACE index f7cd7b31b5..b94aba0f88 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_proportion_data) export(assert_proportion_value) export(check_diff_prop_ci) export(clogit_with_tryCatch) @@ -147,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) @@ -208,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) diff --git a/NEWS.md b/NEWS.md index b702fc5747..f9da8ed85f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,11 @@ # tern 0.9.11.9000 ### Enhancements +* 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. (#1514). * Added `mantel_fleiss_crit()` to check the Mantel-Fleiss criterion for stratified 2 x 2 contingency tables, together with a vignette demonstrating its use. (#1512) @@ -13,6 +18,24 @@ 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) + +### Bug Fixes +* Fixed an issue in `s_proportion_diff()` where the `weights_method` argument + 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 + 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 0bdf31f2cf..1157a1af05 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 @@ -54,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"), @@ -78,92 +85,71 @@ 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( "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", + weights_method = c("cmh", "wilson_h"), + val = TRUE, ...) { - method <- match.arg(method) - if ( - is.null(variables$strata) && - checkmate::test_subset(method, c("cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc")) - ) { - 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." - )) + 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) + if (!is.null(variables)) { + checkmate::assert_set_equal(names(variables), "strata") } - if (!is.null(variables$strata) && identical(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") - ) + checkmate::assert_atomic(val) - 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) + method <- match.arg(method) - # 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 { + checkmate::assert_false(is.null(.ref_group)) + assert_stratification_compatibility( + method = method, + stratified_methods = c( + "cmh", "cmh_sato", "cmh_mn", "strat_newcombe", "strat_newcombecc" + ), + strata_vars = variables$strata + ) - # Defining the std way to calculate weights for strat_newcombe - if (!is.null(variables$weights_method)) { - weights_method <- variables$weights_method - } else { - weights_method <- "cmh" - } + rsp_list <- h_prepare_2x2_table( + df = df, df_ref = .ref_group, var = .var, val = val, + strata_vars = variables$strata, + complete_cases = TRUE + ) + rsp <- rsp_list$rsp + grp <- rsp_list$grp + strata <- rsp_list$strata - 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 +161,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 (%)") } @@ -312,7 +295,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, @@ -394,16 +377,236 @@ 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_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() +} - if (!is.null(strata)) { - checkmate::assert_factor(strata, len = length(rsp)) +#' 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 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 +#' 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 <- 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", +#' 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", +#' )$tbl +h_prepare_2x2_table <- function(df, + df_ref = NULL, + var, + val = TRUE, + 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, + 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, + additional_message = " from the reference group (df_ref)." + ) + } } - invisible() + # 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") + + # 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)) { + interaction(df[strata_vars]) + } else { + NULL + } + + # 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) + strata <- if (!is.null(strata_vars)) { + c(interaction(df_ref[strata_vars]), strata) + } else { + NULL + } + } + + 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 @@ -875,8 +1078,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 @@ -921,18 +1127,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/R/prop_diff_test.R b/R/prop_diff_test.R index b798f072c2..c208256e49 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], [h_prepare_2x2_table()] #' #' @name prop_diff_test #' @order 1 @@ -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. @@ -50,55 +55,62 @@ 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"), + method = c( + "chisq", "schouten", "fisher", + "cmh", "cmh_sato", "cmh_wh" + ), alternative = c("two.sided", "less", "greater"), + val = TRUE, ...) { - method <- match.arg(method) - y <- list(pval = numeric()) - - 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") - ) - grp <- factor( - rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), - levels = c("ref", "Not-ref") - ) + 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) + if (!is.null(variables)) { + checkmate::assert_set_equal(names(variables), "strata") + } + checkmate::assert_atomic(val) - if (!is.null(variables$strata) || method %in% c("cmh", "cmh_wh")) { - strata <- variables$strata - checkmate::assert_false(is.null(strata)) - strata_vars <- stats::setNames(as.list(strata), strata) - assert_df_with_variables(df, strata_vars) - assert_df_with_variables(.ref_group, strata_vars) - strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) - } + method <- match.arg(method) - tbl <- switch(method, - cmh = table(grp, rsp, strata), - cmh_sato = table(grp, rsp, strata), - cmh_wh = table(grp, rsp, strata), - table(grp, rsp) + pval <- if (is.null(.in_ref_col) || .in_ref_col) { + numeric() + } else { + checkmate::assert_false(is.null(.ref_group)) + assert_stratification_compatibility( + method = method, + stratified_methods = c("cmh", "cmh_sato", "cmh_wh"), + strata_vars = variables$strata ) - y$pval <- switch(method, - chisq = prop_chisq(tbl, alternative = alternative), - 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") + rsp_list <- h_prepare_2x2_table( + df = df, df_ref = .ref_group, var = .var, val = val, + strata_vars = variables$strata, + complete_cases = TRUE + ) + rsp_tbl <- rsp_list$tbl + + switch(method, + 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) ) } - 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 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/R/utils_checkmate.R b/R/utils_checkmate.R index a4c2711b6e..a51c8661c8 100644 --- a/R/utils_checkmate.R +++ b/R/utils_checkmate.R @@ -180,3 +180,84 @@ 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) + 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_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_vars) { + checkmate::assert_string(method) + checkmate::assert_character(stratified_methods) + checkmate::assert_character(strata_vars, null.ok = TRUE) + + is_stratified <- method %in% stratified_methods + is_strata_provided <- !is.null(strata_vars) + + # 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/_pkgdown.yml b/_pkgdown.yml index 06ce089982..057aee9dee 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -114,6 +114,7 @@ reference: - -prop_diff - check_diff_prop_ci - mantel_fleiss_crit + - h_prepare_2x2_table - title: rtables Helper Functions desc: These functions help to work with the `rtables` package and may be @@ -189,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/assertions.Rd b/man/assertions.Rd index df83d07c33..d978df41f7 100644 --- a/man/assertions.Rd +++ b/man/assertions.Rd @@ -7,6 +7,8 @@ \alias{assert_valid_factor} \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) @@ -43,6 +45,10 @@ 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_vars) } \arguments{ \item{x}{(\code{any})\cr object to test.} @@ -86,6 +92,27 @@ 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 (\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.} + +\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. @@ -113,6 +140,15 @@ 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. + +\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( @@ -130,5 +166,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/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..e82862544d --- /dev/null +++ b/man/h_prepare_2x2_table.Rd @@ -0,0 +1,165 @@ +% 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 = TRUE, + 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 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}.} + +\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", + 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", +)$tbl +} +\seealso{ +\link{h_prop_diff}, \link{h_prop_diff_test}, \code{\link[=get_complete_cases]{get_complete_cases()}} +} 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 fc31e622e3..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, @@ -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", + weights_method = c("cmh", "wilson_h"), + val = TRUE, ... ) @@ -64,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.} @@ -110,6 +114,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{ @@ -230,4 +239,6 @@ a_proportion_diff( } \seealso{ \code{\link[=d_proportion_diff]{d_proportion_diff()}} + +\code{\link[=h_prepare_2x2_table]{h_prepare_2x2_table()}} } diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index de75429d3e..254d880421 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -31,11 +31,12 @@ 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"), + 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{ @@ -179,6 +185,6 @@ s_test_proportion_diff( } \seealso{ -\link{h_prop_diff_test} +\link{h_prop_diff_test}, \code{\link[=h_prepare_2x2_table]{h_prepare_2x2_table()}} } \keyword{internal} 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..19aa6981aa --- /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 FALSE TRUE + + $grp + [1] ref ref Not-ref + Levels: ref Not-ref + + $strata + [1] S1 S2 S1 + 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-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))) +}) 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..b74acfeb29 --- /dev/null +++ b/tests/testthat/test-h_prepare_2x2_table.R @@ -0,0 +1,678 @@ +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 = 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" + ) + ) + + grp_ref <- which(data$grp == "Placebo") + grp_nonref <- which(data$grp == "X") + + expected <- list( + rsp = data[c(grp_ref, grp_nonref), 1], + grp = factor( + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), + 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 = 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", + strata_vars = "strata" + ) + ) + + grp_ref <- which(data$grp == "Placebo") + grp_nonref <- which(data$grp == "X") + + expected <- list( + rsp = data[c(grp_ref, grp_nonref), "rsp"], + grp = factor( + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), + levels = c("ref", "Not-ref") + ), + 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), + dimnames = list(grp = c("ref", "Not-ref"), rsp = c("TRUE", "FALSE"), strata = LETTERS[1:4]) + )) + ) + + 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_ref, grp_nonref), "rsp"], + grp = factor( + c(rep("ref", length(grp_ref)), rep("Not-ref", length(grp_nonref))), + levels = c("ref", "Not-ref") + ), + 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, + 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(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) + + 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("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) + + 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("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) + + 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_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( + 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") + ) + ) + + # Expected. + rsp <- data$rsp + 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) + + expect_identical(result, expected) +}) + +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("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) + + 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_1 = factor(), + strata_2 = factor() + ) + + expect_silent( + result <- h_prepare_2x2_table( + df = subset(data, grp == "Y"), + df_ref = subset(data, grp == "Cntrl"), + var = "rsp", + strata_vars = c("strata_1", "strata_2") + ) + ) + + # Expected. + rsp <- data$rsp + grp <- factor(levels = c("ref", "Not-ref")) + 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) + + 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) +}) + +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, 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) +}) + +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(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) +}) + +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) +}) + +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" + ) +}) + +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-prop_diff.R b/tests/testthat/test-prop_diff.R index 0346b3f82c..257129630b 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -710,25 +710,73 @@ 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", { +test_that("s_proportion_diff supports a custom response value", { + set.seed(1984, kind = "Mersenne-Twister") dta <- data.frame( - rsp = c(TRUE, FALSE, TRUE, FALSE), - grp = c("A", "A", "B", "B"), - strata = c("S1", "S2", "S1", "S2"), - stringsAsFactors = FALSE + 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 (%)") +}) + +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( - s_proportion_diff( + 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" + ), + "strat" + ) +}) + +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)), + 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"), - conf_level = 0.95, - method = "uncond_exact_diff" + method = "uncond_exact_diff", + val = "Y" ), - "only available for unstratified analyses" + "strat" ) }) diff --git a/tests/testthat/test-test_proportion_diff.R b/tests/testthat/test-test_proportion_diff.R index 615ed7a8c2..0b7eabe6ea 100644 --- a/tests/testthat/test-test_proportion_diff.R +++ b/tests/testthat/test-test_proportion_diff.R @@ -353,6 +353,75 @@ testthat::test_that("s_test_proportion_diff and d_test_proportion_diff work with } }) +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)) + ) + + 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)" + + 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" + ), + "strat" + ) +}) + +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" + ), + "strat" + ) +}) + testthat::test_that("test_proportion_diff returns right result", { 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) + ) +})