Introduce the new DDL (ddl class)

DESCRIPTION

@@ -71,6 +71,9 @@ LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Collate:
+    'ddl-class.R'
+    'ddl-modules.R'
+    'ddl-run.R'
     'dummy_functions.R'
     'get_rcode_utils.R'
     'include_css_js.R'

NAMESPACE

@@ -2,6 +2,8 @@
 
 S3method(c,teal_slices)
 S3method(get_code,tdata)
+S3method(get_dataname,ddl)
+S3method(get_join_keys,ddl)
 S3method(get_join_keys,tdata)
 S3method(get_metadata,default)
 S3method(get_metadata,tdata)
@@ -18,6 +20,9 @@ S3method(ui_nested_tabs,teal_modules)
 export("%>%")
 export(TealReportCard)
 export(as.teal_slices)
+export(close_conn)
+export(ddl)
+export(ddl_run)
 export(example_module)
 export(get_code_tdata)
 export(get_metadata)
@@ -26,10 +31,13 @@ export(landing_popup_module)
 export(module)
 export(modules)
 export(new_tdata)
+export(open_conn)
 export(report_card_template)
 export(reporter_previewer_module)
 export(show_rcode_modal)
 export(srv_teal_with_splash)
+export(submit_button_server)
+export(submit_button_ui)
 export(tdata2env)
 export(teal_slices)
 export(ui_teal_with_splash)

R/ddl-class.R

@@ -0,0 +1,143 @@
+#' 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
+ddl <- function(expr,
+                code,
+                input_mask = list(),
+                ui = submit_button_ui,
+                server = submit_button_server,
+                join_keys = teal.data::join_keys(),
+                datanames = names(join_keys$get())) {
+  checkmate::assert_list(input_mask)
+  checkmate::check_function(ui, args = "id")
+  checkmate::check_function(server, args = c("id", "..."))
+  checkmate::check_class(join_keys, "JoinKeys")
+  checkmate::check_character(datanames, min.len = 1)
+
+  out <- structure(
+    list(ui = ui, server = server),
+    input_mask = input_mask,
+    datanames = datanames,
+    join_keys = join_keys,
+    class = "ddl"
+  )
+
+  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)
+    }
+    attr(out, "code") <- code
+  }
+
+  out
+}
+
+# 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/ddl-modules.R

@@ -0,0 +1,59 @@
+#' 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)
+  })
+}
+
+#' Wrapper for `ui` and `server` in `ddl` object
+#'
+#' Convenience wrapper for `ui` and `server` functions in `ddl` object.
+#' On the `server` side, function calls `shiny` module and adjusts the arguments
+#' to the formals of the `server` function.
+#' @param id (`character`) `shiny` module id.
+#' @param x (`ddl`) object.
+#' @name ddl_module
+#' @return `shiny` module
+#' @keywords internal
+NULL
+
+#' @rdname ddl_module
+#' @keywords internal
+ddl_server <- function(id, x) {
+  # subset attributes to only those that are arguments of the server function
+  args <- names(formals(x$server))
+  attrs <- attributes(x)
+  attrs <- attrs[setdiff(names(attrs), c("id", "class", "names"))]
+  do.call(x$server, c(list(id = id), attrs))
+}
+
+#' @rdname ddl_module
+#' @keywords internal
+ddl_ui <- function(id, x) {
+  x$ui(id = id)
+}

R/ddl-run.R

@@ -0,0 +1,82 @@
+#' Run code and mask inputs
+#'
+#' Function runs the `code`, masks the `code` and creates `teal_data` object.
+#' @param input (`list`) containing inputs to be used in the `code`
+#' @param code (`language`) code to be executed
+#' @param input_mask (`list`) containing inputs to be masked in the `code`
+#' @param datanames (`character`) names of the objects to be created from the code evaluation
+#' @param join_keys (`join_keys`) object
+#'
+#' @return `teal_data` object
+#'
+#' @export
+ddl_run <- function(input = list(),
+                    code,
+                    input_mask = list(),
+                    join_keys = teal.data::join_keys(),
+                    datanames = names(join_keys$get())) {
+  checkmate::assert_list(input)
+  if (inherits(input, "reactivevalues")) {
+    input <- shiny::reactiveValuesToList(input)
+  }
+  data <- teal_data(join_keys = join_keys)
+
+  # evaluate code and substitute input
+  data <- teal.code::eval_code(data, .substitute_inputs(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 code of teal_data with masked code
+    #  question: warnings and errors are not masked, is it ok?
+    data@code <- format_expression(.substitute_inputs(code, args = input))
+  }
+
+  if (length(datanames)) {
+    datanames(data) <- datanames
+  }
+  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
+.substitute_inputs <- 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.
+  as.expression(
+    lapply(code_strings, function(x) {
+      do.call(bquote, list(str2lang(x), list2env(args)))
+    })
+  )
+}

R/init.R

@@ -114,11 +114,10 @@ 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", "ddl"))) {
     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", "ddl"))
   checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
   checkmate::assert_string(title, null.ok = TRUE)
   checkmate::assert(

R/module_teal_with_splash.R

@@ -22,7 +22,7 @@ ui_teal_with_splash <- function(id,
                                 title,
                                 header = tags$p("Add Title Here"),
                                 footer = tags$p("Add Footer Here")) {
-  checkmate::assert_multi_class(data, c("TealDataAbstract", "teal_data"))
+  checkmate::assert_multi_class(data, c("TealDataAbstract", "teal_data", "ddl"))
   ns <- NS(id)
 
   # Startup splash screen for delayed loading
@@ -31,6 +31,8 @@ ui_teal_with_splash <- function(id,
   # Shiny app does not time out.
   splash_ui <- if (inherits(data, "teal_data")) {
     div()
+  } else if (inherits(data, "ddl")) {
+    ddl_ui(id = ns("startapp_module"), x = data)
   } else if (inherits(data, "TealDataAbstract") && teal.data::is_pulled(data)) {
     div()
   } else {
@@ -56,7 +58,7 @@ ui_teal_with_splash <- function(id,
 #' If data is not loaded yet, `reactive` returns `NULL`.
 #' @export
 srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
-  checkmate::assert_multi_class(data, c("TealDataAbstract", "teal_data"))
+  checkmate::assert_multi_class(data, c("TealDataAbstract", "teal_data", "ddl"))
   moduleServer(id, function(input, output, session) {
     logger::log_trace("srv_teal_with_splash initializing module with data { toString(get_dataname(data))}.")
 
@@ -68,6 +70,8 @@ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
     # either passed to teal::init or returned from ddl
     raw_data <- if (inherits(data, "teal_data")) {
       reactiveVal(data)
+    } else if (inherits(data, "ddl")) {
+      ddl_server(id = "startapp_module", x = data)
     } else if (inherits(data, "TealDataAbstract") && teal.data::is_pulled(data)) {
       new_data <- do.call(
         teal.data::teal_data,

R/zzz.R

@@ -32,3 +32,6 @@ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
 coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
 # all *Block objects are private in teal.reporter
 RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+
+# use non-exported function from teal.code
+format_expression <- getFromNamespace("format_expression", "teal.code")