diff --git a/R/__ddl_by_AC.R b/R/__ddl_by_AC.R new file mode 100644 index 000000000..7031098f6 --- /dev/null +++ b/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$` 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) diff --git a/R/tdata.R b/R/tdata.R index 5dd4dd5ee..56a88d673 100644 --- a/R/tdata.R +++ b/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()))) ) } )