Introduce the new DDL (module)

DESCRIPTION

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

R/data-data-utils.R

@@ -0,0 +1,75 @@
+#' Function runs the `code`, masks the `code` and creates `teal_data` object.
+#' @param input (`list`) containing inputs to be used in the `code`
+#' @inheritParams tm_teal_data
+#'
+#' @return `teal_data` object
+#'
+#' @export
+eval_and_mask <- function(data,
+                          code,
+                          input = list(),
+                          input_mask = list()) {
+  checkmate::assert_list(input)
+  if (inherits(input, "reactivevalues")) {
+    input <- shiny::reactiveValuesToList(input)
+  }
+
+  # evaluate code and substitute input
+  data <- teal.code::eval_code(data, .mask_code(code, args = input))
+
+  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(.mask_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 inputs in the code
+#'
+#' Function replaces symbols in the provided code prefixed with `input$` or `input[["`
+#' by values of the `args` argument.
+#'
+#' @param code (`language`) code to substitute
+#' @param args (`list`) named list or arguments
+.mask_code <- function(code, args) {
+  code <- if (identical(as.list(code)[[1L]], as.symbol("{"))) {
+    as.list(code)[-1L]
+  } else {
+    code
+  }
+
+  code_strings <- vapply(code, deparse1, character(1L))
+  # Replace input$ with .()
+  code_strings <- gsub("input\\$(\\w+\\.?\\w*)", "\\.(\\1)", code_strings)
+  code_strings <- gsub("(input\\$)(`[^`]+`)", "\\.(\\2)", code_strings)
+
+  # Replace input[[ with .()
+  code_strings <- gsub("(input\\[\\[\")(\\w+\\.?\\w*)(\"\\]\\])", "\\.(\\2\\)", code_strings)
+  code_strings <- gsub("(input\\[\\[\")(\\w+\\-\\w+)\"\\]\\]", ".(`\\2`)", code_strings)
+
+  # Use bquote to obtain code with input values and masking values.
+  # todo: make sure it produces only one entry in qenv@code!!!
+  as.expression(
+    lapply(code_strings, function(x) {
+      do.call(bquote, list(str2lang(x), list2env(args)))
+    })
+  )
+}

R/data-module.R

@@ -0,0 +1,175 @@
+#' DDL object
+#'
+#' Object to execute custom DDL code in the shiny session.
+#'
+#' @section Creating reproducible data:
+#' `ddl` object can be used to create reproducible data in the shiny session. `ddl$server` function
+#' can execute any R code and return [`teal.data::teal_data-class`]. For reproducibility purposes,
+#' we recommend to initialize empty `teal_data` object and evaluate necessary code with `eval_code` or `within`.
+#' ```r
+#' function(id, ...) {
+#'   moduleServer(id, function(input, output, session) {
+#'     eventReactive(input$submit, {
+#'       data <- teal_data() |> within({
+#'         # code to be run when app user presses submit
+#'       })
+#'     })
+#'   })
+#' }
+#' ```
+#' Obtained data is passed further in the `teal` app with `code` which can be used to recreate the objects.
+#'
+#' @section Code masking:
+#'  `ddl` object can be used in a way that evaluated code is different than the code
+#' returned in `teal_data` object. Typically occurs when app user is asked to input a
+#' password and we'd like to skip this input in the reproducible code. Possibly, users password
+#' could be substituted with `askpass::askpass()` call, so the returned code is still executable but secure.
+#' `ddl` developer must understand that this is a security risk and should be handled with care.
+#' To make sure that the code is reproducible, `ddl` object should be used with `input_mask` argument.
+#' `teal` provides convenience function [ddl_run()] which handles evaluation of the code, masking
+#' and creating `teal_data` object. Such `server` function could look like this:
+#'
+#' ```
+#' server = function(id, ...) {
+#'   moduleServer(id, function(input, output, session) {
+#'     reactive({
+#'      ddl_run(input = input, ...)
+#'     })
+#'   })
+#' }
+#' ```
+#'
+#' If `ddl` developer values more control, then might be interested in using `...` explicitly,
+#' and create `teal_data` object manually.
+#'
+#' @param ui (`shiny.tag`)\cr
+#'  `shiny` user-interface module containing inputs whose `id` correspond to the arguments in the `code`.
+#'
+#' @param server (`function`)\cr
+#'  `shiny` server module [`teal.data::teal_data-class`] possibly wrapped in a [reactive()].
+#'  `server` function should have `id` and `...` as formals. Where:
+#'  - `id` is a `shiny` module id, and
+#'  - `...` passes arguments from the `ddl` object (`code`, `input_mask`, `datanames`, `join_keys`).
+#'  See section `Code masking`.
+#'
+#' @param expr (optional `expression`)\cr
+#'  Syntactically valid R expression to be executed in the shiny session.
+#'  Shouldn't be specified when `code` is specified.
+#'
+#' @param code (optional `character` or `language`)\cr
+#'  Object containing (defused) syntactically valid R expression to be executed in the shiny session.
+#'  Shouldn't be specified when `expr` is specified.
+#'
+#' @param input_mask (optional `named list`)\cr
+#'  arguments to be substituted in the `code`. These (named) list elements are going to replace
+#'  symbols in the code prefixed with `input$` or `input[["`. Typically `input_mask` is used
+#'  to mask username or password with `list(password = quote(askpass::askpass()))`.
+#'  See section `code masking` for more details.
+#'
+#' @param datanames (optional `character`)\cr
+#'  Names of the datasets created by evaluation of the `code`. By default, `datanames`
+#'  are obtained from the `join_keys` or from results of the `code` evaluation.
+#'  If `code` evaluation creates objects which are not considered as datasets, they
+#'  should be omitted from `datanames` to avoid errors.
+#'
+#' @inheritParams teal.data::teal_data
+#'
+#' @export
+tm_teal_data <- function(label = "data",
+                         expr,
+                         code,
+                         input_mask = list(),
+                         ui = submit_button_ui, # or empty div?
+                         server = submit_button_server) {
+  checkmate::assert_list(input_mask)
+  checkmate::check_function(ui, args = "id")
+  checkmate::check_function(server, args = c("id", "...")) # todo: data should be passed to this module
+
+  out <- module(
+    label = label,
+    ui = ui,
+    server = server,
+    server_args = list(input_mask = input_mask)
+    # datanames = "all" by default
+  )
+  class(out) <- c(class(out), "teal_module_data")
+
+  if (!missing(expr) || !missing(code)) {
+    # this is intended to be used with input mask
+    # but in the same time we can't forbid user to use it
+    # without input_mask. Some users might prefer to use ddl_run
+    # to automaticaly handle their code.
+    # Q: can NEST bear responsibility for reproducibility of the masked code?
+    if (!missing(expr)) {
+      code <- substitute(expr)
+    }
+    if (is.character(code)) {
+      code <- parse(text = code)
+    }
+    out$server_args$code <- code
+  }
+
+  out
+}
+
+
+#' Run code and mask inputs
+#'
+#' Delayed Data Loading module with login and password input.
+#'
+#' @name submit_button_module
+#'
+#'
+#' @param id (`character`) `shiny` module id.
+#' @param ... (`list`) arguments passed to `ddl_run` function.
+#' @return `shiny` module
+NULL
+
+#' @rdname submit_button_module
+#' @export
+submit_button_ui <- function(id) {
+  ns <- NS(id)
+  actionButton(inputId = ns("submit"), label = "Submit")
+}
+
+#' @rdname submit_button_module
+#' @export
+submit_button_server <- function(id, ...) {
+  moduleServer(id, function(input, output, session) {
+    tdata <- eventReactive(input$submit, {
+      ddl_run(input = input, ...)
+    })
+
+    # would need to make sure we handle reactivity correctly here as teal::init expects not reactive teal_data...
+    return(tdata)
+  })
+}
+
+
+# methods from teal.data ----
+#  to be removed soon
+
+#' Get data names from `ddl`
+#' @rdname get_dataname
+#' @param x (`ddl`) object
+#' @export
+get_dataname.ddl <- function(x) {
+  attr(x, "datanames")
+}
+
+#' @rdname get_join_keys
+#' @export
+get_join_keys.ddl <- function(data) {
+  attr(data, "join_keys")
+}
+
+# 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/init.R

@@ -118,6 +118,7 @@ init <- function(data,
   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)
@@ -142,26 +143,10 @@ 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 (hashables$data$is_pulled()) {
     sapply(get_dataname(hashables$data), simplify = FALSE, function(dn) {
       hashables$data$get_dataset(dn)$get_raw_data()
@@ -172,20 +157,14 @@ 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))
+
+  # resolve modules datanames (can't be here anymore as we might not have datanames in data)
+  # 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)
+  # assert_filter_datanames(filter, datanames)
 
   if (isTRUE(attr(filter, "module_specific"))) {
     module_names <- unlist(c(module_labels(modules), "global_filters"))
@@ -218,7 +197,7 @@ init <- function(data,
   # the `ui` and `server` with `id = character(0)` and calling the server function directly
   # rather than through `callModule`
   res <- list(
-    ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
+    ui = ui_teal_with_splash(id = id, data = data, modules = modules, title = title, header = header, footer = footer),
     server = function(input, output, session) {
       if (length(landing) == 1L) {
         landing_module <- landing[[1L]]