736 Allow custom card functions in modules

DESCRIPTION

@@ -35,6 +35,7 @@ Imports:
     DT (>= 0.13),
     forcats (>= 1.0.0),
     grid,
+    rlang (>= 1.0.0),
     scales,
     shinyjs,
     shinyTree (>= 0.2.8),
@@ -68,7 +69,6 @@ Suggests:
     logger (>= 0.2.0),
     MASS,
     nestcolor (>= 0.1.0),
-    rlang (>= 1.0.0),
     rtables (>= 0.6.6),
     rvest,
     shinytest2,

NEWS.md

@@ -1,5 +1,7 @@
 # teal.modules.general 0.3.0.9020
 
+* Users can now provide their own card functions to specify the content that modules send to reports.
+
 # teal.modules.general 0.3.0
 
 ### Enhancements

R/tm_g_distribution.R

@@ -118,7 +118,8 @@ tm_g_distribution <- function(label = "Distribution Module",
                               plot_height = c(600, 200, 2000),
                               plot_width = NULL,
                               pre_output = NULL,
-                              post_output = NULL) {
+                              post_output = NULL,
+                              card_function) {
   message("Initializing tm_g_distribution")
 
   # Requires Suggested packages
@@ -169,6 +170,12 @@ 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)
+
+  if (missing(card_function)) {
+    card_function <- tm_g_distribution_card_function
+  } else {
+    checkmate::assert_function(card_function)
+  }
   # End of assertions
 
   # Make UI args
@@ -185,7 +192,7 @@ tm_g_distribution <- function(label = "Distribution Module",
     server = srv_distribution,
     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, card_function = card_function) # nolint: line_length.
     ),
     ui = ui_distribution,
     ui_args = args,
@@ -351,7 +358,8 @@ srv_distribution <- function(id,
                              group_var,
                              plot_height,
                              plot_width,
-                             ggplot2_args) {
+                             ggplot2_args,
+                             card_function) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
   checkmate::assert_class(data, "reactive")
@@ -1282,37 +1290,40 @@ srv_distribution <- function(id,
 
     ### REPORTER
     if (with_reporter) {
-      card_fun <- function(comment, label) {
-        card <- teal::report_card_template(
-          title = "Distribution Plot",
-          label = label,
-          with_filter = with_filter,
-          filter_panel_api = filter_panel_api
-        )
-        card$append_text("Plot", "header3")
-        if (input$tabs == "Histogram") {
-          card$append_plot(dist_r(), dim = pws1$dim())
-        } else if (input$tabs == "QQplot") {
-          card$append_plot(qq_r(), dim = pws2$dim())
-        }
-        card$append_text("Statistics table", "header3")
-
-        card$append_table(common_q()[["summary_table"]])
-        tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")
-        if (inherits(tests_error, "data.frame")) {
-          card$append_text("Tests table", "header3")
-          card$append_table(tests_r())
-        }
-
-        if (!comment == "") {
-          card$append_text("Comment", "header3")
-          card$append_text(comment)
-        }
-        card$append_src(teal.code::get_code(output_q()))
-        card
-      }
-      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+      card_function <- hydrate_function(card_function, with_filter, filter_panel_api)
+      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_function)
     }
     ###
   })
 }
+
+#' @keywords internal
+tm_g_distribution_card_function <- function(comment, label) { #nolint: object_length.
+  card <- teal::report_card_template(
+    title = "Distribution Plot",
+    label = label,
+    with_filter = with_filter,
+    filter_panel_api = filter_panel_api
+  )
+  card$append_text("Plot", "header3")
+  if (input$tabs == "Histogram") {
+    card$append_plot(dist_r(), dim = pws1$dim())
+  } else if (input$tabs == "QQplot") {
+    card$append_plot(qq_r(), dim = pws2$dim())
+  }
+  card$append_text("Statistics table", "header3")
+
+  card$append_table(common_q()[["summary_table"]])
+  tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")
+  if (inherits(tests_error, "data.frame")) {
+    card$append_text("Tests table", "header3")
+    card$append_table(tests_r())
+  }
+
+  if (!comment == "") {
+    card$append_text("Comment", "header3")
+    card$append_text(comment)
+  }
+  card$append_src(teal.code::get_code(output_q()))
+  card
+}

R/utils.R

@@ -35,6 +35,10 @@
 #' - When the length of `size` is three: the plot points size are dynamically adjusted based on
 #' vector of `value`, `min`, and `max`.
 #'
+#' @param card_function (`function`) optional, custom function to create a report card.
+#' See [this vignette](https://insightsengineering.github.io/teal/latest-tag/articles/adding-support-for-reporting.html)
+#' for details.
+#'
 #' @return Object of class `teal_module` to be used in `teal` applications.
 #'
 #' @name shared_params
@@ -278,3 +282,56 @@ assert_single_selection <- function(x,
   }
   invisible(TRUE)
 }
+
+#' Hydrate a function's enclosing environment
+#'
+#' Add bindings of an environment to a function's parent environment.
+#'
+#' This allows any funciton to use bindings present in any environment
+#' as if the funciton were defined there.
+#' All bindings of the additional environment are added to the function's enclosure,
+#' except bindings existing in the enclosure are _not_ overwritten.
+#'
+#' One may also want to add variables that are not bound in the caller
+#' but are accessible from the caller, e.g. they exist in the caller's parent frame.
+#' This may happen in `shiny` modules because `moduleServer` is called
+#' by the module server function so the server funciton's arguments are in scope
+#' of `moduleServer` but are not bindings in its environment.
+#' Such variables should be passed to `...`.
+#' As in the case of calling environment bindings, no overwriting will occur.
+#'
+#' Variables passed to `...` ass `name:value` pairs will be assigned with `value` under `name`.
+#' Variables passed directly will be assigned under the same name.
+#'
+#' Note that the `caller_env` argument must be passed named, otherwise it will be captured by `...`.
+#'
+#' @param fun (`function`)
+#' @param ... additional variables to add to the new enclosure, see `Details`
+#' @param caller_env (`environment`) environment to hydrate `fun`'s enclosure with
+#'
+#' @return A `function` which will work just like `fun` but in a different scope.
+#'
+#' @keywords internal
+#'
+hydrate_function <- function(fun, ..., caller_env = parent.frame()) {
+  enclos_env <- environment(fun)
+  env_new <- rlang::env_clone(enclos_env)
+
+  caller_vars <- setdiff(names(caller_env), names(enclos_env))
+  lapply(caller_vars, function(nm) {
+    assign(nm, get0(nm, envir = caller_env, inherits = FALSE), envir = env_new)
+  })
+
+  args <- list(...)
+  arg_names <- vapply(as.list(substitute(list(...)))[-1L], as.character, character(1L))
+  names(arg_names)[names(arg_names) == ""] <- arg_names[names(arg_names) == ""]
+  names(args) <- arg_names
+
+  extras <- setdiff(arg_names, names(enclos_env))
+  lapply(extras, function(nm) {
+    assign(nm, args[[nm]], envir = env_new)
+  })
+
+  environment(fun) <- env_new
+  fun
+}