Add option to tm_t_summary to include arm_var labels in table hea…

…der (#1205)

Fixes #1204

NEWS.md

@@ -4,11 +4,13 @@
 * Added `teal.logger` functionality for logging changes in shiny inputs in all modules.
 * Introduced `ylim` parameter for `tm_g_km` module that controls width of y-axis.
 * Added functionality to `tm_t_events_patyear` to split columns by multiple (nested) variables via the `arm_var` argument.
+* Added arguments `arm_var_labels` to `template_summary` and `show_arm_var_labels` to `tm_t_summary` to allow user to display arm variable (`arm_var`) labels in table header.
 
 ### Miscellaneous
 * Removed `Show Warnings` modals from modules.
 * Clarified the documentation specifying whether multiple values can be selected in the `arm_var` argument for each module.
 * Replaced use of the `rtables::add_colcounts()` function with the `show_colcounts` argument to `basic_table()`.
+* Began deprecation cycle for the `show_labels` argument of `template_summary` which has no effect on the `tm_t_summary` module.
 
 # teal.modules.clinical 0.9.1
 

R/tm_t_summary.R

@@ -3,8 +3,9 @@
 #' Creates a valid expression to generate a table to summarize variables.
 #'
 #' @inheritParams template_arguments
-#' @param show_labels (`character`)\cr defines whether variable labels should be displayed. Options are
-#'   `"default"`, `"visible"`, and `"hidden"`.
+#' @param show_labels `r lifecycle::badge("deprecated")`
+#' @param arm_var_labels (`character` or `NULL`)\cr vector of column variable labels to display, of the same length as
+#'   `arm_var`. If `NULL`, no labels will be displayed.
 #'
 #' @inherit template_arguments return
 #'
@@ -15,10 +16,11 @@ template_summary <- function(dataname,
                              parentname,
                              arm_var,
                              sum_vars,
-                             show_labels = c("default", "visible", "hidden"),
+                             show_labels = lifecycle::deprecated(),
                              add_total = TRUE,
                              total_label = default_total_label(),
                              var_labels = character(),
+                             arm_var_labels = NULL,
                              na.rm = FALSE, # nolint: object_name.
                              na_level = default_na_str(),
                              numeric_stats = c(
@@ -27,24 +29,32 @@ template_summary <- function(dataname,
                              denominator = c("N", "n", "omit"),
                              drop_arm_levels = TRUE,
                              basic_table_args = teal.widgets::basic_table_args()) {
+  if (lifecycle::is_present(show_labels)) {
+    warning(
+      "The `show_labels` argument of `template_summary` is deprecated as of teal.modules.clinical 0.9.1.9013 ",
+      "as it is has no effect on the module.",
+      call. = FALSE
+    )
+  }
+
   checkmate::assert_string(dataname)
   checkmate::assert_string(parentname)
+  checkmate::assert_character(arm_var, min.len = 1, max.len = 2)
   checkmate::assert_character(sum_vars)
   checkmate::assert_flag(add_total)
   checkmate::assert_string(total_label)
   checkmate::assert_character(var_labels)
+  checkmate::assert_character(arm_var_labels, len = length(arm_var), null.ok = TRUE)
   checkmate::assert_flag(na.rm)
   checkmate::assert_string(na_level)
   checkmate::assert_flag(drop_arm_levels)
-  checkmate::assert_character(arm_var, min.len = 1, max.len = 2)
   checkmate::assert_character(numeric_stats, min.len = 1)
   checkmate::assert_subset(
     numeric_stats,
     c("n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range", "geom_mean")
   )
 
   denominator <- match.arg(denominator)
-  show_labels <- match.arg(show_labels)
 
   y <- list()
 
@@ -133,7 +143,6 @@ template_summary <- function(dataname,
   env_sum_vars <- list(
     sum_vars = sum_vars,
     sum_var_labels = var_labels[sum_vars],
-    show_labels = show_labels,
     na.rm = na.rm,
     na_level = na_level,
     denom = ifelse(denominator == "n", "n", "N_col"),
@@ -150,7 +159,7 @@ template_summary <- function(dataname,
         expr = analyze_vars(
           vars = sum_vars,
           var_labels = sum_var_labels,
-          show_labels = show_labels,
+          show_labels = "visible",
           na.rm = na.rm,
           na_str = na_level,
           denom = denom,
@@ -162,7 +171,7 @@ template_summary <- function(dataname,
       substitute(
         expr = analyze_vars(
           vars = sum_vars,
-          show_labels = show_labels,
+          show_labels = "visible",
           na.rm = na.rm,
           na_str = na_level,
           denom = denom,
@@ -173,6 +182,16 @@ template_summary <- function(dataname,
     }
   )
 
+  if (!is.null(arm_var_labels)) {
+    layout_list <- add_expr(
+      layout_list,
+      substitute(
+        expr = append_topleft(arm_var_labels),
+        env = list(arm_var_labels = c(arm_var_labels, ""))
+      )
+    )
+  }
+
   y$layout <- substitute(
     expr = lyt <- layout_pipe,
     env = list(layout_pipe = pipe_expr(layout_list))
@@ -200,6 +219,7 @@ template_summary <- function(dataname,
 #'   It defines the grouping variable(s) in the results table.
 #'   If there are two elements selected for `arm_var`,
 #'   second variable will be nested under the first variable.
+#' @param show_arm_var_labels (`flag`)\cr whether arm variable label(s) should be displayed. Defaults to `TRUE`.
 #'
 #' @inherit module_arguments return seealso
 #'
@@ -246,6 +266,7 @@ tm_t_summary <- function(label,
                          summarize_vars,
                          add_total = TRUE,
                          total_label = default_total_label(),
+                         show_arm_var_labels = TRUE,
                          useNA = c("ifany", "no"), # nolint: object_name.
                          na_level = default_na_str(),
                          numeric_stats = c(
@@ -264,15 +285,16 @@ tm_t_summary <- function(label,
   checkmate::assert_class(summarize_vars, "choices_selected")
   checkmate::assert_string(na_level)
   checkmate::assert_character(numeric_stats, min.len = 1)
-  useNA <- match.arg(useNA) # nolint: object_name.
-  denominator <- match.arg(denominator)
   checkmate::assert_flag(drop_arm_levels)
   checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE)
   checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE)
   checkmate::assert_class(basic_table_args, "basic_table_args")
-  checkmate::assertFlag(add_total)
+  checkmate::assert_flag(add_total)
+  checkmate::assert_flag(show_arm_var_labels)
   checkmate::assert_string(total_label)
 
+  useNA <- match.arg(useNA) # nolint: object_name.
+  denominator <- match.arg(denominator)
   numeric_stats <- match.arg(numeric_stats, several.ok = TRUE)
 
   args <- as.list(environment())
@@ -293,6 +315,7 @@ tm_t_summary <- function(label,
         dataname = dataname,
         parentname = parentname,
         label = label,
+        show_arm_var_labels = show_arm_var_labels,
         total_label = total_label,
         na_level = na_level,
         basic_table_args = basic_table_args
@@ -396,6 +419,7 @@ srv_summary <- function(id,
                         arm_var,
                         summarize_vars,
                         add_total,
+                        show_arm_var_labels,
                         total_label,
                         na_level,
                         drop_arm_levels,
@@ -516,15 +540,22 @@ srv_summary <- function(id,
 
       summarize_vars <- merged$anl_input_r()$columns_source$summarize_vars
       var_labels <- teal.data::col_labels(data()[[dataname]][, summarize_vars, drop = FALSE])
+
+      arm_var_labels <- NULL
+      if (show_arm_var_labels) {
+        arm_vars <- merged$anl_input_r()$columns_source$arm_var
+        arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE], fill = TRUE)
+      }
+
       my_calls <- template_summary(
         dataname = "ANL",
         parentname = "ANL_ADSL",
         arm_var = merged$anl_input_r()$columns_source$arm_var,
         sum_vars = summarize_vars,
-        show_labels = "visible",
         add_total = input$add_total,
         total_label = total_label,
         var_labels = var_labels,
+        arm_var_labels = arm_var_labels,
         na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE),
         na_level = na_level,
         numeric_stats = input$numeric_stats,

tests/testthat/_snaps/tm_t_summary.md

@@ -168,3 +168,41 @@
       }
       
 
+# template_summary generates correct expressions when arm variable labels are added
+
+    Code
+      res
+    Output
+      $data
+      {
+          anl <- adrs %>% df_explicit_na(omit_columns = setdiff(names(adrs), 
+              c(c("RACE", "COUNTRY", "AGE"))), na_level = "<Missing>")
+          anl <- anl %>% dplyr::mutate(ARM = droplevels(ARM))
+          arm_levels <- levels(anl[["ARM"]])
+          adsl <- adsl %>% dplyr::filter(ARM %in% arm_levels)
+          adsl <- adsl %>% dplyr::mutate(ARM = droplevels(ARM))
+          anl <- anl %>% dplyr::mutate(SEX = droplevels(SEX))
+          arm_levels <- levels(anl[["SEX"]])
+          adsl <- adsl %>% dplyr::filter(SEX %in% arm_levels)
+          adsl <- adsl %>% dplyr::mutate(SEX = droplevels(SEX))
+          adsl <- df_explicit_na(adsl, na_level = "<Missing>")
+      }
+      
+      $layout
+      lyt <- rtables::basic_table(main_footer = "n represents the number of unique subject IDs such that the variable has non-NA values.") %>% 
+          rtables::split_cols_by("ARM", split_fun = drop_split_levels) %>% 
+          rtables::split_cols_by("SEX", split_fun = drop_split_levels) %>% 
+          rtables::add_overall_col("All Patients") %>% rtables::add_colcounts() %>% 
+          analyze_vars(vars = c("RACE", "COUNTRY", "AGE"), show_labels = "visible", 
+              na.rm = FALSE, na_str = "<Missing>", denom = "N_col", 
+              .stats = c("n", "mean_sd", "mean_ci", "median", "median_ci", 
+                  "quantiles", "range", "geom_mean", "count_fraction")) %>% 
+          append_topleft(c("Arm", "Sex", ""))
+      
+      $table
+      {
+          result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = adsl)
+          result
+      }
+      
+

tests/testthat/test-tm_t_summary.R

@@ -4,7 +4,6 @@ testthat::test_that("template_summary generates correct expressions", {
     parentname = "adsl",
     arm_var = "ARM",
     sum_vars = c("RACE", "COUNTRY", "AGE"),
-    show_labels = "visible",
     add_total = FALSE,
     var_labels = character(),
     na.rm = FALSE,
@@ -22,7 +21,6 @@ testthat::test_that("template_summary can generate customized table", {
     parentname = "adsl",
     arm_var = "ARMCD",
     sum_vars = "RACE",
-    show_labels = "visible",
     add_total = TRUE,
     var_labels = c(RACE = "Race"),
     na.rm = TRUE,
@@ -40,7 +38,6 @@ testthat::test_that("template_summary generates correct expressions for multiple
     parentname = "adsl",
     arm_var = c("ARM", "STRATA1"),
     sum_vars = c("RACE", "COUNTRY", "AGE"),
-    show_labels = "visible",
     add_total = FALSE,
     var_labels = character(),
     na.rm = FALSE,
@@ -60,7 +57,6 @@ testthat::test_that(
       parentname = "adsl",
       arm_var = c("ARM", "STRATA1"),
       sum_vars = c("RACE", "COUNTRY", "AGE"),
-      show_labels = "visible",
       add_total = TRUE,
       var_labels = character(),
       na.rm = FALSE,
@@ -79,7 +75,6 @@ testthat::test_that("template_summary generates correct expressions for customiz
     parentname = "adsl",
     arm_var = c("ARM", "STRATA1"),
     sum_vars = c("RACE", "COUNTRY", "AGE"),
-    show_labels = "visible",
     add_total = FALSE,
     var_labels = character(),
     na.rm = FALSE,
@@ -91,3 +86,16 @@ testthat::test_that("template_summary generates correct expressions for customiz
   res <- testthat::expect_silent(result)
   testthat::expect_snapshot(res)
 })
+
+testthat::test_that("template_summary generates correct expressions when arm variable labels are added", {
+  result <- template_summary(
+    dataname = "adrs",
+    parentname = "adsl",
+    arm_var = c("ARM", "SEX"),
+    sum_vars = c("RACE", "COUNTRY", "AGE"),
+    arm_var_labels = c("Arm", "Sex")
+  )
+
+  res <- testthat::expect_silent(result)
+  testthat::expect_snapshot(res)
+})