Merge branch '1187_decorate_output@main' into tm_missing_data_module@1187_decorate_output@main

Author: m7pr

R/tm_data_table.R

@@ -29,6 +29,14 @@
 #'
 #' @inherit shared_params return
 #'
+#' @section Decorating `tm_data_table`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators:
+#' - `table` ([DT::datatable()])
+#'
+#' 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.general)
 #' interactive <- function() TRUE
@@ -96,7 +104,8 @@ tm_data_table <- function(label = "Data Table",
                           ),
                           server_rendering = FALSE,
                           pre_output = NULL,
-                          post_output = NULL) {
+                          post_output = NULL,
+                          decorators = NULL) {
   message("Initializing tm_data_table")
 
   # Start of assertions
@@ -121,6 +130,8 @@ tm_data_table <- function(label = "Data Table",
   checkmate::assert_flag(server_rendering)
   checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
   checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+
+  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
   # End of assertions
 
   ans <- module(
@@ -133,7 +144,8 @@ tm_data_table <- function(label = "Data Table",
       datasets_selected = datasets_selected,
       dt_args = dt_args,
       dt_options = dt_options,
-      server_rendering = server_rendering
+      server_rendering = server_rendering,
+      decorators = decorators
     ),
     ui_args = list(
       pre_output = pre_output,
@@ -145,9 +157,7 @@ tm_data_table <- function(label = "Data Table",
 }
 
 # UI page module
-ui_page_data_table <- function(id,
-                               pre_output = NULL,
-                               post_output = NULL) {
+ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
   ns <- NS(id)
 
   tagList(
@@ -185,7 +195,8 @@ srv_page_data_table <- function(id,
                                 variables_selected,
                                 dt_args,
                                 dt_options,
-                                server_rendering) {
+                                server_rendering,
+                                decorators) {
   checkmate::assert_class(data, "reactive")
   checkmate::assert_class(isolate(data()), "teal_data")
   moduleServer(id, function(input, output, session) {
@@ -238,7 +249,8 @@ srv_page_data_table <- function(id,
                     ui_data_table(
                       id = session$ns(x),
                       choices = choices,
-                      selected = variables_selected
+                      selected = variables_selected,
+                      decorators = decorators
                     )
                   )
                 )
@@ -260,7 +272,8 @@ srv_page_data_table <- function(id,
           if_distinct = if_distinct,
           dt_args = dt_args,
           dt_options = dt_options,
-          server_rendering = server_rendering
+          server_rendering = server_rendering,
+          decorators = decorators
         )
       }
     )
@@ -270,7 +283,8 @@ srv_page_data_table <- function(id,
 # UI function for the data_table module
 ui_data_table <- function(id,
                           choices,
-                          selected) {
+                          selected,
+                          decorators) {
   ns <- NS(id)
 
   if (!is.null(selected)) {
@@ -282,6 +296,7 @@ ui_data_table <- function(id,
   tagList(
     teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
     fluidRow(
+      ui_transform_teal_data(ns("decorate"), transformators = decorators),
       teal.widgets::optionalSelectInput(
         ns("variables"),
         "Select variables:",
@@ -305,7 +320,8 @@ srv_data_table <- function(id,
                            if_distinct,
                            dt_args,
                            dt_options,
-                           server_rendering) {
+                           server_rendering,
+                           decorators) {
   moduleServer(id, function(input, output, session) {
     iv <- shinyvalidate::InputValidator$new()
     iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
@@ -314,27 +330,48 @@ srv_data_table <- function(id,
     ))
     iv$enable()
 
-    output$data_table <- DT::renderDataTable(server = server_rendering, {
-      teal::validate_inputs(iv)
-
+    data_table_data <- reactive({
       df <- data()[[dataname]]
-      variables <- input$variables
 
       teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
 
-      dataframe_selected <- if (if_distinct()) {
-        dplyr::count(df, dplyr::across(dplyr::all_of(variables)))
-      } else {
-        df[variables]
-      }
+      teal.code::eval_code(
+        data(),
+        substitute(
+          expr = {
+            variables <- vars
+            dataframe_selected <- if (if_distinct) {
+              dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
+            } else {
+              dataname[variables]
+            }
+            dt_args <- args
+            dt_args$options <- dt_options
+            if (!is.null(dt_rows)) {
+              dt_args$options$pageLength <- dt_rows
+            }
+            dt_args$data <- dataframe_selected
+            table <- do.call(DT::datatable, dt_args)
+          },
+          env = list(
+            dataname = as.name(dataname),
+            if_distinct = if_distinct(),
+            vars = input$variables,
+            args = dt_args,
+            dt_options = dt_options,
+            dt_rows = input$dt_rows
+          )
+        )
+      )
+    })
 
-      dt_args$options <- dt_options
-      if (!is.null(input$dt_rows)) {
-        dt_args$options$pageLength <- input$dt_rows
-      }
-      dt_args$data <- dataframe_selected
+    decorated_data_table_data <-
+      srv_transform_teal_data("decorate", data = data_table_data, transformators = decorators)
 
-      do.call(DT::datatable, dt_args)
+    output$data_table <- DT::renderDataTable(server = server_rendering, {
+      req(data_table_data())
+      teal::validate_inputs(iv)
+      decorated_data_table_data()[["table"]]
     })
   })
 }

R/tm_g_association.R

@@ -25,6 +25,15 @@
 #'
 #' @inherit shared_params return
 #'
+#' @section Decorating `tm_g_association`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators:
+#' - `plot_top` (`ggplot2`)
+#' - `plot_bottom` (`ggplot2`)
+#'
+#' 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.general)
 #' interactive <- function() TRUE
@@ -130,7 +139,8 @@ tm_g_association <- function(label = "Association",
                              association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
                              pre_output = NULL,
                              post_output = NULL,
-                             ggplot2_args = teal.widgets::ggplot2_args()) {
+                             ggplot2_args = teal.widgets::ggplot2_args(),
+                             decorators = NULL) {
   message("Initializing tm_g_association")
 
   # Normalize the parameters
@@ -166,6 +176,7 @@ tm_g_association <- function(label = "Association",
   plot_choices <- c("Bivariate1", "Bivariate2")
   checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
   checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
   # End of assertions
 
   # Make UI args
@@ -183,7 +194,7 @@ tm_g_association <- function(label = "Association",
     ui_args = args,
     server_args = c(
       data_extract_list,
-      list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
+      list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)
     ),
     datanames = teal.transform::get_extract_datanames(data_extract_list)
   )
@@ -236,6 +247,7 @@ ui_tm_g_association <- function(id, ...) {
         "Log transformed",
         value = FALSE
       ),
+      ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           title = "Plot settings",
@@ -277,7 +289,8 @@ srv_tm_g_association <- function(id,
                                  vars,
                                  plot_height,
                                  plot_width,
-                                 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")
@@ -463,7 +476,6 @@ srv_tm_g_association <- function(id,
             )
           )
         }
-
       teal.code::eval_code(
         merged$anl_q_r(),
         substitute(
@@ -474,10 +486,8 @@ srv_tm_g_association <- function(id,
         teal.code::eval_code(
           substitute(
             expr = {
-              plots <- plot_calls
-              p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))
-              grid::grid.newpage()
-              grid::grid.draw(p)
+              plot_top <- plot_calls[[1]]
+              plot_bottom <- plot_calls[[1]]
             },
             env = list(
               plot_calls = do.call(
@@ -490,9 +500,23 @@ srv_tm_g_association <- function(id,
         )
     })
 
+    decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
+    decorated_output_grob_q <- reactive({
+      within(
+        decorated_output_q(),
+        {
+          plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob))
+          grid::grid.newpage()
+          grid::grid.draw(plot)
+        }
+      )
+    })
+
+
     plot_r <- reactive({
       req(iv_r()$is_valid())
-      output_q()[["p"]]
+      req(output_q())
+      decorated_output_grob_q()[["plot"]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(
@@ -508,7 +532,7 @@ srv_tm_g_association <- function(id,
 
     teal.widgets::verbatim_popup_srv(
       id = "rcode",
-      verbatim_content = reactive(teal.code::get_code(output_q())),
+      verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),
       title = "Association Plot"
     )
 
@@ -527,7 +551,7 @@ srv_tm_g_association <- function(id,
           card$append_text("Comment", "header3")
           card$append_text(comment)
         }
-        card$append_src(teal.code::get_code(output_q()))
+        card$append_src(teal.code::get_code(req(decorated_output_q())))
         card
       }
       teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)