ddl alternative

R/__ddl_by_AC.R

@@ -0,0 +1,298 @@
+#' Create input module.
+#'
+#' Template for creating a simple module that will put up input widgets and produce `tdata`.
+#'
+#' Define any inputs necessary to connect to a remote data source and produce data,
+#' as well as a function (`on_submit`) that will create the desired data sets.
+#'
+#' One of the inputs must be an action button (or action link) called `"submit"`.
+#' When clicked, the `on_submit` function will be run.
+#'
+#' `on_submit` must take one argument called `inputs`,
+#' which will be a list of all input elements defined in the UI function except `"submit"`.
+#' The function body must contain all code necessary to obtain the desired data sets and nothing else.
+#' Do not return values, just assign your data sets to appropriate variables (see examples).
+#'
+#' Clicking the `submit` button/link will run the function provided in `on_submit`.
+#' The obtained data sets will be packed into a `tdata` object.
+#' The body of `on_submit` will be recorded in the resulting `tdata`.
+#'
+#' The `mask` argument can be used to mask input values used as arguments in the recorded code.
+#' This should be a named list with names corresponding to input elements being masked,
+#' and elements containing masked values. The masked values may include quoted `call`s.
+#'
+#' Input elements will be put in a div of class `connector-input`.
+#'
+#' @param ... any number of `shiny.tag`s
+#' @param on_submit function to run after clicking the `submit` button, see `Details`
+#' @param mask optional list specifying how to mask the code run by `on_submit`, see `Details`
+#' @param datanames character vector of names of data sets created; required for compatibility with `teal` apps
+#' @param join_keys `join_keys` object specifying relationships between data sets; defaults to `teal.data::join_keys()`
+#' @return A`reactive` expression returning a `tdata` object.
+#'
+#' #' @examples
+#' library(shiny)
+#' module <- input_template(
+#'   textInput("user", "username", placeholder = "who goes there?"),
+#'   passwordInput("pass", "password", placeholder = "friend or foe?"),
+#'   actionButton("submit", "get it"),
+#'   on_submit = function(input) {
+#'     example_data <- paste(input$user, input$pass, sep = " -- ")
+#'   },
+#'   mask = list(pass = "MASKED PASSWORD")
+#' )
+#' ui <- fluidPage(
+#'   tagList(
+#'     module$ui("id"),
+#'     verbatimTextOutput("value"),
+#'     verbatimTextOutput("code")
+#'   )
+#' )
+#' server <- function(input, output, session) {
+#'   tdata <- module$server("id")
+#'   output[["value"]] <- renderPrint({
+#'     req(tdata())
+#'     teal.code::get_var(tdata(), "example_data")
+#'   })
+#'   output[["code"]] <- renderPrint({
+#'     req(tdata())
+#'     cat(teal.code::get_code(tdata()), cat(sep = "\n"))
+#'   })
+#' }
+#' if (interactive()) shinyApp(ui, server)
+#'
+input_template <- function(..., on_submit, mask, datanames, join_keys) {
+  args <- list(...)
+  checkmate::assert_list(args, types = "shiny.tag")
+
+  args  <- as.list(substitute(list(...)))[-1L]
+  inputIds <- vapply(args, function(x) match.call(eval(x[[1L]]), x)[["inputId"]], character(1L))
+
+  checkmate::assert_true(
+    is.element("submit", inputIds),
+    .var.name = "A \"submit\" element is specified."
+  )
+
+  submit <- unlist(eval(args[[which(inputIds == "submit")]]))
+  submit_class <- submit[grep("class$", names(submit))]
+  checkmate::assert_true(
+    grepl("action-button", submit_class),
+    .var.name = "The \"submit\" element has class \"action-button\"."
+  )
+
+  # Wrap `inputIds` arguments in in `ns` calls.
+  args <- lapply(args, function(call) {
+    call <- match.call(eval(call[[1]]), call)
+    call <- as.list(call)
+    call[["inputId"]] <- call("ns", call[["inputId"]])
+    as.call(call)
+  })
+
+
+  ui <- function(id) {
+    ns <- NS(id)
+    div(
+      class = "connector-input",
+      lapply(args, eval, envir = environment())
+    )
+  }
+
+  checkmate::assert_character(datanames)
+  if (missing(mask)) mask <- list()
+  if (missing(join_keys)) join_keys <- teal.data::join_keys()
+  tracked_request <- with_substitution(on_submit, mask, join_keys)
+  server <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      result <- eventReactive(input[["submit"]], {
+        inputs <- sapply(setdiff(inputIds, "submit"), function(x) input[[x]], simplify = FALSE)
+        tryCatch(
+          do.call(tracked_request, list(inputs)),
+          error = function(e) validate(need(FALSE, sprintf("Error: %s", e$message)))
+        )
+      })
+      result
+    })
+  }
+
+  ans <- list(
+    ui = ui,
+    server = server,
+    datanames = datanames,
+    join_keys = join_keys
+  )
+  class(ans) <- c("ddl", class(ans))
+  ans
+}
+
+
+#' wrapper for `on_submit` functions
+#'
+#' Wrap a function that makes some assignments in its body to return a `tdata` object with optionally masked code.
+#'
+#' Code found in the body of `fun` will be run in order to obtain the desired data sets.
+#' References to `input$<name>` will be substituted with input values of the accompanying `shiny` module
+#' for the purposes of code execution. If `mask` is provided, those references will be substituted with mask values
+#' for the purposes of storing code.
+#'
+#' @param fun a function that takes exactly one argument, `input`, which is a named list
+#' @param mask optional named list to specify code masking; see `input_template` for details
+#' @param join_keys optional `join_keys` object; see `input_template` for details
+#'
+#' @return
+#' A `tdata` object containing variables that were created in the body of `fun`
+#' and the entirety of the body of `fun` in the `@code` slot.
+#'
+#' @keywords internal
+with_substitution <- function(fun, mask, join_keys) {
+  checkmate::assert_true(
+    identical(names(formals(fun)), "input"),
+    .var.name = "'on_submit' function only takes 'input' argument"
+  )
+  checkmate::assert_list(mask, names = "unique")
+  checkmate::assert_r6(join_keys, "JoinKeys")
+
+  function(...) {
+    # Get input values from call arguments.
+    call_args <- as.list(match.call(fun))$input
+    checkmate::assert_list(call_args, names = "unique", .var.name = "input")
+    # Add non-masked arguments to mask.
+    mask <- c(mask, call_args)
+    mask <- mask[!duplicated(names(mask))]
+
+    # Extract function body as list of calls.
+    fun_body <- body(fun)
+    code <-
+      if (is.expression(fun_body)) {
+        as.list(fun_body)
+      } else if (is.call(fun_body)) {
+        if (identical(as.list(fun_body)[[1L]], as.symbol("{"))) {
+          as.list(fun_body)[-1L]
+        } else {
+          list(fun_body)
+        }
+      } else if (is.name(fun_body)) {
+        fun_body
+      } else {
+        stop("with_substitution: don't know ho to handle this kind of function body")
+      }
+
+    # Convert calls to strings and substitute argument references by bquote references.
+    code_strings <- vapply(code, deparse1, character(1L))
+    code_strings <- gsub("(input\\$)(\\w+)", "\\.(\\2\\)", code_strings)
+    code_strings <- gsub("(input\\[\\[\")(\\w+)(\"\\]\\])", "\\.(\\2\\)", code_strings)
+    # Use bquote to obtain code with input values and masking values.
+    code_input <- lapply(code_strings, function(x) do.call(bquote, list(str2lang(x), call_args)))
+    code_masked <- lapply(code_strings, function(x) do.call(bquote, list(str2lang(x), mask)))
+
+    # Evaluate input code in separate environment.
+    env <- new.env()
+    eval(as.expression(code_input), env)
+    # Create `tdata` with masked code.
+    new_tdata(as.list(env), code = as.expression(code_masked), keys = join_keys)
+  }
+}
+
+
+library(shiny)
+
+# mock database connection
+pullme <- function(username, password) {
+  if (username == "user" && password == "pass") {
+    message("connection established")
+  } else {
+    stop("invalid credentials")
+  }
+}
+closeme <- function() {
+  message("connection closed")
+}
+
+
+thefun <- function(input) {
+  on.exit(try(closeme()))
+  pullme(username = input$user, password = input$pass)
+  adsl <- scda::synthetic_cdisc_data('latest')$adsl
+  adtte <- scda::synthetic_cdisc_data('latest')$adtte
+}
+themask <- list(
+  user = quote(askpass("who are you?")),
+  pass = quote(askpass("password please"))
+)
+
+module <- input_template(
+  on_submit = thefun,
+  mask = themask,
+  datanames = c("adsl", "adtte"),
+  textInput("user", "username", value = "user", placeholder = "who goes there?"),
+  passwordInput("pass", "password", value = "pass", placeholder = "friend or foe?"),
+  actionButton("submit", "get it")
+)
+
+
+devtools::load_all("../teal.slice")
+devtools::load_all("../teal")
+devtools::load_all(".")
+
+# ui <- fluidPage(
+#   tagList(
+#     module$ui("id"),
+#     uiOutput("val")
+#   )
+# )
+# server <- function(input, output, session) {
+#   tdata <- module$server("id")
+#   output[["value"]] <- renderPrint({
+#     tdata()
+#   })
+#   output[["code"]] <- renderPrint({
+#     cat(teal.code::get_code(tdata()), sep = "\n")
+#   })
+#   output[["val"]] <- renderUI({
+#     req(tdata())
+#     tagList(
+#       verbatimTextOutput("value"),
+#       verbatimTextOutput("code")
+#     )
+#   })
+# }
+# if (interactive()) shinyApp(ui, server)
+
+
+
+funny_module <- function (label = "Filter states", datanames = "all") {
+  checkmate::assert_string(label)
+  module(
+    label = label,
+    datanames = datanames,
+    ui = function(id, ...) {
+      ns <- NS(id)
+      div(
+        h2("The following filter calls are generated:"),
+        verbatimTextOutput(ns("filter_states")),
+        verbatimTextOutput(ns("filter_calls")),
+        actionButton(ns("reset"), "reset_to_default")
+      )
+    },
+    server = function(input, output, session, data, filter_panel_api) {
+      checkmate::assert_class(data, "tdata")
+      observeEvent(input$reset, set_filter_state(filter_panel_api, default_filters))
+      output$filter_states <-  renderPrint({
+        logger::log_trace("rendering text1")
+        filter_panel_api %>% get_filter_state()
+      })
+      output$filter_calls <- renderText({
+        logger::log_trace("rendering text2")
+        attr(data, "code")()
+      })
+    }
+  )
+}
+
+app <- init(
+  data = module,
+  modules = modules(
+    funny_module("funny1"),
+    funny_module("funny2", datanames = "adtte") # will limit datanames to ADTTE and ADSL (parent)
+  )
+)
+shinyApp(app$ui, app$server)

R/tdata.R

@@ -47,7 +47,7 @@ setMethod(
       messages = rep("", length(code)),
       id = id,
       join_keys = keys,
-      datanames = union(names(env), names(keys$get()))
+      datanames = as.character(union(names(env), names(keys$get())))
     )
   }
 )