Updates "Decorators" to use name-based execution and new wrappers

R/roxygen2_templates.R

@@ -0,0 +1,30 @@
+# nocov start
+roxygen_decorators_param <- function(module_name) {
+  paste(
+    sep = " ",
+    lifecycle::badge("experimental"),
+    " (`list` of `teal_transform_module`, named `list` of `teal_transform_module` or",
+    "`NULL`) optional, if not `NULL`, decorator for tables or plots included in the module.",
+    "When a named list of `teal_transform_module`, the decorators are applied to the",
+    "respective output objects.\n\n",
+    "Otherwise, the decorators are applied to all objects, which is equivalent as using the name `default`.\n\n",
+    sprintf("See section \"Decorating `%s`\"", module_name),
+    "below for more details."
+  )
+}
+
+roxygen_ggplot2_args_param <- function(...) {
+  paste(
+    sep = " ",
+    "(`ggplot2_args`) optional, object created by [`teal.widgets::ggplot2_args()`]",
+    "with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings.",
+    "The argument is merged with options variable `teal.ggplot2_args` and default module setup.\n\n",
+    sprintf(
+      "List names should match the following: `c(\"default\", %s)`.\n\n",
+      paste("\"", unlist(rlang::list2(...)), "\"", collapse = ", ", sep = "")
+    ),
+    "For more details see the vignette: `vignette(\"custom-ggplot2-arguments\", package = \"teal.widgets\")`."
+  )
+}
+
+# nocov end

R/tm_a_pca.R

@@ -13,8 +13,8 @@
 #' It controls the font size for plot titles, axis labels, and legends.
 #' - If vector of `length == 1` then the font sizes will have a fixed size.
 #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
-#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
+#' @param decorators `r roxygen_decorators_param("tm_a_pca")`
 #'
 #' @inherit shared_params return
 #'
@@ -165,7 +165,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
   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)
+  decorators <- normalize_decorators(decorators, "plot")
+  assert_decorators(decorators, null.ok = TRUE, "plot")
   # End of assertions
 
   # Make UI args
@@ -240,7 +241,7 @@ ui_a_pca <- function(id, ...) {
               choices = args$plot_choices,
               selected = args$plot_choices[1]
             ),
-            ui_transform_teal_data(ns("decorate"), transformators = args$decorators)
+            ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("plot", args$decorators))
           ),
           teal.widgets::panel_item(
             title = "Pre-processing",
@@ -975,13 +976,14 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
     })
 
-    decorated_output_q_no_print <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
-    decorated_output_q <- reactive(within(decorated_output_q_no_print(), expr = print(plot)))
+    decorated_output_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = print(plot)
+    )
 
-    plot_r <- reactive({
-      req(output_q())
-      decorated_output_q()[["plot"]]
-    })
+    plot_r <- reactive(req(decorated_output_q())[["plot"]])
 
     pws <- teal.widgets::plot_with_settings_srv(
       id = "pca_plot",

R/tm_a_regression.R

@@ -37,8 +37,8 @@
 #'     It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`
 #'     argument in `teal.widgets::optionalSliderInputValMinMax`.
 #'
-#' @templateVar ggnames `r regression_names`
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param(regression_names)`
+#' @param decorators `r roxygen_decorators_param("tm_a_regression")`
 #'
 #' @inherit shared_params return
 #'
@@ -1035,7 +1035,10 @@ srv_a_regression <- function(id,
   })
 }
 
-regression_names <- paste0(
-  '"Response vs Regressor", "Residuals vs Fitted", ',
-  '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'
+regression_names <- c(
+  "Response vs Regressor",
+  "Residuals vs Fitted",
+  "Scale-Location", "Cook's distance",
+  "Residuals vs Leverage",
+  "Cook's dist vs Leverage"
 )

R/tm_data_table.R

@@ -131,7 +131,8 @@ tm_data_table <- function(label = "Data Table",
   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)
+  decorators <- normalize_decorators(decorators, "table")
+  assert_decorators(decorators, null.ok = TRUE, "table")
   # End of assertions
 
   ans <- module(
@@ -296,7 +297,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),
+      ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("table", decorators)),
       teal.widgets::optionalSelectInput(
         ns("variables"),
         "Select variables:",
@@ -365,13 +366,15 @@ srv_data_table <- function(id,
       )
     })
 
-    decorated_data_table_data <-
-      srv_transform_teal_data("decorate", data = data_table_data, transformators = decorators)
+    decorated_data_table_data <- srv_decorate_teal_data(
+      id = "decorator",
+      data = data_table_data,
+      decorators = subset_decorators("table", decorators)
+    )
 
     output$data_table <- DT::renderDataTable(server = server_rendering, {
-      req(data_table_data())
       teal::validate_inputs(iv)
-      decorated_data_table_data()[["table"]]
+      req(decorated_data_table_data())[["table"]]
     })
   })
 }

R/tm_g_association.R

@@ -20,16 +20,15 @@
 #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
 #' Default to `"gray"`.
 #'
-#' @templateVar ggnames "Bivariate1", "Bivariate2"
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
+#' @param decorators `r roxygen_decorators_param("tm_")`
 #'
 #' @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`)
+#' - `plot` (`grob` created with [ggplot2::ggplotGrob()])
 #'
 #' For additional details and examples of decorators, refer to the vignette
 #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
@@ -176,7 +175,10 @@ 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)
+
+  decorators <- normalize_decorators(decorators, "plot")
+  assert_decorators(decorators, null.ok = TRUE, "plot")
+
   # End of assertions
 
   # Make UI args
@@ -247,7 +249,7 @@ ui_tm_g_association <- function(id, ...) {
         "Log transformed",
         value = FALSE
       ),
