Introduce the new DDL

DESCRIPTION

@@ -71,6 +71,8 @@ LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Collate:
+    'data-data-utils.R'
+    'data-transform_module.R'
     'dummy_functions.R'
     'get_rcode_utils.R'
     'include_css_js.R'

R/data-data-utils.R

@@ -0,0 +1,98 @@
+#' Function runs the `code`, masks the `code` and creates `teal_data` object.
+#' @param data (`teal_data`) object
+#' @param code (`language`) code to evaluate
+#' @param input (`list`) containing inputs to be used in the `code`
+#' @param input_mask (`list`) containing inputs to be masked in the `code`
+#'
+#' @return `teal_data` object
+#'
+#' @export
+eval_and_mask <- function(data,
+                          code,
+                          input = list(),
+                          input_mask = list()) {
+  # todo: do we need also within_and_mask?
+  checkmate::assert_list(input)
+  if (inherits(input, "reactivevalues")) {
+    input <- shiny::reactiveValuesToList(input)
+  }
+  # evaluate code and substitute input
+  data <- teal.code::eval_code(data, .substitute_code(code, args = input))
+  if (inherits(data, "qenv.error")) {
+    return(data)
+  }
+
+  if (identical(ls(data@env), character(0))) {
+    warning(
+      "Evaluation of `ddl` code haven't created any objects.\n",
+      "Please make sure that the code is syntactically correct and creates necessary data."
+    )
+  }
+
+  if (!missing(input_mask)) {
+    # mask dynamic inputs with mask
+    input <- utils::modifyList(input, input_mask)
+
+    # replace last code entry with masked code
+    # format_expression needed to convert expression into character(1)
+    #  question: warnings and errors are not masked, is it ok?
+    data@code[length(data@code)] <- format_expression(.substitute_code(code, args = input))
+  }
+
+  # todo: should it be here or in datanames(data)?
+  if (length(datanames(data)) == 0) {
+    datanames(data) <- ls(data@env)
+  }
+
+  data
+}
+
+#' Substitute symbols in the code
+#'
+#' Function replaces symbols in the provided code by values of the `args` argument.
+#'
+#' @param code (`language`) code to substitute
+#' @param args (`list`) named list or arguments
+#' @keywords internal
+.substitute_code <- function(code, args) {
+  do.call(
+    substitute,
+    list(
+      expr = do.call(
+        substitute,
+        list(expr = code)
+      ),
+      env = args
+    )
+  )
+}
+
+#' Convenience wrapper for ddl_login_password
+ddl_login_password <- function(data, code, input_mask) {
+  srv <- function(id, data) {
+    moduleServer(id, function(input, output, session) {
+      eventReactive(input$submit, {
+        eval_and_mask(data, code = code, input = input, input_mask = input_mask)
+      })
+    })
+  }
+
+  ui <- function(id) {
+    ns <- NS(id)
+    actionButton(inputId = ns("submit"), label = "Submit")
+  }
+
+  teal_transform(data, ui, server)
+}
+
+
+# todo: to remove before merge -------------
+#' @export
+open_conn <- function(username, password) {
+  if (password != "pass") stop("Invalid credentials. 'pass' is the password") else TRUE
+}
+#' @export
+close_conn <- function(conn) {
+  message("closed")
+  return(NULL)
+}

R/data-transform_module.R

@@ -0,0 +1,23 @@
+#' Transform module for `teal_data`
+#'
+#' Function creates object of class `teal_trnasform_module` which allows
+#' `teal` app developer to transform freely `teal_data` object passed to `data` argument in
+#' [teal::init()]. This helps in case when app developer wants to use `teal` app
+#' where `data` can be influenced by app user. For example, app developer can create
+#' `teal` app which allows user to connect to database and then use data from this database.
+#' @param data `teal_data` object
+#' @param ui (`function(id)`) function to create UI
+#' @param server (`function(id, data)`) `shiny` server
+#' which returns `teal_data` object wrapped in `reactive`.
+#' @export
+teal_transform <- function(data, ui, server) {
+  checkmate::assert_class(data, "teal_data")
+  checkmate::assert_function(ui, args = "id")
+  checkmate::assert_function(server, args = c("id", "data"))
+
+  structure(
+    list(ui = ui, server = server),
+    data = data,
+    class = "teal_transform_module"
+  )
+}

R/init.R

@@ -106,7 +106,7 @@
 #'   shinyApp(app$ui, app$server)
 #' }
 #'
-init <- function(data,
+init <- function(data = teal_data(),
                  modules,
                  title = NULL,
                  filter = teal_slices(),
@@ -115,10 +115,11 @@ init <- function(data,
                  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_transform_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_transform_module"))
   checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
   checkmate::assert_string(title, null.ok = TRUE)
   checkmate::assert(
@@ -142,26 +143,12 @@ 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.
   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_transform_module")) {
+    # what?
   } 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 +159,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"))

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!
+  }
 
   # list of reactive filtered data
   data <- sapply(

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)
 

R/module_teal.R

@@ -160,9 +160,21 @@ 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())
+    }
+
+    # 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
     env <- environment()
-    datasets_reactive <- eventReactive(raw_data(), {
+    observeEvent(raw_data(), {
+      logger::log_trace("srv_teal@5 setting main ui after data was pulled")
       env$progress <- shiny::Progress$new(session)
+      on.exit(env$progress$close())
       env$progress$set(0.25, message = "Setting data")
 
       # create a list of data following structure of the nested modules list structure.
@@ -171,6 +183,7 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
       # 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 +193,16 @@ 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
+          datanames <- if (is.null(modules$datanames) || modules$datanames == "all") {
+            include_parent_datanames(raw_data()@datanames, raw_data()@join_keys) # todo: use methods instead
+          } else {
+            modules$datanames
+          }
+          # todo: subset teal_data to datanames
           datasets_module <- teal_data_to_filtered_data(raw_data())
 
           # 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
@@ -201,26 +219,8 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
       }
       datasets <- module_datasets(modules)
 
-      logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
-      datasets
-    })
-
-    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, {
-      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")
       removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
       insertUI(
         selector = paste0("#", session$ns("main_ui_container")),
@@ -230,7 +230,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 +242,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