introduce decorators for tm_g_scatterplotmatrix

R/tm_g_scatterplotmatrix.R

@@ -18,6 +18,14 @@
 #'
 #' @inherit shared_params return
 #'
+#' @section Decorating `tm_g_scatterplotmatrix`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators:
+#' - `plot` (`trellis` - output of `lattice::splom`)
+#'
+#' 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
@@ -168,7 +176,8 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
                                    plot_height = c(600, 200, 2000),
                                    plot_width = NULL,
                                    pre_output = NULL,
-                                   post_output = NULL) {
+                                   post_output = NULL,
+                                   decorators = NULL) {
   message("Initializing tm_g_scatterplotmatrix")
 
   # Requires Suggested packages
@@ -193,6 +202,7 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
 
   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
 
   # Make UI args
@@ -203,7 +213,12 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
     server = srv_g_scatterplotmatrix,
     ui = ui_g_scatterplotmatrix,
     ui_args = args,
-    server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),
+    server_args = list(
+      variables = variables,
+      plot_height = plot_height,
+      plot_width = plot_width,
+      decorators = decorators
+    ),
     datanames = teal.transform::get_extract_datanames(variables)
   )
   attr(ans, "teal_bookmarkable") <- TRUE
@@ -234,6 +249,7 @@ ui_g_scatterplotmatrix <- function(id, ...) {
         is_single_dataset = is_single_dataset_value
       ),
       tags$hr(),
+      ui_transform_teal_data(ns("decorator"), transformators = args$decorators),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           title = "Plot settings",
@@ -267,7 +283,14 @@ ui_g_scatterplotmatrix <- function(id, ...) {
 }
 
 # Server function for the scatterplot matrix module
-srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+srv_g_scatterplotmatrix <- function(id,
+                                    data,
+                                    reporter,
+                                    filter_panel_api,
+                                    variables,
+                                    plot_height,
+                                    plot_width,
+                                    decorators) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
   checkmate::assert_class(data, "reactive")
@@ -364,7 +387,7 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
           qenv,
           substitute(
             expr = {
-              g <- lattice::splom(
+              plot <- lattice::splom(
                 ANL,
                 varnames = varnames_value,
                 panel = function(x, y, ...) {
@@ -388,7 +411,6 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
                 alpha = alpha_value,
                 cex = cex_value
               )
-              print(g)
             },
             env = list(
               varnames_value = varnames,
@@ -407,8 +429,13 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
           qenv,
           substitute(
             expr = {
-              g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
-              g
+              plot <- lattice::splom(
+                ANL,
+                varnames = varnames_value,
+                pch = 16,
+                alpha = alpha_value,
+                cex = cex_value
+              )
             },
             env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
           )
@@ -417,7 +444,12 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
       qenv
     })
 
-    plot_r <- reactive(output_q()[["g"]])
+    decorated_output_q_no_print <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators)
+    decorated_output_q <- reactive(within(decorated_output_q_no_print(), print(plot)))
+    plot_r <- reactive({
+      req(output_q()) # Ensure original errors are displayed
+      decorated_output_q()[["plot"]]
+    })
 
     # Insert the plot into a plot_with_settings module
     pws <- teal.widgets::plot_with_settings_srv(
@@ -451,7 +483,7 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
 
     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 = "Show R Code for Scatterplotmatrix"
     )
 
@@ -470,7 +502,7 @@ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variab
           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)