904 teal_data in teal_module

R/init.R

@@ -114,9 +114,11 @@ init <- function(data,
                  footer = tags$p(),
                  id = character(0)) {
   logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
-  data <- teal.data::to_relational_data(data = data)
+  if (!inherits(data, c("TealData", "tdata", "ddl"))) {
+    data <- teal.data::to_relational_data(data = data)
+  }
 
-  checkmate::assert_class(data, "TealData")
+  checkmate::assert_multi_class(data, c("TealData", "tdata", "ddl"))
   checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
   checkmate::assert_string(title, null.ok = TRUE)
   checkmate::assert(
@@ -138,7 +140,7 @@ init <- function(data,
 
   # resolve modules datanames
   datanames <- teal.data::get_dataname(data)
-  join_keys <- data$get_join_keys()
+  join_keys <- teal.data::get_join_keys(data)
   resolve_modules_datanames <- function(modules) {
     if (inherits(modules, "teal_modules")) {
       modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)
@@ -147,6 +149,18 @@ init <- function(data,
       modules$datanames <- if (identical(modules$datanames, "all")) {
         datanames
       } else if (is.character(modules$datanames)) {
+        extra_datanames <- setdiff(modules$datanames, datanames)
+        if (length(extra_datanames)) {
+          stop(
+            sprintf(
+              "Module %s has datanames that are not available in a 'data':\n %s not in %s",
+              modules$label,
+              toString(extra_datanames),
+              toString(datanames)
+            )
+          )
+        }
+
         datanames_adjusted <- intersect(modules$datanames, datanames)
         include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
       }
@@ -213,7 +227,9 @@ init <- function(data,
     ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
     server = function(input, output, session) {
       # copy object so that load won't be shared between the session
-      data <- data$copy(deep = TRUE)
+      if (inherits(data, "TealDataAbstract")) {
+        data <- data$copy(deep = TRUE)
+      }
       filter <- deep_copy_filter(filter)
       srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)
     }

R/module_nested_tabs.R

@@ -220,13 +220,11 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
     # We want to recalculate only visible modules
     # - trigger the data when the tab is selected
     # - trigger module to be called when the tab is selected for the first time
-    trigger_data <- reactiveVal(1L)
     trigger_module <- reactiveVal(NULL)
     output$data_reactive <- renderUI({
       lapply(datasets$datanames(), function(x) {
         datasets$get_data(x, filtered = TRUE)
       })
-      isolate(trigger_data(trigger_data() + 1))
       isolate(trigger_module(TRUE))
 
       NULL
@@ -243,7 +241,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 <- reactive(.datasets_to_data(modules, datasets))
       args <- c(args, data = list(data))
     }
 
@@ -285,44 +283,33 @@ 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` (`JoinKeys`) 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)) datasets$datanames() else module$datanames
 
   # list of reactive filtered data
   data <- sapply(
     datanames,
-    function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)),
+    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(
+  teal.data::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)
-      )
+    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
+    datasets$get_join_keys()
   )
 }
 

R/module_teal.R

@@ -162,10 +162,7 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
 
     # loading the data -----
     env <- environment()
-    datasets_reactive <- reactive({
-      if (is.null(raw_data())) {
-        return(NULL)
-      }
+    datasets_reactive <- eventReactive(raw_data(), ignoreNULL = TRUE, {
       env$progress <- shiny::Progress$new(session)
       env$progress$set(0.25, message = "Setting data")
 
@@ -184,26 +181,9 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
         } else if (isTRUE(attr(filter, "module_specific"))) {
           # we should create FilteredData even if modules$datanames is null
           # null controls a display of filter panel but data should be still passed
-          datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames
-          data_objects <- sapply(
-            datanames,
-            function(dataname) {
-              dataset <- raw_data()$get_dataset(dataname)
-              list(
-                dataset = dataset$get_raw_data(),
-                metadata = dataset$get_metadata(),
-                label = dataset$get_dataset_label()
-              )
-            },
-            simplify = FALSE
-          )
-          datasets_module <- teal.slice::init_filtered_data(
-            data_objects,
-            join_keys = raw_data()$get_join_keys(),
-            code = raw_data()$get_code_class(),
-            check = raw_data()$get_check()
-          )
-
+          datanames <- if (is.null(modules$datanames)) teal.data::get_dataname(raw_data()) else modules$datanames
+          # todo: subset tdata object to datanames
+          datasets_module <- teal.slice::init_filtered_data(raw_data())
           # set initial filters
           slices <- Filter(x = filter, f = function(x) {
             x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&

R/module_teal_with_splash.R

@@ -22,16 +22,18 @@ ui_teal_with_splash <- function(id,
                                 title,
                                 header = tags$p("Add Title Here"),
                                 footer = tags$p("Add Footer Here")) {
-  checkmate::assert_class(data, "TealDataAbstract")
-  is_pulled_data <- teal.data::is_pulled(data)
+  checkmate::assert_multi_class(data, c("TealDataAbstract", "tdata", "ddl"))
   ns <- NS(id)
 
   # Startup splash screen for delayed loading
   # 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 (is_pulled_data) {
-    # blank ui if data is already pulled
+  splash_ui <- if (inherits(data, "tdata")) {
+    div()
+  } else if (inherits(data, "ddl")) {
+    data$ui(ns("startapp_module"))
+  } else if (teal.data::is_pulled(data)) {
     div()
   } else {
     message("App was initialized with delayed data loading.")
@@ -55,7 +57,7 @@ ui_teal_with_splash <- function(id,
 #' @return `reactive`, return value of [srv_teal()]
 #' @export
 srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
-  checkmate::assert_class(data, "TealDataAbstract")
+  checkmate::assert_multi_class(data, c("TealDataAbstract", "tdata", "ddl"))
   moduleServer(id, function(input, output, session) {
     logger::log_trace(
       "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
@@ -65,19 +67,24 @@ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
       shinyjs::showLog()
     }
 
-    is_pulled_data <- teal.data::is_pulled(data)
     # raw_data contains TealDataAbstract, i.e. R6 object and container for data
     # reactive to get data through delayed loading
     # we must leave it inside the server because of callModule which needs to pick up the right session
-    if (is_pulled_data) {
-      raw_data <- reactiveVal(data) # will trigger by setting it
+    raw_data <- if (inherits(data, "tdata")) {
+      reactiveVal(data)
+    } else if (inherits(data, "ddl")) {
+      data$server("startapp_module", data)
+    } else if (teal.data::is_pulled(data)) {
+      reactiveVal(data) # will trigger by setting it
     } else {
       raw_data <- data$get_server()(id = "startapp_module")
       if (!is.reactive(raw_data)) {
         stop("The delayed loading module has to return a reactive object.")
       }
+      raw_data
     }
 
+
     res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)
     logger::log_trace(
       "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."

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 `tdata_deprecation`
+#'
 #' @examples
 #'
 #' data <- new_tdata(
@@ -171,3 +174,50 @@ get_metadata.tdata <- function(data, dataname) {
 get_metadata.default <- function(data, dataname) {
   stop("get_metadata function not implemented for this object")
 }
+
+
+#' Upgrade or downgrade `tdata` class.
+#'
+#' Convert between `teal::tdata` `teal.data::tdata` classes.
+#'
+#' Functions to switch between `tdata` classes during deprecation of the `tdata` class defined in `teal`.
+#' `.tdata_upgrade` converts object of class `tdata` as defined in `teal` package
+#' (list of reactive expressions, each containing one data set, with a `code` attribute)
+#' to object of class `tdata` as defined in package `teal.data` (extensions of class `qenv` as defined in `teal.code`).
+#' `.tdata_downgrade` does the reverse.
+#'
+#' Note the `metadata` attribute is discarded.
+#'
+#' @param (`tdata`) `tdata` object (old or new class)
+#'
+#' @return Object of class `tdata`: new for `.tdata_upgrade` and old for `.tdata_downgrade`.
+#'
+#' @keywords internal
+#' @rdname tdata_deprecation
+#'
+.tdata_upgrade <- function(x) {
+  checkmate::assert_class(x, "tdata")
+
+  if (inherits(x, "qenv")) return(x)
+
+  teal.data::new_tdata(
+    lapply(x[names(x)], function(x) isolate(x())),
+    code = isolate(attr(x, "code")()),
+    keys = Find(Negate(is.null), list(attr(x, "join_keys"), teal.data::join_keys()))
+  )
+}
+
+#' @keywords internal
+#' @rdname tdata_deprecation
+#'
+.tdata_downgrade <- function(x) {
+  checkmate::assert_class(x, "tdata")
+
+  if (!inherits(x, "qenv")) return(x)
+
+  teal::new_tdata(
+    data = as.list(x@env),
+    code = teal.code::get_code(x),
+    join_keys = teal.data::get_join_keys(x)
+  )
+}

tests/testthat/test-tdata.R

@@ -218,3 +218,83 @@ testthat::test_that("get_join_keys returns JoinKeys object if it exists inside t
 
   testthat::expect_equal(get_join_keys(my_tdata), jk)
 })
+
+
+# tdata conversions ----
+datasets <- list(iris = iris, mtcars = mtcars)
+code <- c("iris <- iris", "mtcars <- mtcars")
+tdata_old <- teal::new_tdata(datasets, code)
+tdata_new <- teal.data::new_tdata(datasets, code)
+
+testthat::test_that("functions accept both versions of tdata class", {
+  testthat::expect_no_error(.tdata_upgrade(tdata_old))
+  testthat::expect_no_error(.tdata_upgrade(tdata_new))
+  testthat::expect_no_error(.tdata_downgrade(tdata_old))
+  testthat::expect_no_error(.tdata_downgrade(tdata_new))
+})
+
+testthat::test_that("classes are changed when appropriate", {
+  tdata_old_upgraded <- .tdata_upgrade(tdata_old)
+  tdata_new_upgraded <- .tdata_upgrade(tdata_new)
+  tdata_old_downgraded <- .tdata_downgrade(tdata_old)
+  tdata_new_downgraded <- .tdata_downgrade(tdata_new)
+
+  testthat::expect_identical(tdata_old, tdata_old_downgraded)
+  testthat::expect_identical(tdata_new, tdata_new_upgraded)
+
+  testthat::expect_s3_class(tdata_new_downgraded, "tdata")
+  testthat::expect_failure( testthat::expect_s4_class(tdata_new_downgraded, "qenv") )
+
+  testthat::expect_s4_class(tdata_old_upgraded, "tdata")
+  testthat::expect_s4_class(tdata_old_upgraded, "qenv")
+})
+
+testthat::test_that("datasets are maintained during conversion", {
+  tdata_old_up <- .tdata_upgrade(tdata_old)
+  tdata_new_down <- .tdata_downgrade(tdata_new)
+
+  datasets_old <- sapply(sort(names(tdata_old)), function(x) shiny::isolate(tdata_old[[x]]()))
+  datasets_old_up <- sapply(ls(tdata_old_up@env), function(x) teal.code::get_var(tdata_old_up, x))
+
+  testthat::expect_identical(datasets_old, datasets_old_up)
+
+
+  datasets_new <- sapply(ls(tdata_new@env), function(x) teal.code::get_var(tdata_new, x))
+  datasets_new_down <- sapply(sort(names(tdata_new_down)), function(x) shiny::isolate(tdata_new_down[[x]]()))
+
+  testthat::expect_identical(datasets_new, datasets_new_down)
+})
+
+testthat::test_that("code is maintained during conversion", {
+  tdata_old_upgraded <- .tdata_upgrade(tdata_old)
+  tdata_new_downgraded <- .tdata_downgrade(tdata_new)
+
+  testthat::expect_identical(
+    shiny::isolate(attr(tdata_old, "code")()),
+    teal.code::get_code(tdata_old_upgraded)
+  )
+  testthat::expect_identical(
+    teal.code::get_code(tdata_new),
+    shiny::isolate(attr(tdata_new_downgraded, "code")())
+  )
+})
+
+testthat::test_that("join keys are added during upgrade if missing in old class object", {
+  testthat::expect_null(attr(tdata_old, "join_keys"))
+  tdata_old_upgraded <- .tdata_upgrade(tdata_old)
+  testthat::expect_failure( testthat::expect_null(teal.data::get_join_keys(tdata_old_upgraded)) )
+  testthat::expect_equal(
+    teal.data::get_join_keys(tdata_old_upgraded),
+    teal.data::join_keys()
+  )
+})
+
+testthat::test_that("join keys are maintained during upgrade if not missing in old class object", {
+  attr(tdata_old, "join_keys") <- teal.data::join_keys()
+  tdata_old_upgraded <- .tdata_upgrade(tdata_old)
+  testthat::expect_equal(
+    teal.data::get_join_keys(tdata_old_upgraded),
+    attr(tdata_old, "join_keys")
+  )
+})
+