diff --git a/NAMESPACE b/NAMESPACE index bc161acd..9c7147e5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export("%>%") export(add_blank_rows) export(add_difference_row) export(add_forest) +export(add_grade_column) export(add_hierarchical_count_row) export(add_overall) export(adjust_stat_columns_wrap) diff --git a/NEWS.md b/NEWS.md index 8c4965aa..83d0f3bb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -33,6 +33,8 @@ * `tbl_coxph()` now accepts a data.frame created by `get_cox_pairwise_df()` as input. (#207) +* Added `add_grade_column()` to inject a grade-label column into `tbl_hierarchical_rate_by_grade()` output. Decoupled from the table builder to prevent Cartesian join explosion in `tbl_merge()`. (#226) + ### Other Updates * `tbl_hierarchical_rate_and_count()` now emits zero-rows for unobserved factor levels in the first hierarchical variable. (#233) diff --git a/R/tbl_hierarchical_rate_by_grade.R b/R/tbl_hierarchical_rate_by_grade.R index 14905dab..c1fb38ee 100644 --- a/R/tbl_hierarchical_rate_by_grade.R +++ b/R/tbl_hierarchical_rate_by_grade.R @@ -41,6 +41,11 @@ #' A gtsummary table of class `'tbl_hierarchical_rate_by_grade'`. #' #' @details +#' This function returns a structurally pristine table where the `label` column retains unique grade text +#' (e.g., "1", "2", "Grade 1-2"). This preserves row uniqueness required by [gtsummary::tbl_merge()] and +#' [tbl_with_pools()]. To apply visual formatting (grade column, label blanking, header styling), pipe the +#' result through [add_grade_column()] **after** any merging operations. +#' #' When using the `filter` argument, the filter will be applied to the second variable from `variables`, i.e. the #' adverse event terms variable. If an AE does not meet the filtering criteria, the AE overall row as well as all grade #' and grade group rows within an AE section will be excluded from the table. Filtering out AEs does not exclude the @@ -81,7 +86,8 @@ #' ), #' grade_groups = grade_groups, #' grades_exclude = "5" -#' ) +#' ) |> +#' add_grade_column() #' #' # Example 2 ---------------------------------- #' # Filter: Keep AEs with an overall prevalence of greater than 10% @@ -93,7 +99,8 @@ #' grade_groups = list("Grades 1-2" = c("1", "2"), "Grades 3-5" = c("3", "4", "5")), #' filter = sum(n) / sum(N) > 0.10 #' ) |> -#' add_overall(last = TRUE) +#' add_overall(last = TRUE) |> +#' add_grade_column() NULL #' @export @@ -365,6 +372,7 @@ tbl_hierarchical_rate_by_grade <- function(data, } ) + # structural cleanup: remove duplicate/empty rows but preserve label uniqueness tbl_final <- tbl_final |> gtsummary::modify_table_body( \(table_body) { @@ -374,63 +382,10 @@ tbl_hierarchical_rate_by_grade <- function(data, # remove soc summary rows if all sub-rows filtered out dplyr::filter(!(.data$variable == soc & dplyr::lead(.data$variable) %in% c(soc, NA))) |> # remove rows for grades in grades_exclude - dplyr::filter(!.data$label %in% grades_exclude) |> - dplyr::rowwise() |> - # add label_grade column to display grade labels - dplyr::mutate( - label_grade = dplyr::case_when( - .data$variable == grade ~ label, - .data$variable == ae | label == "- Any adverse events -" ~ "- Any Grade -", - .default = "" - ), - .after = "label" - ) |> - # remove grade levels from label column - dplyr::mutate(label = if (.data$variable == grade) "" else label) |> - # remove statistics from summary rows if not an overall row - dplyr::mutate( - across( - gtsummary::all_stat_cols(), - ~ if ( - .data$variable %in% c(ae, "..ard_hierarchical_overall..") | - .data$label_grade %in% c(lvls, names(grade_groups)) | - .data$label == "- Any adverse events -" - ) { - . - } else { - NA - } - ) - ) |> - dplyr::ungroup() + dplyr::filter(!.data$label %in% grades_exclude) } - ) |> - # show label_grade column - gtsummary::modify_column_unhide("label_grade") |> - gtsummary::modify_column_alignment("label_grade", align = "left") |> - # remove default footnote - gtsummary::remove_footnote_header(columns = everything()) |> - # convert "0 (0.0%)" to "0" - gtsummary::modify_post_fmt_fun( - fmt_fun = ~ ifelse(. %in% c("0 (0.0%)", "0 (NA%)"), "0", .), - columns = gtsummary::all_stat_cols() - ) |> - # update header label - gtsummary::modify_header( - label ~ paste0(label[[soc]], " \n", paste0(rep("\U00A0", 4L), collapse = ""), label[[ae]]), - label_grade ~ label[[grade]], - gtsummary::all_stat_cols() ~ "{level} \n(N = {n})" ) - # indent grade level labels within grade groups - if (!is_empty(grade_groups)) { - tbl_final <- tbl_final |> - gtsummary::modify_indent( - columns = "label_grade", rows = .data$variable == grade & .data$label_grade %in% unlist(grade_groups), - indent = 4L - ) - } - # return final table --------------------------------------------------------- tbl_final$call_list <- list(tbl_hierarchical_rate_by_grade = match.call()) tbl_final$cards <- list( @@ -438,6 +393,16 @@ tbl_hierarchical_rate_by_grade <- function(data, ) tbl_final$inputs <- tbl_hierarchical_rate_by_grade_inputs + # inject metadata for downstream post-processing by add_grade_column() + tbl_final$custom_info <- list( + soc = soc, + ae = ae, + grade = grade, + grade_groups = grade_groups, + lvls = lvls, + label_list = label + ) + tbl_final |> structure(class = c("tbl_hierarchical_rate_by_grade", "gtsummary")) } @@ -508,3 +473,135 @@ tbl_hierarchical_rate_by_grade <- function(data, #' @rdname tbl_hierarchical_rate_by_grade #' @export add_overall.tbl_hierarchical_rate_by_grade <- asNamespace("gtsummary")[["add_overall.tbl_hierarchical"]] + +#' @param x (`gtsummary`)\cr +#' A gtsummary table produced by [tbl_hierarchical_rate_by_grade()], or a merged table +#' (e.g., from [tbl_with_pools()]) where the underlying tables were produced by +#' [tbl_hierarchical_rate_by_grade()]. +#' +#' @details +#' ## `add_grade_column()` +#' +#' Post-processing function that applies visual formatting to tables generated by +#' [tbl_hierarchical_rate_by_grade()]. Must be called **after** any merging +#' (e.g., via [tbl_with_pools()]) to avoid Cartesian join explosions caused by blanking +#' the `label` column prior to merge. +#' +#' The function extracts metadata injected by [tbl_hierarchical_rate_by_grade()] via +#' `x$custom_info` (standalone tables) or the first sub-table's `custom_info` (merged tables). +#' If no metadata is found, the function aborts with an informative error. +#' +#' `add_grade_column()` only works on tables produced by +#' [tbl_hierarchical_rate_by_grade()] — it reads the `custom_info` metadata +#' that function stores. They share a help page because they are designed +#' to be used together: build the table first, optionally merge with +#' [gtsummary::tbl_merge()] or [tbl_with_pools()], then call +#' `add_grade_column()` as the final step. +#' +#' @rdname tbl_hierarchical_rate_by_grade +#' @export +add_grade_column <- function(x) { + set_cli_abort_call() + + if (!inherits(x, "gtsummary")) { + cli::cli_abort( + "{.arg x} must be a {.cls gtsummary} object.", + call = get_cli_abort_call() + ) + } + + # idempotency guard: skip if already applied + if ("label_grade" %in% names(x$table_body)) { + return(x) + } + + # extract metadata: standalone vs merged table + info <- x$custom_info %||% + Find(Negate(is.null), lapply(x$tbls, \(t) t$custom_info)) + + if (is.null(info)) { + cli::cli_abort( + c( + "No {.field custom_info} metadata found on the input table.", + "i" = "Ensure the table was created with {.fun tbl_hierarchical_rate_by_grade}." + ), + call = get_cli_abort_call() + ) + } + + soc <- info$soc + ae <- info$ae + grade <- info$grade + grade_groups <- info$grade_groups + lvls <- info$lvls + label_list <- info$label_list + + + # apply visual formatting to the table body + # TODO: extract anonymous functions into named helpers (#251) + x <- x |> + gtsummary::modify_table_body( + \(table_body) { + table_body |> + dplyr::rowwise() |> + # create label_grade column + dplyr::mutate( + label_grade = dplyr::case_when( + .data$variable == grade ~ .data$label, + .data$variable == ae | .data$label == "- Any adverse events -" ~ "- Any Grade -", + .default = "" + ), + .after = "label" + ) |> + # blank the label column for grade rows (safe after merge) + dplyr::mutate(label = if (.data$variable == grade) "" else .data$label) |> + # remove statistics from non-summary rows + dplyr::mutate( + across( + gtsummary::all_stat_cols(), + ~ if ( + .data$variable %in% c(ae, "..ard_hierarchical_overall..") | + .data$label_grade %in% c(lvls, names(grade_groups)) | + .data$label == "- Any adverse events -" + ) { + . + } else { + NA + } + ) + ) |> + dplyr::ungroup() + } + ) |> + # show and align label_grade column + gtsummary::modify_column_unhide("label_grade") |> + gtsummary::modify_column_alignment("label_grade", align = "left") |> + # remove default footnote + gtsummary::remove_footnote_header(columns = everything()) |> + # convert "0 (0.0%)" to "0" + gtsummary::modify_post_fmt_fun( + fmt_fun = ~ ifelse(. %in% c("0 (0.0%)", "0 (NA%)"), "0", .), + columns = gtsummary::all_stat_cols() + ) |> + # update header labels + gtsummary::modify_header( + label ~ paste0( + label_list[[soc]], " \n", + paste0(rep("\U00A0", 4L), collapse = ""), label_list[[ae]] + ), + label_grade ~ label_list[[grade]], + gtsummary::all_stat_cols() ~ "{level} \n(N = {n})" + ) + + # indent grade level labels within grade groups + if (!is_empty(grade_groups)) { + x <- x |> + gtsummary::modify_indent( + columns = "label_grade", + rows = .data$variable == grade & .data$label_grade %in% unlist(grade_groups), + indent = 4L + ) + } + + x +} diff --git a/man/crane-package.Rd b/man/crane-package.Rd index effdaba7..8c7b5804 100644 --- a/man/crane-package.Rd +++ b/man/crane-package.Rd @@ -28,7 +28,7 @@ Authors: \item Emily de la Rua \email{emilydelarua@gmail.com} (\href{https://orcid.org/0009-0000-8738-5561}{ORCID}) \item Davide Garolini \email{davide.garolini@roche.com} (\href{https://orcid.org/0000-0002-1445-1369}{ORCID}) \item Chi Zhang \email{chi.zhang.cz7@roche.com} (\href{https://orcid.org/0000-0003-0501-5909}{ORCID}) - \item Jan Szczypiński \email{jan.szczypinski@external.roche.com} (\href{https://orcid.org/0000-0002-5682-5840}{ORCID}) + \item Jan Szczypiski \email{jan.szczypinski@external.roche.com} (\href{https://orcid.org/0000-0002-5682-5840}{ORCID}) } Other contributors: diff --git a/man/tbl_hierarchical_rate_by_grade.Rd b/man/tbl_hierarchical_rate_by_grade.Rd index 2aca6595..3011bb94 100644 --- a/man/tbl_hierarchical_rate_by_grade.Rd +++ b/man/tbl_hierarchical_rate_by_grade.Rd @@ -3,6 +3,7 @@ \name{tbl_hierarchical_rate_by_grade} \alias{tbl_hierarchical_rate_by_grade} \alias{add_overall.tbl_hierarchical_rate_by_grade} +\alias{add_grade_column} \title{AE Rates by Highest Toxicity Grade} \usage{ tbl_hierarchical_rate_by_grade( @@ -30,6 +31,8 @@ tbl_hierarchical_rate_by_grade( digits = NULL, ... ) + +add_grade_column(x) } \arguments{ \item{data}{(\code{data.frame})\cr @@ -108,8 +111,10 @@ computing overall totals and grade group totals. For example, to avoid duplicati Whether rows containing zero rates across all columns should be kept. If \code{FALSE}, this filter will be applied prior to any filters specified via the \code{filter} argument which may still remove these rows. Defaults to \code{FALSE}.} -\item{x}{(\code{tbl_hierarchical_rate_by_grade})\cr -A gtsummary table of class \code{'tbl_hierarchical_rate_by_grade'}.} +\item{x}{(\code{gtsummary})\cr +A gtsummary table produced by \code{\link[=tbl_hierarchical_rate_by_grade]{tbl_hierarchical_rate_by_grade()}}, or a merged table +(e.g., from \code{\link[=tbl_with_pools]{tbl_with_pools()}}) where the underlying tables were produced by +\code{\link[=tbl_hierarchical_rate_by_grade]{tbl_hierarchical_rate_by_grade()}}.} \item{last}{(scalar \code{logical})\cr Logical indicator to display overall column last in table. @@ -134,6 +139,11 @@ Grades will appear in rows in the order of the factor levels given, with each gr first level in its group. } \details{ +This function returns a structurally pristine table where the \code{label} column retains unique grade text +(e.g., "1", "2", "Grade 1-2"). This preserves row uniqueness required by \code{\link[gtsummary:tbl_merge]{gtsummary::tbl_merge()}} and +\code{\link[=tbl_with_pools]{tbl_with_pools()}}. To apply visual formatting (grade column, label blanking, header styling), pipe the +result through \code{\link[=add_grade_column]{add_grade_column()}} \strong{after} any merging operations. + When using the \code{filter} argument, the filter will be applied to the second variable from \code{variables}, i.e. the adverse event terms variable. If an AE does not meet the filtering criteria, the AE overall row as well as all grade and grade group rows within an AE section will be excluded from the table. Filtering out AEs does not exclude the @@ -142,6 +152,25 @@ all AEs for a given SOC have been filtered out, the SOC will be excluded from th and the SOC variable is included in \code{include_overall} the \verb{- Any adverse events -} section will still be kept. See \code{\link[gtsummary:filter_hierarchical]{gtsummary::filter_hierarchical()}} for more details and examples. + +\subsection{\code{add_grade_column()}}{ + +Post-processing function that applies visual formatting to tables generated by +\code{\link[=tbl_hierarchical_rate_by_grade]{tbl_hierarchical_rate_by_grade()}}. Must be called \strong{after} any merging +(e.g., via \code{\link[=tbl_with_pools]{tbl_with_pools()}}) to avoid Cartesian join explosions caused by blanking +the \code{label} column prior to merge. + +The function extracts metadata injected by \code{\link[=tbl_hierarchical_rate_by_grade]{tbl_hierarchical_rate_by_grade()}} via +\code{x$custom_info} (standalone tables) or the first sub-table's \code{custom_info} (merged tables). +If no metadata is found, the function aborts with an informative error. + +\code{add_grade_column()} only works on tables produced by +\code{\link[=tbl_hierarchical_rate_by_grade]{tbl_hierarchical_rate_by_grade()}} — it reads the \code{custom_info} metadata +that function stores. They share a help page because they are designed +to be used together: build the table first, optionally merge with +\code{\link[gtsummary:tbl_merge]{gtsummary::tbl_merge()}} or \code{\link[=tbl_with_pools]{tbl_with_pools()}}, then call +\code{add_grade_column()} as the final step. +} } \examples{ \dontshow{if (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) withAutoprint(\{ # examplesIf} @@ -172,7 +201,8 @@ tbl_hierarchical_rate_by_grade( ), grade_groups = grade_groups, grades_exclude = "5" -) +) |> + add_grade_column() # Example 2 ---------------------------------- # Filter: Keep AEs with an overall prevalence of greater than 10\% @@ -184,6 +214,7 @@ tbl_hierarchical_rate_by_grade( grade_groups = list("Grades 1-2" = c("1", "2"), "Grades 3-5" = c("3", "4", "5")), filter = sum(n) / sum(N) > 0.10 ) |> - add_overall(last = TRUE) + add_overall(last = TRUE) |> + add_grade_column() \dontshow{\}) # examplesIf} } diff --git a/tests/testthat/_snaps/add_grade_column.md b/tests/testthat/_snaps/add_grade_column.md new file mode 100644 index 00000000..2651d48d --- /dev/null +++ b/tests/testthat/_snaps/add_grade_column.md @@ -0,0 +1,17 @@ +# add_grade_column() errors when custom_info is missing + + Code + add_grade_column(tbl) + Condition + Error in `add_grade_column()`: + ! No custom_info metadata found on the input table. + i Ensure the table was created with `tbl_hierarchical_rate_by_grade()`. + +# add_grade_column() errors on non-gtsummary input + + Code + add_grade_column(data.frame(x = 1)) + Condition + Error in `add_grade_column()`: + ! `x` must be a object. + diff --git a/tests/testthat/_snaps/tbl_hierarchical_rate_by_grade.md b/tests/testthat/_snaps/tbl_hierarchical_rate_by_grade.md index ab9238ae..75ce1bf1 100644 --- a/tests/testthat/_snaps/tbl_hierarchical_rate_by_grade.md +++ b/tests/testthat/_snaps/tbl_hierarchical_rate_by_grade.md @@ -1,7 +1,7 @@ # tbl_hierarchical_rate_by_grade() works Code - as.data.frame(tbl)[1:25, ] + as.data.frame(add_grade_column(tbl))[1:25, ] Output MedDRA System Organ Class \n    MedDRA Preferred Term Grade Placebo \n(N = 86) Xanomeline High Dose \n(N = 84) Xanomeline Low Dose \n(N = 84) 1 - Any adverse events - - Any Grade - 26 (30.2%) 42 (50.0%) 40 (47.6%) @@ -33,7 +33,7 @@ --- Code - as.data.frame(tbl)[1:25, ] + as.data.frame(add_grade_column(tbl))[1:25, ] Output MedDRA System Organ Class \n    MedDRA Preferred Term Grade Placebo \n(N = 86) Xanomeline High Dose \n(N = 84) Xanomeline Low Dose \n(N = 84) 1 - Any adverse events - - Any Grade - 26 (30.2%) 42 (50.0%) 40 (47.6%) @@ -65,7 +65,7 @@ --- Code - as.data.frame(tbl)[1, ] + as.data.frame(add_grade_column(tbl))[1, ] Output MedDRA System Organ Class \n    MedDRA Preferred Term Grade Placebo \n(N = 86) Xanomeline High Dose \n(N = 84) Xanomeline Low Dose \n(N = 84) 1 - Any adverse events - - Any Grade - 26,0/86, 30.233% 42,0/84, 50.000% 40,0/84, 47.619% @@ -73,7 +73,7 @@ # tbl_hierarchical_rate_by_grade(include_overall) works Code - as.data.frame(tbl)[1:25, ] + as.data.frame(add_grade_column(tbl))[1:25, ] Output MedDRA System Organ Class \n    MedDRA Preferred Term Grade Placebo \n(N = 86) Xanomeline High Dose \n(N = 84) Xanomeline Low Dose \n(N = 84) 1 - Any adverse events - - Any Grade - 26 (30.2%) 42 (50.0%) 40 (47.6%) @@ -105,7 +105,7 @@ --- Code - as.data.frame(tbl)[1:25, ] + as.data.frame(add_grade_column(tbl))[1:25, ] Output MedDRA System Organ Class \n    MedDRA Preferred Term Grade Placebo \n(N = 86) Xanomeline High Dose \n(N = 84) Xanomeline Low Dose \n(N = 84) 1 CARDIAC DISORDERS diff --git a/tests/testthat/test-add_grade_column.R b/tests/testthat/test-add_grade_column.R new file mode 100644 index 00000000..05f005b1 --- /dev/null +++ b/tests/testthat/test-add_grade_column.R @@ -0,0 +1,212 @@ +skip_on_cran() + +ADSL <- cards::ADSL +ADAE_subset <- cards::ADAE |> + dplyr::filter( + AESOC %in% unique(cards::ADAE$AESOC)[1:5], + AETERM %in% unique(cards::ADAE$AETERM)[1:5] + ) + +label <- list( + AEBODSYS = "MedDRA System Organ Class", + AEDECOD = "MedDRA Preferred Term", + AETOXGR = "Grade" +) + +grade_groups <- list( + "Grade 1-2" = c("1", "2"), + "Grade 3-4" = c("3", "4"), + "Grade 5" = "5" +) + +# --- 1. Standalone table formatting ------------------------------------------ +test_that("add_grade_column() works on a standalone tbl_hierarchical_rate_by_grade", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + # before add_grade_column: no label_grade column, label not blanked + expect_false("label_grade" %in% names(tbl$table_body)) + expect_true(any(tbl$table_body$label %in% as.character(1:5))) + + result <- tbl |> add_grade_column() + + # after add_grade_column: label_grade exists, grade labels blanked from label + expect_true("label_grade" %in% names(result$table_body)) + + # grade rows have blank label + grade_rows <- result$table_body$variable == "AETOXGR" + expect_true(all(result$table_body$label[grade_rows] == "")) + + # label_grade has grade text for grade rows + expect_true(all(result$table_body$label_grade[grade_rows] != "")) + + # AE rows get "- Any Grade -" + ae_rows <- result$table_body$variable == "AEDECOD" + expect_true(all(result$table_body$label_grade[ae_rows] == "- Any Grade -")) + + # SOC label rows get empty label_grade (not "- Any Grade -") + soc_rows <- result$table_body$variable == "AEBODSYS" & + result$table_body$label != "- Any adverse events -" + expect_true(all(result$table_body$label_grade[soc_rows] == "")) +}) + +# --- 2. Standalone without grade groups -------------------------------------- +test_that("add_grade_column() works without grade groups", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label + ) + + result <- tbl |> add_grade_column() + + expect_true("label_grade" %in% names(result$table_body)) + # no grade-group-specific indentation when none defined + indent_rows <- result$table_styling$indent |> + dplyr::filter(column == "label_grade") + expect_equal(nrow(indent_rows), 0) +}) + +# --- 3. Metadata extraction from merged tables -------------------------------- +test_that("add_grade_column() extracts custom_info from merged tables", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + # simulate a merged table structure + merged <- gtsummary::tbl_merge( + tbls = list(tbl, tbl), + tab_spanner = FALSE, + quiet = TRUE + ) + + result <- merged |> add_grade_column() + expect_true("label_grade" %in% names(result$table_body)) +}) + +# --- 4. Error when no custom_info metadata ------------------------------------ +test_that("add_grade_column() errors when custom_info is missing", { + # use a plain gtsummary table with no custom_info + tbl <- gtsummary::tbl_summary(cards::ADSL, include = AGE) + + expect_snapshot( + add_grade_column(tbl), + error = TRUE + ) +}) + +# --- 5. Error when input is not gtsummary ------------------------------------ +test_that("add_grade_column() errors on non-gtsummary input", { + expect_snapshot( + add_grade_column(data.frame(x = 1)), + error = TRUE + ) +}) + +# --- 6. Stats blanking for non-summary rows ----------------------------------- +test_that("add_grade_column() blanks stats for SOC label rows", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + result <- tbl |> add_grade_column() + + # SOC label rows (not "- Any adverse events -") should have NA stats + soc_label_rows <- result$table_body |> + dplyr::filter( + variable == "AEBODSYS", + label != "- Any adverse events -" + ) + + stat_cols <- names(soc_label_rows)[grepl("^stat_", names(soc_label_rows))] + for (col in stat_cols) { + expect_true(all(is.na(soc_label_rows[[col]]))) + } +}) + +# --- 7. Zero formatting ("0 (0.0%)" -> "0") ---------------------------------- +test_that("add_grade_column() recodes zero statistics", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + result <- tbl |> add_grade_column() + + # recoding "0 (0.0%)" -> "0" happens at render time via post_fmt_fun; + # we verify the formatting function is registered, not the rendered output + expect_true(nrow(result$table_styling$post_fmt_fun) > 0) +}) + +# --- 8. Idempotency: calling add_grade_column() twice ------------------------- +test_that("add_grade_column() is idempotent when called twice", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + result_once <- tbl |> add_grade_column() + result_twice <- result_once |> add_grade_column() + + # second call should return the same table unchanged + expect_identical(result_once$table_body, result_twice$table_body) + + # grade labels should not be corrupted + grade_labels <- result_twice$table_body |> + dplyr::filter(variable == "AETOXGR") |> + dplyr::pull(label_grade) + expect_true(all(grade_labels != "")) +}) + +# --- 9. Header labels are set correctly -------------------------------------- +test_that("add_grade_column() sets correct header labels", { + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_subset, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = grade_groups + ) + + result <- tbl |> add_grade_column() + + # label_grade header should be the grade label + lg_header <- result$table_styling$header |> + dplyr::filter(column == "label_grade") |> + dplyr::pull(label) + expect_equal(lg_header, "Grade") + + # label header should combine SOC and AE labels + lbl_header <- result$table_styling$header |> + dplyr::filter(column == "label") |> + dplyr::pull(label) + expect_true(grepl("MedDRA System Organ Class", lbl_header)) + expect_true(grepl("MedDRA Preferred Term", lbl_header)) +}) diff --git a/tests/testthat/test-tbl_hierarchical_rate_by_grade.R b/tests/testthat/test-tbl_hierarchical_rate_by_grade.R index f23ccc88..f00ebb97 100644 --- a/tests/testthat/test-tbl_hierarchical_rate_by_grade.R +++ b/tests/testthat/test-tbl_hierarchical_rate_by_grade.R @@ -32,7 +32,18 @@ test_that("tbl_hierarchical_rate_by_grade() works", { label = label ) ) - expect_snapshot(as.data.frame(tbl)[1:25, ]) + + # custom_info metadata is injected for add_grade_column() + + expect_true(!is.null(tbl$custom_info)) + expect_equal(tbl$custom_info$soc, "AEBODSYS") + expect_equal(tbl$custom_info$ae, "AEDECOD") + expect_equal(tbl$custom_info$grade, "AETOXGR") + + # label column retains grade text (not blanked) for merge safety + expect_true(any(tbl$table_body$label %in% as.character(1:5))) + + expect_snapshot(as.data.frame(tbl |> add_grade_column())[1:25, ]) # with grade groups expect_no_error( @@ -46,7 +57,7 @@ test_that("tbl_hierarchical_rate_by_grade() works", { grade_groups = grade_groups ) ) - expect_snapshot(as.data.frame(tbl)[1:25, ]) + expect_snapshot(as.data.frame(tbl |> add_grade_column())[1:25, ]) # no by, no label expect_no_error( @@ -71,7 +82,7 @@ test_that("tbl_hierarchical_rate_by_grade() works", { digits = everything() ~ list(n = label_roche_number(digits = 1, decimal.mark = ","), p = 3) ) ) - expect_snapshot(as.data.frame(tbl)[1, ]) + expect_snapshot(as.data.frame(tbl |> add_grade_column())[1, ]) }) test_that("tbl_hierarchical_rate_by_grade(include_overall) works", { @@ -90,7 +101,7 @@ test_that("tbl_hierarchical_rate_by_grade(include_overall) works", { include_overall = everything() ) ) - expect_snapshot(as.data.frame(tbl)[1:25, ]) + expect_snapshot(as.data.frame(tbl |> add_grade_column())[1:25, ]) # all overall sections removed expect_no_error( @@ -105,7 +116,7 @@ test_that("tbl_hierarchical_rate_by_grade(include_overall) works", { include_overall = NULL ) ) - expect_snapshot(as.data.frame(tbl)[1:25, ]) + expect_snapshot(as.data.frame(tbl |> add_grade_column())[1:25, ]) }) test_that("tbl_hierarchical_rate_by_grade() works with add_overall()", { @@ -280,6 +291,26 @@ test_that("tbl_hierarchical_rate_by_grade(grade_groups) works with some grades n ) }) +test_that("tbl_hierarchical_rate_by_grade() appends missing grade group levels to character grade", { + # character grade column (not factor), partial grade groups with a level absent from data + ADAE_char <- ADAE_subset + ADAE_char$AETOXGR <- as.character(ADAE_char$AETOXGR) + ADAE_char <- ADAE_char[!ADAE_char$AETOXGR %in% c("1", "2"), ] + + # grade_groups reference grades "1" and "2" which are absent from data + expect_message( + tbl <- tbl_hierarchical_rate_by_grade( + ADAE_char, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL, + by = TRTA, + label = label, + grade_groups = list("Grade 3-4" = c("3", "4"), "Grade 1-2" = c("1", "2")) + ), + "\\`AETOXGR\\`: " + ) +}) + test_that("tbl_hierarchical_rate_by_grade(grades_exclude) works", { # no grades excluded tbl_no_excl <- @@ -309,7 +340,7 @@ test_that("tbl_hierarchical_rate_by_grade(grades_exclude) works", { expect_identical( tbl_excl$table_body, tbl_no_excl$table_body |> - dplyr::filter(label_grade != "5") + dplyr::filter(label != "5") ) # all grades excluded @@ -328,7 +359,7 @@ test_that("tbl_hierarchical_rate_by_grade(grades_exclude) works", { expect_identical( tbl_excl$table_body, tbl_no_excl$table_body |> - dplyr::filter(!label_grade %in% as.character(1:5)) + dplyr::filter(!label %in% as.character(1:5)) ) }) diff --git a/tests/testthat/test-tbl_with_pools.R b/tests/testthat/test-tbl_with_pools.R index 5915cb78..fb9b9d5c 100644 --- a/tests/testthat/test-tbl_with_pools.R +++ b/tests/testthat/test-tbl_with_pools.R @@ -3,11 +3,11 @@ skip_on_cran() # Setup small, reproducible datasets using {cards} ADSL_subset <- cards::ADSL |> dplyr::filter(TRTA %in% c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) |> - dplyr::slice(1:30) + dplyr::slice_head(n = 30) ADAE_subset <- cards::ADAE |> dplyr::filter(USUBJID %in% ADSL_subset$USUBJID) |> - dplyr::slice(1:30) + dplyr::slice_head(n = 30) # Define standard pools for testing standard_pools <- list( @@ -416,3 +416,73 @@ test_that("tbl_with_pools() skips if an rlang::expr() evaluates to 0 rows", { error = TRUE ) }) + + +# --- 13. Pipeline: tbl_with_pools + tbl_hierarchical_rate_by_grade + add_grade_column --- +test_that("tbl_with_pools() + add_grade_column() pipeline does not duplicate rows (#226)", { + # Regression test: deferred grade-column injection avoids row duplication + # during tbl_merge() inside tbl_with_pools(). + + # Full ADSL + filtered ADAE (3 SOCs/AETERMs) — needs enough hierarchical + # depth for tbl_hierarchical_rate_by_grade; file-level subsets are too small. + ADSL_pipe <- cards::ADSL + ADAE_pipe <- cards::ADAE |> + dplyr::filter( + AESOC %in% unique(cards::ADAE$AESOC)[1:3], + AETERM %in% unique(cards::ADAE$AETERM)[1:3] + ) + + pools <- list( + "Any Xanomeline" = c("Xanomeline High Dose", "Xanomeline Low Dose"), + "All Patients" = "all" + ) + + grade_groups <- list( + "Grade 1-2" = c("1", "2"), + "Grade 3-4" = c("3", "4") + ) + + # the merge should complete without row explosion + expect_silent( + merged_tbl <- tbl_with_pools( + data = ADAE_pipe, + pools = pools, + by = "TRTA", + denominator = ADSL_pipe, + keep_original = TRUE, + .tbl_fun = tbl_hierarchical_rate_by_grade, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + grade_groups = grade_groups + ) + ) + + # verify no Cartesian explosion: row count should match a single table + single_tbl <- tbl_hierarchical_rate_by_grade( + ADAE_pipe, + variables = c(AEBODSYS, AEDECOD, AETOXGR), + denominator = ADSL_pipe, + by = TRTA, + grade_groups = grade_groups + ) + # merged table should have same number of rows (not exponentially more) + expect_equal(nrow(merged_tbl$table_body), nrow(single_tbl$table_body)) + + # verify label column retains unique values (not all blank) + grade_labels <- merged_tbl$table_body |> + dplyr::filter(variable == "AETOXGR") |> + dplyr::pull(label) + expect_true(all(grade_labels != "")) + + # apply add_grade_column() to the merged result + final_tbl <- merged_tbl |> add_grade_column() + + # after styling: label_grade exists, grade labels blanked from label + expect_true("label_grade" %in% names(final_tbl$table_body)) + grade_labels_after <- final_tbl$table_body |> + dplyr::filter(variable == "AETOXGR") |> + dplyr::pull(label) + expect_true(all(grade_labels_after == "")) + + # custom_info is extracted from the first sub-table + expect_true(!is.null(merged_tbl$tbls[[1]]$custom_info)) +})