fix: decouple visual styling from tbl_hierarchical_rate_by_grade to prevent Cartesian join explosion

R/add_grade_column.R

@@ -0,0 +1,163 @@
+#' Add Grade Column to Hierarchical Rate-by-Grade Tables
+#'
+#' @description
+#'
+#' Post-processing function that applies visual formatting to tables generated by
+#' [tbl_hierarchical_rate_by_grade()]. This function 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:
+#' - Creates a `label_grade` column to display grade labels separately.
+#' - Blanks the `label` column for grade-level rows.
+#' - Removes statistics from non-summary rows (SOC label rows without rates).
+#' - Applies indentation for grade levels within grade groups.
+#' - Updates column headers and formatting.
+#'
+#' @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
+#' 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.
+#'
+#' ## Intended Workflow
+#'
+#' ```r
+#' # Standalone
+#' tbl_hierarchical_rate_by_grade(...) |> add_grade_column()
+#'
+#' # With pooled columns
+#' tbl_with_pools(..., .tbl_fun = tbl_hierarchical_rate_by_grade) |> add_grade_column()
+#' ```
+#'
+#' @returns The input gtsummary table with grade column formatting applied.
+#' @export
+#'
+#' @examplesIf identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")
+#' 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]
+#'   )
+#'
+#' grade_groups <- list(
+#'   "Grade 1-2" = c("1", "2"),
+#'   "Grade 3-4" = c("3", "4"),
+#'   "Grade 5" = "5"
+#' )
+#'
+#' # Standalone usage
+#' tbl_hierarchical_rate_by_grade(
+#'   ADAE_subset,
+#'   variables = c(AEBODSYS, AEDECOD, AETOXGR),
+#'   denominator = ADSL,
+#'   by = TRTA,
+#'   grade_groups = grade_groups
+#' ) |>
+#'   add_grade_column()
+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
+  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 ~ label,
+              .data$variable == ae | 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 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
+}

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,70 +382,27 @@ 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(
     tbl_hierarchical_rate_by_grade = list(tbl_hierarchical = tbl_final$cards$tbl_ard_hierarchical)
   )
   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"))
 }

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 <gtsummary> object.
+