904 teal_data in teal_module (#924)

Closes #904 Added `as_tdata` function to convert the data object received by modules from `teal_data` to `tdata` class. Modified `srv_nested_tabs.teal_module` now returns a `teal_data`. To make a module handle a `teal_data` object without (much) modification, the incoming `data` argument should be downgraded to the old class. ``` data <- as_tdata(data) ``` Also modified `example_module` to handle `teal_data` objects. --------- Co-authored-by: go_gonzo <[email protected]> Co-authored-by: Dony Unardi <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
insightsengineering · Nov 22, 2023 · e7ab218 · e7ab218
1 parent 50bbab6
commit e7ab218
Show file tree

Hide file tree

Showing 18 changed files with 182 additions and 114 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -18,6 +18,7 @@ S3method(ui_nested_tabs,teal_modules)
 export("%>%")
 export(TealReportCard)
 export(as.teal_slices)
+export(as_tdata)
 export(example_module)
 export(get_code_tdata)
 export(get_metadata)

diff --git a/NEWS.md b/NEWS.md
@@ -5,6 +5,7 @@
 * `data` argument in `init` now accepts `teal_data` and `teal_data_module`.
 * Added `landing_popup_module` function which creates a module that will display a popup when the app starts. The popup will block access to the app until it is dismissed.
 * Filter state snapshots can now be uploaded from file. See `?snapshot`.
+* Added `as_tdata` function to facilitate migration of modules to the new `teal_data` class.
 
 ### Miscellaneous
 

diff --git a/R/dummy_functions.R b/R/dummy_functions.R
@@ -79,8 +79,8 @@ example_datasets <- function() { # nolint
 #' @examples
 #' app <- init(
 #'   data = teal_data(
-#'     dataset("IRIS", iris),
-#'     dataset("MTCARS", mtcars)
+#'     IRIS = iris,
+#'     MTCARS = mtcars
 #'   ),
 #'   modules = example_module()
 #' )
@@ -93,12 +93,12 @@ example_module <- function(label = "example teal module", datanames = "all") {
   module(
     label,
     server = function(id, data) {
-      checkmate::assert_class(data, "tdata")
+      checkmate::assert_class(data(), "teal_data")
       moduleServer(id, function(input, output, session) {
-        output$text <- renderPrint(data[[input$dataname]]())
+        output$text <- renderPrint(data()[[input$dataname]])
         teal.widgets::verbatim_popup_srv(
           id = "rcode",
-          verbatim_content = attr(data, "code")(),
+          verbatim_content = reactive(teal.code::get_code(data())),
           title = "Association Plot"
         )
       })
@@ -108,7 +108,7 @@ example_module <- function(label = "example teal module", datanames = "all") {
       teal.widgets::standard_layout(
         output = verbatimTextOutput(ns("text")),
         encoding = div(
-          selectInput(ns("dataname"), "Choose a dataset", choices = names(data)),
+          selectInput(ns("dataname"), "Choose a dataset", choices = teal.data::datanames(data)),
           teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
         )
       )

diff --git a/R/init.R b/R/init.R
@@ -54,13 +54,10 @@
 #' @include modules.R
 #'
 #' @examples
-#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
-#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
-#'
 #' app <- init(
 #'   data = teal_data(
-#'     dataset("new_iris", new_iris),
-#'     dataset("new_mtcars", new_mtcars),
+#'     new_iris = transform(iris, id = seq_len(nrow(iris))),
+#'     new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),
 #'     code = "
 #'       new_iris <- transform(iris, id = seq_len(nrow(iris)))
 #'       new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
@@ -78,7 +75,7 @@
 #'       "Iris Sepal.Length histogram",
 #'       server = function(input, output, session, data) {
 #'         output$hist <- renderPlot(
-#'           hist(data[["new_iris"]]()$Sepal.Length)
+#'           hist(data()[["new_iris"]]$Sepal.Length)
 #'         )
 #'       },
 #'       ui = function(id, ...) {

diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R
@@ -243,7 +243,7 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
     }
 
     if (is_arg_used(modules$server, "data")) {
-      data <- .datasets_to_data(modules, datasets, trigger_data)
+      data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))
       args <- c(args, data = list(data))
     }
 
@@ -285,17 +285,12 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
 #'
 #' @param module (`teal_module`) module where needed filters are taken from
 #' @param datasets (`FilteredData`) object where needed data are taken from
-#' @param trigger_data (`reactiveVal`) to trigger getting the filtered data
-#' @return list of reactive datasets with following attributes:
-#' - `code` (`character`) containing datasets reproducible code.
-#' - `join_keys` (`join_keys`) containing relationships between datasets.
-#' - `metadata` (`list`) containing metadata of datasets.
+#' @return A `tdata` object.
 #'
 #' @keywords internal
-.datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+.datasets_to_data <- function(module, datasets) {
   checkmate::assert_class(module, "teal_module")
   checkmate::assert_class(datasets, "FilteredData")
-  checkmate::assert_class(trigger_data, "reactiveVal")
 
   datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
     datasets$datanames()
@@ -304,31 +299,20 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
   }
 
   # list of reactive filtered data
-  data <- sapply(
-    datanames,
-    function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)),
-    simplify = FALSE
-  )
+  data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
 
   hashes <- calculate_hashes(datanames, datasets)
-  metadata <- lapply(datanames, datasets$get_metadata)
-  names(metadata) <- datanames
-
-  new_tdata(
-    data,
-    eventReactive(
-      trigger_data(),
-      {
-        c(
-          get_rcode_str_install(),
-          get_rcode_libraries(),
-          get_datasets_code(datanames, datasets, hashes),
-          teal.slice::get_filter_expr(datasets, datanames)
-        )
-      }
-    ),
-    datasets$get_join_keys(),
-    metadata
+
+  code <- c(
+    get_rcode_str_install(),
+    get_rcode_libraries(),
+    get_datasets_code(datanames, datasets, hashes),
+    teal.slice::get_filter_expr(datasets, datanames)
+  )
+
+  do.call(
+    teal.data::teal_data,
+    args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))
   )
 }
 

