Introduce decorators for tm_t events by grade

R/tm_t_events_by_grade.R

@@ -249,7 +249,7 @@ template_events_by_grade <- function(dataname,
 
   # Full table.
   y$table <- substitute(
-    expr = result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent),
+    expr = table <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent),
     env = list(parent = as.name(parentname))
   )
 
@@ -258,7 +258,7 @@ template_events_by_grade <- function(dataname,
   prune_list <- add_expr(
     prune_list,
     quote(
-      pruned_result <- result
+      pruned_table <- table
     )
   )
 
@@ -267,7 +267,7 @@ template_events_by_grade <- function(dataname,
     prune_list <- add_expr(
       prune_list,
       substitute(
-        expr = col_indices <- 1:(ncol(result) - add_total),
+        expr = col_indices <- 1:(ncol(table) - add_total),
         env = list(add_total = add_total)
       )
     )
@@ -303,7 +303,7 @@ template_events_by_grade <- function(dataname,
     prune_list <- add_expr(
       prune_list,
       substitute(
-        expr = pruned_result <- pruned_result %>% rtables::prune_table(keep_content_rows(row_condition))
+        expr = table <- pruned_table %>% rtables::prune_table(keep_content_rows(row_condition))
       )
     )
   }
@@ -330,9 +330,9 @@ template_events_by_grade <- function(dataname,
       sort_list,
       substitute(
         expr = {
-          pruned_and_sorted_result <- pruned_result %>%
+          pruned_and_sorted_table <- pruned_table %>%
             sort_at_path(path = term_var, scorefun = scorefun, decreasing = TRUE)
-          pruned_and_sorted_result
+          pruned_and_sorted_table
         },
         env = list(
           term_var = term_var,
@@ -345,7 +345,7 @@ template_events_by_grade <- function(dataname,
       sort_list,
       substitute(
         expr = {
-          pruned_and_sorted_result <- pruned_result %>%
+          table <- pruned_table %>%
             sort_at_path(path = hlt, scorefun = scorefun, decreasing = TRUE) %>%
             sort_at_path(path = c(hlt, "*", llt), scorefun = scorefun, decreasing = TRUE)
         },
@@ -359,7 +359,7 @@ template_events_by_grade <- function(dataname,
 
     sort_list <- add_expr(
       sort_list,
-      quote(pruned_and_sorted_result)
+      quote(table)
     )
   }
   y$sort <- bracket_expr(sort_list)
@@ -638,7 +638,7 @@ template_events_col_by_grade <- function(dataname,
   )
 
   # Full table.
-  y$table <- quote(result <- rtables::build_table(lyt = lyt, df = anl, col_counts = col_counts))
+  y$table <- quote(table <- rtables::build_table(lyt = lyt, df = anl, col_counts = col_counts))
 
   # Start sorting table.
   sort_list <- list()
@@ -657,7 +657,7 @@ template_events_col_by_grade <- function(dataname,
   sort_list <- add_expr(
     sort_list,
     substitute(
-      expr = col_indices <- seq(start_index, ncol(result), by = length(grading_groups)),
+      expr = col_indices <- seq(start_index, ncol(table), by = length(grading_groups)),
       env = list(grading_groups = grading_groups)
     )
   )
@@ -679,7 +679,7 @@ template_events_col_by_grade <- function(dataname,
       sort_list,
       substitute(
         expr = {
-          sorted_result <- result %>%
+          sorted_table <- table %>%
             sort_at_path(path = c(llt), scorefun = scorefun_term, decreasing = TRUE)
         },
         env = list(llt = llt)
@@ -690,7 +690,7 @@ template_events_col_by_grade <- function(dataname,
       sort_list,
       substitute(
         expr = {
-          sorted_result <- result %>%
+          sorted_table <- table %>%
             sort_at_path(path = c(hlt), scorefun = scorefun_soc, decreasing = TRUE) %>%
             sort_at_path(path = c(hlt, "*", llt), scorefun = scorefun_term, decreasing = TRUE)
         },
@@ -739,7 +739,7 @@ template_events_col_by_grade <- function(dataname,
   prune_pipe <- add_expr(
     prune_pipe,
     quote(
-      pruned_and_sorted_result <- sorted_result %>% rtables::trim_rows(criteria = criteria_fun)
+      pruned_and_sorted_table <- sorted_table %>% rtables::trim_rows(criteria = criteria_fun)
     )
   )
 
@@ -771,7 +771,7 @@ template_events_col_by_grade <- function(dataname,
   )
   prune_list <- add_expr(
     prune_list,
-    quote(pruned_and_sorted_result)
+    quote(pruned_and_sorted_table)
   )
 
   y$prune <- bracket_expr(prune_list)
@@ -788,9 +788,18 @@ template_events_col_by_grade <- function(dataname,
 #' @inheritParams template_events_col_by_grade
 #' @param col_by_grade (`logical`)\cr whether to display the grading groups in nested columns.
 #' @param grading_groups (`list`)\cr named list of grading groups used when `col_by_grade = TRUE`.
+#' @param decorators `r roxygen_decorators_param("tm_t_events_by_grade")`
 #'
 #' @inherit module_arguments return seealso
 #'
+#' @section Decorating `tm_t_events_by_grade`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators:
+#' - `table` (`TableTree` as created from `rtables::build_table`)
+#'
+#' For additional details and examples of decorators, refer to the vignette
+#' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
+#'
 #' @export
 #'
 #' @examplesShinylive
@@ -865,7 +874,8 @@ tm_t_events_by_grade <- function(label,
                                  drop_arm_levels = TRUE,
                                  pre_output = NULL,
                                  post_output = NULL,
-                                 basic_table_args = teal.widgets::basic_table_args()) {
+                                 basic_table_args = teal.widgets::basic_table_args(),
+                                 decorators = NULL) {
   message("Initializing tm_t_events_by_grade")
   checkmate::assert_string(label)
   checkmate::assert_string(dataname)
@@ -883,6 +893,8 @@ tm_t_events_by_grade <- function(label,
   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")
+  decorators <- normalize_decorators(decorators)
+  assert_decorators(decorators, "table", null.ok = TRUE)
 
   args <- as.list(environment())
 
@@ -907,7 +919,8 @@ tm_t_events_by_grade <- function(label,
         total_label = total_label,
         grading_groups = grading_groups,
         na_level = na_level,
-        basic_table_args = basic_table_args
+        basic_table_args = basic_table_args,
+        decorators = decorators
       )
     ),
     datanames = teal.transform::get_extract_datanames(data_extract_list)
@@ -962,6 +975,7 @@ ui_t_events_by_grade <- function(id, ...) {
         "Display grade groupings in nested columns",
         value = a$col_by_grade
       ),
+      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(a$decorators, "table")),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           "Additional table settings",
@@ -1017,7 +1031,8 @@ srv_t_events_by_grade <- function(id,
                                   drop_arm_levels,
                                   total_label,
                                   na_level,
-                                  basic_table_args) {
+                                  basic_table_args,
+                                  decorators) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
   checkmate::assert_class(data, "reactive")
@@ -1202,9 +1217,16 @@ srv_t_events_by_grade <- function(id,
       teal.code::eval_code(merged$anl_q(), as.expression(unlist(my_calls)))
     })
 
+
+    decorated_table_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = table_q,
+      decorators = select_decorators(decorators, "table"),
+      expr = table
+    )
     # Outputs to render.
     table_r <- reactive({
-      table_q()[["pruned_and_sorted_result"]]
+      decorated_table_q()[["table"]]
     })
 
     teal.widgets::table_with_settings_srv(
@@ -1215,7 +1237,7 @@ srv_t_events_by_grade <- function(id,
     # Render R code.
     teal.widgets::verbatim_popup_srv(
       id = "rcode",
-      verbatim_content = reactive(teal.code::get_code(table_q())),
+      verbatim_content = reactive(teal.code::get_code(req(decorated_table_q()))),
       title = label
     )
 
@@ -1234,7 +1256,7 @@ srv_t_events_by_grade <- function(id,
           card$append_text("Comment", "header3")
           card$append_text(comment)
         }
-        card$append_src(teal.code::get_code(table_q()))
+        card$append_src(teal.code::get_code(req(decorated_table_q())))
         card
       }
       teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)