Introduce teal_data class (#925)

insightsengineering · Oct 30, 2023 · 278488b · 278488b
1 parent a3cbbe1
commit 278488b
Show file tree

Hide file tree

Showing 28 changed files with 331 additions and 286 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,7 +2,6 @@
 
 S3method(c,teal_slices)
 S3method(get_code,tdata)
-S3method(get_join_keys,default)
 S3method(get_join_keys,tdata)
 S3method(get_metadata,default)
 S3method(get_metadata,tdata)
@@ -21,7 +20,6 @@ export(TealReportCard)
 export(as.teal_slices)
 export(example_module)
 export(get_code_tdata)
-export(get_join_keys)
 export(get_metadata)
 export(init)
 export(landing_popup_module)

diff --git a/R/dummy_functions.R b/R/dummy_functions.R
@@ -23,14 +23,9 @@ example_cdisc_data <- function() { # nolint
   ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint
   ADSL$SEX[c(2, 5)] <- NA # nolint
 
-  cdisc_data_obj <- teal.data::cdisc_data(
-    cdisc_dataset(dataname = "ADSL", x = ADSL),
-    cdisc_dataset(dataname = "ADTTE", x = ADTTE)
-  )
-
   res <- teal.data::cdisc_data(
-    teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),
-    teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),
+    ADSL = ADSL,
+    ADTTE = ADTTE,
     code = '
       ADSL <- data.frame(
         STUDYID = "study",
@@ -62,7 +57,7 @@ example_cdisc_data <- function() { # nolint
 #' @keywords internal
 example_datasets <- function() { # nolint
   dummy_cdisc_data <- example_cdisc_data()
-  datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)
+  datasets <- teal_data_to_filtered_data(dummy_cdisc_data)
   list(
     "d2" = list(
       "d3" = list(

diff --git a/R/init.R b/R/init.R
@@ -15,7 +15,7 @@
 #' an end-user, don't use this function, but instead this module.
 #'
 #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`
-#' or `MultiAssayExperiment`)\cr
+#' or `MultiAssayExperiment`, `teal_data`)\cr
 #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],
 #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or
 #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`
@@ -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)
 
-  checkmate::assert_class(data, "TealData")
+  if (!inherits(data, c("TealData", "teal_data"))) {
+    data <- teal.data::to_relational_data(data = data)
+  }
+  checkmate::assert_multi_class(data, c("TealData", "teal_data"))
   checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
   checkmate::assert_string(title, null.ok = TRUE)
   checkmate::assert(
@@ -142,22 +144,8 @@ init <- function(data,
 
   # resolve modules datanames
   datanames <- teal.data::get_dataname(data)
-  join_keys <- data$get_join_keys()
-  resolve_modules_datanames <- function(modules) {
-    if (inherits(modules, "teal_modules")) {
-      modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)
-      modules
-    } else {
-      modules$datanames <- if (identical(modules$datanames, "all")) {
-        datanames
-      } else if (is.character(modules$datanames)) {
-        datanames_adjusted <- intersect(modules$datanames, datanames)
-        include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
-      }
-      modules
-    }
-  }
-  modules <- resolve_modules_datanames(modules = modules)
+  join_keys <- teal.data::get_join_keys(data)
+  modules <- resolve_modules_datanames(modules = modules, datanames = datanames, join_keys = join_keys)
 
   if (!inherits(filter, "teal_slices")) {
     checkmate::assert_subset(names(filter), choices = datanames)
@@ -170,13 +158,18 @@ init <- function(data,
 
   # Calculate app hash to ensure snapshot compatibility. See ?snapshot. Raw data must be extracted from environments.
   hashables <- mget(c("data", "modules"))
-  hashables$data <- sapply(hashables$data$get_datanames(), function(dn) {
-    if (hashables$data$is_pulled()) {
+  hashables$data <- if (inherits(hashables$data, "teal_data")) {
+    as.list(hashables$data@env)
+  } else if (inherits(hashables$data, "ddl")) {
+    attr(hashables$data, "code")
+  } else if (hashables$data$is_pulled()) {
+    sapply(get_dataname(hashables$data), simplify = FALSE, function(dn) {
       hashables$data$get_dataset(dn)$get_raw_data()
-    } else {
-      hashables$data$get_code(dn)
-    }
-  }, simplify = FALSE)
+    })
+  } else {
+    hashables$data$get_code()
+  }
+
   attr(filter, "app_id") <- rlang::hash(hashables)
 
   # check teal_slices
@@ -231,8 +224,10 @@ init <- function(data,
         landing_module <- landing[[1L]]
         do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
       }
-      # copy object so that load won't be shared between the session
-      data <- data$copy(deep = TRUE)
+      if (inherits(data, "TealDataAbstract")) {
+        # copy TealData so that load won't be shared between the session
+        data <- data$copy(deep = TRUE)
+      }
       filter <- deep_copy_filter(filter)
       srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)
     }

diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R
@@ -314,12 +314,14 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
     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

diff --git a/R/module_teal.R b/R/module_teal.R
@@ -34,7 +34,7 @@
 #'   [init()] about how to call the corresponding server function.
 #'
 #' @param raw_data (`reactive`)\cr
-#'   returns the `TealData`, only evaluated once, `NULL` value is ignored
+#'   returns the `teal_data`, only evaluated once, `NULL` value is ignored
 #'
 #' @return
 #' `ui_teal` returns `HTML` for Shiny module UI.
@@ -160,18 +160,14 @@ 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(), {
       env$progress <- shiny::Progress$new(session)
       env$progress$set(0.25, message = "Setting data")
 
       # create a list of data following structure of the nested modules list structure.
       # Because it's easier to unpack modules and datasets when they follow the same nested structure.
-      datasets_singleton <- teal.slice::init_filtered_data(raw_data())
+      datasets_singleton <- teal_data_to_filtered_data(raw_data())
       # Singleton starts with only global filters active.
       filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)
       datasets_singleton$set_filter_state(filter_global)
@@ -184,25 +180,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_data_to_filtered_data(raw_data())
 
           # set initial filters
           slices <- Filter(x = filter, f = function(x) {

diff --git a/R/module_teal_with_splash.R b/R/module_teal_with_splash.R
@@ -22,16 +22,16 @@ 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", "teal_data"))
   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, "teal_data")) {
+    div()
+  } else if (inherits(data, "TealDataAbstract") && teal.data::is_pulled(data)) {
     div()
   } else {
     message("App was initialized with delayed data loading.")
@@ -52,36 +52,58 @@ ui_teal_with_splash <- function(id,
 #'   will be displayed in the teal application. See [modules()] and [module()] for
 #'   more details.
 #' @inheritParams shiny::moduleServer
-#' @return `reactive`, return value of [srv_teal()]
+#' @return `reactive` containing `teal_data` object when data is loaded.
+#' If data is not loaded yet, `reactive` returns `NULL`.
 #' @export
 srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
-  checkmate::assert_class(data, "TealDataAbstract")
+  checkmate::assert_multi_class(data, c("TealDataAbstract", "teal_data"))
   moduleServer(id, function(input, output, session) {
-    logger::log_trace(
-      "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
-    )
+    logger::log_trace("srv_teal_with_splash initializing module with data { toString(get_dataname(data))}.")
 
     if (getOption("teal.show_js_log", default = FALSE)) {
       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 contains teal_data object
+    # either passed to teal::init or returned from ddl
+    raw_data <- if (inherits(data, "teal_data")) {
+      reactiveVal(data)
+    } else if (inherits(data, "TealDataAbstract") && teal.data::is_pulled(data)) {
+      new_data <- do.call(
+        teal.data::teal_data,
+        c(
+          lapply(data$get_datasets(), function(x) x$get_raw_data()),
+          code = data$get_code(),
+          join_keys = data$get_join_keys()
+        )
+      )
+      reactiveVal(new_data) # will trigger by setting it
     } else {
-      raw_data <- data$get_server()(id = "startapp_module")
+      raw_data_old <- data$get_server()(id = "startapp_module")
+      raw_data <- reactive({
+        data <- raw_data_old()
+        if (!is.null(data)) {
+          # raw_data is a reactive which returns data only when submit button clicked
+          # otherwise it returns NULL
+          do.call(
+            teal.data::teal_data,
+            c(
+              lapply(data$get_datasets(), function(x) x$get_raw_data()),
+              code = data$get_code(),
+              join_keys = data$get_join_keys()
+            )
+          )
+        }
+      })
+
       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 = ' ') }."
-    )
+    logger::log_trace("srv_teal_with_splash initialized module with data { toString(get_dataname(data))}.")
     return(res)
   })
 }
diff --git a/R/tdata.R b/R/tdata.R
@@ -123,29 +123,15 @@ get_code_tdata <- function(data) {
   get_code(data)
 }
 
-
-#' Function to get join keys from a `tdata` object
-#' @param data `tdata` - object to extract the join keys
-#' @return Either `JoinKeys` object or `NULL` if no join keys
-#' @export
-get_join_keys <- function(data) {
-  UseMethod("get_join_keys", data)
-}
-
-
+#' Extract `JoinKeys` from `tdata`
 #' @rdname get_join_keys
+#' @param data (`tdata`) object
+#' @keywords internal
 #' @export
 get_join_keys.tdata <- function(data) {
   attr(data, "join_keys")
 }
 
-
-#' @rdname get_join_keys
-#' @export
-get_join_keys.default <- function(data) {
-  stop("get_join_keys function not implemented for this object")
-}
-
 #' Function to get metadata from a `tdata` object
 #' @param data `tdata` - object to extract the data from
 #' @param dataname `character(1)` the dataset name whose metadata is requested