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

R/tm_a_pca.R

@@ -165,7 +165,14 @@ 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)
+  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+    decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", "plot"))) {
+      lapply(decorators, list)
+    } else {
+      list(default = decorators)
+    }
+  }
+  assert_decorators(decorators, null.ok = TRUE, names = c("default", "plot"))
   # End of assertions
 
   # Make UI args
@@ -240,7 +247,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 +982,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_g_bivariate.R

@@ -276,7 +276,14 @@ 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)
+  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+    decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", "plot"))) {
+      lapply(decorators, list)
+    } else {
+      list(default = decorators)
+    }
+  }
+  assert_decorators(decorators, null.ok = TRUE, names = c("default", "plot"))
   # End of assertions
 
   # Make UI args
@@ -350,7 +357,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 +672,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_response.R

@@ -201,7 +201,14 @@ tm_g_response <- function(label = "Response Plot",
   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)
+  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+    decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", "plot"))) {
+      lapply(decorators, list)
+    } else {
+      list(default = decorators)
+    }
+  }
+  assert_decorators(decorators, null.ok = TRUE, names = c("default", "plot"))
   # End of assertions
 
   # Make UI args
@@ -285,7 +292,7 @@ ui_g_response <- function(id, ...) {
         selected = ifelse(args$freq, "frequency", "density"),
         justified = TRUE
       ),
-      ui_transform_teal_data(ns("decorator"), 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",
@@ -552,13 +559,14 @@ srv_g_response <- function(id,
       teal.code::eval_code(qenv, plot_call)
     })
 
-    decorated_output_q <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators)
+    decorated_output_plot_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = print(plot)
+    )
 
-    decorated_output_plot_q <- reactive(within(decorated_output_q(), print(plot)))
-    plot_r <- reactive({
-      req(output_q()) # Ensure original errors are displayed
-      decorated_output_plot_q()[["plot"]]
-    })
+    plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])
 
     # Insert the plot into a plot_with_settings module from teal.widgets
     pws <- teal.widgets::plot_with_settings_srv(

R/tm_g_scatterplot.R

@@ -307,7 +307,16 @@ tm_g_scatterplot <- function(label = "Scatterplot",
 
   checkmate::assert_scalar(table_dec)
   checkmate::assert_class(ggplot2_args, "ggplot2_args")
-  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
+
+  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+    decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", "plot"))) {
+      lapply(decorators, list)
+    } else {
+      list(default = decorators)
+    }
+  }
+  assert_decorators(decorators, null.ok = TRUE, names = c("default", "plot"))
+
   # End of assertions
 
   # Make UI args
@@ -430,7 +439,7 @@ ui_g_scatterplot <- function(id, ...) {
             is_single_dataset = is_single_dataset_value
           )
         },
-        ui_transform_teal_data(ns("decorator"), 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",
@@ -1005,12 +1014,14 @@ srv_g_scatterplot <- function(id,
       teal.code::eval_code(plot_q, plot_call)
     })
 
-    decorated_output_q <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators)
-    decorated_output_plot_q <- reactive(within(decorated_output_q(), print(plot)))
-    plot_r <- reactive({
-      req(output_q()) # Ensure original errors are displayed
-      decorated_output_plot_q()[["plot"]]
-    })
+    decorated_output_plot_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = print(plot)
+    )
+
+    plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])
 
     # Insert the plot into a plot_with_settings module from teal.widgets
     pws <- teal.widgets::plot_with_settings_srv(

R/tm_g_scatterplotmatrix.R

@@ -202,7 +202,15 @@ 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)
+
+  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+    decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", "plot"))) {
+      lapply(decorators, list)
+    } else {
+      list(default = decorators)
+    }
+  }
+  assert_decorators(decorators, null.ok = TRUE, names = c("default", "plot"))
   # End of assertions
 
   # Make UI args
@@ -249,7 +257,7 @@ ui_g_scatterplotmatrix <- function(id, ...) {
         is_single_dataset = is_single_dataset_value
       ),
       tags$hr(),
-      ui_transform_teal_data(ns("decorator"), 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",
@@ -444,12 +452,14 @@ srv_g_scatterplotmatrix <- function(id,
       qenv
     })
 
-    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"]]
-    })
+    decorated_output_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = print(plot)
+    )
+
+    plot_r <- reactive(req(decorated_output_q())[["plot"]])
 
     # Insert the plot into a plot_with_settings module
     pws <- teal.widgets::plot_with_settings_srv(

R/utils.R

@@ -286,19 +286,21 @@ assert_single_selection <- function(x,
 #' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration.
 #' When an expression it must be inline code. See [within()]
 #' Default is `NULL` which won't evaluate any appending code.
+#' @param expr_is_reactive ()
 #' @details
 #' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
 #' allows to decorate the data with additional expressions.
 #' When original `teal_data` object is in error state, it will show that error
 #' first.
 #'
 #' @keywords internal
-srv_decorate_teal_data <- function(id, data, decorators, expr) {
+srv_decorate_teal_data <- function(id, data, decorators, expr, expr_is_reactive = FALSE) {
   assert_reactive(data)
   checkmate::assert_list(decorators, "teal_transform_module")
+  checkmate::assert_flag(expr_is_reactive)
 
   missing_expr <- missing(expr)
-  if (!missing_expr) {
+  if (!missing_expr && !expr_is_reactive) {
     expr <- rlang::enexpr(expr)
   }
 
@@ -310,6 +312,8 @@ srv_decorate_teal_data <- function(id, data, decorators, expr) {
       req(data(), decorated_output())
       if (missing_expr) {
         decorated_output()
+      } else if (expr_is_reactive) {
+        eval_code(decorated_output(), expr())
       } else {
         eval_code(decorated_output(), expr)
       }