-      ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
+      ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("plot", args$decorators)),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           title = "Plot settings",
@@ -405,8 +407,6 @@ srv_tm_g_association <- function(id,
       # association
       ref_class_cov <- ifelse(association, ref_class, "NULL")
 
-      print_call <- quote(print(p))
-
       var_calls <- lapply(vars_names, function(var_i) {
         var_class <- class(ANL[[var_i]])[1]
         if (is.numeric(ANL[[var_i]]) && log_transformation) {
@@ -488,6 +488,7 @@ srv_tm_g_association <- function(id,
             expr = {
               plot_top <- plot_calls[[1]]
               plot_bottom <- plot_calls[[1]]
+              plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob))
             },
             env = list(
               plot_calls = do.call(
@@ -500,23 +501,19 @@ 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)
-        }
-      )
-    })
-
+    decorated_output_grob_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = {
+        grid::grid.newpage()
+        grid::grid.draw(plot)
+      }
+    )
 
     plot_r <- reactive({
       req(iv_r()$is_valid())
-      req(output_q())
-      decorated_output_grob_q()[["plot"]]
+      req(decorated_output_grob_q())[["plot"]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(

R/tm_g_bivariate.R

@@ -276,7 +276,8 @@ tm_g_bivariate <- function(label = "Bivariate Plots",
   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)
+  decorators <- normalize_decorators(decorators, "plot")
+  assert_decorators(decorators, null.ok = TRUE, "plot")
   # End of assertions
 
   # Make UI args
@@ -350,7 +351,7 @@ ui_g_bivariate <- function(id, ...) {
           justified = TRUE
         )
       ),
-      ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
+      ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("plot", args$decorators)),
       if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
         tags$div(
           class = "data-extract-box",
@@ -665,47 +666,46 @@ srv_g_bivariate <- function(id,
       teal.code::eval_code(merged$anl_q_r(), substitute(expr = plot <- cl, env = list(cl = cl)))
     })
 
-    decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
-
-    decorated_output_q_facets <- reactive({
-      ANL <- merged$anl_q_r()[["ANL"]]
-      row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
-      col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)
-
-      # Add labels to facets
-      nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)
-      nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)
-      facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))
-      without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting
-
-      print_call <- if (without_facet) {
-        quote(print(plot))
-      } else {
-        substitute(
-          expr = {
-            # Add facetting labels
-            # optional: grid.newpage() # nolint: commented_code.
-            # Prefixed with teal.modules.general as its usage will appear in "Show R code"
-            plot <- teal.modules.general::add_facet_labels(
-              plot,
-              xfacet_label = nulled_col_facet_name,
-              yfacet_label = nulled_row_facet_name
-            )
-            grid::grid.newpage()
-            grid::grid.draw(plot)
-          },
-          env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
-        )
-      }
-      decorated_output_q() %>%
-        teal.code::eval_code(print_call)
-    })
-
+    decorated_output_q_facets <- srv_decorate_teal_data(
+      "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = reactive({
+        ANL <- merged$anl_q_r()[["ANL"]]
+        row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
+        col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)
+
+        # Add labels to facets
+        nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)
+        nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)
+        facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))
+        without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting
+
+        print_call <- if (without_facet) {
+          quote(print(plot))
+        } else {
+          substitute(
+            expr = {
+              # Add facetting labels
+              # optional: grid.newpage() # nolint: commented_code.
+              # Prefixed with teal.modules.general as its usage will appear in "Show R code"
+              plot <- teal.modules.general::add_facet_labels(
+                plot,
+                xfacet_label = nulled_col_facet_name,
+                yfacet_label = nulled_row_facet_name
+              )
+              grid::grid.newpage()
+              grid::grid.draw(plot)
+            },
+            env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
+          )
+        }
+        print_call
+      }),
+      expr_is_reactive = TRUE
+    )
 
-    plot_r <- reactive({
-      req(output_q())
-      decorated_output_q_facets()[["plot"]]
-    })
+    plot_r <- reactive(req(decorated_output_q_facets())[["plot"]])
 
     pws <- teal.widgets::plot_with_settings_srv(
       id = "myplot",

R/tm_g_distribution.R

@@ -22,18 +22,35 @@
 #' and `max`.
 #' Defaults to `c(30L, 1L, 100L)`.
 #'
-#' @templateVar ggnames "Histogram", "QQplot"
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
+#' @param decorators `r roxygen_decorators_param("tm_g_distribution")`
 #'
 #' @inherit shared_params return
 #'
 #' @section Decorating `tm_outliers`:
 #'
-#' This module generates the following objects, which can be modified in place using decorators:
+#' This module generates the following objects, which can be modified in place using decorators::
 #' - `plot` (`ggplot2`)
 #' - `test_table` (`data.frame`)
 #' - `summary_table` (`data.frame`)
 #'
+#' 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_distribution(
+#'    ..., # arguments for module
+#'    decorators = list(
+#'      default = list(teal_transform_module(...)), # applied to all outputs
+#'      plot = list(teal_transform_module(...)), # applied only to `plot` output (histogram plot)
+#'      test_table = list(teal_transform_module(...)) # applied only to `test_table` output
+#'      summary_table = list(teal_transform_module(...)) # applied only to `summary_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.
 #'
@@ -184,7 +201,10 @@ tm_g_distribution <- function(label = "Distribution Module",
   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)
+  available_decorators <- c("plot", "test_table", "summary_table")
+  decorators <- normalize_decorators(decorators, available_decorators)
+  assert_decorators(decorators, null.ok = TRUE, names = available_decorators)
+
   # End of assertions
 
   # Make UI args