introduce decorators for tm_g_pp_adverse_events

R/tm_g_pp_adverse_events.R

@@ -47,7 +47,7 @@ template_adverse_events <- function(dataname = "ANL",
     list(),
     substitute(
       expr = {
-        table <- dataname %>%
+        table_data <- dataname %>%
           dplyr::select(
             aeterm, tox_grade, causality, outcome, action, time, decod
           ) %>%
@@ -63,9 +63,7 @@ template_adverse_events <- function(dataname = "ANL",
           key_cols = NULL,
           default_formatting = list(all = fmt_config(align = "left"))
         )
-        main_title(table) <- paste("Patient ID:", patient_id)
-
-        table
+        main_title(table_output) <- paste("Patient ID:", patient_id)
       },
       env = list(
         dataname = as.name(dataname),
@@ -110,7 +108,7 @@ template_adverse_events <- function(dataname = "ANL",
   chart_list <- add_expr(
     list(),
     substitute(
-      expr = plot <- dataname %>%
+      expr = plot_output <- dataname %>%
         dplyr::select(aeterm, time, tox_grade, causality) %>%
         dplyr::mutate(ATOXGR = as.character(tox_grade)) %>%
         dplyr::arrange(dplyr::desc(ATOXGR)) %>%
@@ -156,11 +154,6 @@ template_adverse_events <- function(dataname = "ANL",
     )
   )
 
-  chart_list <- add_expr(
-    expr_ls = chart_list,
-    new_expr = quote(plot)
-  )
-
   y$table <- bracket_expr(table_list)
   y$chart <- bracket_expr(chart_list)
 
@@ -187,9 +180,35 @@ template_adverse_events <- function(dataname = "ANL",
 #'   available choices and preselected option for the `ASTDY` variable from `dataname`.
 #' @param decod ([teal.transform::choices_selected()])\cr object with all
 #'   available choices and preselected option for the `AEDECOD` variable from `dataname`.
+#' @param decorators `r roxygen_decorators_param("tm_g_pp_adverse_events")`
 #'
 #' @inherit module_arguments return
 #'
+#' @section Decorating `tm_g_pp_adverse_events`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators::
+#' - `plot` (`ggplot2`)
+#' - `table` (`listing_df` - output of `rlistings::as_listing`)
+#'
+#' Decorators can be applied to all outputs or only to specific objects using a
+#' named list of `teal_transform_module` objects.
+#' The `"default"` name is reserved for decorators that are applied to all outputs.
+#' See code snippet below:
+#'
+#' ```
+#' tm_g_pp_adverse_events(
+#'    ..., # arguments for module
+#'    decorators = list(
+#'      default = list(teal_transform_module(...)), # applied to all outputs
+#'      plot = list(teal_transform_module(...)), # applied only to `plot` output
+#'      table = list(teal_transform_module(...)) # applied only to `table` output
+#'    )
+#' )
+#' ```
+#'
+#' For additional details and examples of decorators, refer to the vignette
+#' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
+#'
 #' @examplesShinylive
 #' library(teal.modules.clinical)
 #' interactive <- function() TRUE
@@ -268,7 +287,8 @@ tm_g_pp_adverse_events <- function(label,
                                    plot_width = NULL,
                                    pre_output = NULL,
                                    post_output = NULL,
-                                   ggplot2_args = teal.widgets::ggplot2_args()) {
+                                   ggplot2_args = teal.widgets::ggplot2_args(),
+                                   decorators = NULL) {
   message("Initializing tm_g_pp_adverse_events")
   checkmate::assert_string(label)
   checkmate::assert_string(dataname)
@@ -293,6 +313,8 @@ tm_g_pp_adverse_events <- 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(ggplot2_args, "ggplot2_args")
+  decorators <- normalize_decorators(decorators)
+  assert_decorators(decorators, names = c("plot", "table"), null.ok = TRUE)
 
   args <- as.list(environment())
   data_extract_list <- list(
@@ -319,7 +341,8 @@ tm_g_pp_adverse_events <- function(label,
         patient_col = patient_col,
         plot_height = plot_height,
         plot_width = plot_width,
-        ggplot2_args = ggplot2_args
+        ggplot2_args = ggplot2_args,
+        decorators = decorators
       )
     ),
     datanames = c(dataname, parentname)
@@ -408,6 +431,8 @@ ui_g_adverse_events <- function(id, ...) {
           is_single_dataset = is_single_dataset_value
         )
       ),
+      ui_decorate_teal_data(ns("d_table"), decorators = select_decorators(ui_args$decorators, "table")),
+      ui_decorate_teal_data(ns("d_plot"), decorators = select_decorators(ui_args$decorators, "plot")),
       teal.widgets::panel_item(
         title = "Plot settings",
         collapsed = TRUE,
@@ -445,7 +470,8 @@ srv_g_adverse_events <- function(id,
                                  plot_height,
                                  plot_width,
                                  label,
-                                 ggplot2_args) {
+                                 ggplot2_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")
@@ -564,14 +590,29 @@ srv_g_adverse_events <- function(id,
       paste("<h5><b>Patient ID:", all_q()[["pt_id"]], "</b></h5>")
     })
 
-    output$table <- DT::renderDataTable(
-      expr = teal.code::dev_suppress(all_q()[["table"]]),
-      options = list(pageLength = input$table_rows)
+    # Allow for the table and plot qenv to be joined
+    table_q <- reactive(within(all_q(), table <- table_output))
+    plot_q <- reactive(within(all_q(), plot <- plot_output))
+
+    decorated_all_q_table <- srv_decorate_teal_data(
+      "d_table",
+      data = table_q,
+      decorators = select_decorators(decorators, "table"),
+      expr = table
+    )
+
+    decorated_all_q_plot <- srv_decorate_teal_data(
+      "d_plot",
+      data = plot_q,
+      decorators = select_decorators(decorators, "plot"),
+      expr = print(plot)
     )
 
+    table_r <- reactive(teal.code::dev_suppress(decorated_all_q_table()[["table"]]))
+
     plot_r <- reactive({
       req(iv_r()$is_valid())
-      all_q()[["plot"]]
+      decorated_all_q_plot()[["plot"]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(
@@ -581,9 +622,18 @@ srv_g_adverse_events <- function(id,
       width = plot_width
     )
 
+    output$table <- DT::renderDataTable(
+      expr = table_r(),
+      options = list(pageLength = input$table_rows)
+    )
+
+    decorated_all_q <- reactive(
+      c(decorated_all_q_table(), decorated_all_q_plot())
+    )
+
     teal.widgets::verbatim_popup_srv(
       id = "rcode",
-      verbatim_content = reactive(teal.code::get_code(all_q())),
+      verbatim_content = reactive(teal.code::get_code(req(decorated_all_q()))),
       title = label
     )
 
@@ -597,14 +647,14 @@ srv_g_adverse_events <- function(id,
           filter_panel_api = filter_panel_api
         )
         card$append_text("Table", "header3")
-        card$append_table(teal.code::dev_suppress(all_q()[["table"]]))
+        card$append_table(teal.code::dev_suppress(table_r()))
         card$append_text("Plot", "header3")
         card$append_plot(plot_r(), dim = pws$dim())
         if (!comment == "") {
           card$append_text("Comment", "header3")
           card$append_text(comment)
         }
-        card$append_src(teal.code::get_code(all_q()))
+        card$append_src(teal.code::get_code(req(decorated_all_q())))
         card
       }
       teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)