From e6221499497addb0432823768755930924bba8a2 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Mon, 14 Aug 2023 14:10:57 +0200 Subject: [PATCH 01/18] any data possible --- DESCRIPTION | 1 + NAMESPACE | 11 +++++- R/cdisc_data.R | 89 ++++++++++++++++++++++++------------------ R/get_dataname.R | 6 +++ R/get_datasets.R | 6 +++ R/get_join_keys.R | 21 ++++++++++ R/is_pulled.R | 1 - R/tdata.R | 75 +++++++++++++++++++++++++++++++++++ R/teal_data.R | 40 +++++++++++++------ R/to_relational_data.R | 6 +++ man/get_dataname.Rd | 3 ++ man/get_datasets.Rd | 3 ++ man/get_join_keys.Rd | 23 +++++++++++ man/new_tdata.Rd | 31 +++++++++++++++ 14 files changed, 264 insertions(+), 52 deletions(-) create mode 100644 R/get_join_keys.R create mode 100644 R/tdata.R create mode 100644 man/get_join_keys.Rd create mode 100644 man/new_tdata.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 3c7c40408..5573ef4fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,6 +29,7 @@ Imports: shinyjs, stats, teal.logger (>= 0.1.1), + teal.code, utils, yaml Suggests: diff --git a/NAMESPACE b/NAMESPACE index 9ac8192cd..50e7cac3c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ S3method(get_code,default) S3method(get_dataname,TealDataAbstract) S3method(get_dataname,TealDataset) S3method(get_dataname,TealDatasetConnector) +S3method(get_dataname,tdata) S3method(get_dataset,TealDataAbstract) S3method(get_dataset,TealDataset) S3method(get_dataset,TealDatasetConnector) @@ -20,6 +21,9 @@ S3method(get_dataset_label,TealDatasetConnector) S3method(get_datasets,TealDataAbstract) S3method(get_datasets,TealDataset) S3method(get_datasets,TealDatasetConnector) +S3method(get_datasets,tdata) +S3method(get_join_keys,TealData) +S3method(get_join_keys,tdata) S3method(get_key_duplicates,TealDataset) S3method(get_key_duplicates,data.frame) S3method(get_keys,TealDataAbstract) @@ -55,6 +59,7 @@ S3method(to_relational_data,TealDataset) S3method(to_relational_data,TealDatasetConnector) S3method(to_relational_data,data.frame) S3method(to_relational_data,list) +S3method(to_relational_data,tdata) export("col_labels<-") export("data_label<-") export(as_cdisc) @@ -89,11 +94,11 @@ export(get_dataname) export(get_dataset) export(get_dataset_label) export(get_datasets) +export(get_join_keys) export(get_key_duplicates) export(get_keys) export(get_labels) export(get_raw_data) -export(is_pulled) export(join_key) export(join_keys) export(load_dataset) @@ -102,6 +107,7 @@ export(mae_dataset) export(mutate_data) export(mutate_dataset) export(mutate_join_keys) +export(new_tdata) export(python_cdisc_dataset_connector) export(python_code) export(python_dataset_connector) @@ -117,7 +123,10 @@ export(teal_data) export(teal_data_file) export(to_relational_data) export(validate_metadata) +exportClasses(tdata) +exportMethods(new_tdata) import(shiny) +import(teal.code) importFrom(digest,digest) importFrom(logger,log_trace) importFrom(shinyjs,show) diff --git a/R/cdisc_data.R b/R/cdisc_data.R index 63562afea..ad097ad5b 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -68,58 +68,73 @@ cdisc_data <- function(..., code = "", check = FALSE) { data_objects <- list(...) - checkmate::assert_list( - data_objects, - types = c("TealDataset", "TealDatasetConnector", "TealDataConnector") - ) + + # todo: is it really important? - to remove if (inherits(join_keys, "JoinKeySet")) { join_keys <- teal.data::join_keys(join_keys) } - update_join_keys_to_primary(data_objects, join_keys) + if ( + checkmate::test_list(data_objects, types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")) + ) { + warning("Using TealDatasetConnector and TealDataset is deprecated, please just include data directly.") - retrieve_parents <- function(x) { - tryCatch( - x$get_parent(), - error = function(cond) rep(character(0), length(x$get_datanames())) - ) - } + update_join_keys_to_primary(data_objects, join_keys) + + retrieve_parents <- function(x) { + tryCatch( + x$get_parent(), + error = function(cond) rep(character(0), length(x$get_datanames())) + ) + } - new_parents_fun <- function(data_objects) { - lapply(data_objects, function(x) { + new_parents_fun <- function(data_objects) { + lapply(data_objects, function(x) { + if (inherits(x, "TealDataConnector")) { + unlist(new_parents_fun(x$get_items()), recursive = FALSE) + } else { + list(retrieve_parents(x)) + } + }) + } + + new_parents <- unlist(new_parents_fun(data_objects), recursive = FALSE) + + names(new_parents) <- unlist(lapply(data_objects, function(x) { if (inherits(x, "TealDataConnector")) { - unlist(new_parents_fun(x$get_items()), recursive = FALSE) + lapply(x$get_items(), function(z) z$get_dataname()) } else { - list(retrieve_parents(x)) + x$get_datanames() } - }) - } + })) - new_parents <- unlist(new_parents_fun(data_objects), recursive = FALSE) - - names(new_parents) <- unlist(lapply(data_objects, function(x) { - if (inherits(x, "TealDataConnector")) { - lapply(x$get_items(), function(z) z$get_dataname()) - } else { - x$get_datanames() + if (is_dag(new_parents)) { + stop("Cycle detected in a parent and child dataset graph.") } - })) + join_keys$set_parents(new_parents) + join_keys$update_keys_given_parents() - if (is_dag(new_parents)) { - stop("Cycle detected in a parent and child dataset graph.") - } - join_keys$set_parents(new_parents) - join_keys$update_keys_given_parents() + x <- TealData$new(..., check = check, join_keys = join_keys) + + if (length(code) > 0 && !identical(code, "")) { + x$set_pull_code(code = code) + } - x <- TealData$new(..., check = check, join_keys = join_keys) + x$check_reproducibility() + x$check_metadata() - if (length(code) > 0 && !identical(code, "")) { - x$set_pull_code(code = code) + if (is_pulled(x)) { + new_tdata( + env = lapply(x$get_datasets(), function(x) x$get_raw_data()), + code = x$get_code(), + keys = x$get_join_keys() + ) + } else { + x + } + } else { + new_tdata(env = data_objects, code = code, keys = join_keys) } - - x$check_reproducibility() - x$check_metadata() - return(x) } #' Load `TealData` object from a file diff --git a/R/get_dataname.R b/R/get_dataname.R index 3418c9087..731c3f295 100644 --- a/R/get_dataname.R +++ b/R/get_dataname.R @@ -32,3 +32,9 @@ get_dataname.TealDatasetConnector <- function(x) { # nolint get_dataname.TealDataset <- function(x) { # nolint return(x$get_dataname()) } + +#' @rdname get_dataname +#' @export +get_dataname.tdata <- function(x) { # nolint + return(x@datanames) +} diff --git a/R/get_datasets.R b/R/get_datasets.R index e72595725..4a52a42ac 100644 --- a/R/get_datasets.R +++ b/R/get_datasets.R @@ -133,3 +133,9 @@ get_datasets.TealDatasetConnector <- function(x) { # nolint get_datasets.TealDataset <- function(x) { x } + +#' @rdname get_datasets +#' @export +get_datasets.tdata <- function(x) { + as.list(x@env)[teal.data::get_dataname(x)] +} diff --git a/R/get_join_keys.R b/R/get_join_keys.R new file mode 100644 index 000000000..dae6e38d8 --- /dev/null +++ b/R/get_join_keys.R @@ -0,0 +1,21 @@ +#' Function to get join keys from a `tdata` object +#' @param data `tdata` - object to extract the join keys +#' @return Either `JoinKeys` object or `NULL` if no join keys +#' @export +get_join_keys <- function(data) { + UseMethod("get_join_keys", data) +} + + +#' @rdname get_join_keys +#' @export +get_join_keys.tdata <- function(data) { + data@join_keys +} + + +#' @rdname get_join_keys +#' @export +get_join_keys.TealData <- function(data) { + data$get_join_keys() +} diff --git a/R/is_pulled.R b/R/is_pulled.R index ee0139632..898a47bd1 100644 --- a/R/is_pulled.R +++ b/R/is_pulled.R @@ -6,7 +6,6 @@ #' @param x ([`TealDatasetConnector`], [`TealDataset`] or [`TealDataAbstract`]) #' #' @return (`logical`) `TRUE` if connector has been already pulled, else `FALSE`. -#' @export is_pulled <- function(x) { UseMethod("is_pulled") } diff --git a/R/tdata.R b/R/tdata.R new file mode 100644 index 000000000..5dd4dd5ee --- /dev/null +++ b/R/tdata.R @@ -0,0 +1,75 @@ +setOldClass("JoinKeys") + +#' @import teal.code +#' @export +setClass( + Class = "tdata", + contains = "qenv", + slots = c(join_keys = "JoinKeys", datanames = "character"), + prototype = list( + join_keys = join_keys(), + datanames = character(0) + ) +) + +#' Initialize `tdata` object +#' +#' Initialize `tdata` object. +#' @name new_tdata +#' +#' @param code (`character(1)` or `language`) code to evaluate. Accepts and stores comments also. +#' @param env (`list`) List of data. +#' +#' @examples +#' new_tdata(env = list(a = 1), code = quote(a <- 1)) +#' new_tdata(env = list(a = 1), code = parse(text = "a <- 1")) +#' new_tdatas(env = list(a = 1), code = "a <- 1") +#' +#' @export +setGeneric("new_tdata", function(env = new.env(), code = expression(), keys = join_keys()) { + standardGeneric("new_tdata") +}) + +#' @rdname new_tdata +#' @export +setMethod( + "new_tdata", + signature = c(env = "list", code = "expression", keys = "ANY"), + function(env, code, keys = join_keys()) { + new_env <- rlang::env_clone(list2env(env), parent = parent.env(.GlobalEnv)) + lockEnvironment(new_env, bindings = TRUE) + id <- sample.int(.Machine$integer.max, size = length(code)) + methods::new( + "tdata", + env = new_env, + code = code, + warnings = rep("", length(code)), + messages = rep("", length(code)), + id = id, + join_keys = keys, + datanames = union(names(env), names(keys$get())) + ) + } +) + +#' @rdname new_tdata +#' @export +setMethod( + "new_tdata", + signature = c(env = "list", code = "language", keys = "ANY"), + function(env, code, keys = join_keys()) { + code_expr <- as.expression(code) + new_tdata(env = env, code = code_expr, keys = keys) + } +) + +#' @rdname new_tdata +#' @export +setMethod( + "new_tdata", + signature = c(env = "list", code = "character", keys = "ANY"), + function(env, code, keys = join_keys()) { + code_expr <- parse(text = code) + new_tdata(env = env, code = code_expr, keys = keys) + } +) diff --git a/R/teal_data.R b/R/teal_data.R index 2aab2abdc..374a5644f 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -36,27 +36,41 @@ teal_data <- function(..., code = "", check = FALSE) { data_objects <- list(...) - checkmate::assert_list( - data_objects, - types = c("TealDataset", "TealDatasetConnector", "TealDataConnector") - ) if (inherits(join_keys, "JoinKeySet")) { join_keys <- teal.data::join_keys(join_keys) } + if ( + checkmate::test_list(data_objects, types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")) + ) { + warning("Using TealDatasetConnector and TealDataset is deprecated, please just include data directly.") + update_join_keys_to_primary(data_objects, join_keys) - update_join_keys_to_primary(data_objects, join_keys) - - x <- TealData$new(..., check = check, join_keys = join_keys) + x <- TealData$new(..., check = check, join_keys = join_keys) + if (length(code) > 0 && !identical(code, "")) { + x$set_pull_code(code = code) + } + x$check_reproducibility() + x$check_metadata() - if (length(code) > 0 && !identical(code, "")) { - x$set_pull_code(code = code) + if (is_pulled(x)) { + new_tdata( + env = lapply(x$get_datasets(), function(x) x$get_raw_data()), + code = x$get_code(), + keys = x$get_join_keys() + ) + } else { + x + } + } else { + new_tdata( + env = data_objects, + code = code, + keys = join_keys + ) } +} - x$check_reproducibility() - x$check_metadata() - return(x) -} #' Load `TealData` object from a file diff --git a/R/to_relational_data.R b/R/to_relational_data.R index 3cb132b67..bb583d9d8 100644 --- a/R/to_relational_data.R +++ b/R/to_relational_data.R @@ -126,3 +126,9 @@ to_relational_data.MultiAssayExperiment <- function(data) { # nolint to_relational_data.TealData <- function(data) { # nolint data } + +#' @keywords internal +#' @export +to_relational_data.tdata <- function(data) { + data +} diff --git a/man/get_dataname.Rd b/man/get_dataname.Rd index 3c7ae2953..0214a4855 100644 --- a/man/get_dataname.Rd +++ b/man/get_dataname.Rd @@ -5,6 +5,7 @@ \alias{get_dataname.TealDataAbstract} \alias{get_dataname.TealDatasetConnector} \alias{get_dataname.TealDataset} +\alias{get_dataname.tdata} \title{S3 method for getting a \code{dataname(s)} of (\code{TealDataAbstract}, (\code{TealDatasetConnector} or \code{TealDataset}) R6 object} @@ -16,6 +17,8 @@ get_dataname(x) \method{get_dataname}{TealDatasetConnector}(x) \method{get_dataname}{TealDataset}(x) + +\method{get_dataname}{tdata}(x) } \arguments{ \item{x}{(\code{TealDataAbstract}, \code{TealDatasetConnector} or diff --git a/man/get_datasets.Rd b/man/get_datasets.Rd index ea34069a8..8e3cb0eb1 100644 --- a/man/get_datasets.Rd +++ b/man/get_datasets.Rd @@ -5,6 +5,7 @@ \alias{get_datasets.TealDataAbstract} \alias{get_datasets.TealDatasetConnector} \alias{get_datasets.TealDataset} +\alias{get_datasets.tdata} \title{Get a \code{\link{TealDataset}} objects.} \usage{ get_datasets(x) @@ -14,6 +15,8 @@ get_datasets(x) \method{get_datasets}{TealDatasetConnector}(x) \method{get_datasets}{TealDataset}(x) + +\method{get_datasets}{tdata}(x) } \arguments{ \item{x}{(\code{\link{TealData}})\cr diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd new file mode 100644 index 000000000..938825196 --- /dev/null +++ b/man/get_join_keys.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_join_keys.R +\name{get_join_keys} +\alias{get_join_keys} +\alias{get_join_keys.tdata} +\alias{get_join_keys.TealData} +\title{Function to get join keys from a \code{tdata} object} +\usage{ +get_join_keys(data) + +\method{get_join_keys}{tdata}(data) + +\method{get_join_keys}{TealData}(data) +} +\arguments{ +\item{data}{\code{tdata} - object to extract the join keys} +} +\value{ +Either \code{JoinKeys} object or \code{NULL} if no join keys +} +\description{ +Function to get join keys from a \code{tdata} object +} diff --git a/man/new_tdata.Rd b/man/new_tdata.Rd new file mode 100644 index 000000000..106a6ea84 --- /dev/null +++ b/man/new_tdata.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tdata.R +\name{new_tdata} +\alias{new_tdata} +\alias{new_tdata,list,expression-method} +\alias{new_tdata,list,language-method} +\alias{new_tdata,list,character-method} +\title{Initialize \code{tdata} object} +\usage{ +new_tdata(env = new.env(), code = expression(), keys = join_keys()) + +\S4method{new_tdata}{list,expression}(env = new.env(), code = expression(), keys = join_keys()) + +\S4method{new_tdata}{list,language}(env = new.env(), code = expression(), keys = join_keys()) + +\S4method{new_tdata}{list,character}(env = new.env(), code = expression(), keys = join_keys()) +} +\arguments{ +\item{env}{(\code{list}) List of data.} + +\item{code}{(\code{character(1)} or \code{language}) code to evaluate. Accepts and stores comments also.} +} +\description{ +Initialize \code{tdata} object. +} +\examples{ +new_tdata(env = list(a = 1), code = quote(a <- 1)) +new_tdata(env = list(a = 1), code = parse(text = "a <- 1")) +new_tdatas(env = list(a = 1), code = "a <- 1") + +} From bef092fd1955e566716e9d182b647657d1eac1ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Tue, 15 Aug 2023 05:55:14 +0200 Subject: [PATCH 02/18] ddl --- R/ddl.R | 239 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 239 insertions(+) create mode 100644 R/ddl.R diff --git a/R/ddl.R b/R/ddl.R new file mode 100644 index 000000000..19b04b378 --- /dev/null +++ b/R/ddl.R @@ -0,0 +1,239 @@ +#' DDL object +#' +#' Object to execute custom DDL code in the shiny session +#' +#' @param code (`character`)\cr +#' Code to be evaluated and returned to the `postprocess_fun` +#' +#' @param ui (`shiny.tag`)\cr +#' `shiny` ui module containing inputs which `id` correspond to the +#' args in the `code`. +#' +#' @param server (`function(id, offline_args, code, postprocess_fun)`)\cr +#' `shiny` server module returning data. This server suppose to execute +#' DDL code and return a reactive data containing necessary data. +#' Package provides universal `username_password_server` which +#' runs [ddl_run] function, which returns `tdata` object. +#' Details in the the example +#' +#' @param offline_args (`list` named)\cr +#' arguments to be substituted in the `code`. These +#' argument are going to replace arguments set through +#' `ui` and `server`. Example use case is when app user +#' is asked to input a password and we'd like to skip this +#' input in the reproducible code. Typically users password +#' is substituted with `askpass::askpass()` call, so the +#' returned code is still executable but secure. +#' +#' @param postprocess_fun (`function(env, code)`)\cr +#' Function to be run after code is run. This function suppose +#' has two arguments: +#' - `env` (`environment`) returned as a result of the code evaluation +#' - code (`character`) `code` provided with resolved (substituted) args. +#' +#' @examples +#' +#' # simple example +#' +#' x <- ddl( +#' # code to be run when app user presses submit +#' code = " +#' ADSL <- scda::synthetic_cdisc_data({ version })$adsl +#' ADTTE <- scda::synthetic_cdisc_data({ version })$adtte +#' ADRS <- scda::synthetic_cdisc_data({ version })$adrs +#' ", +#' +#' # ui they wish to use for the loading data +#' ui = function(id) { +#' ns <- NS(id) +#' tagList( +#' textInput(ns("version"), label = "SCDA version", value = "latest"), +#' actionButton(ns("submit"), label = "Submit") +#' ) +#' }, +#' +#' server = function(id, offline_args, code, postprocess_fun) { +#' moduleServer(id, function(input, output, session) { +#' # run code +#' tdata <- eventReactive(input$submit, { +#' ddl_run( +#' offline_args = offline_args, +#' code = code, +#' postprocess_fun = postprocess_fun, +#' online_args = reactiveValuesToList(input) +#' ) +#' }) +#' +#' # function returning data objects +#' postprocess_fun = function(env_list, code) { +#' do.call(teal.data::cdisc_data, args = c(env_list, code = code)) +#' } +#' ) +#' +#' app <- shinyApp( +#' ui = fluidPage( +#' fluidRow( +#' column(3, h1("User Inputs"), x$ui(id = "custom_ui")), +#' column(9, h1("R code"), verbatimTextOutput("output")) +#' ) +#' ), +#' server = function(input, output, session) { +#' loaded_data <- x$server(id = "custom_ui", x$offline_args, x$code, x$postprocess_fun) +#' output$output <- renderText({ +#' req(loaded_data()) +#' teal.code::get_code(loaded_data()) |> paste(collapse = "\n") +#' }) +#' } +#' ) +#' +#' \dontrun{ +#' shiny::runApp(app) +#' } +#' +#' # example with username and password +#' +#' @export +ddl <- function(code, + postprocess_fun = function(env_list, code) { + do.call(teal.data::teal_data, args = c(env_list, code = code)) + }, + offline_args = list(), + ui = submit_button_ui, + server = submit_button_server) { + structure( + list( + code = code, + ui = ui, + server = server, + offline_args = offline_args, + postprocess_fun = postprocess_fun + ), + class = "ddl" + ) +} + +#' Creates `tdata` object +#' +#' Resolves arguments and executes custom DDL `code`. +#' Custom `code` and `data` created from code evaluation +#' are passed to the `postprocess_fun` +#' +#' @inheritParams ddl +#' +#' @export +ddl_run <- function(code, offline_args, online_args, postprocess_fun) { + env_list <- ddl_eval_substitute(code = code, args = online_args) + + for (i in names(offline_args)) { + online_args[[i]] <- offline_args[[i]] + } + + if (!is.null(env_list)) { + code <- glue_code(code, args = online_args) + # create tdata object + postprocess_fun( + env_list, + # {username} is converted to askpass here + code = unclass(code) + ) # would need error handling here + } else { + NULL + } +} + +#' Substitute and evaluate ddl code +#' +#' @inheritParams ddl +#' @param args (`list` named)\cr +#' Containing elements named after arguments in the code +#' enclosed in currly brackets ex. `{ arg_name }` +#' @return `list` of objects being a result of the code evaluation +#' @examples +#' ddl_eval_substitute("x <- { arg }", list(arg = 1)) +#' ddl_eval_substitute("x <- { arg }", list(arg = "a")) +#' ddl_eval_substitute("a <- 1; x <- { arg } + 1", list(arg = quote(a))) +#' ddl_eval_substitute("a <- b", list(b = 1)) +ddl_eval_substitute <- function(code, args) { + tryCatch( # at the moment the try catch is around everything - should be around the eval only + expr = { + # extract arguments from the UI + # create the call by replacing { xyz } with the value from the args$xyz + call_str <- glue_code(code, args) + + # create environment to run the code + e <- list2env(args, parent = parent.env(.GlobalEnv)) + + # evaluate the code + eval(parse(text = call_str), envir = e) + + # return a list + as.list(e) + }, + error = function(cond) { + showNotification(cond$message, type = "error") + NULL + } + ) +} + +#' Substitute ddl code args +#' +#' Substitutes code arguments with `args`. Parts of the code +#' wrapped in curly brackets ex. `{ arg_name }` are replaced +#' with corresponding list elements +#' @inheritsParams ddl_eval_substitute +#' @return `character` +#' @examples +#' glue_code("x <- { arg }", list(arg = 1)) +#' glue_code("x <- { arg }", list(arg = "a")) +#' glue_code("a <- 1; x <- { arg } + 1", list(arg = quote(a))) +#' glue_code( +#' "a <- connect(login = { login }, password = { pass})", +#' list( +#' login = quote(askpass::askpass()), +#' password = quote(askpass::askpass()) +#' ) +#' ) +glue_code <- function(code, args) { + args <- lapply(args, function(x) { + if (is.character(x)) { + dQuote(x, q = FALSE) + } else if (is.language(x)) { + deparse1(x) + } else { + x + } + }) + glue::glue(code, .envir = args) +} + +#' @name submit_button_module +#' +#' @inheritParams ddl +#' @param id (`character`) `shiny` module id. +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, offline_args, code, postprocess_fun) { + moduleServer(id, function(input, output, session) { + tdata <- eventReactive(input$submit, { + ddl_run( + code = code, + offline_args = offline_args, + online_args = reactiveValuesToList(input), + postprocess_fun = postprocess_fun + ) + }) + + # would need to make sure we handle reactivity correctly here as teal::init expects not reactive tdata... + return(tdata) + }) +} From 5e3c0cb4276cc049e7969f70a92e757b8cf1d8b4 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 15 Aug 2023 04:27:40 +0000 Subject: [PATCH 03/18] [skip actions] Restyle files --- R/ddl.R | 60 --------------------------------------------------------- 1 file changed, 60 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 19b04b378..99af6f536 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -32,66 +32,6 @@ #' - code (`character`) `code` provided with resolved (substituted) args. #' #' @examples -#' -#' # simple example -#' -#' x <- ddl( -#' # code to be run when app user presses submit -#' code = " -#' ADSL <- scda::synthetic_cdisc_data({ version })$adsl -#' ADTTE <- scda::synthetic_cdisc_data({ version })$adtte -#' ADRS <- scda::synthetic_cdisc_data({ version })$adrs -#' ", -#' -#' # ui they wish to use for the loading data -#' ui = function(id) { -#' ns <- NS(id) -#' tagList( -#' textInput(ns("version"), label = "SCDA version", value = "latest"), -#' actionButton(ns("submit"), label = "Submit") -#' ) -#' }, -#' -#' server = function(id, offline_args, code, postprocess_fun) { -#' moduleServer(id, function(input, output, session) { -#' # run code -#' tdata <- eventReactive(input$submit, { -#' ddl_run( -#' offline_args = offline_args, -#' code = code, -#' postprocess_fun = postprocess_fun, -#' online_args = reactiveValuesToList(input) -#' ) -#' }) -#' -#' # function returning data objects -#' postprocess_fun = function(env_list, code) { -#' do.call(teal.data::cdisc_data, args = c(env_list, code = code)) -#' } -#' ) -#' -#' app <- shinyApp( -#' ui = fluidPage( -#' fluidRow( -#' column(3, h1("User Inputs"), x$ui(id = "custom_ui")), -#' column(9, h1("R code"), verbatimTextOutput("output")) -#' ) -#' ), -#' server = function(input, output, session) { -#' loaded_data <- x$server(id = "custom_ui", x$offline_args, x$code, x$postprocess_fun) -#' output$output <- renderText({ -#' req(loaded_data()) -#' teal.code::get_code(loaded_data()) |> paste(collapse = "\n") -#' }) -#' } -#' ) -#' -#' \dontrun{ -#' shiny::runApp(app) -#' } -#' -#' # example with username and password -#' #' @export ddl <- function(code, postprocess_fun = function(env_list, code) { From 7429b557ed7e31dd0c9c0e9db45dd04177e00905 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 15 Aug 2023 08:57:54 +0200 Subject: [PATCH 04/18] adjust to teal --- R/ddl.R | 22 ++++++++++++++-------- R/get_dataname.R | 6 ++++++ R/get_join_keys.R | 6 ++++++ 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 99af6f536..df97fb748 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -39,14 +39,18 @@ ddl <- function(code, }, offline_args = list(), ui = submit_button_ui, - server = submit_button_server) { + server = submit_button_server, + join_keys = teal.data::join_keys(), + datanames = NULL) { structure( list( code = code, ui = ui, server = server, offline_args = offline_args, - postprocess_fun = postprocess_fun + postprocess_fun = postprocess_fun, + datanames = datanames, + join_keys = join_keys ), class = "ddl" ) @@ -61,15 +65,17 @@ ddl <- function(code, #' @inheritParams ddl #' #' @export -ddl_run <- function(code, offline_args, online_args, postprocess_fun) { - env_list <- ddl_eval_substitute(code = code, args = online_args) - - for (i in names(offline_args)) { - online_args[[i]] <- offline_args[[i]] +ddl_run <- function(ddl, online_args) { + env_list <- ddl_eval_substitute(code = ddl$code, args = online_args) + if (!is.null(ddl$datanames)) { + env_list <- env_list[ddl$datanames] + } + for (i in names(ddl$offline_args)) { + online_args[[i]] <- ddl$offline_args[[i]] } if (!is.null(env_list)) { - code <- glue_code(code, args = online_args) + code <- glue_code(ddl$code, args = online_args) # create tdata object postprocess_fun( env_list, diff --git a/R/get_dataname.R b/R/get_dataname.R index 731c3f295..68949fa2a 100644 --- a/R/get_dataname.R +++ b/R/get_dataname.R @@ -38,3 +38,9 @@ get_dataname.TealDataset <- function(x) { # nolint get_dataname.tdata <- function(x) { # nolint return(x@datanames) } + +#' @rdname get_dataname +#' @export +get_dataname.ddl <- function(x) { + x$datanames +} diff --git a/R/get_join_keys.R b/R/get_join_keys.R index dae6e38d8..512234d6b 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -13,6 +13,12 @@ get_join_keys.tdata <- function(data) { data@join_keys } +#' @rdname get_join_keys +#' @export +get_join_keys.ddl <- function(data) { + data$join_keys +} + #' @rdname get_join_keys #' @export From e964b95be5111216e924621b7793ff046249de99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Tue, 15 Aug 2023 15:32:22 +0200 Subject: [PATCH 05/18] fix --- R/ddl.R | 83 ++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 58 insertions(+), 25 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index df97fb748..810dc81e2 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -31,17 +31,25 @@ #' - `env` (`environment`) returned as a result of the code evaluation #' - code (`character`) `code` provided with resolved (substituted) args. #' +#' @param datanames (`character`)\cr +#' Names of the objects to be created from the code evaluation. +#' If not specified (`character(0)`), all objects will be used to `teal_data` function +#' (via `env_list` in `postprocess_fun`). +#' +#' @inheritParams teal_data +#' +#' #' @examples #' @export ddl <- function(code, - postprocess_fun = function(env_list, code) { - do.call(teal.data::teal_data, args = c(env_list, code = code)) - }, - offline_args = list(), ui = submit_button_ui, server = submit_button_server, + offline_args = list(), + postprocess_fun = function(env_list, code, join_keys) { + do.call(teal.data::teal_data, args = c(env_list, code = code, join_keys)) + }, join_keys = teal.data::join_keys(), - datanames = NULL) { + datanames = character(0)) { structure( list( code = code, @@ -59,32 +67,48 @@ ddl <- function(code, #' Creates `tdata` object #' #' Resolves arguments and executes custom DDL `code`. -#' Custom `code` and `data` created from code evaluation -#' are passed to the `postprocess_fun` +#' Custom `code` is substituted by `online_args` and evaluated. Then obtained code is +#' substituted again by `offline_args` and passed to the `postprocess_fun`. #' #' @inheritParams ddl +#' @param online_args (`list` named)\cr +#' Arguments to be substituted in the `code` and evaluated. Result of the evaluation +#' is based on the provided (dynamic) arguments. +#' +#' @return `tdata` containing objects created: +#' - `env` created by the `code` substitution and evaluation using +#' `online_args`, while the `code`. +#' - `code` with substituted `offline_args. +#' - `join_keys` specified in the `ddl` object. #' #' @export -ddl_run <- function(ddl, online_args) { +ddl_run <- function(ddl, online_args = list()) { + # substitute by online args and evaluate env_list <- ddl_eval_substitute(code = ddl$code, args = online_args) - if (!is.null(ddl$datanames)) { + if (is.null(env_list)) { + warning("DDL code returned NULL. Returning empty tdata object") + } + + # to create tdata with limited number of objects + if (length(ddl$datanames)) { env_list <- env_list[ddl$datanames] } + + # substitute by offline args for (i in names(ddl$offline_args)) { online_args[[i]] <- ddl$offline_args[[i]] } - - if (!is.null(env_list)) { - code <- glue_code(ddl$code, args = online_args) - # create tdata object - postprocess_fun( - env_list, - # {username} is converted to askpass here - code = unclass(code) - ) # would need error handling here - } else { - NULL + code <- glue_code(ddl$code, args = online_args) + # create tdata object + obj <- ddl$postprocess_fun( + env_list, + code = unclass(code), + join_keys = ddl$join_keys + ) + if (!inherits(obj, "tdata")) { + stop("postprocess_fun should return tdata object") } + obj } #' Substitute and evaluate ddl code @@ -168,14 +192,13 @@ submit_button_ui <- function(id) { #' @rdname submit_button_module #' @export -submit_button_server <- function(id, offline_args, code, postprocess_fun) { +submit_button_server <- function(id, ddl) { moduleServer(id, function(input, output, session) { tdata <- eventReactive(input$submit, { + req(input$pass) ddl_run( - code = code, - offline_args = offline_args, - online_args = reactiveValuesToList(input), - postprocess_fun = postprocess_fun + ddl = ddl, + online_args = reactiveValuesToList(input) ) }) @@ -183,3 +206,13 @@ submit_button_server <- function(id, offline_args, code, postprocess_fun) { return(tdata) }) } + + +# todo: to remove ------------- +open_conn <- function(username, password) { + if (password != "pass") stop("Invalid credentials. 'pass' is the password") else TRUE +} +close_conn <- function(conn) { + message("closed") + return(NULL) +} \ No newline at end of file From 3f37efeb9bfaa5643e7a361dd5707c10adf47bcb Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 15 Aug 2023 13:35:20 +0000 Subject: [PATCH 06/18] [skip actions] Restyle files --- R/ddl.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/ddl.R b/R/ddl.R index 810dc81e2..ae821ceb2 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -215,4 +215,4 @@ open_conn <- function(username, password) { close_conn <- function(conn) { message("closed") return(NULL) -} \ No newline at end of file +} From 212806c9022ed33d26adab5b14defd912a6ebd8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Wed, 16 Aug 2023 14:40:56 +0200 Subject: [PATCH 07/18] change arg names --- NAMESPACE | 6 ++++ R/ddl.R | 39 ++++++++++++----------- man/ddl.Rd | 64 ++++++++++++++++++++++++++++++++++++++ man/ddl_eval_substitute.Rd | 28 +++++++++++++++++ man/ddl_run.Rd | 27 ++++++++++++++++ man/get_dataname.Rd | 3 ++ man/get_join_keys.Rd | 3 ++ man/glue_code.Rd | 28 +++++++++++++++++ 8 files changed, 179 insertions(+), 19 deletions(-) create mode 100644 man/ddl.Rd create mode 100644 man/ddl_eval_substitute.Rd create mode 100644 man/ddl_run.Rd create mode 100644 man/glue_code.Rd diff --git a/NAMESPACE b/NAMESPACE index 50e7cac3c..28a48f365 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ S3method(get_code,default) S3method(get_dataname,TealDataAbstract) S3method(get_dataname,TealDataset) S3method(get_dataname,TealDatasetConnector) +S3method(get_dataname,ddl) S3method(get_dataname,tdata) S3method(get_dataset,TealDataAbstract) S3method(get_dataset,TealDataset) @@ -23,6 +24,7 @@ S3method(get_datasets,TealDataset) S3method(get_datasets,TealDatasetConnector) S3method(get_datasets,tdata) S3method(get_join_keys,TealData) +S3method(get_join_keys,ddl) S3method(get_join_keys,tdata) S3method(get_key_duplicates,TealDataset) S3method(get_key_duplicates,data.frame) @@ -84,6 +86,8 @@ export(dataset) export(dataset_connector) export(dataset_connector_file) export(dataset_file) +export(ddl) +export(ddl_run) export(example_cdisc_data) export(fun_cdisc_dataset_connector) export(fun_dataset_connector) @@ -119,6 +123,8 @@ export(script_cdisc_dataset_connector) export(script_dataset_connector) export(set_args) export(set_keys) +export(submit_button_server) +export(submit_button_ui) export(teal_data) export(teal_data_file) export(to_relational_data) diff --git a/R/ddl.R b/R/ddl.R index ae821ceb2..d24c32cca 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -46,10 +46,14 @@ ddl <- function(code, server = submit_button_server, offline_args = list(), postprocess_fun = function(env_list, code, join_keys) { - do.call(teal.data::teal_data, args = c(env_list, code = code, join_keys)) + do.call(teal.data::teal_data, args = c(env_list, code = code, join_keys = join_keys)) }, join_keys = teal.data::join_keys(), - datanames = character(0)) { + datanames) { + if (missing(datanames)) { + stop("`dataname` argument is required") + } + structure( list( code = code, @@ -82,32 +86,33 @@ ddl <- function(code, #' - `join_keys` specified in the `ddl` object. #' #' @export -ddl_run <- function(ddl, online_args = list()) { +ddl_run <- function(x, online_args = list()) { + checkmate::assert_class(x, "ddl") # substitute by online args and evaluate - env_list <- ddl_eval_substitute(code = ddl$code, args = online_args) + env_list <- ddl_eval_substitute(code = x$code, args = online_args) if (is.null(env_list)) { warning("DDL code returned NULL. Returning empty tdata object") } - # to create tdata with limited number of objects - if (length(ddl$datanames)) { - env_list <- env_list[ddl$datanames] - } + # don't pass non-dataset bindings further + # we don't want to initialize tdata with them + env_list <- env_list[x$datanames] # substitute by offline args - for (i in names(ddl$offline_args)) { - online_args[[i]] <- ddl$offline_args[[i]] + for (i in names(x$offline_args)) { + online_args[[i]] <- x$offline_args[[i]] } - code <- glue_code(ddl$code, args = online_args) + code <- glue_code(x$code, args = online_args) # create tdata object - obj <- ddl$postprocess_fun( + obj <- x$postprocess_fun( env_list, code = unclass(code), - join_keys = ddl$join_keys + join_keys = x$join_keys ) if (!inherits(obj, "tdata")) { stop("postprocess_fun should return tdata object") } + obj } @@ -192,14 +197,10 @@ submit_button_ui <- function(id) { #' @rdname submit_button_module #' @export -submit_button_server <- function(id, ddl) { +submit_button_server <- function(id, x) { moduleServer(id, function(input, output, session) { tdata <- eventReactive(input$submit, { - req(input$pass) - ddl_run( - ddl = ddl, - online_args = reactiveValuesToList(input) - ) + ddl_run(x = x, online_args = reactiveValuesToList(input)) }) # would need to make sure we handle reactivity correctly here as teal::init expects not reactive tdata... diff --git a/man/ddl.Rd b/man/ddl.Rd new file mode 100644 index 000000000..e985cfcb5 --- /dev/null +++ b/man/ddl.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddl.R +\name{ddl} +\alias{ddl} +\title{DDL object} +\usage{ +ddl( + code, + ui = submit_button_ui, + server = submit_button_server, + offline_args = list(), + postprocess_fun = function(env_list, code, join_keys) { + + do.call(teal.data::teal_data, args = c(env_list, code = code, join_keys = + join_keys)) + }, + join_keys = teal.data::join_keys(), + datanames +) +} +\arguments{ +\item{code}{(\code{character})\cr +Code to be evaluated and returned to the \code{postprocess_fun}} + +\item{ui}{(\code{shiny.tag})\cr +\code{shiny} ui module containing inputs which \code{id} correspond to the +args in the \code{code}.} + +\item{server}{(\verb{function(id, offline_args, code, postprocess_fun)})\cr +\code{shiny} server module returning data. This server suppose to execute +DDL code and return a reactive data containing necessary data. +Package provides universal \code{username_password_server} which +runs \link{ddl_run} function, which returns \code{tdata} object. +Details in the the example} + +\item{offline_args}{(\code{list} named)\cr +arguments to be substituted in the \code{code}. These +argument are going to replace arguments set through +\code{ui} and \code{server}. Example use case is when app user +is asked to input a password and we'd like to skip this +input in the reproducible code. Typically users password +is substituted with \code{askpass::askpass()} call, so the +returned code is still executable but secure.} + +\item{postprocess_fun}{(\verb{function(env, code)})\cr +Function to be run after code is run. This function suppose +has two arguments: +\itemize{ +\item \code{env} (\code{environment}) returned as a result of the code evaluation +\item code (\code{character}) \code{code} provided with resolved (substituted) args. +}} + +\item{join_keys}{(\code{JoinKeys}) or a single (\code{JoinKeySet})\cr +(optional) object with dataset column relationships used for joining. +If empty then no joins between pairs of objects} + +\item{datanames}{(\code{character})\cr +Names of the objects to be created from the code evaluation. +If not specified (\code{character(0)}), all objects will be used to \code{teal_data} function +(via \code{env_list} in \code{postprocess_fun}).} +} +\description{ +Object to execute custom DDL code in the shiny session +} diff --git a/man/ddl_eval_substitute.Rd b/man/ddl_eval_substitute.Rd new file mode 100644 index 000000000..c97786cdc --- /dev/null +++ b/man/ddl_eval_substitute.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddl.R +\name{ddl_eval_substitute} +\alias{ddl_eval_substitute} +\title{Substitute and evaluate ddl code} +\usage{ +ddl_eval_substitute(code, args) +} +\arguments{ +\item{code}{(\code{character})\cr +Code to be evaluated and returned to the \code{postprocess_fun}} + +\item{args}{(\code{list} named)\cr +Containing elements named after arguments in the code +enclosed in currly brackets ex. \code{{ arg_name }}} +} +\value{ +\code{list} of objects being a result of the code evaluation +} +\description{ +Substitute and evaluate ddl code +} +\examples{ +ddl_eval_substitute("x <- { arg }", list(arg = 1)) +ddl_eval_substitute("x <- { arg }", list(arg = "a")) +ddl_eval_substitute("a <- 1; x <- { arg } + 1", list(arg = quote(a))) +ddl_eval_substitute("a <- b", list(b = 1)) +} diff --git a/man/ddl_run.Rd b/man/ddl_run.Rd new file mode 100644 index 000000000..1c1f9f887 --- /dev/null +++ b/man/ddl_run.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddl.R +\name{ddl_run} +\alias{ddl_run} +\title{Creates \code{tdata} object} +\usage{ +ddl_run(x, online_args = list()) +} +\arguments{ +\item{online_args}{(\code{list} named)\cr +Arguments to be substituted in the \code{code} and evaluated. Result of the evaluation +is based on the provided (dynamic) arguments.} +} +\value{ +\code{tdata} containing objects created: +\itemize{ +\item \code{env} created by the \code{code} substitution and evaluation using +\code{online_args}, while the \code{code}. +\item \code{code} with substituted `offline_args. +\item \code{join_keys} specified in the \code{ddl} object. +} +} +\description{ +Resolves arguments and executes custom DDL \code{code}. +Custom \code{code} is substituted by \code{online_args} and evaluated. Then obtained code is +substituted again by \code{offline_args} and passed to the \code{postprocess_fun}. +} diff --git a/man/get_dataname.Rd b/man/get_dataname.Rd index 0214a4855..7dce7328a 100644 --- a/man/get_dataname.Rd +++ b/man/get_dataname.Rd @@ -6,6 +6,7 @@ \alias{get_dataname.TealDatasetConnector} \alias{get_dataname.TealDataset} \alias{get_dataname.tdata} +\alias{get_dataname.ddl} \title{S3 method for getting a \code{dataname(s)} of (\code{TealDataAbstract}, (\code{TealDatasetConnector} or \code{TealDataset}) R6 object} @@ -19,6 +20,8 @@ get_dataname(x) \method{get_dataname}{TealDataset}(x) \method{get_dataname}{tdata}(x) + +\method{get_dataname}{ddl}(x) } \arguments{ \item{x}{(\code{TealDataAbstract}, \code{TealDatasetConnector} or diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 938825196..bea5bb8c2 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -3,6 +3,7 @@ \name{get_join_keys} \alias{get_join_keys} \alias{get_join_keys.tdata} +\alias{get_join_keys.ddl} \alias{get_join_keys.TealData} \title{Function to get join keys from a \code{tdata} object} \usage{ @@ -10,6 +11,8 @@ get_join_keys(data) \method{get_join_keys}{tdata}(data) +\method{get_join_keys}{ddl}(data) + \method{get_join_keys}{TealData}(data) } \arguments{ diff --git a/man/glue_code.Rd b/man/glue_code.Rd new file mode 100644 index 000000000..0b5ff1a38 --- /dev/null +++ b/man/glue_code.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddl.R +\name{glue_code} +\alias{glue_code} +\title{Substitute ddl code args} +\usage{ +glue_code(code, args) +} +\value{ +\code{character} +} +\description{ +Substitutes code arguments with \code{args}. Parts of the code +wrapped in curly brackets ex. \code{{ arg_name }} are replaced +with corresponding list elements +} +\examples{ +glue_code("x <- { arg }", list(arg = 1)) +glue_code("x <- { arg }", list(arg = "a")) +glue_code("a <- 1; x <- { arg } + 1", list(arg = quote(a))) +glue_code( + "a <- connect(login = { login }, password = { pass})", + list( + login = quote(askpass::askpass()), + password = quote(askpass::askpass()) + ) +) +} From 7edaf2a1ad832cb2bef73e0a0ea1f3fe6368dc2f Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 7 Sep 2023 12:14:47 +0200 Subject: [PATCH 08/18] cleanup builds --- R/ddl.R | 4 +--- man/glue_code.Rd | 8 ++++++++ 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index d24c32cca..57926e377 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -38,8 +38,6 @@ #' #' @inheritParams teal_data #' -#' -#' @examples #' @export ddl <- function(code, ui = submit_button_ui, @@ -156,7 +154,7 @@ ddl_eval_substitute <- function(code, args) { #' Substitutes code arguments with `args`. Parts of the code #' wrapped in curly brackets ex. `{ arg_name }` are replaced #' with corresponding list elements -#' @inheritsParams ddl_eval_substitute +#' @inheritParams ddl_eval_substitute #' @return `character` #' @examples #' glue_code("x <- { arg }", list(arg = 1)) diff --git a/man/glue_code.Rd b/man/glue_code.Rd index 0b5ff1a38..65290e2d8 100644 --- a/man/glue_code.Rd +++ b/man/glue_code.Rd @@ -6,6 +6,14 @@ \usage{ glue_code(code, args) } +\arguments{ +\item{code}{(\code{character})\cr +Code to be evaluated and returned to the \code{postprocess_fun}} + +\item{args}{(\code{list} named)\cr +Containing elements named after arguments in the code +enclosed in currly brackets ex. \code{{ arg_name }}} +} \value{ \code{character} } From b30029bdeeb2075d82db84406a0c77c888c74aa0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 7 Sep 2023 22:03:11 +0200 Subject: [PATCH 09/18] @anverissimo review --- R/cdisc_data.R | 11 +++++++++-- R/teal_data.R | 10 +++++++++- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/R/cdisc_data.R b/R/cdisc_data.R index ad097ad5b..a2f23bc9b 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -77,11 +77,15 @@ cdisc_data <- function(..., if ( checkmate::test_list(data_objects, types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { - warning("Using TealDatasetConnector and TealDataset is deprecated, please just include data directly.") update_join_keys_to_primary(data_objects, join_keys) - retrieve_parents <- function(x) { + retrieve_parents <- function(x) {lifecycle::deprecate_warn( + when = "0.3.1", + "cdisc_data( + data_objects = 'should use data directly. Using TealDatasetConnector and TealDataset is deprecated.' + )" + ) tryCatch( x$get_parent(), error = function(cond) rep(character(0), length(x$get_datanames())) @@ -133,6 +137,9 @@ cdisc_data <- function(..., x } } else { + if (!checkmate::test_names(names(data_objects), type = "named")) { + stop("Dot (`...`) arguments on `teal_data()` must be named.") + } new_tdata(env = data_objects, code = code, keys = join_keys) } } diff --git a/R/teal_data.R b/R/teal_data.R index 374a5644f..fbd4c8ea1 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -42,7 +42,12 @@ teal_data <- function(..., if ( checkmate::test_list(data_objects, types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { - warning("Using TealDatasetConnector and TealDataset is deprecated, please just include data directly.") + lifecycle::deprecate_warn( + when = "0.3.1", + "cdisc_data( + data_objects = 'should use data directly. Using TealDatasetConnector and TealDataset is deprecated.' + )" + ) update_join_keys_to_primary(data_objects, join_keys) x <- TealData$new(..., check = check, join_keys = join_keys) @@ -62,6 +67,9 @@ teal_data <- function(..., x } } else { + if (!checkmate::test_names(names(data_objects), type = "named")) { + stop("Dot (`...`) arguments on `teal_data()` must be named.") + } new_tdata( env = data_objects, code = code, From 1ca4cb14626c0edf1b4e1841d248cdfa85b397ab Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Date: Fri, 29 Sep 2023 09:09:19 +0200 Subject: [PATCH 10/18] ddl alternative (#167) `ddl` implementation alternative to #161 . Complemented by [this PR](https://github.com/insightsengineering/teal/pull/922). In order to simplify the user (app dev) experience, I tried to streamline the logic. In order to create a `ddl` connector module, one has to: 1. use `input_template` to create the module: enumerate input widgets 2. provide a function, `on_submit`, to be run when `"submit"` button is clicked; function takes input values wrapped in a list called `input` and body refers to input values with `input$` or `input[[""]]` 3. optionally provide mask for input values that will be used in code of resulting `tdata` object 4. specify names of data sets for compatibility with `teal` (I don't like it) 5. optionally specify join keys as one would previously, for compatibility with `teal`; defaults to empty `teal.data::join_keys()` When inputs are submitted, `on_submit` is passed to a function that extracts the body, substitutes `input` placeholders with input values and evaluates the code to obtain data sets in a separate environment. Then it replaces the input values in the code with ones provided in `mask` (if any) and uses the environment and the masked code to create `tdata`. Much like in the solution proposed on branch `refactor`, the user provides code to obtain data sets and replacements for input values, and data is created in separate environment, which is then used to create `tdata` with masked code. Unlike that solution, the user specifies everything in one place, rather than having to define module ui, module server that runs a post-processing function, the post-processing function itself, etc. This is easier to understand **for me**. Another difference is that the user provides code as code with `input$` references, not text with `glue` syntax (`{ value }`). This is done move focus to masking rather than have the user think about "online" and "offline" arguments. It also uses pure base R. #### MOCK DATABASE CONNECTION ``` pullme <- function(username, password) { if (username == "user" && password == "pass") { message("connection established") } else { stop("invalid credentials") } } closeme <- function() { message("connection closed") } ``` #### MODULE DEFINITION ``` library(shiny) 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") ) ``` #### AN APP ``` 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) ``` #### A TEAL APP ``` 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")() }) } ) } devtools::load_all("../teal.slice") devtools::load_all("../teal") devtools::load_all(".") 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/__ddl_by_AC.R | 298 ++++++++++++++++++++++++++++++++++++++++++++++++ R/tdata.R | 2 +- 2 files changed, 299 insertions(+), 1 deletion(-) create mode 100644 R/__ddl_by_AC.R 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()))) ) } ) From 65041975651448289c66c22929cd38209f7c6666 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 29 Sep 2023 10:34:54 +0200 Subject: [PATCH 11/18] ddl WIP --- R/ddl.R | 71 +++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 51 insertions(+), 20 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 57926e377..59cc5726a 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -2,21 +2,27 @@ #' #' Object to execute custom DDL code in the shiny session #' -#' @param code (`character`)\cr -#' Code to be evaluated and returned to the `postprocess_fun` +#' @expr (`expression`)\cr +#' Syntatically valid R code to be executed in the shiny session. +#' shouldn't be specified when `code` is specified. +#' +#' @param code (`character`, `language`)\cr +#' Object containing code to be evaluated to load data. Shouldn't be specified when `expr` +#' is specified. +#' #' #' @param ui (`shiny.tag`)\cr #' `shiny` ui module containing inputs which `id` correspond to the #' args in the `code`. #' -#' @param server (`function(id, offline_args, code, postprocess_fun)`)\cr +#' @param server (`function(id, mask_args, code, postprocess_fun)`)\cr #' `shiny` server module returning data. This server suppose to execute #' DDL code and return a reactive data containing necessary data. #' Package provides universal `username_password_server` which #' runs [ddl_run] function, which returns `tdata` object. #' Details in the the example #' -#' @param offline_args (`list` named)\cr +#' @param mask_args (`list` named)\cr #' arguments to be substituted in the `code`. These #' argument are going to replace arguments set through #' `ui` and `server`. Example use case is when app user @@ -39,15 +45,23 @@ #' @inheritParams teal_data #' #' @export -ddl <- function(code, +ddl <- function(expr, + code, ui = submit_button_ui, server = submit_button_server, - offline_args = list(), + mask_args = list(), postprocess_fun = function(env_list, code, join_keys) { - do.call(teal.data::teal_data, args = c(env_list, code = code, join_keys = join_keys)) + NULL }, join_keys = teal.data::join_keys(), datanames) { + if (!missing(expr) && !missing(code)) { + stop("Only one of `expr` or `code` should be specified") + } + if (!missing(expr)) { + code <- substitute(expr) + } + if (missing(datanames)) { stop("`dataname` argument is required") } @@ -57,7 +71,7 @@ ddl <- function(code, code = code, ui = ui, server = server, - offline_args = offline_args, + mask_args = mask_args, postprocess_fun = postprocess_fun, datanames = datanames, join_keys = join_keys @@ -70,7 +84,7 @@ ddl <- function(code, #' #' Resolves arguments and executes custom DDL `code`. #' Custom `code` is substituted by `online_args` and evaluated. Then obtained code is -#' substituted again by `offline_args` and passed to the `postprocess_fun`. +#' substituted again by `mask_args` and passed to the `postprocess_fun`. #' #' @inheritParams ddl #' @param online_args (`list` named)\cr @@ -80,33 +94,37 @@ ddl <- function(code, #' @return `tdata` containing objects created: #' - `env` created by the `code` substitution and evaluation using #' `online_args`, while the `code`. -#' - `code` with substituted `offline_args. +#' - `code` with substituted `mask_args. #' - `join_keys` specified in the `ddl` object. #' #' @export ddl_run <- function(x, online_args = list()) { checkmate::assert_class(x, "ddl") # substitute by online args and evaluate - env_list <- ddl_eval_substitute(code = x$code, args = online_args) - if (is.null(env_list)) { + env <- list2env(list(input = online_args)) + eval(x$code, envir = env) + + if (identical(ls(env), character(0))) { warning("DDL code returned NULL. Returning empty tdata object") } # don't pass non-dataset bindings further # we don't want to initialize tdata with them - env_list <- env_list[x$datanames] + env_list <- as.list(env)[x$datanames] # substitute by offline args - for (i in names(x$offline_args)) { - online_args[[i]] <- x$offline_args[[i]] + for (i in names(x$mask_args)) { + online_args[[i]] <- x$mask_args[[i]] } - code <- glue_code(x$code, args = online_args) + code <- .substitute_inputs(x$code, args = online_args) + # create tdata object - obj <- x$postprocess_fun( - env_list, - code = unclass(code), - join_keys = x$join_keys + obj <- teal.data::new_tdata( + env = env_list, + code = as.expression(code), + keys = join_keys ) + if (!inherits(obj, "tdata")) { stop("postprocess_fun should return tdata object") } @@ -215,3 +233,16 @@ close_conn <- function(conn) { message("closed") return(NULL) } + +.substitute_inputs <- function(code, args) { + code <- if (identical(as.list(code)[[1L]], as.symbol("{"))) { + as.list(code)[-1L] + } else { + list(code) + } + 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. + lapply(code_strings, function(x) do.call(bquote, list(str2lang(x), args))) +} From d067b93795a32a6dd7393dabd575a83638107bf6 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 29 Sep 2023 14:07:30 +0200 Subject: [PATCH 12/18] POC --- R/ddl.R | 206 +++++++++++++++------------------------------- R/get_dataname.R | 2 +- R/get_join_keys.R | 2 +- 3 files changed, 68 insertions(+), 142 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 59cc5726a..c62c07037 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -16,8 +16,9 @@ #' args in the `code`. #' #' @param server (`function(id, mask_args, code, postprocess_fun)`)\cr -#' `shiny` server module returning data. This server suppose to execute -#' DDL code and return a reactive data containing necessary data. +#' `shiny` server module returning data. This server should execute +#' `code` and return a reactive data containing necessary data. To handle +#' evaluation and code masking process it is recommended to use `ddl_run`. #' Package provides universal `username_password_server` which #' runs [ddl_run] function, which returns `tdata` object. #' Details in the the example @@ -44,15 +45,13 @@ #' #' @inheritParams teal_data #' +#' #' @export ddl <- function(expr, code, ui = submit_button_ui, - server = submit_button_server, mask_args = list(), - postprocess_fun = function(env_list, code, join_keys) { - NULL - }, + server = submit_button_server, join_keys = teal.data::join_keys(), datanames) { if (!missing(expr) && !missing(code)) { @@ -61,143 +60,59 @@ ddl <- function(expr, if (!missing(expr)) { code <- substitute(expr) } + if (is.character(code)) { + code <- parse(text = code) + } if (missing(datanames)) { stop("`dataname` argument is required") } - structure( - list( - code = code, - ui = ui, - server = server, - mask_args = mask_args, - postprocess_fun = postprocess_fun, - datanames = datanames, - join_keys = join_keys - ), - class = "ddl" - ) -} -#' Creates `tdata` object -#' -#' Resolves arguments and executes custom DDL `code`. -#' Custom `code` is substituted by `online_args` and evaluated. Then obtained code is -#' substituted again by `mask_args` and passed to the `postprocess_fun`. -#' -#' @inheritParams ddl -#' @param online_args (`list` named)\cr -#' Arguments to be substituted in the `code` and evaluated. Result of the evaluation -#' is based on the provided (dynamic) arguments. -#' -#' @return `tdata` containing objects created: -#' - `env` created by the `code` substitution and evaluation using -#' `online_args`, while the `code`. -#' - `code` with substituted `mask_args. -#' - `join_keys` specified in the `ddl` object. -#' -#' @export -ddl_run <- function(x, online_args = list()) { - checkmate::assert_class(x, "ddl") - # substitute by online args and evaluate - env <- list2env(list(input = online_args)) - eval(x$code, envir = env) - - if (identical(ls(env), character(0))) { - warning("DDL code returned NULL. Returning empty tdata object") - } + # function creates tdata object from the code, input and mask_args + # function defined here to have access to the arguments + ddl_run <- function(online_args = list()) { + # substitute by online args and evaluate + env <- list2env(list(input = online_args)) + eval(code, envir = env) - # don't pass non-dataset bindings further - # we don't want to initialize tdata with them - env_list <- as.list(env)[x$datanames] + if (identical(ls(env), character(0))) { + warning("DDL code returned NULL. Returning empty tdata object") + } - # substitute by offline args - for (i in names(x$mask_args)) { - online_args[[i]] <- x$mask_args[[i]] - } - code <- .substitute_inputs(x$code, args = online_args) + # don't pass non-dataset bindings further + # we don't want to initialize tdata with them + env_list <- as.list(env)[datanames] - # create tdata object - obj <- teal.data::new_tdata( - env = env_list, - code = as.expression(code), - keys = join_keys - ) + # substitute by offline args + for (i in names(mask_args)) { + online_args[[i]] <- mask_args[[i]] + } + code <- .substitute_inputs(code, args = online_args) + + # create tdata object + obj <- teal.data::new_tdata(env = env_list, code = as.expression(code), keys = join_keys) + + if (!inherits(obj, "tdata")) { + stop("postprocess_fun should return tdata object") + } - if (!inherits(obj, "tdata")) { - stop("postprocess_fun should return tdata object") + obj } - obj -} + # changing enclosing environment of the server to have access to ddl_fun function + # Thanks to this ddl object contains only ui and server functions + # and server function can be run just by calling ddl$server("")! + environment(server) <- environment() -#' Substitute and evaluate ddl code -#' -#' @inheritParams ddl -#' @param args (`list` named)\cr -#' Containing elements named after arguments in the code -#' enclosed in currly brackets ex. `{ arg_name }` -#' @return `list` of objects being a result of the code evaluation -#' @examples -#' ddl_eval_substitute("x <- { arg }", list(arg = 1)) -#' ddl_eval_substitute("x <- { arg }", list(arg = "a")) -#' ddl_eval_substitute("a <- 1; x <- { arg } + 1", list(arg = quote(a))) -#' ddl_eval_substitute("a <- b", list(b = 1)) -ddl_eval_substitute <- function(code, args) { - tryCatch( # at the moment the try catch is around everything - should be around the eval only - expr = { - # extract arguments from the UI - # create the call by replacing { xyz } with the value from the args$xyz - call_str <- glue_code(code, args) - - # create environment to run the code - e <- list2env(args, parent = parent.env(.GlobalEnv)) - - # evaluate the code - eval(parse(text = call_str), envir = e) - - # return a list - as.list(e) - }, - error = function(cond) { - showNotification(cond$message, type = "error") - NULL - } + structure( + list(ui = ui, server = server), + datanames = datanames, + join_keys = join_keys, + class = "ddl" ) } -#' Substitute ddl code args -#' -#' Substitutes code arguments with `args`. Parts of the code -#' wrapped in curly brackets ex. `{ arg_name }` are replaced -#' with corresponding list elements -#' @inheritParams ddl_eval_substitute -#' @return `character` -#' @examples -#' glue_code("x <- { arg }", list(arg = 1)) -#' glue_code("x <- { arg }", list(arg = "a")) -#' glue_code("a <- 1; x <- { arg } + 1", list(arg = quote(a))) -#' glue_code( -#' "a <- connect(login = { login }, password = { pass})", -#' list( -#' login = quote(askpass::askpass()), -#' password = quote(askpass::askpass()) -#' ) -#' ) -glue_code <- function(code, args) { - args <- lapply(args, function(x) { - if (is.character(x)) { - dQuote(x, q = FALSE) - } else if (is.language(x)) { - deparse1(x) - } else { - x - } - }) - glue::glue(code, .envir = args) -} - #' @name submit_button_module #' #' @inheritParams ddl @@ -216,7 +131,7 @@ submit_button_ui <- function(id) { submit_button_server <- function(id, x) { moduleServer(id, function(input, output, session) { tdata <- eventReactive(input$submit, { - ddl_run(x = x, online_args = reactiveValuesToList(input)) + ddl_run(online_args = reactiveValuesToList(input)) }) # would need to make sure we handle reactivity correctly here as teal::init expects not reactive tdata... @@ -224,25 +139,36 @@ submit_button_server <- function(id, x) { }) } - -# todo: to remove ------------- -open_conn <- function(username, password) { - if (password != "pass") stop("Invalid credentials. 'pass' is the password") else TRUE -} -close_conn <- function(conn) { - message("closed") - return(NULL) -} - +#' 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 { - list(code) + code } + 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. - lapply(code_strings, function(x) do.call(bquote, list(str2lang(x), args))) + lapply(code_strings, function(x) { + bquote_call <- substitute(bquote(code), list(code = str2lang(x))) + eval(bquote_call, envir = list2env(args)) + }) +} + +# todo: to remove ------------- +open_conn <- function(username, password) { + if (password != "pass") stop("Invalid credentials. 'pass' is the password") else TRUE +} +close_conn <- function(conn) { + message("closed") + return(NULL) } diff --git a/R/get_dataname.R b/R/get_dataname.R index 68949fa2a..a25c9068e 100644 --- a/R/get_dataname.R +++ b/R/get_dataname.R @@ -42,5 +42,5 @@ get_dataname.tdata <- function(x) { # nolint #' @rdname get_dataname #' @export get_dataname.ddl <- function(x) { - x$datanames + attr(x, "datanames") } diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 512234d6b..8eb508c68 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -16,7 +16,7 @@ get_join_keys.tdata <- function(data) { #' @rdname get_join_keys #' @export get_join_keys.ddl <- function(data) { - data$join_keys + attr(data, "join_keys") } From 56a7b2dd1cf0b9b309d7a26193273594880c4105 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 29 Sep 2023 15:21:32 +0200 Subject: [PATCH 13/18] tdata -> teal_data --- NAMESPACE | 15 +++++++------ R/__ddl_by_AC.R | 12 +++++------ R/cdisc_data.R | 14 ++++++------- R/ddl.R | 18 ++++++++-------- R/get_dataname.R | 2 +- R/get_datasets.R | 2 +- R/get_join_keys.R | 6 +++--- R/{tdata.R => teal_data-class.R} | 36 ++++++++++++++++---------------- R/teal_data.R | 4 ++-- R/to_relational_data.R | 2 +- 10 files changed, 55 insertions(+), 56 deletions(-) rename R/{tdata.R => teal_data-class.R} (65%) diff --git a/NAMESPACE b/NAMESPACE index 28a48f365..2800d172b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,7 +13,7 @@ S3method(get_dataname,TealDataAbstract) S3method(get_dataname,TealDataset) S3method(get_dataname,TealDatasetConnector) S3method(get_dataname,ddl) -S3method(get_dataname,tdata) +S3method(get_dataname,teal_data) S3method(get_dataset,TealDataAbstract) S3method(get_dataset,TealDataset) S3method(get_dataset,TealDatasetConnector) @@ -22,10 +22,10 @@ S3method(get_dataset_label,TealDatasetConnector) S3method(get_datasets,TealDataAbstract) S3method(get_datasets,TealDataset) S3method(get_datasets,TealDatasetConnector) -S3method(get_datasets,tdata) +S3method(get_datasets,teal_data) S3method(get_join_keys,TealData) S3method(get_join_keys,ddl) -S3method(get_join_keys,tdata) +S3method(get_join_keys,teal_data) S3method(get_key_duplicates,TealDataset) S3method(get_key_duplicates,data.frame) S3method(get_keys,TealDataAbstract) @@ -61,7 +61,7 @@ S3method(to_relational_data,TealDataset) S3method(to_relational_data,TealDatasetConnector) S3method(to_relational_data,data.frame) S3method(to_relational_data,list) -S3method(to_relational_data,tdata) +S3method(to_relational_data,teal_data) export("col_labels<-") export("data_label<-") export(as_cdisc) @@ -87,7 +87,6 @@ export(dataset_connector) export(dataset_connector_file) export(dataset_file) export(ddl) -export(ddl_run) export(example_cdisc_data) export(fun_cdisc_dataset_connector) export(fun_dataset_connector) @@ -111,7 +110,7 @@ export(mae_dataset) export(mutate_data) export(mutate_dataset) export(mutate_join_keys) -export(new_tdata) +export(new_teal_data) export(python_cdisc_dataset_connector) export(python_code) export(python_dataset_connector) @@ -129,8 +128,8 @@ export(teal_data) export(teal_data_file) export(to_relational_data) export(validate_metadata) -exportClasses(tdata) -exportMethods(new_tdata) +exportClasses(teal_data) +exportMethods(new_teal_data) import(shiny) import(teal.code) importFrom(digest,digest) diff --git a/R/__ddl_by_AC.R b/R/__ddl_by_AC.R index 7031098f6..813ecb45b 100644 --- a/R/__ddl_by_AC.R +++ b/R/__ddl_by_AC.R @@ -65,7 +65,7 @@ input_template <- function(..., on_submit, mask, datanames, join_keys) { args <- list(...) checkmate::assert_list(args, types = "shiny.tag") - args <- as.list(substitute(list(...)))[-1L] + args <- as.list(substitute(list(...)))[-1L] inputIds <- vapply(args, function(x) match.call(eval(x[[1L]]), x)[["inputId"]], character(1L)) checkmate::assert_true( @@ -188,7 +188,7 @@ with_substitution <- function(fun, mask, join_keys) { 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) + new_teal_data(as.list(env), code = as.expression(code_masked), keys = join_keys) } } @@ -211,8 +211,8 @@ closeme <- function() { 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 + adsl <- scda::synthetic_cdisc_data("latest")$adsl + adtte <- scda::synthetic_cdisc_data("latest")$adtte } themask <- list( user = quote(askpass("who are you?")), @@ -259,7 +259,7 @@ devtools::load_all(".") -funny_module <- function (label = "Filter states", datanames = "all") { +funny_module <- function(label = "Filter states", datanames = "all") { checkmate::assert_string(label) module( label = label, @@ -276,7 +276,7 @@ funny_module <- function (label = "Filter states", datanames = "all") { 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({ + output$filter_states <- renderPrint({ logger::log_trace("rendering text1") filter_panel_api %>% get_filter_state() }) diff --git a/R/cdisc_data.R b/R/cdisc_data.R index a2f23bc9b..09c953179 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -77,15 +77,15 @@ cdisc_data <- function(..., if ( checkmate::test_list(data_objects, types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { - update_join_keys_to_primary(data_objects, join_keys) - retrieve_parents <- function(x) {lifecycle::deprecate_warn( - when = "0.3.1", - "cdisc_data( + retrieve_parents <- function(x) { + lifecycle::deprecate_warn( + when = "0.3.1", + "cdisc_data( data_objects = 'should use data directly. Using TealDatasetConnector and TealDataset is deprecated.' )" - ) + ) tryCatch( x$get_parent(), error = function(cond) rep(character(0), length(x$get_datanames())) @@ -128,7 +128,7 @@ cdisc_data <- function(..., x$check_metadata() if (is_pulled(x)) { - new_tdata( + new_teal_data( env = lapply(x$get_datasets(), function(x) x$get_raw_data()), code = x$get_code(), keys = x$get_join_keys() @@ -140,7 +140,7 @@ cdisc_data <- function(..., if (!checkmate::test_names(names(data_objects), type = "named")) { stop("Dot (`...`) arguments on `teal_data()` must be named.") } - new_tdata(env = data_objects, code = code, keys = join_keys) + new_teal_data(env = data_objects, code = code, keys = join_keys) } } diff --git a/R/ddl.R b/R/ddl.R index c62c07037..7a78a4355 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -20,7 +20,7 @@ #' `code` and return a reactive data containing necessary data. To handle #' evaluation and code masking process it is recommended to use `ddl_run`. #' Package provides universal `username_password_server` which -#' runs [ddl_run] function, which returns `tdata` object. +#' runs [ddl_run] function, which returns `` object. #' Details in the the example #' #' @param mask_args (`list` named)\cr @@ -69,7 +69,7 @@ ddl <- function(expr, } - # function creates tdata object from the code, input and mask_args + # function creates object from the code, input and mask_args # function defined here to have access to the arguments ddl_run <- function(online_args = list()) { # substitute by online args and evaluate @@ -77,11 +77,11 @@ ddl <- function(expr, eval(code, envir = env) if (identical(ls(env), character(0))) { - warning("DDL code returned NULL. Returning empty tdata object") + warning("DDL code returned NULL. Returning empty object") } # don't pass non-dataset bindings further - # we don't want to initialize tdata with them + # we don't want to initialize with them env_list <- as.list(env)[datanames] # substitute by offline args @@ -90,11 +90,11 @@ ddl <- function(expr, } code <- .substitute_inputs(code, args = online_args) - # create tdata object - obj <- teal.data::new_tdata(env = env_list, code = as.expression(code), keys = join_keys) + # create object + obj <- teal.data::new_teal_data(env = env_list, code = as.expression(code), keys = join_keys) - if (!inherits(obj, "tdata")) { - stop("postprocess_fun should return tdata object") + if (!inherits(obj, "teal_data")) { + stop("postprocess_fun should return `teal_data` object") } obj @@ -134,7 +134,7 @@ submit_button_server <- function(id, x) { ddl_run(online_args = reactiveValuesToList(input)) }) - # would need to make sure we handle reactivity correctly here as teal::init expects not reactive tdata... + # would need to make sure we handle reactivity correctly here as teal::init expects not reactive teal_data... return(tdata) }) } diff --git a/R/get_dataname.R b/R/get_dataname.R index a25c9068e..f525a846f 100644 --- a/R/get_dataname.R +++ b/R/get_dataname.R @@ -35,7 +35,7 @@ get_dataname.TealDataset <- function(x) { # nolint #' @rdname get_dataname #' @export -get_dataname.tdata <- function(x) { # nolint +get_dataname.teal_data <- function(x) { # nolint return(x@datanames) } diff --git a/R/get_datasets.R b/R/get_datasets.R index 4a52a42ac..48414bcef 100644 --- a/R/get_datasets.R +++ b/R/get_datasets.R @@ -136,6 +136,6 @@ get_datasets.TealDataset <- function(x) { #' @rdname get_datasets #' @export -get_datasets.tdata <- function(x) { +get_datasets.teal_data <- function(x) { as.list(x@env)[teal.data::get_dataname(x)] } diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 8eb508c68..3c362da02 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -1,5 +1,5 @@ -#' Function to get join keys from a `tdata` object -#' @param data `tdata` - object to extract the join keys +#' Function to get join keys from a `` object +#' @param data `` - object to extract the join keys #' @return Either `JoinKeys` object or `NULL` if no join keys #' @export get_join_keys <- function(data) { @@ -9,7 +9,7 @@ get_join_keys <- function(data) { #' @rdname get_join_keys #' @export -get_join_keys.tdata <- function(data) { +get_join_keys.teal_data <- function(data) { data@join_keys } diff --git a/R/tdata.R b/R/teal_data-class.R similarity index 65% rename from R/tdata.R rename to R/teal_data-class.R index 56a88d673..382f48bce 100644 --- a/R/tdata.R +++ b/R/teal_data-class.R @@ -3,7 +3,7 @@ setOldClass("JoinKeys") #' @import teal.code #' @export setClass( - Class = "tdata", + Class = "teal_data", contains = "qenv", slots = c(join_keys = "JoinKeys", datanames = "character"), prototype = list( @@ -12,35 +12,35 @@ setClass( ) ) -#' Initialize `tdata` object +#' Initialize `teal_data` object #' -#' Initialize `tdata` object. -#' @name new_tdata +#' Initialize `teal_data` object. +#' @name new_teal_data #' #' @param code (`character(1)` or `language`) code to evaluate. Accepts and stores comments also. #' @param env (`list`) List of data. #' #' @examples -#' new_tdata(env = list(a = 1), code = quote(a <- 1)) -#' new_tdata(env = list(a = 1), code = parse(text = "a <- 1")) -#' new_tdatas(env = list(a = 1), code = "a <- 1") +#' new_teal_data(env = list(a = 1), code = quote(a <- 1)) +#' new_teal_data(env = list(a = 1), code = parse(text = "a <- 1")) +#' new_teal_data(env = list(a = 1), code = "a <- 1") #' #' @export -setGeneric("new_tdata", function(env = new.env(), code = expression(), keys = join_keys()) { - standardGeneric("new_tdata") +setGeneric("new_teal_data", function(env = new.env(), code = expression(), keys = join_keys()) { + standardGeneric("new_teal_data") }) -#' @rdname new_tdata +#' @rdname new_teal_data #' @export setMethod( - "new_tdata", + "new_teal_data", signature = c(env = "list", code = "expression", keys = "ANY"), function(env, code, keys = join_keys()) { new_env <- rlang::env_clone(list2env(env), parent = parent.env(.GlobalEnv)) lockEnvironment(new_env, bindings = TRUE) id <- sample.int(.Machine$integer.max, size = length(code)) methods::new( - "tdata", + "teal_data", env = new_env, code = code, warnings = rep("", length(code)), @@ -52,24 +52,24 @@ setMethod( } ) -#' @rdname new_tdata +#' @rdname new_teal_data #' @export setMethod( - "new_tdata", + "new_teal_data", signature = c(env = "list", code = "language", keys = "ANY"), function(env, code, keys = join_keys()) { code_expr <- as.expression(code) - new_tdata(env = env, code = code_expr, keys = keys) + new_teal_data(env = env, code = code_expr, keys = keys) } ) -#' @rdname new_tdata +#' @rdname new_teal_data #' @export setMethod( - "new_tdata", + "new_teal_data", signature = c(env = "list", code = "character", keys = "ANY"), function(env, code, keys = join_keys()) { code_expr <- parse(text = code) - new_tdata(env = env, code = code_expr, keys = keys) + new_teal_data(env = env, code = code_expr, keys = keys) } ) diff --git a/R/teal_data.R b/R/teal_data.R index fbd4c8ea1..486cee6a7 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -58,7 +58,7 @@ teal_data <- function(..., x$check_metadata() if (is_pulled(x)) { - new_tdata( + new_teal_data( env = lapply(x$get_datasets(), function(x) x$get_raw_data()), code = x$get_code(), keys = x$get_join_keys() @@ -70,7 +70,7 @@ teal_data <- function(..., if (!checkmate::test_names(names(data_objects), type = "named")) { stop("Dot (`...`) arguments on `teal_data()` must be named.") } - new_tdata( + new_teal_data( env = data_objects, code = code, keys = join_keys diff --git a/R/to_relational_data.R b/R/to_relational_data.R index bb583d9d8..4455d6ba5 100644 --- a/R/to_relational_data.R +++ b/R/to_relational_data.R @@ -129,6 +129,6 @@ to_relational_data.TealData <- function(data) { # nolint #' @keywords internal #' @export -to_relational_data.tdata <- function(data) { +to_relational_data.teal_data <- function(data) { data } From f3876df27f647a3c43e9407a961fb57ef9371081 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 3 Oct 2023 08:16:27 +0200 Subject: [PATCH 14/18] mask_args -> input_mask --- R/__ddl_by_AC.R | 298 ------------------------------------------------ R/ddl.R | 22 ++-- 2 files changed, 8 insertions(+), 312 deletions(-) delete mode 100644 R/__ddl_by_AC.R diff --git a/R/__ddl_by_AC.R b/R/__ddl_by_AC.R deleted file mode 100644 index 813ecb45b..000000000 --- a/R/__ddl_by_AC.R +++ /dev/null @@ -1,298 +0,0 @@ -#' 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_teal_data(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/ddl.R b/R/ddl.R index 7a78a4355..6e6848bcf 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -2,7 +2,7 @@ #' #' Object to execute custom DDL code in the shiny session #' -#' @expr (`expression`)\cr +#' @param expr (`expression`)\cr #' Syntatically valid R code to be executed in the shiny session. #' shouldn't be specified when `code` is specified. #' @@ -15,15 +15,15 @@ #' `shiny` ui module containing inputs which `id` correspond to the #' args in the `code`. #' -#' @param server (`function(id, mask_args, code, postprocess_fun)`)\cr +#' @param server (`function`)\cr #' `shiny` server module returning data. This server should execute #' `code` and return a reactive data containing necessary data. To handle #' evaluation and code masking process it is recommended to use `ddl_run`. #' Package provides universal `username_password_server` which -#' runs [ddl_run] function, which returns `` object. +#' runs [ddl_run] function, which returns `teal_data` object. #' Details in the the example #' -#' @param mask_args (`list` named)\cr +#' @param input_mask (`list` named)\cr #' arguments to be substituted in the `code`. These #' argument are going to replace arguments set through #' `ui` and `server`. Example use case is when app user @@ -32,12 +32,6 @@ #' is substituted with `askpass::askpass()` call, so the #' returned code is still executable but secure. #' -#' @param postprocess_fun (`function(env, code)`)\cr -#' Function to be run after code is run. This function suppose -#' has two arguments: -#' - `env` (`environment`) returned as a result of the code evaluation -#' - code (`character`) `code` provided with resolved (substituted) args. -#' #' @param datanames (`character`)\cr #' Names of the objects to be created from the code evaluation. #' If not specified (`character(0)`), all objects will be used to `teal_data` function @@ -50,7 +44,7 @@ ddl <- function(expr, code, ui = submit_button_ui, - mask_args = list(), + input_mask = list(), server = submit_button_server, join_keys = teal.data::join_keys(), datanames) { @@ -69,7 +63,7 @@ ddl <- function(expr, } - # function creates object from the code, input and mask_args + # function creates object from the code, input and input_mask # function defined here to have access to the arguments ddl_run <- function(online_args = list()) { # substitute by online args and evaluate @@ -85,8 +79,8 @@ ddl <- function(expr, env_list <- as.list(env)[datanames] # substitute by offline args - for (i in names(mask_args)) { - online_args[[i]] <- mask_args[[i]] + for (i in names(input_mask)) { + online_args[[i]] <- input_mask[[i]] } code <- .substitute_inputs(code, args = online_args) From c407adfe23202809d68cf78eeff978250dc39e5f Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 3 Oct 2023 08:28:11 +0200 Subject: [PATCH 15/18] online_args -> input --- R/ddl.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 6e6848bcf..d1d5d01ff 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -65,9 +65,10 @@ ddl <- function(expr, # function creates object from the code, input and input_mask # function defined here to have access to the arguments - ddl_run <- function(online_args = list()) { + ddl_run <- function(input = list()) { + checkmate::assert_list(input) + env <- list2env(list(input = input)) # substitute by online args and evaluate - env <- list2env(list(input = online_args)) eval(code, envir = env) if (identical(ls(env), character(0))) { @@ -80,9 +81,9 @@ ddl <- function(expr, # substitute by offline args for (i in names(input_mask)) { - online_args[[i]] <- input_mask[[i]] + input[[i]] <- input_mask[[i]] } - code <- .substitute_inputs(code, args = online_args) + code <- .substitute_inputs(code, args = input) # create object obj <- teal.data::new_teal_data(env = env_list, code = as.expression(code), keys = join_keys) @@ -125,7 +126,7 @@ submit_button_ui <- function(id) { submit_button_server <- function(id, x) { moduleServer(id, function(input, output, session) { tdata <- eventReactive(input$submit, { - ddl_run(online_args = reactiveValuesToList(input)) + ddl_run(input = input) }) # would need to make sure we handle reactivity correctly here as teal::init expects not reactive teal_data... From 5443613fc3df2021a6310249be3559a5cf6ad699 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Tue, 3 Oct 2023 08:42:39 +0200 Subject: [PATCH 16/18] ddl_run - input can be of class "reactivevalues" --- R/ddl.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/ddl.R b/R/ddl.R index d1d5d01ff..6154deb5a 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -67,6 +67,9 @@ ddl <- function(expr, # function defined here to have access to the arguments ddl_run <- function(input = list()) { checkmate::assert_list(input) + if (inherits(input, "reactivevalues")) { + input <- reactiveValuesToList(input) + } env <- list2env(list(input = input)) # substitute by online args and evaluate eval(code, envir = env) From 48e0f3bc5fae9800ea4963ed31d397d134e5b5aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Tue, 3 Oct 2023 13:35:34 +0200 Subject: [PATCH 17/18] handling datanames information --- R/ddl.R | 16 +++++++++++----- R/teal_data-class.R | 15 +++++++++------ 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/R/ddl.R b/R/ddl.R index 6154deb5a..46925f6e0 100644 --- a/R/ddl.R +++ b/R/ddl.R @@ -68,7 +68,7 @@ ddl <- function(expr, ddl_run <- function(input = list()) { checkmate::assert_list(input) if (inherits(input, "reactivevalues")) { - input <- reactiveValuesToList(input) + input <- shiny::reactiveValuesToList(input) } env <- list2env(list(input = input)) # substitute by online args and evaluate @@ -78,9 +78,10 @@ ddl <- function(expr, warning("DDL code returned NULL. Returning empty object") } - # don't pass non-dataset bindings further - # we don't want to initialize with them - env_list <- as.list(env)[datanames] + # don't keep input further we don't want to keep input in the @env of teal_data + # but we want to keep other non-dataset objects created in the code + env_list <- as.list(env) + env_list <- env_list[!names(env_list) != "input"] # substitute by offline args for (i in names(input_mask)) { @@ -89,7 +90,12 @@ ddl <- function(expr, code <- .substitute_inputs(code, args = input) # create object - obj <- teal.data::new_teal_data(env = env_list, code = as.expression(code), keys = join_keys) + obj <- teal.data::new_teal_data( + env = env_list, + code = as.expression(code), + keys = join_keys, + datanames = datanames + ) if (!inherits(obj, "teal_data")) { stop("postprocess_fun should return `teal_data` object") diff --git a/R/teal_data-class.R b/R/teal_data-class.R index 382f48bce..0923b069f 100644 --- a/R/teal_data-class.R +++ b/R/teal_data-class.R @@ -19,6 +19,9 @@ setClass( #' #' @param code (`character(1)` or `language`) code to evaluate. Accepts and stores comments also. #' @param env (`list`) List of data. +#' @param keys (`JoinKeys`) object +#' @param datanames (`character`) names of datasets in `env`. Needed when non-dataset +#' objects are needed in the `env` slot. #' #' @examples #' new_teal_data(env = list(a = 1), code = quote(a <- 1)) @@ -26,7 +29,7 @@ setClass( #' new_teal_data(env = list(a = 1), code = "a <- 1") #' #' @export -setGeneric("new_teal_data", function(env = new.env(), code = expression(), keys = join_keys()) { +setGeneric("new_teal_data", function(env = new.env(), code = expression(), keys = join_keys(), datanames = character()) { standardGeneric("new_teal_data") }) @@ -35,7 +38,7 @@ setGeneric("new_teal_data", function(env = new.env(), code = expression(), keys setMethod( "new_teal_data", signature = c(env = "list", code = "expression", keys = "ANY"), - function(env, code, keys = join_keys()) { + function(env, code, keys = join_keys(), datanames = names(env)) { new_env <- rlang::env_clone(list2env(env), parent = parent.env(.GlobalEnv)) lockEnvironment(new_env, bindings = TRUE) id <- sample.int(.Machine$integer.max, size = length(code)) @@ -57,9 +60,9 @@ setMethod( setMethod( "new_teal_data", signature = c(env = "list", code = "language", keys = "ANY"), - function(env, code, keys = join_keys()) { + function(env, code, keys = join_keys(), datanames = names(env)) { code_expr <- as.expression(code) - new_teal_data(env = env, code = code_expr, keys = keys) + new_teal_data(env = env, code = code_expr, keys = keys, datanames = datanames) } ) @@ -68,8 +71,8 @@ setMethod( setMethod( "new_teal_data", signature = c(env = "list", code = "character", keys = "ANY"), - function(env, code, keys = join_keys()) { + function(env, code, keys = join_keys(), datanames = names(env)) { code_expr <- parse(text = code) - new_teal_data(env = env, code = code_expr, keys = keys) + new_teal_data(env = env, code = code_expr, keys = keys, datanames = datanames) } ) From 6b46e4c54385a8eaff4fa0bbda23d6274bc8f13e Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 3 Oct 2023 14:33:47 +0200 Subject: [PATCH 18/18] ddl from teal.data to teal --- R/ddl.R | 178 ---------------------------------------------- R/get_dataname.R | 6 -- R/get_join_keys.R | 7 -- 3 files changed, 191 deletions(-) delete mode 100644 R/ddl.R diff --git a/R/ddl.R b/R/ddl.R deleted file mode 100644 index 46925f6e0..000000000 --- a/R/ddl.R +++ /dev/null @@ -1,178 +0,0 @@ -#' DDL object -#' -#' Object to execute custom DDL code in the shiny session -#' -#' @param expr (`expression`)\cr -#' Syntatically valid R code to be executed in the shiny session. -#' shouldn't be specified when `code` is specified. -#' -#' @param code (`character`, `language`)\cr -#' Object containing code to be evaluated to load data. Shouldn't be specified when `expr` -#' is specified. -#' -#' -#' @param ui (`shiny.tag`)\cr -#' `shiny` ui module containing inputs which `id` correspond to the -#' args in the `code`. -#' -#' @param server (`function`)\cr -#' `shiny` server module returning data. This server should execute -#' `code` and return a reactive data containing necessary data. To handle -#' evaluation and code masking process it is recommended to use `ddl_run`. -#' Package provides universal `username_password_server` which -#' runs [ddl_run] function, which returns `teal_data` object. -#' Details in the the example -#' -#' @param input_mask (`list` named)\cr -#' arguments to be substituted in the `code`. These -#' argument are going to replace arguments set through -#' `ui` and `server`. Example use case is when app user -#' is asked to input a password and we'd like to skip this -#' input in the reproducible code. Typically users password -#' is substituted with `askpass::askpass()` call, so the -#' returned code is still executable but secure. -#' -#' @param datanames (`character`)\cr -#' Names of the objects to be created from the code evaluation. -#' If not specified (`character(0)`), all objects will be used to `teal_data` function -#' (via `env_list` in `postprocess_fun`). -#' -#' @inheritParams teal_data -#' -#' -#' @export -ddl <- function(expr, - code, - ui = submit_button_ui, - input_mask = list(), - server = submit_button_server, - join_keys = teal.data::join_keys(), - datanames) { - if (!missing(expr) && !missing(code)) { - stop("Only one of `expr` or `code` should be specified") - } - if (!missing(expr)) { - code <- substitute(expr) - } - if (is.character(code)) { - code <- parse(text = code) - } - - if (missing(datanames)) { - stop("`dataname` argument is required") - } - - - # function creates object from the code, input and input_mask - # function defined here to have access to the arguments - ddl_run <- function(input = list()) { - checkmate::assert_list(input) - if (inherits(input, "reactivevalues")) { - input <- shiny::reactiveValuesToList(input) - } - env <- list2env(list(input = input)) - # substitute by online args and evaluate - eval(code, envir = env) - - if (identical(ls(env), character(0))) { - warning("DDL code returned NULL. Returning empty object") - } - - # don't keep input further we don't want to keep input in the @env of teal_data - # but we want to keep other non-dataset objects created in the code - env_list <- as.list(env) - env_list <- env_list[!names(env_list) != "input"] - - # substitute by offline args - for (i in names(input_mask)) { - input[[i]] <- input_mask[[i]] - } - code <- .substitute_inputs(code, args = input) - - # create object - obj <- teal.data::new_teal_data( - env = env_list, - code = as.expression(code), - keys = join_keys, - datanames = datanames - ) - - if (!inherits(obj, "teal_data")) { - stop("postprocess_fun should return `teal_data` object") - } - - obj - } - - # changing enclosing environment of the server to have access to ddl_fun function - # Thanks to this ddl object contains only ui and server functions - # and server function can be run just by calling ddl$server("")! - environment(server) <- environment() - - structure( - list(ui = ui, server = server), - datanames = datanames, - join_keys = join_keys, - class = "ddl" - ) -} - -#' @name submit_button_module -#' -#' @inheritParams ddl -#' @param id (`character`) `shiny` module id. -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, x) { - 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) - }) -} - -#' 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)) - 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. - lapply(code_strings, function(x) { - bquote_call <- substitute(bquote(code), list(code = str2lang(x))) - eval(bquote_call, envir = list2env(args)) - }) -} - -# todo: to remove ------------- -open_conn <- function(username, password) { - if (password != "pass") stop("Invalid credentials. 'pass' is the password") else TRUE -} -close_conn <- function(conn) { - message("closed") - return(NULL) -} diff --git a/R/get_dataname.R b/R/get_dataname.R index f525a846f..9ac544a37 100644 --- a/R/get_dataname.R +++ b/R/get_dataname.R @@ -38,9 +38,3 @@ get_dataname.TealDataset <- function(x) { # nolint get_dataname.teal_data <- function(x) { # nolint return(x@datanames) } - -#' @rdname get_dataname -#' @export -get_dataname.ddl <- function(x) { - attr(x, "datanames") -} diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 3c362da02..f2f21c4fd 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -13,13 +13,6 @@ get_join_keys.teal_data <- function(data) { data@join_keys } -#' @rdname get_join_keys -#' @export -get_join_keys.ddl <- function(data) { - attr(data, "join_keys") -} - - #' @rdname get_join_keys #' @export get_join_keys.TealData <- function(data) {