Introduce the new DDL (#957)

DDL
insightsengineering · Nov 13, 2023 · 91e000d · 91e000d
1 parent 6075555
commit 91e000d
Show file tree

Hide file tree

Showing 32 changed files with 843 additions and 186 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -88,6 +88,7 @@ Collate:
     'show_rcode_modal.R'
     'tdata.R'
     'teal.R'
+    'teal_data_module.R'
     'teal_reporter.R'
     'teal_slices-store.R'
     'teal_slices.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -31,6 +31,7 @@ export(reporter_previewer_module)
 export(show_rcode_modal)
 export(srv_teal_with_splash)
 export(tdata2env)
+export(teal_data_module)
 export(teal_slices)
 export(ui_teal_with_splash)
 export(validate_has_data)

diff --git a/NEWS.md b/NEWS.md
@@ -1,13 +1,19 @@
 # teal 0.14.0.9017
 
+### New features
+
+* `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`.
+
 ### Miscellaneous
 
 * Enhanced a `module` validation checks so that it won't throw messages about `data` argument unnecessarily.
-* Removed `Report previewer` module from mapping matrix display in filter manager.
-* Added internal functions for storing and restoring of `teal_slices` objects.
-* Filter state snapshots can now be uploaded from file. See `?snapshot`.
 * Added argument to `teal_slices` and made modifications to `init` to enable tagging `teal_slices` with an app id to safely upload snapshots from disk.
-* 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.
+
+### Bug fixes
+
+* Removed `Report previewer` module from mapping matrix display in filter manager.
 
 # teal 0.14.0
 

diff --git a/R/dummy_functions.R b/R/dummy_functions.R
@@ -96,13 +96,21 @@ example_module <- function(label = "example teal module", datanames = "all") {
       checkmate::assert_class(data, "tdata")
       moduleServer(id, function(input, output, session) {
         output$text <- renderPrint(data[[input$dataname]]())
+        teal.widgets::verbatim_popup_srv(
+          id = "rcode",
+          verbatim_content = attr(data, "code")(),
+          title = "Association Plot"
+        )
       })
     },
     ui = function(id, data) {
       ns <- NS(id)
       teal.widgets::standard_layout(
         output = verbatimTextOutput(ns("text")),
-        encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
+        encoding = div(
+          selectInput(ns("dataname"), "Choose a dataset", choices = names(data)),
+          teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+        )
       )
     },
     datanames = datanames

diff --git a/R/init.R b/R/init.R
@@ -15,10 +15,11 @@
 #' 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`, `teal_data`)\cr
+#' or `MultiAssayExperiment`, `teal_data`, `teal_data_module`)\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`
+#' [teal.data::cdisc_dataset_connector()] or [teal_data_module()] or a single `data.frame` or
+#' a `MultiAssayExperiment`
 #' or a list of the previous objects or function returning a named list.
 #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements
 #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]
@@ -114,11 +115,11 @@ init <- function(data,
                  footer = tags$p(),
                  id = character(0)) {
   logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
-
-  if (!inherits(data, c("TealData", "teal_data"))) {
+  if (!inherits(data, c("TealData", "teal_data", "teal_data_module"))) {
     data <- teal.data::to_relational_data(data = data)
   }
-  checkmate::assert_multi_class(data, c("TealData", "teal_data"))
+
+  checkmate::assert_multi_class(data, c("TealData", "teal_data", "teal_data_module"))
   checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
   checkmate::assert_string(title, null.ok = TRUE)
   checkmate::assert(
@@ -142,26 +143,14 @@ init <- function(data,
   if (length(landing) > 1L) stop("Only one `landing_popup_module` can be used.")
   modules <- drop_module(modules, "teal_module_landing")
 
-  # resolve modules datanames
-  datanames <- teal.data::get_dataname(data)
-  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)
-    # list_to_teal_slices is lifted from teal.slice package, see zzz.R
-    # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
-    filter <- list_to_teal_slices(filter)
-  }
-  # convert teal.slice::teal_slices to teal::teal_slices
-  filter <- as.teal_slices(as.list(filter))
-
-  # Calculate app hash to ensure snapshot compatibility. See ?snapshot. Raw data must be extracted from environments.
+  # Calculate app id that will be used to stamp filter state snapshots.
+  # App id is a hash of the app's data and modules.
+  # See "transferring snapshots" section in ?snapshot.
   hashables <- mget(c("data", "modules"))
   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 (inherits(data, "teal_data_module")) {
+    body(data$server)
   } else if (hashables$data$is_pulled()) {
     sapply(get_dataname(hashables$data), simplify = FALSE, function(dn) {
       hashables$data$get_dataset(dn)$get_raw_data()
@@ -172,20 +161,8 @@ init <- function(data,
 
   attr(filter, "app_id") <- rlang::hash(hashables)
 
-  # check teal_slices
-  for (i in seq_along(filter)) {
-    dataname_i <- shiny::isolate(filter[[i]]$dataname)
-    if (!dataname_i %in% datanames) {
-      stop(
-        sprintf(
-          "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",
-          i,
-          dataname_i,
-          toString(datanames)
-        )
-      )
-    }
-  }
+  # convert teal.slice::teal_slices to teal::teal_slices
+  filter <- as.teal_slices(as.list(filter))
 
   if (isTRUE(attr(filter, "module_specific"))) {
     module_names <- unlist(c(module_labels(modules), "global_filters"))
@@ -213,6 +190,27 @@ init <- function(data,
     }
   }
 
+  if (inherits(data, "teal_data")) {
+    if (length(teal.data::datanames(data)) == 0) {
+      stop("`data` object has no datanames. Specify `datanames(data)` and try again.")
+    }
+
+    # in case of teal_data_module this check is postponed to the srv_teal_with_splash
+    is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data))
+    if (!isTRUE(is_modules_ok)) {
+      logger::log_error(is_modules_ok)
+      checkmate::assert(is_modules_ok, .var.name = "modules")
+    }
+
+
+    is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data))
+    if (!isTRUE(is_filter_ok)) {
+      logger::log_warn(is_filter_ok)
+      # we allow app to continue if applied filters are outside
+      # of possible data range
+    }
+  }
+
   # Note regarding case `id = character(0)`:
   # rather than using `callModule` and creating a submodule of this module, we directly modify
   # the `ui` and `server` with `id = character(0)` and calling the server function directly

diff --git a/R/landing_popup_module.R b/R/landing_popup_module.R
@@ -15,7 +15,7 @@
 #'
 #' @examples
 #' app1 <- teal::init(
-#'   data = teal.data::dataset("iris", iris),
+#'   data = teal_data(iris = iris),
 #'   modules = teal::modules(
 #'     teal::landing_popup_module(
 #'       content = "A place for the welcome message or a disclaimer statement.",
@@ -29,7 +29,7 @@
 #' }
 #'
 #' app2 <- teal::init(
-#'   data = teal.data::dataset("iris", iris),
+#'   data = teal_data(iris = iris),
 #'   modules = teal::modules(
 #'     teal::landing_popup_module(
 #'       title = "Welcome",

diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R
@@ -297,7 +297,11 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specifi
   checkmate::assert_class(datasets, "FilteredData")
   checkmate::assert_class(trigger_data, "reactiveVal")
 
-  datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames
+  datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
+    datasets$datanames()
+  } else {
+    unique(module$datanames) # todo: include parents! unique shouldn't be needed here!
+  }
 
   # list of reactive filtered data
   data <- sapply(

diff --git a/R/module_snapshot_manager.R b/R/module_snapshot_manager.R
@@ -59,7 +59,8 @@
 #' which is disassembled for storage and used directly for restoring app state.
 #'
 #' @section Transferring snapshots:
-#' Snapshots uploaded from disk should only be used in the same application they come from.
+#' Snapshots uploaded from disk should only be used in the same application they come from,
+#' _i.e._ an application that uses the same data and the same modules.
 #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of
 #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that
 #' of the current app state and only if the match is the snapshot admitted to the session.

diff --git a/R/module_tabs_with_filters.R b/R/module_tabs_with_filters.R
@@ -122,7 +122,13 @@ srv_tabs_with_filters <- function(id,
     )
 
     if (!is_module_specific) {
-      active_datanames <- reactive(active_module()$datanames)
+      active_datanames <- reactive({
+        if (identical(active_module()$datanames, "all")) {
+          singleton$datanames()
+        } else {
+          active_module()$datanames
+        }
+      })
       singleton <- unlist(datasets)[[1]]
       singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
 

diff --git a/R/module_teal.R b/R/module_teal.R
@@ -15,7 +15,7 @@
 #' for non-delayed data which takes time to load into memory, avoiding
 #' Shiny session timeouts.
 #'
-#' Server evaluates the `raw_data` (delayed data mechanism) and creates the
+#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the
 #' `datasets` object that is shared across modules.
 #' Once it is ready and non-`NULL`, the splash screen is replaced by the
 #' main teal UI that depends on the data.
@@ -33,7 +33,7 @@
 #'   can be a splash screen or a Shiny module UI. For the latter, see
 #'   [init()] about how to call the corresponding server function.
 #'
-#' @param raw_data (`reactive`)\cr
+#' @param teal_data_rv (`reactive`)\cr
 #'   returns the `teal_data`, only evaluated once, `NULL` value is ignored
 #'
 #' @return
@@ -44,13 +44,13 @@
 #'
 #' @examples
 #' mods <- teal:::example_modules()
-#' raw_data <- reactive(teal:::example_cdisc_data())
+#' teal_data_rv <- reactive(teal:::example_cdisc_data())
 #' app <- shinyApp(
 #'   ui = function() {
 #'     teal:::ui_teal("dummy")
 #'   },
 #'   server = function(input, output, session) {
-#'     active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)
+#'     active_module <- teal:::srv_teal(id = "dummy", modules = mods, teal_data_rv = teal_data_rv)
 #'   }
 #' )
 #' if (interactive()) {
@@ -130,8 +130,8 @@ ui_teal <- function(id,
 
 
 #' @rdname module_teal
-srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
-  stopifnot(is.reactive(raw_data))
+srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
+  stopifnot(is.reactive(teal_data_rv))
   moduleServer(id, function(input, output, session) {
     logger::log_trace("srv_teal initializing the module.")
 
@@ -160,17 +160,23 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
       }
     )
 
+    reporter <- teal.reporter::Reporter$new()
+    if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
+      modules <- append_module(modules, reporter_previewer_module())
+    }
+
     env <- environment()
-    datasets_reactive <- eventReactive(raw_data(), {
+    datasets_reactive <- eventReactive(teal_data_rv(), {
       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_data_to_filtered_data(raw_data())
+      datasets_singleton <- teal_data_to_filtered_data(teal_data_rv())
       # 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)
+
       module_datasets <- function(modules) {
         if (inherits(modules, "teal_modules")) {
           datasets <- lapply(modules$children, module_datasets)
@@ -180,11 +186,19 @@ 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)) teal.data::get_dataname(raw_data()) else modules$datanames
-          # todo: subset tdata object to datanames
-          datasets_module <- teal_data_to_filtered_data(raw_data())
+          datanames <- if (is.null(modules$datanames) || modules$datanames == "all") {
+            include_parent_datanames(
+              teal.data::datanames(teal_data_rv()),
+              teal_data_rv()@join_keys
+            )
+          } else {
+            modules$datanames
+          }
+          # todo: subset teal_data to datanames
+          datasets_module <- teal_data_to_filtered_data(teal_data_rv())
 
           # set initial filters
+          #  - filtering filters for this module
           slices <- Filter(x = filter, f = function(x) {
             x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&
               x$dataname %in% datanames
@@ -199,29 +213,23 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
           datasets_singleton
         }
       }
-      datasets <- module_datasets(modules)
-
-      logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
-      datasets
+      module_datasets(modules)
     })
 
-    reporter <- teal.reporter::Reporter$new()
-    if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
-      modules <- append_module(modules, reporter_previewer_module())
-    }
-
     # Replace splash / welcome screen once data is loaded ----
     # ignoreNULL to not trigger at the beginning when data is NULL
     # just handle it once because data obtained through delayed loading should
     # usually not change afterwards
     # if restored from bookmarked state, `filter` is ignored
-    observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
+
+    observeEvent(datasets_reactive(), once = TRUE, {
       logger::log_trace("srv_teal@5 setting main ui after data was pulled")
-      env$progress$set(0.5, message = "Setting up main UI")
       on.exit(env$progress$close())
-      # main_ui_container contains splash screen first and we remove it and replace it by the real UI
+      env$progress$set(0.5, message = "Setting up main UI")
+      datasets <- datasets_reactive()
 
-      removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
+      # main_ui_container contains splash screen first and we remove it and replace it by the real UI
+      removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
       insertUI(
         selector = paste0("#", session$ns("main_ui_container")),
         where = "beforeEnd",
@@ -230,7 +238,7 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
         ui = div(ui_tabs_with_filters(
           session$ns("main_ui"),
           modules = modules,
-          datasets = datasets_reactive(),
+          datasets = datasets,
           filter = filter
         )),
         # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
@@ -242,7 +250,7 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
       # registered once (calling server functions twice would trigger observers twice each time)
       active_module <- srv_tabs_with_filters(
         id = "main_ui",
-        datasets = datasets_reactive(),
+        datasets = datasets,
         modules = modules,
         reporter = reporter,
         filter = filter