Add functionality to tm_t_events_patyear to split columns by multiple (nested) variables

NEWS.md

@@ -1,12 +1,12 @@
 # teal.modules.clinical 0.9.1.9013
 
-* Removed `Show Warnings` modals from modules.
-
 ### Enhancements
 * 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.
 
 ### 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.
 
 # teal.modules.clinical 0.9.1

R/tm_t_events_patyear.R

@@ -23,6 +23,8 @@ template_events_patyear <- function(dataname,
                                     control = control_incidence_rate(),
                                     drop_arm_levels = TRUE,
                                     basic_table_args = teal.widgets::basic_table_args()) {
+  checkmate::assert_character(arm_var, min.len = 1, max.len = 2)
+
   # initialize
   y <- list()
   # data
@@ -39,10 +41,21 @@ template_events_patyear <- function(dataname,
     prepare_arm_levels(
       dataname = "anl",
       parentname = parentname,
-      arm_var = arm_var,
+      arm_var = arm_var[[1]],
       drop_arm_levels = drop_arm_levels
     )
   )
+  if (length(arm_var) == 2) {
+    data_list <- add_expr(
+      data_list,
+      prepare_arm_levels(
+        dataname = "anl",
+        parentname = parentname,
+        arm_var = arm_var[[2]],
+        drop_arm_levels = drop_arm_levels
+      )
+    )
+  }
 
   data_list <- add_expr(
     data_list,
@@ -94,9 +107,27 @@ template_events_patyear <- function(dataname,
       expr = expr_basic_table_args %>%
         rtables::split_cols_by(var = arm_var) %>%
         rtables::add_colcounts(),
-      env = list(arm_var = arm_var, expr_basic_table_args = parsed_basic_table_args)
+      env = list(arm_var = arm_var[[1]], expr_basic_table_args = parsed_basic_table_args)
     )
   )
+
+  if (length(arm_var) == 2) {
+    layout_list <- add_expr(
+      layout_list,
+      if (drop_arm_levels) {
+        substitute(
+          expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels),
+          env = list(nested_col = arm_var[[2]])
+        )
+      } else {
+        substitute(
+          expr = rtables::split_cols_by(nested_col),
+          env = list(nested_col = arm_var[[2]])
+        )
+      }
+    )
+  }
+
   if (add_total) {
     layout_list <- add_expr(
       layout_list,
@@ -152,6 +183,11 @@ template_events_patyear <- function(dataname,
 #'
 #' @inheritParams module_arguments
 #' @inheritParams template_events_patyear
+#' @param arm_var ([teal.transform::choices_selected()])\cr object with all
+#'   available choices and preselected option for variable names that can be used as `arm_var`.
+#'   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 events_var ([teal.transform::choices_selected()])\cr object with
 #'   all available choices and preselected option for the variable with all event counts.
 #'
@@ -253,7 +289,7 @@ tm_t_events_patyear <- function(label,
   args <- c(as.list(environment()))
 
   data_extract_list <- list(
-    arm_var = cs_to_des_select(arm_var, dataname = parentname),
+    arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE),
     paramcd = cs_to_des_filter(paramcd, dataname = dataname),
     aval_var = cs_to_des_select(aval_var, dataname = dataname),
     avalu_var = cs_to_des_select(avalu_var, dataname = dataname),
@@ -495,7 +531,7 @@ srv_events_patyear <- function(id,
         adslvars = c("USUBJID", "STUDYID", input_arm_var),
         anl = anl_filtered,
         anlvars = c("USUBJID", "STUDYID", input_paramcd, input_events_var, input_aval_var, input_avalu_var),
-        arm_var = input_arm_var
+        arm_var = input_arm_var[[1]]
       )
 
       validate(

tests/testthat/_snaps/tm_t_events_patyear.md

@@ -66,6 +66,10 @@
       $data
       {
           anl <- adaette
+          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(ARMCD = droplevels(ARMCD))
           arm_levels <- levels(anl[["ARMCD"]])
           adsl <- adsl %>% dplyr::filter(ARMCD %in% arm_levels)
@@ -76,8 +80,9 @@
 
       $layout
       lyt <- rtables::basic_table(title = "Event Rates Adjusted for Patient-Years by Time to First Occurrence of any Adverse Event", 
-          main_footer = "CI Method: Exact") %>% rtables::split_cols_by(var = "ARMCD") %>% 
-          rtables::add_colcounts() %>% rtables::add_overall_col(label = "All Patients") %>% 
+          main_footer = "CI Method: Exact") %>% rtables::split_cols_by(var = "ARM") %>% 
+          rtables::add_colcounts() %>% rtables::split_cols_by("ARMCD", 
+          split_fun = drop_split_levels) %>% rtables::add_overall_col(label = "All Patients") %>% 
           estimate_incidence_rate(vars = "AVAL", n_events = "n_events", 
               control = control_incidence_rate(conf_level = 0.9, conf_type = "exact", 
                   input_time_unit = "month", num_pt_year = 80))

tests/testthat/test-shinytest2-tm_t_events_patyear.R

@@ -175,3 +175,21 @@ testthat::test_that("e2e - tm_t_events_patyear: Deselection of arm_var throws va
   )
   app_driver$stop()
 })
+
+testthat::test_that(
+  "e2e - tm_t_events_patyear: Selecting 2 variables as arm_var changes the table and does not throw validation errors.",
+  {
+    skip_if_too_deep(5)
+    app_driver <- app_driver_tm_t_events_patyear()
+    table_before <- app_driver$get_active_module_table_output("patyear_table-table-with-settings")
+    app_driver$set_active_module_input("arm_var-dataset_ADSL_singleextract-select", c("ARM", "ARMCD"))
+    testthat::expect_false(
+      identical(
+        table_before,
+        app_driver$get_active_module_table_output("patyear_table-table-with-settings")
+      )
+    )
+    app_driver$expect_no_validation_error()
+    app_driver$stop()
+  }
+)

tests/testthat/test-tm_t_events_patyear.R

@@ -36,7 +36,7 @@ testthat::test_that("template_events_patyear generates right expressions with no
   result <- template_events_patyear(
     dataname = "adaette",
     parentname = "adsl",
-    arm_var = "ARMCD",
+    arm_var = c("ARM", "ARMCD"),
     aval_var = "AVAL",
     events_var = "n_events",
     label_paramcd = "Time to first occurrence of any adverse event",