Add modify_split_caption() to label paginated splits and hide the split column (#282)

NAMESPACE

@@ -46,6 +46,7 @@ export(label_roche_percent)
 export(label_roche_pvalue)
 export(label_roche_ratio)
 export(modify_header_rm_md)
+export(modify_split_caption)
 export(modify_zero_recode)
 export(preprocess_lineplot_data)
 export(process_survfit)

NEWS.md

@@ -1,5 +1,7 @@
 # crane 0.3.3.9009
 
+* Added `modify_split_caption()` to subtitle each page of a split `{gtsummary}` table (e.g. from `tbl_listing()`, `tbl_baseline_chg()`, or `tbl_shift()`) from its split level via a glue `pattern` (default `"Parameter: {spl_level}"`) and hide the now-redundant split column. (#282)
+
 * `annotate_riskdf()` now builds the "Numbers at Risk" table at the plot's x-axis breaks, so custom ticks set with `ggplot2::scale_x_continuous(breaks = ...)` are reflected in the table. (#278)
 
 * `theme_gtsummary_roche()` now frames the flextable column labels with an outer border only, removing the internal borders between header rows and the inconsistent missing right border. (#272)

R/modify_split_caption.R

@@ -0,0 +1,108 @@
+#' Label and Trim Split Tables
+#'
+#' @description
+#' Post-process a table that was paginated with
+#' [gtsummary::tbl_split_by_rows()] (via its `variable_level` argument). For each
+#' page, a subtitle is built from the split level using a [glue()]
+#' `pattern`, and the now-redundant split column is hidden.
+#'
+#' This is useful for any split `{gtsummary}` table, such as listings
+#' ([tbl_listing()]) split by treatment, or baseline/change tables
+#' ([tbl_baseline_chg()]) and shift tables ([tbl_shift()]) split by `PARAM`.
+#'
+#' The label is set both as a `{gtsummary}` caption (via
+#' [gtsummary::modify_caption()]) and on the native `variable_level` attribute.
+#' The caption makes the subtitle visible when the table is printed on its own
+#' (it renders inside the table's `<caption>` element), while `variable_level`
+#' lets downstream reporting engines promote the same text to a dedicated
+#' subtitle row.
+#'
+#' @param x (`tbl_split`, `list`, or `gtsummary`)\cr
+#'   a table split with [gtsummary::tbl_split_by_rows()], the list of split
+#'   tables, or a single split page.
+#' @param spl_col (`string`)\cr
+#'   name of the column the table was split by (the `variable_level` passed to
+#'   [gtsummary::tbl_split_by_rows()]). Used to hide that column on each page
+#'   when `hide_spl_col = TRUE`.
+#' @param pattern (`string`)\cr
+#'   a [glue()] pattern used to build each page's subtitle from the split level.
+#'   The `{spl_level}` token is replaced by the split value. Defaults to
+#'   `"Parameter: {spl_level}"`, matching parameter-split tables such as
+#'   laboratory tables split by `PARAM`.
+#' @param hide_spl_col (`flag`)\cr
+#'   whether to hide `spl_col` on each split page, since it is redundant after a
+#'   single-level split. Defaults to `TRUE`. Silently does nothing when the
+#'   column is absent or already hidden.
+#'
+#' @returns an object of the same class as `x`, with the split subtitle set as a
+#'   caption and on the `variable_level` attribute (and the split column hidden)
+#'   on each page.
+#'
+#' @seealso [tbl_listing()], [tbl_baseline_chg()], [tbl_shift()],
+#'   [gtsummary::tbl_split_by_rows()]
+#'
+#' @examples
+#' lst <- gtsummary::trial |>
+#'   dplyr::select(trt, age, grade) |>
+#'   dplyr::arrange(trt) |>
+#'   tbl_listing(split_by_rows = list(variable_level = "trt"))
+#'
+#' # Split a listing by treatment, then subtitle each page and drop the column
+#' modify_split_caption(lst, spl_col = "trt", pattern = "Treatment: {spl_level}")[[1]]
+#'
+#' # Keep the split column and use the default "Parameter:" subtitle
+#' modify_split_caption(lst, spl_col = "trt", hide_spl_col = FALSE)[[1]]
+#'
+#' @export
+modify_split_caption <- function(x,
+                                 spl_col,
+                                 pattern = "Parameter: {spl_level}",
+                                 hide_spl_col = TRUE) {
+  set_cli_abort_call()
+
+  # checks ---------------------------------------------------------------------
+  # argument checks run before the map so a list of split tables is validated
+  # once, up front, rather than on each recursive call.
+  check_not_missing(x)
+  check_not_missing(spl_col)
+  check_string(spl_col)
+  check_string(pattern)
+  check_scalar_logical(hide_spl_col)
+
+  # map over a list of split tables --------------------------------------------
+  if (is.list(x) && inherits(x[[1]], "gtsummary")) {
+    return(
+      map(
+        x,
+        modify_split_caption,
+        spl_col = spl_col,
+        pattern = pattern,
+        hide_spl_col = hide_spl_col
+      ) |>
+        structure(class = class(x))
+    )
+  }
+
+  check_class(x, "gtsummary")
+
+  # build the split subtitle from the split level ------------------------------
+  # `variable_level` is the gtsummary-native attribute set by
+  # tbl_split_by_rows(variable_level = ); row-number splits do not set it, so
+  # those pages are skipped silently.
+  spl_level <- attr(x, "variable_level")
+  if (!is_empty(spl_level)) {
+    subtitle <- as.character(glue::glue(pattern))
+    # set the label as a caption so it is visible when the page is printed on
+    # its own, and mirror it onto `variable_level` so reporting engines can
+    # promote the same text to a dedicated subtitle row.
+    x <- gtsummary::modify_caption(x, caption = subtitle)
+    attr(x, "variable_level") <- subtitle
+  }
+
+  # hide the split column, if present and not already hidden --------------------
+  if (isTRUE(hide_spl_col) && all(spl_col %in% x$table_styling$header$column)) {
+    x <- gtsummary::modify_column_hide(x, columns = all_of(spl_col))
+  }
+
+  x
+}

R/tbl_baseline_chg.R

@@ -67,8 +67,12 @@
 #'   .combine_with = "tbl_stack",
 #'   .combine_args = list(group_header = NULL, quiet = TRUE)
 #' ) |>
-#'   tbl_split_by_rows(variable_level = ends_with("lbl"))
+#'   tbl_split_by_rows(variable_level = ends_with("lbl")) |>
+#'   # caption each page with its parameter and hide the split column
+#'   modify_split_caption(spl_col = "tbl_id1_lbl")
 #'
+#' @seealso [modify_split_caption()] to caption each page of a split table and
+#'   hide the redundant split column.
 #' @rdname tbl_baseline_chg
 #' @export
 tbl_baseline_chg <- function(data,

R/tbl_listing.R

@@ -22,6 +22,8 @@
 #'   string to use for blank values. Defaults to `NA`. It should not be changed.
 #'
 #' @name tbl_listing
+#' @seealso [modify_split_caption()] to label each page of a split table and
+#'   hide the redundant split column.
 #' @note
 #' Common pre-processing steps for the data frame that may be common:
 #'  * Unique values - this should be enforced in pre-processing by users.
@@ -88,6 +90,12 @@
 #' out <- list_lst |>
 #'   remove_duplicate_keys(keys = c("trt", "stage"))
 #' out[[2]]
+#'
+#' # Example 8 --------------------------------
+#' # Label each split page and hide the redundant split column
+#' by_stage <- tbl_listing(trial_data, split_by_rows = list(variable_level = "stage")) |>
+#'   modify_split_caption(spl_col = "stage", pattern = "Stage: {spl_level}")
+#' by_stage[[1]]
 NULL
 
 #' @export

R/tbl_shift.R

@@ -140,6 +140,8 @@
 #'   modify_spanning_header(all_stat_cols() ~ "Worst Post-baseline NCI-CTCAE Grade")
 NULL
 
+#' @seealso [modify_split_caption()] to caption each page of a split table and
+#'   hide the redundant split column.
 #' @rdname tbl_shift
 #' @export
 tbl_shift <- function(data,

_pkgdown.yml

@@ -90,6 +90,7 @@ reference:
       - theme_gtsummary_roche
       - modify_header_rm_md
       - modify_zero_recode
+      - modify_split_caption
       - add_blank_rows
       - label_roche
       - reverse_ci

tests/testthat/test-modify_split_caption.R

@@ -0,0 +1,100 @@
+tld <- trial |> # table_listing_data
+  dplyr::select(trt, age, marker, stage) |>
+  dplyr::filter(stage %in% c("T2", "T3")) |> # down sampling
+  dplyr::slice_head(n = 2, by = c(trt, stage))
+
+# get the hide flag of a single column from a gtsummary table
+hide_flag <- function(x, col) {
+  x$table_styling$header$hide[x$table_styling$header$column == col]
+}
+
+test_that("modify_split_caption() labels each page and hides the split column", {
+  expect_no_error(
+    out <- tbl_listing(tld, split_by_rows = list(variable_level = "trt")) |>
+      modify_split_caption(spl_col = "trt")
+  )
+
+  # one page per treatment level, class preserved
+  expect_s3_class(out, "tbl_split")
+  expect_s3_class(out[[1]], "tbl_listing")
+
+  # default pattern is applied on every page as both a caption (visible when
+  # the page prints on its own) and the variable_level attribute (promoted to a
+  # subtitle row by reporting engines)
+  expect_equal(attr(out[[1]], "variable_level"), "Parameter: Drug B")
+  expect_equal(attr(out[[2]], "variable_level"), "Parameter: Drug A")
+  expect_equal(as.character(out[[1]]$table_styling$caption), "Parameter: Drug B")
+  expect_equal(as.character(out[[2]]$table_styling$caption), "Parameter: Drug A")
+
+  # the split column is hidden by default on every page
+  expect_true(hide_flag(out[[1]], "trt"))
+  expect_true(hide_flag(out[[2]], "trt"))
+})
+
+test_that("modify_split_caption() honors a custom glue pattern", {
+  out <- tbl_listing(tld, split_by_rows = list(variable_level = "trt")) |>
+    modify_split_caption(spl_col = "trt", pattern = "Treatment: {spl_level}")
+
+  expect_equal(attr(out[[1]], "variable_level"), "Treatment: Drug B")
+})
+
+test_that("modify_split_caption(hide_spl_col = FALSE) keeps the split column", {
+  out <- tbl_listing(tld, split_by_rows = list(variable_level = "trt")) |>
+    modify_split_caption(spl_col = "trt", hide_spl_col = FALSE)
+
+  expect_false(hide_flag(out[[1]], "trt"))
+  # subtitle is still applied
+  expect_equal(attr(out[[1]], "variable_level"), "Parameter: Drug B")
+})
+
+test_that("modify_split_caption() is silent when the column is absent or already hidden", {
+  base <- tbl_listing(tld, split_by_rows = list(variable_level = "trt"))
+
+  # absent column -> no error, subtitle still applied from the split level
+  expect_no_error(
+    out_absent <- modify_split_caption(base, spl_col = "not_a_column")
+  )
+  expect_equal(attr(out_absent[[1]], "variable_level"), "Parameter: Drug B")
+
+  # applying twice is idempotent (column already hidden the second time)
+  expect_no_error(
+    out_twice <- base |>
+      modify_split_caption(spl_col = "trt") |>
+      modify_split_caption(spl_col = "trt")
+  )
+  expect_true(hide_flag(out_twice[[1]], "trt"))
+})
+
+test_that("modify_split_caption() skips row-number splits that lack a level", {
+  # row_numbers splits do not set the variable_level attribute
+  out <- tbl_listing(tld, split_by_rows = list(row_numbers = c(2, 3))) |>
+    modify_split_caption(spl_col = "trt", hide_spl_col = FALSE)
+
+  expect_null(attr(out[[1]], "variable_level"))
+})
+
+test_that("modify_split_caption() works on a single (non-list) split element", {
+  one <- tbl_listing(tld, split_by_rows = list(variable_level = "trt"))[[1]]
+  out <- modify_split_caption(one, spl_col = "trt")
+
+  expect_s3_class(out, "tbl_listing")
+  expect_equal(attr(out, "variable_level"), "Parameter: Drug B")
+  expect_true(hide_flag(out, "trt"))
+})
+
+test_that("modify_split_caption() checks its inputs", {
+  one <- tbl_listing(tld, split_by_rows = list(variable_level = "trt"))[[1]]
+
+  expect_error(
+    modify_split_caption(data.frame(a = 1), spl_col = "trt"),
+    "must be class"
+  )
+  expect_error(
+    modify_split_caption(one),
+    "cannot be missing"
+  )
+  expect_error(
+    modify_split_caption(one, spl_col = "trt", pattern = 5),
+    "must be a string"
+  )
+})