introduce decorators for tm_data_table

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(
@@ -172,6 +182,9 @@ ui_page_data_table <- function(id,
           )
         )
       ),
+      forms = tagList(
+        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+      ),
       pre_output = pre_output,
       post_output = post_output
     )
@@ -185,7 +198,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 +252,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 +275,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 +286,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 +299,7 @@ ui_data_table <- function(id,
   tagList(
     teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
     fluidRow(
+      ui_teal_transform_data(ns("decorate"), transformators = decorators),
       teal.widgets::optionalSelectInput(
         ns("variables"),
         "Select variables:",
@@ -305,36 +323,65 @@ 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"))
     iv$add_rule("variables", shinyvalidate::sv_in_set(
       set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
     ))
     iv$enable()
+    # teal::validate_inputs(iv)
 
-    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_teal_transform_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())
+      # no table is displayed
+      decorated_data_table_data()[["table"]]
     })
+
+    teal.widgets::verbatim_popup_srv(
+      id = "rcode",
+      verbatim_content = reactive(teal.code::get_code(req(decorated_data_table_data()))),
+      title = "R Code for PCA"
+    )
   })
 }