From 59da2e1926f09cab83c2d8b9c3ef0f1c6e69068d Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 12:18:22 +0200 Subject: [PATCH 1/8] add hydrate_function --- R/utils.R | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/R/utils.R b/R/utils.R index 5876abcab..75601af1d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -278,3 +278,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 +} From 55dc29e104f31188e71f581b3a36ad082a15b5d1 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 12:18:51 +0200 Subject: [PATCH 2/8] upgrade rlang dependency --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 190de8b63..f7cbefd73 100644 --- a/DESCRIPTION +++ b/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), shinytest2, sparkline, From e2a1a40f24b7bec5a914a162192238dd5f784230 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 12:20:12 +0200 Subject: [PATCH 3/8] isolate card function and add arguments in tm_g_distribution --- R/tm_g_distribution.R | 76 ++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 758db9038..1db204018 100644 --- a/R/tm_g_distribution.R +++ b/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,39 @@ 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) } ### }) } + +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 +} From 676b2af48b34881fd997784af5a831a74a18142e Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 12:37:56 +0200 Subject: [PATCH 4/8] amend documentation --- R/utils.R | 4 ++++ man/hydrate_function.Rd | 41 ++++++++++++++++++++++++++++++++++++++++ man/shared_params.Rd | 4 ++++ man/tm_g_distribution.Rd | 11 ++++++++--- 4 files changed, 57 insertions(+), 3 deletions(-) create mode 100644 man/hydrate_function.Rd diff --git a/R/utils.R b/R/utils.R index 75601af1d..dd95f1b42 100644 --- a/R/utils.R +++ b/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 diff --git a/man/hydrate_function.Rd b/man/hydrate_function.Rd new file mode 100644 index 000000000..75346370c --- /dev/null +++ b/man/hydrate_function.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{hydrate_function} +\alias{hydrate_function} +\title{Hydrate a function's enclosing environment} +\usage{ +hydrate_function(fun, ..., caller_env = parent.frame()) +} +\arguments{ +\item{fun}{(\code{function})} + +\item{...}{additional variables to add to the new enclosure, see \code{Details}} + +\item{caller_env}{(\code{environment}) environment to hydrate \code{fun}'s enclosure with} +} +\value{ +A \code{function} which will work just like \code{fun} but in a different scope. +} +\description{ +Add bindings of an environment to a function's parent environment. +} +\details{ +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 \emph{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 \code{shiny} modules because \code{moduleServer} is called +by the module server function so the server funciton's arguments are in scope +of \code{moduleServer} but are not bindings in its environment. +Such variables should be passed to \code{...}. +As in the case of calling environment bindings, no overwriting will occur. + +Variables passed to \code{...} ass \code{name:value} pairs will be assigned with \code{value} under \code{name}. +Variables passed directly will be assigned under the same name. + +Note that the \code{caller_env} argument must be passed named, otherwise it will be captured by \code{...}. +} +\keyword{internal} diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 1ea6b7094..8009e40af 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -47,6 +47,10 @@ vector of \code{value}, \code{min}, and \code{max}. \item When the length of \code{size} is three: the plot points size are dynamically adjusted based on vector of \code{value}, \code{min}, and \code{max}. }} + +\item{card_function}{(\code{function}) optional, custom function to create a report card. +See \href{https://insightsengineering.github.io/teal/latest-tag/articles/adding-support-for-reporting.html}{this vignette} +for details.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 033161a0c..12d74e707 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -16,7 +16,8 @@ tm_g_distribution( plot_height = c(600, 200, 2000), plot_width = NULL, pre_output = NULL, - post_output = NULL + post_output = NULL, + card_function ) } \arguments{ @@ -59,11 +60,15 @@ Defaults to \code{c(30L, 1L, 100L)}. \item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of \code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} -\item{pre_output}{(\code{shiny.tag}) optional,\cr +\item{pre_output}{(\code{shiny.tag}, optional)\cr with text placed before the output to put the output into context. For example a title.} -\item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output +\item{post_output}{(\code{shiny.tag}, optional) with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} + +\item{card_function}{(\code{function}) optional, custom function to create a report card. +See \href{https://insightsengineering.github.io/teal/latest-tag/articles/adding-support-for-reporting.html}{this vignette} +for details.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. From 180be37d661fd77b7f36c985034994cdcab28f70 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 12:45:09 +0200 Subject: [PATCH 5/8] amend NEWS --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 3e849c1a7..0d6833564 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # teal.modules.general 0.3.0.9008 +* Users can now provide their own card functions to specify the content that modules send to reports. + # teal.modules.general 0.3.0 ### Enhancements From d13fb79ae13ba4dd07aef42572f1ffa7f848dfe3 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 19 Apr 2024 13:06:52 +0200 Subject: [PATCH 6/8] add missing roxygen tag --- R/tm_g_distribution.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 1db204018..757952feb 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -1297,6 +1297,7 @@ srv_distribution <- function(id, }) } +#' @keywords internal tm_g_distribution_card_function <- function(comment, label) { #nolint: object_length. card <- teal::report_card_template( title = "Distribution Plot", From e2f51bb110c45999b05568cbb56cdd0b0e764ab9 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 22 Apr 2024 18:10:45 +0200 Subject: [PATCH 7/8] improve argument name --- R/utils.R | 12 ++++++------ man/hydrate_function.Rd | 6 +++--- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/R/utils.R b/R/utils.R index dd95f1b42..5e8877afd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -303,23 +303,23 @@ assert_single_selection <- function(x, #' 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 `...`. +#' Note that the `added_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 +#' @param added_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()) { +hydrate_function <- function(fun, ..., added_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) + added_vars <- setdiff(names(added_env), names(enclos_env)) + lapply(added_vars, function(nm) { + assign(nm, get0(nm, envir = added_env, inherits = FALSE), envir = env_new) }) args <- list(...) diff --git a/man/hydrate_function.Rd b/man/hydrate_function.Rd index 75346370c..f59daa535 100644 --- a/man/hydrate_function.Rd +++ b/man/hydrate_function.Rd @@ -4,14 +4,14 @@ \alias{hydrate_function} \title{Hydrate a function's enclosing environment} \usage{ -hydrate_function(fun, ..., caller_env = parent.frame()) +hydrate_function(fun, ..., added_env = parent.frame()) } \arguments{ \item{fun}{(\code{function})} \item{...}{additional variables to add to the new enclosure, see \code{Details}} -\item{caller_env}{(\code{environment}) environment to hydrate \code{fun}'s enclosure with} +\item{added_env}{(\code{environment}) environment to hydrate \code{fun}'s enclosure with} } \value{ A \code{function} which will work just like \code{fun} but in a different scope. @@ -36,6 +36,6 @@ As in the case of calling environment bindings, no overwriting will occur. Variables passed to \code{...} ass \code{name:value} pairs will be assigned with \code{value} under \code{name}. Variables passed directly will be assigned under the same name. -Note that the \code{caller_env} argument must be passed named, otherwise it will be captured by \code{...}. +Note that the \code{added_env} argument must be passed named, otherwise it will be captured by \code{...}. } \keyword{internal} From 76c118dd31de42ea65da5fecd2cb366a97b8e33a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 24 Apr 2024 10:21:03 +0200 Subject: [PATCH 8/8] fix documentation --- R/tm_g_distribution.R | 2 +- man/tm_g_distribution.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 757952feb..fd6b4cbd8 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -39,7 +39,7 @@ #' #' app <- init( #' data = data, -#' modules = list( +#' modules = modules( #' tm_g_distribution( #' dist_var = data_extract_spec( #' dataname = "iris", diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 12d74e707..4bf929234 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -90,7 +90,7 @@ datanames(data) <- "iris" app <- init( data = data, - modules = list( + modules = modules( tm_g_distribution( dist_var = data_extract_spec( dataname = "iris",