diff --git a/R/module_teal_with_splash.R b/R/module_teal_with_splash.R
@@ -29,7 +29,6 @@ ui_teal_with_splash <- function(id,
   # We use delayed loading in all cases, even when the data does not need to be fetched.
   # This has the benefit that when filtering the data takes a lot of time initially, the
   # Shiny app does not time out.
-
   splash_ui <- if (inherits(data, "teal_data_module")) {
     data$ui(ns("teal_data_module"))
   } else if (inherits(data, "teal_data")) {

diff --git a/R/modules.R b/R/modules.R
@@ -22,7 +22,7 @@
 #' library(shiny)
 #'
 #' app <- init(
-#'   data = teal_data(dataset("iris", iris)),
+#'   data = teal_data(iris = iris),
 #'   modules = modules(
 #'     label = "Modules",
 #'     modules(
@@ -199,7 +199,7 @@ is_arg_used <- function(modules, arg) {
 #' library(shiny)
 #'
 #' app <- init(
-#'   data = teal_data(dataset("iris", iris)),
+#'   data = teal_data(iris = iris),
 #'   modules = list(
 #'     module(
 #'       label = "Module",

diff --git a/R/tdata.R b/R/tdata.R
@@ -20,6 +20,9 @@
 #' @param metadata A `named list` each element contains a list of metadata about the named data.frame
 #' Each element of these list should be atomic and length one.
 #' @return A `tdata` object
+#'
+#' @seealso `as_tdata`
+#'
 #' @examples
 #'
 #' data <- new_tdata(
@@ -157,3 +160,48 @@ get_metadata.tdata <- function(data, dataname) {
 get_metadata.default <- function(data, dataname) {
   stop("get_metadata function not implemented for this object")
 }
+
+
+#' Downgrade `teal_data` objects in modules for compatibility.
+#'
+#' Convert `teal_data` to `tdata` in `teal` modules.
+#'
+#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
+#' to be passed to the `data` argument but instead they receive a `teal_data` object,
+#' which is additionally wrapped in a reactive expression in the server functions.
+#' In order to easily adapt such modules without a proper refactor,
+#' use this function to downgrade the `data` argument.
+#'
+#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression
+#'
+#' @return Object of class `tdata`.
+#'
+#' @examples
+#' td <- teal_data()
+#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)
+#' td
+#' as_tdata(td)
+#' as_tdata(reactive(td))
+#'
+#' @export
+#' @rdname tdata_deprecation
+#'
+as_tdata <- function(x) {
+  if (inherits(x, "tdata")) {
+    return(x)
+  }
+  if (is.reactive(x)) {
+    checkmate::assert_class(isolate(x()), "teal_data")
+    datanames <- isolate(teal.data::datanames(x()))
+    datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
+    code <- reactive(teal.code::get_code(x()))
+    join_keys <- isolate(teal.data::join_keys(x()))
+  } else if (inherits(x, "teal_data")) {
+    datanames <- teal.data::datanames(x)
+    datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
+    code <- reactive(teal.code::get_code(x))
+    join_keys <- isolate(teal.data::join_keys(x))
+  }
+
+  new_tdata(data = datasets, code = code, join_keys = join_keys)
+}
diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -114,6 +114,7 @@ reference:
       - landing_popup_module
   - title: Functions for Module Developers
     contents:
+      - as_tdata
       - tdata
       - get_code_tdata
       - get_metadata

diff --git a/man/dot-datasets_to_data.Rd b/man/dot-datasets_to_data.Rd
diff --git a/man/example_module.Rd b/man/example_module.Rd
diff --git a/man/init.Rd b/man/init.Rd
diff --git a/man/module.Rd b/man/module.Rd
diff --git a/man/modules.Rd b/man/modules.Rd
diff --git a/man/tdata.Rd b/man/tdata.Rd
diff --git a/man/tdata_deprecation.Rd b/man/tdata_deprecation.Rd