diff --git a/DESCRIPTION b/DESCRIPTION index 6d5247c24..1f5b7de04 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ BugReports: https://github.com/insightsengineering/teal.transform/issues Depends: R (>= 3.6) Imports: + bsicons, checkmate (>= 2.1.0), dplyr (>= 1.1.0), htmltools, @@ -30,19 +31,25 @@ Imports: shiny (>= 1.6.0), shinyjs (>= 2.1.0), shinyvalidate (>= 0.1.3), + shinyWidgets, stats, + teal, + teal.code, teal.data (>= 0.8.0), teal.logger (>= 0.4.0), teal.widgets (>= 0.5.0), tidyr (>= 1.0.0), tidyselect (>= 1.2.1), - utils + utils, + yaml Suggests: bslib (>= 0.8.0), knitr (>= 1.42), rmarkdown (>= 2.23), + rvest, roxy.shinylive (>= 1.0.0), testthat (>= 3.1.5), + tibble, withr (>= 2.0.0) VignetteBuilder: knitr, @@ -58,4 +65,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 3bc5cee7b..dd6ca8d6d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,16 +1,39 @@ # Generated by roxygen2: do not edit by hand +S3method(.is_delayed,default) +S3method(.is_delayed,list) +S3method(.is_delayed,pick) +S3method(.picker_icon,Date) +S3method(.picker_icon,POSIXct) +S3method(.picker_icon,POSIXlt) +S3method(.picker_icon,character) +S3method(.picker_icon,data.frame) +S3method(.picker_icon,default) +S3method(.picker_icon,factor) +S3method(.picker_icon,integer) +S3method(.picker_icon,logical) +S3method(.picker_icon,numeric) +S3method(.picker_icon,primary_key) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) +S3method(determine,datasets) +S3method(determine,values) +S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) +S3method(format,pick) +S3method(format,picks) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) +S3method(picks_srv,list) +S3method(picks_srv,picks) +S3method(picks_ui,list) +S3method(picks_ui,picks) S3method(print,choices_labeled) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) @@ -19,6 +42,8 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) +S3method(print,pick) +S3method(print,picks) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -36,6 +61,7 @@ S3method(variable_choices,data.frame) export("%>%") export(add_no_selected_choices) export(all_choices) +export(as.picks) export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) @@ -45,6 +71,7 @@ export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) export(datanames_input) +export(datasets) export(filter_spec) export(first_choice) export(first_choices) @@ -55,6 +82,7 @@ export(get_extract_datanames) export(get_merge_call) export(get_relabel_call) export(is.choices_selected) +export(is_categorical) export(is_single_dataset) export(last_choice) export(last_choices) @@ -62,13 +90,22 @@ export(list_extract_spec) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) +export(merge_srv) export(no_selected_as_NULL) +export(picks) +export(picks_srv) +export(picks_ui) export(resolve_delayed) +export(resolver) export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) +export(teal_transform_filter) +export(tm_merge) export(value_choices) +export(values) export(variable_choices) +export(variables) import(shiny) importFrom(dplyr,"%>%") diff --git a/R/0-as_picks.R b/R/0-as_picks.R new file mode 100644 index 000000000..43fa2de88 --- /dev/null +++ b/R/0-as_picks.R @@ -0,0 +1,235 @@ +#' Convert data_extract_spec to picks +#' +#' @description +#' `r lifecycle::badge("experimental")` +#' Helper functions to ease transition between [data_extract_spec()] and [picks()]. +#' @inheritParams teal::teal_transform_module +#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`] +#' @details +#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to +#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`] +#' will be deprecated. +#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1 +#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`] +#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent. +#' +#' @examples +#' # convert des with eager select_spec +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = c("Sepal.Length", "Sepal.Width", "Species"), +#' selected = c("Sepal.Length", "Species"), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' # convert des with delayed select_spec +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = variable_choices("iris"), +#' selected = first_choice(), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = variable_choices("iris", subset = function(data) names(Filter(is.numeric, data))), +#' selected = first_choice(), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' @export +as.picks <- function(x) { # nolint + if (inherits(x, c("picks", "pick"))) { + x + } else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) { + Filter(length, lapply(x, as.picks)) + } else if (inherits(x, "data_extract_spec")) { + args <- Filter( + length, + list( + datasets(choices = x$dataname, fixed = TRUE), + as.picks(x$select), + as.picks(x$filter) + # filter_spec as they are not necessary linked with `select` (selected variables) + # as filter_spec can be specified on the variable(s) different than select_spec for example: + # for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD)) + ) + ) + do.call(picks, args) + } else if (inherits(x, "select_spec")) { + .select_spec_to_variables(x) + } else if (inherits(x, "filter_spec")) { + # warning + warning( + "`filter_spec` are not convertible to picks - please use `transformers` argument", + "and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`" + ) + + NULL + } +} + +#' @rdname as.picks +#' @examples +#' # teal_transform_module build on teal.transform +#' +#' teal_transform_filter( +#' data_extract_spec( +#' dataname = "iris", +#' filter = filter_spec( +#' vars = "Species", +#' choices = c("setosa", "versicolor", "virginica"), +#' selected = c("setosa", "versicolor") +#' ) +#' ) +#' ) +#' +#' teal_transform_filter( +#' picks( +#' datasets(choices = "iris", select = "iris"), +#' variables(choices = "Species", "Species"), +#' values( +#' choices = c("setosa", "versicolor", "virginica"), +#' selected = c("setosa", "versicolor") +#' ) +#' ) +#' ) +#' +#' @export +teal_transform_filter <- function(x, label = "Filter") { + checkmate::assert_multi_class(x, c("data_extract_spec", "picks")) + if (inherits(x, "data_extract_spec")) { + lapply(.as.picks.filter(x), teal_transform_filter, label = label) + } else { + checkmate::assert_true("values" %in% names(x)) + teal::teal_transform_module( + label = label, + ui <- function(id) { + ns <- NS(id) + picks_ui(ns("transformer"), picks = x, container = div) + }, + server <- function(id, data) { + shiny::moduleServer(id, function(input, output, session) { + selector <- picks_srv("transformer", picks = x, data = data) + reactive({ + req(data(), selector()) + filter_call <- .make_filter_call( + datasets = selector()$datasets$selected, + variables = selector()$variables$selected, + values = selector()$values$selected + ) + teal.code::eval_code(data(), filter_call) + }) + }) + } + ) + } +} + +.as.picks.filter <- function(x, dataname) { # nolint + if (inherits(x, "filter_spec")) { + if (inherits(x$choices, "delayed_data")) { + warning( + "filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ", + "Setting to all possible choices..." + ) + x$choices <- function(x) TRUE + } + if (inherits(x$selected, "delayed_data")) { + warning( + "filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ", + "Setting to all possible choices..." + ) + x$selected <- function(x) TRUE + } + picks( + datasets(choices = dataname, selected = dataname), + variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple + values(choices = x$choices, selected = x$selected, multiple = x$multiple) + ) + } else if (checkmate::test_list(x, "filter_spec")) { + lapply(x, .as.picks.filter, dataname = dataname) + } else if (inherits(x, "data_extract_spec")) { + .as.picks.filter(x$filter, dataname = x$dataname) + } else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) { + unlist( + lapply(Filter(length, x), .as.picks.filter), + recursive = FALSE + ) + } +} + +.make_filter_call <- function(datasets, variables, values) { + checkmate::assert_character(datasets) + checkmate::assert_character(variables) + checkmate::assert_character(values) + substitute( + dataname <- dplyr::filter(dataname, varname %in% values), + list( + dataname = as.name(datasets), + varname = if (length(variables) == 1) { + as.name(variables) + } else { + as.call( + c( + quote(paste), + lapply(variables, as.name), + list(sep = ", ") + ) + ) + }, + values = values + ) + ) +} + +.select_spec_to_variables <- function(x) { + if (length(x)) { + variables( + choices = if (inherits(x$choices, "delayed_data")) { + out <- x$choices$subset + if (is.null(out)) { + function(x) TRUE # same effect as tidyselect::everything + } else { + class(out) <- "des-delayed" + out + } + } else { + x$choices + }, + selected = if (inherits(x$selected, "delayed_choices")) { + out <- x$selected + class(out) <- "des-delayed" + out + } else if (inherits(x$selected, "delayed_data")) { + out <- x$selected$subset + if (is.null(out)) { + 1L + } else { + class(out) <- "des-delayed" + out + } + } else { + unname(x$selected) + }, + ordered = x$ordered, + multiple = x$multiple, + fixed = x$fixed + ) + } +} diff --git a/R/0-badge_dropdown.R b/R/0-badge_dropdown.R new file mode 100644 index 000000000..dc6885d21 --- /dev/null +++ b/R/0-badge_dropdown.R @@ -0,0 +1,39 @@ +#' Drop-down badge +#' +#' Drop-down button in a form of a badge with `bg-primary` as default style +#' Clicking badge shows a drop-down containing any `HTML` element. Folded drop-down +#' doesn't trigger display output which means that items rendered using `render*` +#' will be recomputed only when drop-down is show. +#' +#' @param id (`character(1)`) shiny module's id +#' @param label (`shiny.tag`) Label displayed on a badge. +#' @param content (`shiny.tag`) Content of a drop-down. +#' @keywords internal +badge_dropdown <- function(id, label, content) { + ns <- shiny::NS(id) + htmltools::tagList( + htmltools::singleton(htmltools::tags$head( + htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.transform")), + htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.transform")) + )), + htmltools::tags$div( + class = "badge-dropdown-wrapper", + htmltools::tags$span( + id = ns("summary_badge"), + class = "badge bg-primary rounded-pill badge-dropdown", + tags$span(class = "badge-dropdown-label", label), + tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")), + onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container")) + ), + htmltools::tags$div( + content, + id = ns("inputs_container"), + style = paste( + "visibility: hidden; opacity: 0; pointer-events: none; position: absolute; background: white;", + "border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1);", + "padding: 10px; z-index: 1000; min-width: 200px; transition: opacity 0.2s ease;" + ) + ) + ) + ) +} diff --git a/R/call_utils.R b/R/0-call_utils.R similarity index 54% rename from R/call_utils.R rename to R/0-call_utils.R index 8811c04a0..65a2347a9 100644 --- a/R/call_utils.R +++ b/R/0-call_utils.R @@ -71,11 +71,11 @@ call_condition_choice <- function(varname, choices) { if (length(choices) == 1) { - call("==", varname, choices) + call("==", varname, unname(choices)) } else { c_call <- do.call( "call", - append(list("c"), choices) + append(list("c"), unname(choices)) ) # c_call needed because it needs to be vector call # instead of vector. SummarizedExperiment.subset @@ -104,8 +104,8 @@ call_condition_range <- function(varname, range) { varname <- call_check_parse_varname(varname) call( "&", - call(">=", varname, range[1]), - call("<=", varname, range[2]) + call(">=", varname, unname(range[1])), + call("<=", varname, unname(range[2])) ) } @@ -162,8 +162,8 @@ call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone range[1] <- trunc(range[1], units = c("secs")) range[2] <- trunc(range[2] + 1, units = c("secs")) - range <- format( - range, + range <- format.POSIXct( + unname(range), format = "%Y-%m-%d %H:%M:%S", tz = timezone ) @@ -198,154 +198,6 @@ call_condition_range_date <- function(varname, range) { ) } -#' Get call to subset and select array -#' -#' @param dataname (`character(1)` or `name`). -#' @param row (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' @param column (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `column` or condition. -#' @param aisle (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' -#' @return [Extract()] `call` for 3-dimensional array in `x[i, j, k]` notation. -#' -#' @keywords internal -#' -call_extract_array <- function(dataname = ".", row = NULL, column = NULL, aisle = NULL) { - checkmate::assert( - checkmate::check_string(dataname), - checkmate::check_class(dataname, "call"), - checkmate::check_class(dataname, "name") - ) - stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row)) - stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column)) - stopifnot(is.null(aisle) || is.call(aisle) || is.vector(aisle) || is.name(aisle)) - - if (is.language(dataname)) { - dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n") - } - - row <- if (is.null(row)) { - "" - } else { - paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n") - } - column <- if (is.null(column)) { - "" - } else { - paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n") - } - aisle <- if (is.null(aisle)) { - "" - } else { - paste(trimws(deparse(aisle, width.cutoff = 500L)), collapse = "\n") - } - - parse( - text = sprintf("%s[%s, %s, %s]", dataname, row, column, aisle), - keep.source = FALSE - )[[1]] -} - -#' Get call to subset and select matrix -#' -#' @param dataname (`character(1)` or `name`). -#' @param row (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' @param column (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `column` or condition. -#' -#' @return [Extract()] `call` for matrix in `x[i, j]` notation. -#' -#' @keywords internal -#' -call_extract_matrix <- function(dataname = ".", row = NULL, column = NULL) { - checkmate::assert( - checkmate::check_string(dataname), - checkmate::check_class(dataname, "call"), - checkmate::check_class(dataname, "name") - ) - stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row)) - stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column)) - - if (is.language(dataname)) { - dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n") - } - - row <- if (is.null(row)) { - "" - } else { - paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n") - } - column <- if (is.null(column)) { - "" - } else { - paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n") - } - - parse( - text = sprintf("%s[%s, %s]", dataname, row, column), - keep.source = FALSE - )[[1]] -} - - -#' Compose extract call with `$` operator -#' -#' @param dataname (`character(1)` or `name`) name of the object. -#' @param varname (`character(1)` or `name`) name of the slot in data. -#' @param dollar (`logical(1)`) whether returned call should use `$` or `[[` operator. -#' -#' @return [Extract()] `call` in `$` or `[[` notation (depending on parameters). -#' -#' @keywords internal -#' -call_extract_list <- function(dataname, varname, dollar = TRUE) { - checkmate::assert_flag(dollar) - checkmate::assert( - checkmate::check_string(varname), - checkmate::check_class(varname, "name"), - checkmate::assert( - combine = "and", - checkmate::check_class(varname, "call"), - checkmate::check_false(dollar) - ) - ) - - dataname <- call_check_parse_varname(dataname) - - if (dollar) { - call("$", dataname, varname) - } else { - call("[[", dataname, varname) - } -} - -#' Create a call using a function in a given namespace -#' -#' The dot arguments in `...` need to be quoted because they will be evaluated otherwise. -#' -#' @param name `character` function name, possibly using namespace colon `::`, also -#' works with `:::` (sometimes needed, but strongly discouraged). -#' @param ... arguments to pass to function with name `name`. -#' @param unlist_args `list` extra arguments passed in a single list, -#' avoids the use of `do.call` with this function. -#' -#' @return `call`. -#' -#' @keywords internal -#' -call_with_colon <- function(name, ..., unlist_args = list()) { - checkmate::assert_string(name) - checkmate::assert_list(unlist_args) - as.call(c( - parse(text = name, keep.source = FALSE)[[1]], - c(list(...), unlist_args) - )) -} - - #' Combine calls by operator #' #' Combine list of calls by specific operator. @@ -368,9 +220,58 @@ calls_combine_by <- function(operator, calls) { ) ) ) - Reduce( x = calls, f = function(x, y) call(operator, x, y) ) } + +#' @param variables (`list` of `character`) variables to select. If list is named then +#' variables will be renamed if their name is different than its value +#' (this produces a call `select(..., = )`). +.call_dplyr_select <- function(dataname, variables) { + as.call( + c( + list( + str2lang("dplyr::select"), + str2lang(dataname) + ), + lapply(unname(variables), as.name) + ) + ) +} + +.call_dplyr_filter <- function(x) { + predicates <- lapply(unname(x), function(x) { + if (is.numeric(x$values)) { + call_condition_range(varname = x$variables, range = x$values) + } else if (inherits(x$values, "Date")) { + call_condition_range_date(varname = x$variables, range = x$values) + } else if (inherits(x$values, "POSIXct")) { + call_condition_range_posixct(varname = x$variables, range = x$values) + } else if (is.logical(x$values)) { + call_condition_logical(varname = x$variables, choice = x$values) + } else if (length(x$variables)) { + variable <- if (length(x$variables) > 1) { + as.call( + c( + list( + quote(paste) + ), + unname(lapply(x$variables, as.name)), + list(sep = ", ") + ) + ) + } else { + x$variables + } + call_condition_choice(varname = variable, choices = x$values) + } + }) + as.call( + c( + list(str2lang("dplyr::filter")), + Filter(length, predicates) + ) + ) +} diff --git a/R/0-module_merge.R b/R/0-module_merge.R new file mode 100644 index 000000000..664edca86 --- /dev/null +++ b/R/0-module_merge.R @@ -0,0 +1,537 @@ +#' Merge Server Function for Dataset Integration +#' +#' @description +#' `merge_srv` is a powerful Shiny server function that orchestrates the merging of multiple datasets +#' based on user selections from `picks` objects. It creates a reactive merged dataset (`teal_data` object) +#' and tracks which variables from each selector are included in the final merged output. +#' +#' This function serves as the bridge between user interface selections (managed by selectors) and +#' the actual data merging logic. It automatically handles: +#' - Dataset joining based on join keys +#' - Variable selection and renaming to avoid conflicts +#' - Reactive updates when user selections change +#' - Generation of reproducible R code for the merge operation +#' +#' @param id (`character(1)`) Module ID for the Shiny module namespace +#' @param data (`reactive`) A reactive expression returning a [teal.data::teal_data] object containing +#' the source datasets to be merged. This object must have join keys defined via +#' [teal.data::join_keys()] to enable proper dataset relationships. +#' @param selectors (`named list`) A named list of selector objects. Each element can be: +#' - A `picks` object defining dataset and variable selections +#' - A `reactive` expression returning a `picks` object +#' The names of this list are used as identifiers for tracking which variables come from which selector. +#' @param output_name (`character(1)`) Name of the merged dataset that will be created in the +#' returned `teal_data` object. Default is `"anl"`. This name will be used in the generated R code. +#' @param join_fun (`character(1)`) The joining function to use for merging datasets. Must be a +#' qualified function name (e.g., `"dplyr::left_join"`, `"dplyr::inner_join"`, `"dplyr::full_join"`). +#' Default is `"dplyr::inner_join"`. The function must accept `by` and `suffix` parameters. +#' +#' @return A `list` with two reactive elements: +#' - `data`A `reactive` returning a [teal.data::teal_data] object containing the merged dataset. +#' The merged dataset is named according to `output_name` parameter. The `teal_data` object includes: +#' - The merged dataset with all selected variables +#' - Complete R code to reproduce the merge operation +#' - Updated join keys reflecting the merged dataset structure +#' - `variables` A `reactive` returning a named list mapping selector names to their selected +#' variables in the merged dataset. The structure is: +#' `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`. +#' Variable names reflect any renaming that occurred during the merge to avoid conflicts. +#' +#' @section How It Works: +#' +#' The `merge_srv` function performs the following steps: +#' +#' 1. **Receives Input Data**: Takes a reactive `teal_data` object containing source datasets with +#' defined join keys +#' +#' 2. **Processes Selectors**: Evaluates each selector (whether static `picks` or reactive) to +#' determine which datasets and variables are selected +#' +#' 3. **Determines Merge Order**: Uses topological sort based on the `join_keys` to determine +#' the optimal order for merging datasets. +#' +#' 4. **Handles Variable Conflicts**: Automatically renames variables when: +#' - Multiple selectors choose variables with the same name from different datasets +#' - Foreign key variables would conflict with existing variables +#' - Renaming follows the pattern `{column-name}_{dataset-name}` +#' +#' 5. **Performs Merge**: Generates and executes merge code that: +#' - Selects only required variables from each dataset +#' - Applies any filters defined in selectors +#' - Joins datasets using specified join function and join keys +#' - Maintains reproducibility through generated R code +#' +#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset (`"anl"`) +#' relative to remaining datasets in the `teal_data` object +#' +#' 7. **Tracks Variables**: Keeps track of the variable names in the merged dataset +#' +#' @section Usage Pattern: +#' +#' ```r +#' # In your Shiny server function +#' merged <- merge_srv( +#' id = "merge", +#' data = reactive(my_teal_data), +#' selectors = list( +#' selector1 = picks(...), +#' selector2 = reactive(picks(...)) +#' ), +#' output_name = "anl", +#' join_fun = "dplyr::left_join" +#' ) +#' +#' # Access merged data +#' merged_data <- merged$data() # teal_data object with merged dataset +#' anl <- merged_data[["anl"]] # The actual merged data.frame/tibble +#' +#' # Get variable mapping +#' vars <- merged$variables() +#' # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) +#' +#' # Get reproducible code +#' code <- teal.code::get_code(merged_data) +#' ``` +#' +#' @section Merge Logic Details: +#' +#' **Dataset Order**: Datasets are merged in topological order based on join keys. The first dataset +#' acts as the "left" side of the join, and subsequent datasets are joined one by one. +#' +#' **Join Keys**: The function uses join keys from the source `teal_data` object to determine: +#' - Which datasets can be joined together +#' - Which columns to use for joining (the `by` parameter) +#' - Whether datasets need intermediate joins (not yet implemented) +#' +#' **Variable Selection**: For each dataset being merged: +#' - Selects user-chosen variables from selectors +#' - Includes foreign key variables needed for joining (even if not explicitly selected) +#' - Removes duplicate foreign keys after join (they're already in the left dataset) +#' +#' **Conflict Resolution**: When variable names conflict: +#' - Variables from later datasets get suffixed with `_dataname` +#' - Foreign keys that match are merged (not duplicated) +#' - The mapping returned in `merge_vars` reflects the final names +#' +#' @section Integration with Selectors: +#' +#' `merge_srv` is designed to work with [picks_srv()] which creates selector objects: +#' +#' ```r +#' # Create selectors in server +#' selectors <- picks_srv( +#' picks = list( +#' adsl = picks(...), +#' adae = picks(...) +#' ), +#' data = data +#' ) +#' +#' # Pass to merge_srv +#' merged <- merge_srv( +#' id = "merge", +#' data = data, +#' selectors = selectors +#' ) +#' ``` +#' +#' @seealso +#' - [picks_srv()] for creating selectors +#' - [teal.data::join_keys()] for defining dataset relationships +#' +#' @examples +#' # Complete example with CDISC data +#' library(teal.transform) +#' library(teal.data) +#' library(shiny) +#' +#' # Prepare data with join keys +#' data <- teal_data() +#' data <- within(data, { +#' ADSL <- teal.data::rADSL +#' ADAE <- teal.data::rADAE +#' }) +#' join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")] +#' +#' # Create Shiny app +#' ui <- fluidPage( +#' picks_ui("adsl", picks(datasets("ADSL"), variables())), +#' picks_ui("adae", picks(datasets("ADAE"), variables())), +#' verbatimTextOutput("code"), +#' verbatimTextOutput("vars") +#' ) +#' +#' server <- function(input, output, session) { +#' # Create selectors +#' selectors <- list( +#' adsl = picks_srv("adsl", +#' data = reactive(data), +#' picks = picks(datasets("ADSL"), variables()) +#' ), +#' adae = picks_srv("adae", +#' data = reactive(data), +#' picks = picks(datasets("ADAE"), variables()) +#' ) +#' ) +#' +#' # Merge datasets +#' merged <- merge_srv( +#' id = "merge", +#' data = reactive(data), +#' selectors = selectors, +#' output_name = "anl", +#' join_fun = "dplyr::left_join" +#' ) +#' +#' # Display results +#' output$code <- renderPrint({ +#' cat(teal.code::get_code(merged$data())) +#' }) +#' +#' output$vars <- renderPrint({ +#' merged$variables() +#' }) +#' } +#' if (interactive()) { +#' shinyApp(ui, server) +#' } +#' +#' @export +merge_srv <- function(id, + data, + selectors, + output_name = "anl", + join_fun = "dplyr::inner_join") { + checkmate::assert_list(selectors, "reactive", names = "named") + checkmate::assert_class(data, "reactive") + checkmate::assert_string(output_name) + checkmate::assert_string(join_fun) + moduleServer(id, function(input, output, session) { + # selectors is a list of reactive picks. + selectors_unwrapped <- reactive({ + lapply(selectors, function(x) req(x())) + }) + + data_r <- reactive({ + req(data(), selectors_unwrapped()) + .qenv_merge( + data(), + selectors = selectors_unwrapped(), + output_name = output_name, + join_fun = join_fun + ) + }) + + variables_selected <- eventReactive( + selectors_unwrapped(), + { + req(selectors_unwrapped()) + lapply( + .merge_summary_list(selectors_unwrapped(), join_keys = teal.data::join_keys(data()))$mapping, + function(selector) unname(selector$variables) + ) + } + ) + + list(data = data_r, variables = variables_selected) + }) +} + + +#' @keywords internal +.qenv_merge <- function(x, + selectors, + output_name = "anl", + join_fun = "dplyr::left_join") { + checkmate::assert_class(x, "teal_data") + checkmate::assert_list(selectors, "picks", names = "named") + checkmate::assert_string(join_fun) + + # Early validation of merge keys between datasets + merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) + + expr <- .merge_expr(merge_summary = merge_summary, output_name = output_name, join_fun = join_fun) + + merged_q <- teal.code::eval_code(x, expr) + teal.data::join_keys(merged_q) <- merge_summary$join_keys + merged_q +} + + +#' @keywords internal +.merge_expr <- function(merge_summary, + output_name = "anl", + join_fun = "dplyr::left_join") { + checkmate::assert_list(merge_summary) + checkmate::assert_string(output_name) + checkmate::assert_string(join_fun) + + join_keys <- merge_summary$join_keys + mapping <- merge_summary$mapping + mapping <- lapply(mapping, function(x) { + # because we need `$new_name = $old_name` to rename in select call + x$variables <- stats::setNames(names(x$variables), unname(x$variables)) + x + }) + datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) + calls <- expression() + anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) + anl_primary_keys <- character(0) # to determine accumulated keys of anl + for (i in seq_along(datanames)) { + dataname <- datanames[i] + this_mapping <- Filter(function(x) x$datasets == dataname, mapping) + this_filter_mapping <- Filter( + x = this_mapping, function(x) !is.null(x$values) && !is.null(x$variables) + ) + this_foreign_keys <- .fk(join_keys, dataname) + this_primary_keys <- join_keys[dataname, dataname] + this_variables <- c( + this_foreign_keys, + unlist(lapply(unname(this_mapping), `[[`, "variables")) + ) + this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names + + this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) + this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) + + if (i > 1) { + anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) + this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) + if (length(anl_vs_this) && length(this_vs_anl)) { + warning("cartesian join - happens when primary keys A is not a subset of B and B is not a subset of A") + } + this_call <- as.call( + list( + str2lang(join_fun), + y = this_call, + by = join_keys["anl", dataname], + suffix = c("", sprintf("_%s", dataname)) + ) + ) + } + + anl_datanames <- c(anl_datanames, dataname) + anl_primary_keys <- union(anl_primary_keys, this_primary_keys) + calls <- c(calls, this_call) + } + + call("<-", str2lang(output_name), calls_combine_by("%>%", calls)) +} + + +#' Analyse selectors and concludes a merge parameters +#' +#' @return list containing: +#' - mapping (`named list`) containing selected values in each selector. This `mapping` +#' is sorted according to correct datasets merge order. `variables` contains names of the +#' variables in `ANL` +#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` +#' +#' @keywords internal +.merge_summary_list <- function(selectors, join_keys) { + checkmate::assert_list(selectors, "picks") + checkmate::assert_class(join_keys, "join_keys") + + .validate_is_eager(selectors) + .validate_join_keys(selectors, join_keys) + + mapping <- lapply( # what has been selected in each selector + selectors, + function(selector) { + lapply(selector, function(x) { + stats::setNames(x$selected, x$selected) + }) + } + ) + + mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) + mapping_by_dataset <- split(mapping, mapped_datanames) + + datanames <- unique(mapped_datanames) + if (length(datanames) > 1) { + # datanames are handed over in order of selectors but + # they must be in topological order - otherwise join might not be possible + datanames <- c( + intersect(names(join_keys), datanames), # join_keys are in topological order + setdiff(datanames, names(join_keys)) # non-joinable datasets at the end + ) + + # mapping will be reused so needs to be reordered as well + mapping <- mapping[order(match(mapped_datanames, datanames))] + } + remaining_datanames <- datanames + join_keys <- join_keys[datanames] + anl_colnames <- character(0) + for (dataname in datanames) { + # glossary: + # dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop) + # anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process) + # remaining datasets/datanames: datasets (or names) which are about to be merged + # + # Rules: + # 1. anl "inherits" foreign keys from anl datasets to remaining datasets + # 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. + # 3. foreign keys should be renamed if duplicated with anl colnames + # 4. (for later) selected datasets might not be directly mergable, we need to find the "path" which + # will probably involve add intermediate datasets in between to perform merge + # 5. selected variables are added to anl. + # 6. duplicated variables added to anl should be renamed + remaining_datanames <- setdiff(remaining_datanames, dataname) + + # ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets + this_join_keys <- do.call( + teal.data::join_keys, + lapply( + remaining_datanames, + function(dataset_2) { + new_keys <- join_keys[dataname, dataset_2] + # ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already + if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) { + # ↓ 3. foreign keys should be renamed if duplicated with anl colnames + new_key_names <- .suffix_duplicated_vars( + vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) + all_vars = anl_colnames, + suffix = dataname + ) + names(new_keys) <- new_key_names + teal.data::join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) + } + } + ) + ) + join_keys <- c(this_join_keys, join_keys) + + + mapping_ds <- mapping_by_dataset[[dataname]] + mapping_ds <- lapply(mapping_ds, function(x) { + new_vars <- .suffix_duplicated_vars( + # is dropped by merge call. We should refer this selected foreign-key-variable + # to equivalent key variable added in previous iteration (existing anl foreign key) + # 6. duplicated variables added to anl should be renamed + vars = x$variables, + all_vars = anl_colnames, + suffix = dataname + ) + + # if foreign key of this dataset is selected and if this foreign key took a part in the merge + # then this key is dropped and we need to refer to the first variable + existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl + existing_fk_selected <- intersect(names(existing_fk), x$variables) + new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] + x$variables <- new_vars + x + }) + mapping[names(mapping_ds)] <- mapping_ds + + this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) + anl_colnames <- c(anl_colnames, this_colnames) + + anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) + } + + + list(mapping = mapping, join_keys = join_keys) +} + +.fk <- function(x, dataname) { + this_jk <- x[[dataname]] + unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names))) +} + +.suffix_duplicated_vars <- function(vars, all_vars, suffix) { + names <- names(vars) + idx_duplicated <- vars %in% all_vars + if (any(idx_duplicated)) { + # make sure that names are unchanged! + vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix) + } + vars +} + +#' Check if datasets can be merged in topological order +#' +#' Determines the topological order from join_keys, then checks that each dataset +#' can be joined with at least one of the previously accumulated datasets. +#' +#' @inheritParams merge_srv +#' @param join_keys (`join_keys`) The join keys object +#' +#' @keywords internal +.validate_join_keys <- function(selectors, join_keys) { + validate(need( + inherits(join_keys, "join_keys"), + "Provided data doesn't have join_keys specified" + )) + + datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected))) + # No validation needed for single dataset + if (length(datanames) <= 1) { + return(TRUE) + } + + # Get topological order from join_keys (this is the canonical ordering) + topological_order <- names(join_keys) + + # Filter to only selected datasets and maintain topological order + ordered_datasets <- intersect(topological_order, datanames) + + # Check if any dataset has no keys defined at all + if (length(ordered_datasets) != length(datanames)) { + datasets_without_keys <- setdiff(datanames, ordered_datasets) + validate( + need( + FALSE, + sprintf( + "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define `join_keys`.", + if (length(datasets_without_keys) == 1) " has" else "s have", + paste(sprintf("'%s'", datasets_without_keys), collapse = ", ") + ) + ) + ) + } + + # Iteratively check if each dataset can join with accumulated datasets + accumulated <- ordered_datasets[1] + + for (i in seq(2, length(ordered_datasets))) { + current_dataset <- ordered_datasets[i] + can_join <- FALSE + + # Check if current dataset has join keys with ANY accumulated dataset + for (prev_dataset in accumulated) { + if (length(join_keys[current_dataset, prev_dataset]) > 0) { + can_join <- TRUE + break + } + } + + if (!can_join) { + validate( + need( + FALSE, + sprintf( + paste( + "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets:", + "%s.\n\nPlease define join keys using teal.data::join_keys()." + ), + current_dataset, + current_dataset, + paste(sprintf("'%s'", accumulated), collapse = ", ") + ) + ) + ) + } + + # Add current dataset to accumulated + accumulated <- c(accumulated, current_dataset) + } + + TRUE +} + +.validate_is_eager <- function(x) { + validate(need( + !.is_delayed(x), + "selected values have not been resolved correctly. Please report this issue to an app-developer." + )) +} diff --git a/R/0-module_picks.R b/R/0-module_picks.R new file mode 100644 index 000000000..4a79cef30 --- /dev/null +++ b/R/0-module_picks.R @@ -0,0 +1,461 @@ +#' Interactive picks +#' +#' @description +#' +#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on +#' configuration provided via [picks()] and its responsibility is to determine relevant input +#' values +#' +#' +#' The module supports both single and combined `picks`: +#' - Single `picks` objects for a single input +#' - Named lists of `picks` objects for multiple inputs +#' +#' @param id (`character(1)`) Shiny module ID +#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects +#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags` +#' functions. By default, elements are wrapped in a package-specific drop-down. +#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices +#' +#' @return +#' - `picks_ui()`: UI elements for the input controls +#' - `picks_srv()`: Server-side reactive logic returning the processed data +#' +#' @details +#' The module uses S3 method dispatch to handle different ways to provide `picks`: +#' - `.picks` methods handle single `picks`` object +#' - `.list` methods handle multiple `picks` objects +#' +#' The UI component (`picks_ui`) creates the visual elements, while the +#' server component (`picks_srv`) manages the reactive logic, +#' +#' @seealso [picks()] for creating `picks`` objects +#' +#' @name picks_module +NULL + +#' @rdname picks_module +#' @export +picks_ui <- function(id, picks, container = "badge_dropdown") { + checkmate::assert_string(id) + UseMethod("picks_ui", picks) +} + +#' @rdname picks_module +#' @export +picks_ui.list <- function(id, picks, container) { + checkmate::assert_list(picks, names = "unique") + ns <- shiny::NS(id) + sapply( + Filter(length, names(picks)), + USE.NAMES = TRUE, + function(name) picks_ui(ns(name), picks[[name]], container = container) + ) +} + +#' @rdname picks_module +#' @export +picks_ui.picks <- function(id, picks, container) { + ns <- shiny::NS(id) + badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) + + content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x)))) + htmltools::tags$div( + if (missing(container)) { + badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) + } else { + if (!any(sapply(htmltools::tags, identical, container))) { + stop("Container should be one of `htmltools::tags`") + } + container(content) + } + ) +} + +#' @rdname picks_module +#' @export +picks_srv <- function(id = "", picks, data) { + checkmate::assert_string(id) + checkmate::assert_class(data, "reactive") + UseMethod("picks_srv", picks) +} + +#' @rdname picks_module +#' @export +picks_srv.list <- function(id, picks, data) { + checkmate::assert_named(picks, type = "unique") + sapply( + names(Filter(length, picks)), + USE.NAMES = TRUE, + function(name) picks_srv(name, picks[[name]], data) + ) +} + +#' @rdname picks_module +#' @export +picks_srv.picks <- function(id, picks, data) { + moduleServer(id, function(input, output, session) { + picks_resolved <- shiny::reactiveVal( + restoreValue( + session$ns("picks"), + resolver(picks, shiny::isolate(data())) + ) + ) + session$onBookmark(function(state) { + logger::log_debug("picks_srv@onBookmark: storing current picks") + state$values$picks <- picks_resolved() + }) + + badge <- shiny::reactive({ + lapply( + picks_resolved(), + function(x) { + label <- if (inherits(x, "values")) { + if (!setequal(x$choices, x$selected)) { + bsicons::bs_icon("funnel") + } + } else if (length(x$selected)) { + toString(x$selected) + } else { + "~" + } + label + } + ) + }) + + output$summary <- shiny::renderUI(tagList(badge())) + + Reduce( + function(this_data, slot_name) { # this_data is a (drilled-down) data for current pick + choices <- reactiveVal(isolate(picks_resolved())[[slot_name]]$choices) + selected <- reactiveVal(isolate(picks_resolved())[[slot_name]]$selected) + all_choices <- reactive(determine(x = picks[[slot_name]], data = this_data())$x$choices) + + observeEvent(all_choices(), ignoreInit = TRUE, { + current_choices <- picks_resolved()[[slot_name]]$choices + current_selected <- picks_resolved()[[slot_name]]$selected + new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) { + c( + max(current_selected[1], all_choices()[1], na.rm = TRUE), + min(current_selected[2], all_choices()[2], na.rm = TRUE) + ) + } else { + intersect(current_selected, all_choices()) + } + + .update_rv( + selected, new_selected, + sprintf("picks_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name) + ) + .update_rv( + choices, all_choices(), + sprintf("picks_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name) + ) + }) + + observeEvent(picks_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, { + .update_rv(choices, picks_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices") + .update_rv(selected, picks_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected") + }) + + args <- attributes(picks[[slot_name]]) + .pick_srv( + id = slot_name, + pick_type = slot_name, + choices = choices, + selected = selected, + args = args[!names(args) %in% c("names", "class")], + data = this_data + ) + + # this works as follows: + # Each observer is observes input$selected of i-th element of picks ($datasets, $variables, ...) + shiny::observeEvent( + selected(), + ignoreInit = TRUE, # because picks_resolved is already resolved and `selected()` is being set + ignoreNULL = FALSE, # because input$selected can be empty + { + .resolve( + selected(), + slot_name = slot_name, + picks_resolved = picks_resolved, + old_picks = picks, + data = data() # data() object needed as we resolve the WHOLE picks INSTEAD OF one picks element. + ) + } + ) + + reactive(.extract(x = picks_resolved()[[slot_name]], this_data())) + }, + x = names(picks), + init = data + ) + + picks_resolved + }) +} + +.pick_ui <- function(id) { + ns <- shiny::NS(id) + uiOutput(ns("selected_container")) +} + +.pick_srv <- function(id, pick_type, choices, selected, data, args) { + checkmate::assert_string(id) + checkmate::assert_class(choices, "reactiveVal") + checkmate::assert_class(selected, "reactiveVal") + checkmate::assert_list(args) + + shiny::moduleServer(id, function(input, output, session) { + is_numeric <- reactive(is.numeric(choices())) + choices_opt_content <- reactive({ + if (pick_type != "values") { + sapply( + choices(), + function(choice) { + icon <- toString(icon(.picker_icon(data()[[choice]]), lib = "font-awesome")) + label <- attr(data()[[choice]], "label") + paste( + icon, + choice, + if (!is.null(label) && !is.na(label) && !identical(label, choice)) { + toString(tags$small(label, class = "text-muted")) + } + ) + } + ) + } + }) + + output$selected_container <- renderUI({ + logger::log_debug(".pick_srv@1 rerender {pick_type} input") + .validate_is_eager(choices()) + .validate_is_eager(selected()) + if (isTRUE(args$fixed) || length(choices()) <= 1) {} else if (is_numeric()) { + .pick_ui_numeric( + session$ns("range"), + label = sprintf("Select %s range:", pick_type), + choices = choices(), + selected = selected(), + args = args + ) + } else { + .pick_ui_categorical( + session$ns("selected"), + label = sprintf("Select %s:", pick_type), + choices = choices(), + selected = selected(), + multiple = args$multiple, + choicesOpt = list(content = isolate(choices_opt_content())), + args = args[!names(args) %in% c("multiple")] + ) + } + }) |> bindEvent(is_numeric(), choices()) # never change on selected() + + # for numeric + range_debounced <- reactive(input$range) |> debounce(1000) + shiny::observeEvent(range_debounced(), { + .update_rv(selected, input$range, log = ".pick_srv@2 update selected after input changed") + }) + + # for non-numeric + shiny::observeEvent(input$selected_open, { + if (!isTRUE(input$selected_open)) { + # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) + new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) + if (args$ordered) { + new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected())) + } + .update_rv(selected, new_selected, log = ".pick_srv@1 update selected after input changed") + } + }) + selected + }) +} + + +.pick_ui_numeric <- function(id, label, choices, selected, args) { + shinyWidgets::numericRangeInput( + inputId = id, + label = label, + min = unname(choices[1]), + max = unname(utils::tail(choices, 1)), + value = unname(selected) + ) +} + +.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { # nolint + htmltools::div( + style = "max-width: 500px;", + shinyWidgets::pickerInput( + inputId = id, + label = label, + choices = choices, + selected = selected, + multiple = multiple, + choicesOpt = choicesOpt, + options = c( + list( + "actions-box" = !multiple, + "live-search" = length(choices) > 10, + "none-selected-text" = "- Nothing selected -", + "show-subtext" = TRUE + ), + args + ) + ) + ) +} + +#' Update reactive values with log +#' +#' Update reactive values only if values differ to avoid unnecessary reactive trigger +#' @param rv (`reactiveVal`) +#' @param value (`vector`) +#' @param log (`character(1)`) message to `log_debug` +#' @keywords internal +.update_rv <- function(rv, value, log) { + if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets. + logger::log_debug(log) + rv(value) + } +} + +#' Resolve downstream after selected changes +#' +#' @description +#' When i-th select input changes then +#' - picks_resolved containing current state is being unresolved but only after the i-th element as +#' values are sequentially dependent. For example if variables (i=2) is selected we don't want +#' to unresolve (restart) dataset. +#' - new value (selected) is replacing old value in current slot (i) +#' - we call resolve which resolves only "unresolved" (delayed) values +#' - new picks is replacing `reactiveValue` +#' Thanks to this design reactive values are triggered only once +#' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column. +#' @param slot_name (`character(1)`) one of `c("datasets", "variables", "values")` +#' @param picks_resolved (`reactiveVal`) +#' @param old_picks (`picks`) +#' @param data (`any` asserted further in `resolver`) +#' @keywords internal +.resolve <- function(selected, slot_name, picks_resolved, old_picks, data) { + checkmate::assert_vector(selected, null.ok = TRUE) + checkmate::assert_string(slot_name) + checkmate::assert_class(picks_resolved, "reactiveVal") + checkmate::assert_class(old_picks, "picks") + if (isTRUE(all.equal(selected, picks_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { + return(NULL) + } + logger::log_info("picks_server@1 selected has changed. Resolving downstream...") + + new_picks_unresolved <- old_picks + # ↓ everything after `slot_idx` is to resolve + slot_idx <- which(names(old_picks) == slot_name) + new_picks_unresolved[seq_len(slot_idx - 1)] <- picks_resolved()[seq_len(slot_idx - 1)] + new_picks_unresolved[[slot_idx]]$selected <- selected + + resolver_warnings <- character(0) + new_picks_resolved <- withCallingHandlers( + resolver(new_picks_unresolved, data), + warning = function(w) { + resolver_warnings <<- paste(conditionMessage(w), collapse = " ") + } + ) + if (length(resolver_warnings)) { + showNotification(resolver_warnings, type = "error") + } + + picks_resolved(new_picks_resolved) +} + +#' Restore value from bookmark. +#' +#' Get value from bookmark or return default. +#' +#' Bookmarks can store not only inputs but also arbitrary values. +#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks, +#' and they are placed in the `values` environment in the `session$restoreContext` field. +#' Using `teal_data_module` makes it impossible to run the callbacks +#' because the app becomes ready before modules execute and callbacks are registered. +#' In those cases the stored values can still be recovered from the `session` object directly. +#' +#' Note that variable names in the `values` environment are prefixed with module name space names, +#' therefore, when using this function in modules, `value` must be run through the name space function. +#' +#' @param value (`character(1)`) name of value to restore +#' @param default fallback value +#' +#' @return +#' In an application restored from a server-side bookmark, +#' the variable specified by `value` from the `values` environment. +#' Otherwise `default`. +#' +#' @keywords internal +#' +restoreValue <- function(value, default) { # nolint: object_name. + checkmate::assert_character("value") + session_default <- shiny::getDefaultReactiveDomain() + session_parent <- .subset2(session_default, "parent") + session <- if (is.null(session_parent)) session_default else session_parent + + if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) { + session$restoreContext$values[[value]] + } else { + default + } +} + +#' `pickerInput` choices icons +#' +#' Icons describing a class of the choice +#' @param x (`any`) object which class will determine icon +#' @return html-tag in form of `character(1)` +#' @keywords internal +.picker_icon <- function(x) { + UseMethod(".picker_icon") +} + +#' @keywords internal +#' @export +.picker_icon.numeric <- function(x) "arrow-up-1-9" + +#' @keywords internal +#' @export +.picker_icon.integer <- function(x) "arrow-up-1-9" + +#' @keywords internal +#' @export +.picker_icon.logical <- function(x) "pause" + +#' @keywords internal +#' @export +.picker_icon.Date <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.POSIXct <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.POSIXlt <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.factor <- function(x) "chart-bar" + +#' @keywords internal +#' @export +.picker_icon.character <- function(x) "font" + +#' @keywords internal +#' @export +.picker_icon.primary_key <- function(x) "key" + +#' @keywords internal +#' @export +.picker_icon.data.frame <- function(x) "table" + +#' @keywords internal +#' @export +.picker_icon.default <- function(x) "circle-question" diff --git a/R/0-picks.R b/R/0-picks.R new file mode 100644 index 000000000..229c04d95 --- /dev/null +++ b/R/0-picks.R @@ -0,0 +1,487 @@ +#' Choices/selected settings +#' +#' Define choices and default selection for variables. `picks` allows app-developer to specify +#' `datasets`, `variables` and `values` to be selected by app-user during Shiny session. +#' Functions are based on the idea of `choices/selected` where app-developer provides `choices` +#' and what is `selected` by default. App-user changes `selected` interactively (see [`picks_module`]). +#' +#' @param choices (`tidyselect::language` or `character`) +#' Available values to choose. +#' @param selected (`tidyselect::language` or `character`) +#' Choices to be selected. +#' @param multiple (`logical(1)`) if more than one selection is possible. +#' @param fixed (`logical(1)`) selection will be fixed and not possible to change interactively. +#' @param ordered (`logical(1)`) if the selected should follow the selection order. If `FALSE` +#' `selected` returned from `srv_module_input()` would be ordered according to order in `choices`. +#' @param ... additional arguments delivered to `pickerInput` +#' +#' @details +#' # `tidyselect` support +#' +#' Both `choices` and `selected` parameters support `tidyselect` syntax, enabling dynamic +#' and flexible variable selection patterns. This allows choices to be determined at runtime +#' based on data characteristics rather than hard-coded values. +#' +#' ## Using `tidyselect` for `choices` and `selected` +#' +#' When `choices` uses `tidyselect`, the available options are determined dynamically based on actually +#' selected data: +#' +#' - `tidyselect::everything()` - All variables/datasets +#' - `tidyselect::starts_with("prefix")` - Variables starting with a prefix +#' - `tidyselect::ends_with("suffix")` - Variables ending with a suffix +#' - `tidyselect::contains("pattern")` - Variables containing a pattern +#' - `tidyselect::matches("regex")` - Variables matching a regular expression +#' - `tidyselect::where(predicate)` - Variables/datasets satisfying a predicate function +#' - `tidyselect::all_of(vars)` - All specified variables (error if missing) +#' - `tidyselect::any_of(vars)` - Any specified variables (silent if missing) +#' - Range selectors like `Sepal.Length:Petal.Width` - Variables between two positions +#' - Integer indices (e.g., `1L`, `1L:3L`, `c(1L, 3L, 5L)`) - Select by position. Be careful, must be integer! +#' +#' The `selected` parameter can use the same syntax but it will be applied to the subset defined in choices. This +#' means that `choices = is.numeric, selected = is.factor` or `choices = c("a", "b", "c"), selected = c("d", "e")` +#' will imply en empty `selected`. +#' +#' **Warning:** Using explicit character values for `selected` with dynamic `choices` may +#' cause issues if the selected values are not present in the dynamically determined choices. +#' Prefer using numeric indices (e.g., `1` for first variable) when `choices` is dynamic. +#' +#' # Structure and element dependencies +#' +#' The `picks()` function creates a hierarchical structure where elements depend on their +#' predecessors, enabling cascading reactive updates during Shiny sessions. +#' +#' ## Element hierarchy +#' +#' A `picks` object must follow this order: +#' +#' 1. **`datasets()`** - to select a dataset. Always the first element (required). +#' 2. **`variables()`** - To select columns from the chosen dataset. +#' 3. **`values()`** - To select specific values from the chosen variable(s). +#' +#' Each element's choices are evaluated within the context of its predecessor's selection. +#' +#' ## How dependencies work +#' +#' - **Fixed dataset**: When `datasets(choices = "iris")` specifies one dataset, the +#' `variables()` choices are evaluated against that dataset columns. +#' +#' - **Multiple dataset choices**: When `datasets(choices = c("iris", "mtcars"))` allows multiple +#' options, `variables()` choices are re-evaluated each time the user selects a different +#' dataset. This creates a reactive dependency where variable choices update automatically. +#' +#' - **Dynamic dataset choices**: When using `datasets(choices = tidyselect::where(is.data.frame))`, +#' all available data frames are discovered at runtime, and variable choices adapt to +#' whichever dataset the user selects. +#' +#' - **Variable to values**: Similarly, `values()` choices are evaluated based on the +#' selected variable(s), allowing users to filter specific levels or values. When multiple +#' variables are selected, then values will be a concatenation of the columns. +#' +#' ## Best practices +#' +#' - Always start with `datasets()` - this is enforced by validation +#' - Use dynamic `choices` in `variables()` when working with multiple datasets to ensure +#' compatibility across different data structures +#' - Prefer `tidyselect::everything()` or `tidyselect::where()` predicates for flexible +#' variable selection that works across datasets with different schemas +#' - Use numeric indices for `selected` when `choices` are dynamic to avoid referencing +#' variables that may not exist in all datasets +#' +#' ## Important: `values()` requires type-aware configuration +#' +#' ### Why `values()` is different from `datasets()` and `variables()` +#' +#' `datasets()` and `variables()` operate on named lists of objects, meaning they work with character-based +#' identifiers. This allows you to use text-based selectors like `starts_with("S")` or `contains("prefix")` +#' consistently for both datasets and variable names. +#' +#' `values()` is fundamentally different because it operates on the **actual data content** within a +#' selected variable (column). The type of data in the column determines what kind of filtering makes sense: +#' +#' - **`numeric` columns** (e.g., `age`, `height`, `price`) contain numbers +#' - **`character`/`factor` columns** (e.g., `country`, `category`, `status`) contain categorical values +#' - **`Date`/`POSIXct` columns** contain temporal data +#' - **`logical` columns** contain TRUE/FALSE values +#' +#' ### Type-specific UI controls +#' +#' The `values()` function automatically renders different UI controls based on data type: +#' +#' - **`numeric` data**: Creates a `sliderInput` for range selection +#' - `choices` must be a numeric vector of length 2: `c(min, max)` +#' - `selected` must be a numeric vector of length 2: `c(selected_min, selected_max)` +#' +#' - **Categorical data** (`character`/`factor`): Creates a `pickerInput` for discrete selection +#' - `choices` can be a character vector or predicate function +#' - `selected` can be specific values or a predicate function +#' +#' - **`Date`/`POSIXct` data**: Creates date/datetime range selectors +#' - `choices` must be a Date or `POSIXct` vector of length 2 +#' +#' - **`logical` data**: Creates a checkbox or picker for TRUE/FALSE selection +#' +#' ### Developer responsibility +#' +#' **App developers must ensure `values()` configuration matches the variable type:** +#' +#' 1. **Know your data**: Understand what type of variable(s) users might select +#' 2. **Configure appropriately**: Set `choices` and `selected` to match expected data types +#' 3. **Use predicates for flexibility**: When variable type is dynamic, use predicate functions +#' like `function(x) !is.na(x)` (the default) to handle multiple types safely +#' +#' ### Examples of correct usage +#' +#' ```r +#' # For a numeric variable (e.g., age) +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = "age", multiple = FALSE), +#' values(choices = c(0, 100), selected = c(18, 65)) +#' ) +#' +#' # For a categorical variable (e.g., country) +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = "country", multiple = FALSE), +#' values(choices = c("USA", "Canada", "Mexico"), selected = "USA") +#' ) +#' +#' # Safe approach when variable type is unknown - use predicates +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = tidyselect::everything(), selected = 1L), +#' values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) +#' ) +#' ``` +#' +#' ### Common mistakes to avoid +#' +#' ```r +#' # WRONG: Using string selectors for numeric data +#' values(choices = starts_with("5")) # Doesn't make sense for numeric data! +#' +#' # WRONG: Providing categorical choices for a numeric variable +#' values(choices = c("low", "medium", "high")) # Won't work if variable is numeric! +#' +#' # WRONG: Providing numeric range for categorical variable +#' values(choices = c(0, 100)) # Won't work if variable is factor/character! +#' ``` +#' +#' ## Example: Three-level hierarchy +#' +#' ```r +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = "iris"), +#' variables(choices = tidyselect::where(is.numeric), selected = 1L), +#' values(choices = tidyselect::everything(), selected = seq_len(10)) +#' ) +#' ``` +#' +#' In this example: +#' - User first selects a dataset (`iris` or `mtcars`) +#' - Variable choices update to show only numeric columns from selected dataset +#' - After selecting a variable, value choices show all unique values from that column +#' +#' @examples +#' # Select columns from iris dataset using range selector +#' picks( +#' datasets(choices = "iris"), +#' variables(choices = Sepal.Length:Petal.Width, selected = 1L) +#' ) +#' +#' # Single variable selection from iris dataset +#' picks( +#' datasets(choices = "iris", selected = "iris"), +#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) +#' ) +#' +#' # Dynamic selection: any variable from iris, first selected by default +#' picks( +#' datasets(choices = "iris", selected = "iris"), +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +#' ) +#' +#' # Multiple dataset choices: variable choices will update when dataset changes +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = "iris"), +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +#' ) +#' +#' # Select from any dataset, filter by numeric variables +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = 1L), +#' variables(choices = tidyselect::where(is.numeric), selected = 1L) +#' ) +#' +#' # Fully dynamic: auto-discover datasets and variables +#' picks( +#' datasets(choices = tidyselect::where(is.data.frame), selected = 1L), +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +#' ) +#' +#' # Select categorical variables with length constraints +#' picks( +#' datasets(choices = tidyselect::everything(), selected = 1L), +#' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = seq_len(2)) +#' ) +#' +#' @export +picks <- function(...) { + picks <- rlang::dots_list(..., .ignore_empty = "trailing") + checkmate::assert_list(picks, types = "pick") + if (!inherits(picks[[1]], "datasets")) { + stop("picks() requires datasets() as the first element", call. = FALSE) + } + + # Check if values exists and is preceded by variables + element_classes <- vapply(picks, FUN = methods::is, FUN.VALUE = character(1)) + values_idx <- which(element_classes == "values") + + if (length(values_idx) > 0) { + variables_idx <- which(element_classes == "variables") + if (length(variables_idx) == 0) { + stop("picks() requires variables() before values()", call. = FALSE) + } + if (values_idx != variables_idx + 1) { + stop("values() must immediately follow variables() in picks()", call. = FALSE) + } + } + + previous_has_dynamic_choices <- c( + FALSE, + vapply(utils::head(picks, -1), FUN.VALUE = logical(1), FUN = .is_delayed) + ) + has_eager_choices <- vapply(picks, function(x) !.is_delayed(x$choices), logical(1)) + + if (any(previous_has_dynamic_choices & has_eager_choices)) { + idx_wrong <- which(previous_has_dynamic_choices & has_eager_choices)[1] + warning( + element_classes[idx_wrong], " has eager choices (character) while ", + element_classes[idx_wrong - 1], " has dynamic choices. ", + "It is not guaranteed that explicitly defined choices will be a subset of data selected in a previous element.", + call. = FALSE + ) + } + + names(picks) <- element_classes + structure(picks, class = c("picks", "list")) +} + +#' @rdname picks +#' @export +datasets <- function(choices = tidyselect::everything(), + selected = 1L, + fixed = NULL, + ...) { + checkmate::assert( + .check_tidyselect(choices), + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1) + ) + checkmate::assert( + .check_tidyselect(selected), + .check_predicate(selected), + checkmate::check_character(selected, len = 1, null.ok = TRUE) + ) + + if (is.null(fixed)) { + fixed <- !.is_tidyselect(choices) && !.is_predicate(choices) && length(choices) == 1 + } + + out <- .pick( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = FALSE, + fixed = fixed, + ... + ) + class(out) <- c("datasets", class(out)) + out +} + +#' @rdname picks +#' @export +variables <- function(choices = tidyselect::everything(), + selected = 1L, + multiple = NULL, + fixed = NULL, + ordered = FALSE, + ...) { + checkmate::assert( + .check_tidyselect(choices), + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1) + ) + checkmate::assert( + .check_tidyselect(selected), + .check_predicate(selected), + checkmate::check_character(selected, min.len = 1, null.ok = TRUE) + ) + if (is.null(multiple)) { + multiple <- !(.is_tidyselect(selected) || .is_predicate(selected)) && length(selected) > 1 + } + if (is.null(fixed)) { + fixed <- !(.is_tidyselect(choices) || .is_predicate(choices)) && length(choices) == 1 + } + + out <- .pick( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple, + fixed = fixed, + ordered = ordered, + `allow-clear` = !.is_tidyselect(selected) && !.is_predicate(selected) && (is.null(selected) || multiple), + ... + ) + class(out) <- c("variables", class(out)) + out +} + +#' @rdname picks +#' @export +values <- function(choices = function(x) !is.na(x), + selected = function(x) !is.na(x), + multiple = TRUE, + fixed = NULL, + ...) { + checkmate::assert( + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1, unique = TRUE), + checkmate::check_logical(choices, min.len = 1, unique = TRUE), + checkmate::check_numeric(choices, len = 2, sorted = TRUE, finite = TRUE), + checkmate::check_date(choices, len = 2), # should be sorted but determine + checkmate::check_posixct(choices, len = 2) + ) + checkmate::assert( + .check_predicate(selected), + checkmate::check_null(selected), + checkmate::check_character(selected, min.len = 1, unique = TRUE), + checkmate::check_logical(selected, min.len = 1, unique = TRUE), + checkmate::check_numeric(selected, len = 2, sorted = TRUE, finite = TRUE), + checkmate::check_date(selected, len = 2), + checkmate::check_posixct(selected, len = 2) + ) + + if (is.null(fixed)) { + fixed <- !.is_predicate(choices) && length(choices) == 1 + } + + out <- .pick( + choices = choices, + selected = selected, + multiple = multiple, + fixed = fixed, + ... + ) + class(out) <- c("values", class(out)) + out +} + +.pick <- function(choices, + selected, + multiple = length(selected) > 1, + ordered = FALSE, + fixed = FALSE, + ...) { + is_choices_delayed <- rlang::is_quosure(choices) || .is_predicate(choices) + is_selected_eager <- is.character(selected) + if (is_choices_delayed && is_selected_eager) { + warning( + deparse(sys.call(-1)), + "\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) doesn't ", + "guarantee that `selected` is a subset of `choices`.", + call. = FALSE + ) + } + + if (is.character(choices) && is.character(selected) && any(!selected %in% choices)) { + not_in_choices <- setdiff(selected, choices) + stop(sprintf( + "Some `selected`:{%s}\nare not a subset of `choices`: {%s}", + toString(sQuote(not_in_choices)), + toString(sQuote(choices)) + )) + } + + out <- structure( + list(choices = choices, selected = selected), + multiple = multiple, + ordered = ordered, + fixed = fixed, + ..., + class = "pick" + ) +} + +#' Is an object created using `tidyselect` +#' +#' @description +#' `choices` and `selected` can be provided using `tidyselect`, (e.g. [tidyselect::everything()] +#' [tidyselect::where()], [tidyselect::starts_with()]). These functions can't be called +#' independently but rather as an argument of function which consumes them. +#' `.is_tidyselect` safely determines if `x` can be evaluated with `tidyselect::eval_select()` +#' @param x `choices` or `selected` +#' @return `logical(1)` +#' @keywords internal +.is_tidyselect <- function(x) { + out <- suppressWarnings(tryCatch(x, error = function(e) e)) + inherits(out, "error") && grepl("must be used within a \\*selecting\\* function", out$message) || # e.g. everything + inherits(out, "error") && grepl("object .+ not found", out$message) || # e.g. var:var2 + inherits(out, "error") && grepl("operations are possible", out$message) || # e.g. where() | where() + checkmate::test_integer(out, min.len = 1) # e.g. 1L:5L +} + +.is_predicate <- function(x) { + !.is_tidyselect(x) && + ( + checkmate::test_function(x, nargs = 1) || + checkmate::test_function(x) && identical(names(formals(x)), "...") + ) +} + +.check_tidyselect <- function(x) { + if (!.is_tidyselect(x)) { + "choices/selected has not been created using tidyselect-helper" + } else { + TRUE + } +} + +.check_predicate <- function(x) { + if (!.is_predicate(x)) { + "choices/selected has not been created using predicate function (single arg function returning TRUE or FALSE)" + } else { + TRUE + } +} + + +#' Is picks delayed +#' +#' Determine whether list of picks/picks or pick are delayed. +#' When [pick()] is created it could be either: +#' - `quosure` when `tidyselect` helper used (delayed) +#' - `function` when predicate function provided (delayed) +#' - `atomic` when vector of choices/selected provided (eager) +#' @param x (`list`, `list of picks`, `picks`, `pick`, `$choices`, `$selected`) +#' @keywords internal +.is_delayed <- function(x) { + UseMethod(".is_delayed") +} + +#' @export +.is_delayed.list <- function(x) { + any(vapply(x, .is_delayed, logical(1))) +} + +#' @export +.is_delayed.pick <- function(x) { + .is_delayed(x$choices) | .is_delayed(x$selected) +} + +#' @export +.is_delayed.default <- function(x) { + rlang::is_quosure(x) | + is.function(x) +} diff --git a/R/0-print.R b/R/0-print.R new file mode 100644 index 000000000..2bb09f076 --- /dev/null +++ b/R/0-print.R @@ -0,0 +1,74 @@ +#' @export +print.pick <- function(x, ...) { + cat(format(x, indent = 0)) + invisible(x) +} + +#' @export +print.picks <- function(x, ...) { + cat(format(x, indent = 0)) + invisible(x) +} + +#' @export +format.picks <- function(x, indent = 0, ...) { + out <- .indent(sprintf("%s\n", .bold("")), indent) + for (i in seq_along(x)) { + element_name <- names(x)[i] + out <- paste0(out, .indent(sprintf(" %s:\n", .bold(sprintf("<%s>", element_name))), indent)) + out <- paste0(out, .format_pick_content(x[[i]], indent + 4)) + out <- paste0(out, .format_pick_attributes(x[[i]], indent + 4)) + } + out +} + +#' @export +format.pick <- function(x, indent = 0, ...) { + element_class <- setdiff(class(x), "pick")[1] + out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent) + out <- paste0(out, .format_pick_content(x, indent + 2)) + out <- paste0(out, .format_pick_attributes(x, indent + 2)) + out +} + +.format_pick_content <- function(x, indent = 0) { + out <- .indent(sprintf("%s %s\n", "choices:", .format_pick_value(x$choices)), indent) + out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_pick_value(x$selected)), indent)) + out +} + +.format_pick_attributes <- function(x, indent = 0) { + attrs <- attributes(x) + attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")] + if (length(attrs_to_show) > 0) { + attrs_str <- vapply(names(attrs_to_show), function(name) { + value <- attrs_to_show[[name]] + sprintf("%s=%s", name, paste(value, collapse = ",")) + }, character(1)) + paste0(.indent(.italic(paste(attrs_str, collapse = ", ")), indent), "\n") + } else { + "" + } +} + +.format_pick_value <- function(x) { + choices_str <- if (rlang::is_quosure(x) || is.function(x)) { + rlang::as_label(x) + } else if (length(x) == 0) { + "~" + } else { + paste(x, collapse = ", ") + } +} + +.indent <- function(x, n) { + paste(formatC("", width = n), x) +} + +.bold <- function(x) { + sprintf("\033[1m%s\033[0m", x) +} + +.italic <- function(x) { + sprintf("\033[3m%s\033[0m", x) +} diff --git a/R/0-resolver.R b/R/0-resolver.R new file mode 100644 index 000000000..034d65212 --- /dev/null +++ b/R/0-resolver.R @@ -0,0 +1,255 @@ +#' Resolve `picks` +#' +#' Resolve iterates through each `picks` element and determines values . +#' @param x ([picks()]) settings for picks. +#' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`. +#' Used to determine values of unresolved `picks`. +#' +#' @returns resolved `picks`. +#' @export +#' +#' @examples +#' x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a")) +#' data <- list( +#' df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]), +#' df2 = data.frame(a = LETTERS[1:5], b = 1:5), +#' m = matrix() +#' ) +#' resolver(x = x, data = data) +resolver <- function(x, data) { + checkmate::assert_class(x, "picks") + checkmate::assert( + is.environment(data), + checkmate::check_list(data, names = "unique") + ) + data_i <- data + for (i in seq_along(x)) { + determined_i <- determine(x[[i]], data = data_i) + data_i <- determined_i$data + x[[i]] <- determined_i$x + } + x +} + +#' A method that should take a type and resolve it. +#' +#' Generic that makes the minimal check on spec. +#' Responsible of subsetting/extract the data received and check that the type matches +#' @param x The specification to resolve. +#' @param data The minimal data required. +#' @return A list with two elements, the `type` resolved and the data extracted. +#' @keywords internal +determine <- function(x, data) { + if (is.null(data)) { # this happens when $selected=NULL + return(list(x = .nullify_pick(x))) + } + UseMethod("determine") +} + +#' @export +determine.datasets <- function(x, data) { + checkmate::assert(is.environment(data), is.list(data)) + data <- as.list(data) + x$choices <- .determine_choices(x = x$choices, data = data) + x$selected <- .determine_selected( + x = x$selected, + data = data[intersect(x$choices, names(data))], + multiple = attr(x, "multiple") + ) + list(x = x, data = .extract(x, data)) +} + +#' @export +determine.variables <- function(x, data) { + checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame")) + if (ncol(data) <= 0L) { + warning("Selected dataset has no columns", call. = FALSE) + return(list(x = .nullify_pick(x))) + } + + x$choices <- .determine_choices(x$choices, data = data) + x$selected <- .determine_selected( + x$selected, + data = data[intersect(x$choices, colnames(data))], + multiple = attr(x, "multiple") + ) + list(x = x, data = .extract(x, data)) +} + +#' @export +determine.values <- function(x, data) { + data <- if (ncol(data) > 1) { + apply(data, 1, toString) + } else { + data[[1]] + } + + x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names + x$selected <- if (length(x$choices)) { + .determine_selected(x$selected, data = stats::setNames(x$choices, x$choices), multiple = attr(x, "multiple")) + } + list(x = x) # no picks element possible after picks(..., values) (no need to pass data further) +} + + +#' Evaluate delayed choices +#' +#' @param data (`list`, `data.frame`, `vector`) +#' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract. +#' @param multiple (`logical(1)`) whether multiple selection is possible. +#' +#' @details +#' +#' ## Various ways to evaluate choices/selected. +#' +#' Function resolves `x` to determine `choices` or `selected`. `x` is matched in multiple ways with +#' `data` to return valid choices: +#' - `x (character)`: values are matched with names of data and only intersection is returned. +#' - `x (tidyselect-helper)`: using [tidyselect::eval_select] +#' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE +#' +#' Mechanism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL` +#' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`. +#' +#' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`. +#' +#' - `character`: refers to the object name in `data`, for example +#' ``` +#' .determine_delayed(data = iris, x = "Species") +#' .determine_delayed(data = iris, x = c("Species", "inexisting")) +#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris") +#' ``` +#' - `quosure`: delayed (quoted) `tidyselect-helper` to be evaluated through `tidyselect::eval_select`. For example +#' ``` +#' .determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal"))) +#' .determine_delayed(data = iris, x = rlang::quo(1:2)) +#' .determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length)) +#' ``` +#' - `function(x)`: predicate function returning a logical flag. Evaluated for each `data` element. For example +#' ``` +#' +#' .determine_delayed(data = iris, x = is.numeric) +#' .determine_delayed(data = letters, x = function(x) x > "c") +#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame) +#' ``` +#' +#' @return `character` containing names/levels of `data` elements which match `x`, with two differences: +#' - `.determine_choices` returns vector named after data labels +#' - `.determine_selected` cuts vector to scalar when `multiple = FALSE` +#' +#' @keywords internal +.determine_choices <- function(x, data) { + out <- .determine_delayed(data = data, x = x) + if (!is.null(names(data)) && !is.atomic(data) && is.character(out) && is.null(names(out))) { + # only named non-atomic can have label + # don't rename if names provided by app dev + labels <- vapply( + out, + FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], + FUN.VALUE = character(1) + ) + stats::setNames(out, labels) + } else { + out + } +} + +#' @rdname dot-determine_choices +.determine_selected <- function(x, data, multiple = FALSE) { + if (!is.null(x) && length(data)) { + out <- .determine_delayed(data = data, x = x) + if (!isTRUE(multiple) && length(out) > 1) { + warning( + "`multiple` has been set to `FALSE`, while selected contains multiple values, forcing to select first:", + rlang::as_label(x) + ) + out <- out[1] + } + out + } +} + +#' @rdname dot-determine_choices +.determine_delayed <- function(x, data) { + if (length(dim(data)) == 2L) { # for example matrix + data <- as.data.frame(data) + } + + out <- tryCatch( # app developer might provide failing function + if (inherits(data, c("integer", "numeric", "Date", "POSIXct"))) { + data_range <- range(data, na.rm = TRUE) + this_range <- if (inherits(x, c("integer", "numeric", "Date", "POSIXct")) && length(x) == 2) { + x + } else if (is.function(x)) { + idx_match <- unique(which(vapply(data, x, logical(1)))) + range(data[idx_match], na.rm = TRUE) + } else { + data_range + } + mins <- c(this_range[1], data_range[1]) + maxs <- c(this_range[2], data_range[2]) + mins <- mins[is.finite(mins)] + maxs <- maxs[is.finite(maxs)] + if (length(mins) && length(maxs)) { + c(max(mins), min(maxs)) + } + } else { + if (is.character(x) && length(x)) { + # don't need to evaluated eager choices - just make sure choices are subset of possible + x[which(x %in% .possible_choices(data))] + } else if (is.function(x)) { + if (inherits(x, "des-delayed")) { + x(data) + } else { + idx_match <- unique(which(vapply(data, x, logical(1)))) + .possible_choices(data[idx_match]) + } + } else if (rlang::is_quosure(x)) { + # app developer might provide failing function + idx_match <- unique(tidyselect::eval_select(expr = x, data)) + .possible_choices(data[idx_match]) + } + }, + error = function(e) NULL # not returning error to avoid design complication to handle errors + ) + + if (length(out) == 0) { + warning( + "None of the `choices/selected`: ", rlang::as_label(x), "\n", + "are subset of: ", toString(.possible_choices(data), width = 30), "\n", + "Emptying choices..." + ) + return(NULL) + } + # unique() for idx containing duplicated values + if (is.atomic(out) && length(out)) out # this function should return atomic vector of length > 1 or NULL +} + +#' @rdname dot-determine_choices +.possible_choices <- function(data) { + if (is.factor(data)) { + levels(data) + } else if (inherits(data, c("numeric", "Date", "POSIXct"))) { + suppressWarnings(range(data, na.rm = TRUE)) # we don't need to warn as we handle this case (inf) + } else if (is.character(data)) { + unique(data) + } else { + names(data) + } +} + +.extract <- function(x, data) { + if (length(x$selected) == 0) { + NULL # this nullifies following pick-elements. See determine (generic) + } else if (length(x$selected) == 1 && inherits(x, "datasets")) { + data[[x$selected]] + } else if (all(x$selected %in% names(data))) { + data[x$selected] + } +} + +.nullify_pick <- function(x) { + x$choices <- NULL + x$selected <- NULL + x +} diff --git a/R/0-tidyselect-helpers.R b/R/0-tidyselect-helpers.R new file mode 100644 index 000000000..2e90aad27 --- /dev/null +++ b/R/0-tidyselect-helpers.R @@ -0,0 +1,37 @@ +#' `tidyselect` helpers +#' +#' @description +#' #' `r lifecycle::badge("experimental")` +#' Predicate functions simplifying `picks` specification. +#' @examples +#' # select factor column but exclude foreign keys +#' variables(choices = is_categorical(min.len = 2, max.len = 10)) +#' +#' @name tidyselectors +#' @rdname tidyselectors +#' @param min.len (`integer(1)`) minimal number of unique values +#' @param max.len (`integer(1)`) maximal number of unique values +#' @export +is_categorical <- function(min.len, max.len) { + # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len + # without a need to compute unique on the whole vector. + if (missing(max.len) && missing(min.len)) { + function(x) is.factor(x) || is.character(x) + } else if (!missing(max.len) && missing(min.len)) { + checkmate::assert_int(max.len, lower = 0) + function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len + } else if (!missing(min.len) && missing(max.len)) { + checkmate::assert_int(min.len, lower = 0) + function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len + } else { + checkmate::assert_int(min.len, lower = 0) + checkmate::assert_int(max.len, lower = 0) + checkmate::assert_true(max.len >= min.len) + function(x) { + (is.factor(x) || is.character(x)) && { + n <- length(unique(x)) + n >= min.len && n <= max.len + } + } + } +} diff --git a/R/0-tm_merge.R b/R/0-tm_merge.R new file mode 100644 index 000000000..632f3152d --- /dev/null +++ b/R/0-tm_merge.R @@ -0,0 +1,97 @@ +#' Merge module +#' +#' Example [`teal::module`] containing interactive inputs and displaying results of merge. +#' +#' @inheritParams teal::module +#' @param picks (`list` of `picks`) +#' @examples +#' library(teal) +#' +#' data <- within(teal.data::teal_data(), { +#' iris <- iris +#' mtcars <- mtcars +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' modules( +#' label = "Testing modules", +#' tm_merge( +#' label = "non adam", +#' picks = list( +#' a = picks( +#' datasets("iris", "iris"), +#' variables( +#' choices = c("Sepal.Length", "Species"), +#' selected = +#' ), +#' values() +#' ) +#' ) +#' ) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server, enableBookmarking = "server") +#' } +#' +#' @export +tm_merge <- function(label = "merge-module", picks, transformators = list()) { + teal::module( + label = label, + ui = function(id, picks) { + ns <- shiny::NS(id) + tags$div( + tags$div( + class = "row g-2", + lapply(names(picks), function(id) { + tags$div( + class = "col-auto", + tags$strong(tags$label(id)), + teal.transform::picks_ui( + id = ns(id), + picks = picks[[id]] + ) + ) + }) + ), + shiny::div( + shiny::tableOutput(ns("table_merged")), + shiny::verbatimTextOutput(ns("join_keys")), + shiny::verbatimTextOutput(ns("mapped")), + shiny::verbatimTextOutput(ns("src")) + ) + ) + }, + server = function(id, data, picks) { + moduleServer(id, function(input, output, session) { + selectors <- picks_srv(id, picks = picks, data = data) + + merged <- merge_srv("merge", data = data, selectors = selectors) + + table_q <- reactive({ + req(merged$data()) + within(merged$data(), anl, selectors = selectors) + }) + + output$table_merged <- shiny::tableOutput({ + req(table_q()) + teal.code::get_outputs(table_q())[[1]] + }) + + output$src <- renderPrint({ + cat(teal.code::get_code(req(table_q()))) + }) + + output$mapped <- renderText(yaml::as.yaml(merged$variables())) + + output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) + }) + }, + ui_args = list(picks = picks), + server_args = list(picks = picks), + transformators = transformators + ) +} diff --git a/R/choices_selected.R b/R/choices_selected.R index 197a58c88..771f3e53f 100644 --- a/R/choices_selected.R +++ b/R/choices_selected.R @@ -95,11 +95,11 @@ no_select_keyword <- "-- no selection --" #' choices_selected(choices = letters, selected = all_choices()) #' #' choices_selected( -#' choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), +#' choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), #' selected = "E" #' ) #' choices_selected( -#' choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), +#' choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), #' selected = last_choice() #' ) #' diff --git a/R/data_extract_filter_module.R b/R/data_extract_filter_module.R index d87a6d85a..00bcea1c4 100644 --- a/R/data_extract_filter_module.R +++ b/R/data_extract_filter_module.R @@ -70,7 +70,7 @@ data_extract_filter_srv <- function(id, datasets, filter) { # when the filter is initialized with a delayed spec, the choices and selected are NULL # here delayed are resolved and the values are set up # Begin by resolving delayed choices. - if (inherits(filter$selected, "delayed_choices")) { + if (inherits(filter$selected, "delayed_choices")) { filter$selected <- filter$selected(filter$choices) } teal.widgets::updateOptionalSelectInput( @@ -106,7 +106,6 @@ data_extract_filter_srv <- function(id, datasets, filter) { } else { choices[1] } - } else { choices <- character(0) selected <- character(0) diff --git a/R/get_merge_call.R b/R/get_merge_call.R index b319299b9..5646f37a9 100644 --- a/R/get_merge_call.R +++ b/R/get_merge_call.R @@ -383,16 +383,14 @@ get_anl_relabel_call <- function(columns_source, datasets, anl_name = "ANL") { column_labels <- labels[intersect(colnames(data_used()), column_names)] # NULL for no labels at all, character(0) for no labels for a given columns - return( - if (rlang::is_empty(column_labels)) { - column_labels - } else { - stats::setNames( - column_labels, - selector[names(column_labels)] - ) - } - ) + if (rlang::is_empty(column_labels)) { + column_labels + } else { + stats::setNames( + column_labels, + selector[names(column_labels)] + ) + } } ) ) diff --git a/_pkgdown.yml b/_pkgdown.yml index 1fb8c182e..43605f6cf 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -65,3 +65,28 @@ reference: - title: Human-readable formatting of a data extract object contents: - format_data_extract + - title: Picks + desc: >- + Picks contructors + contents: + - picks + - datasets + - variables + - values + - title: Shiny modules + desc: >- + Modules to interactively select-and-merge + contents: + - merge_srv + - picks_srv + - picks_ui + - tm_merge + - title: Picks utilities + desc: >- + Additional tools to help working with picks + contents: + - as.picks + - is_categorical + - resolver + - teal_transform_filter + diff --git a/inst/WORDLIST b/inst/WORDLIST index 7ed60e27f..5b22b1f89 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,7 +1,16 @@ +Analyse CDISC +cloneable +colData Forkers +funder Hoffmann +preselected +qenv +repo +reproducibility +schemas Shinylive +th UI -funder -preselected +unresolve diff --git a/inst/badge-dropdown/script.js b/inst/badge-dropdown/script.js new file mode 100644 index 000000000..d044f7098 --- /dev/null +++ b/inst/badge-dropdown/script.js @@ -0,0 +1,31 @@ +function toggleBadgeDropdown(summaryId, containerId) { + var container = document.getElementById(containerId); + var summary = document.getElementById(summaryId); + + if(container.style.visibility === 'hidden' || container.style.visibility === '') { + container.style.visibility = 'visible'; + container.style.opacity = '1'; + container.style.pointerEvents = 'auto'; + $(container).trigger('shown'); + Shiny.bindAll(container); + + // Add click outside handler + setTimeout(function() { + function handleClickOutside(event) { + if (!container.contains(event.target) && !summary.contains(event.target)) { + container.style.visibility = 'hidden'; + container.style.opacity = '0'; + container.style.pointerEvents = 'none'; + $(container).trigger('hidden'); + document.removeEventListener('click', handleClickOutside); + } + } + document.addEventListener('click', handleClickOutside); + }, 10); + } else { + container.style.visibility = 'hidden'; + container.style.opacity = '0'; + container.style.pointerEvents = 'none'; + $(container).trigger('hidden'); + } +} \ No newline at end of file diff --git a/inst/badge-dropdown/style.css b/inst/badge-dropdown/style.css new file mode 100644 index 000000000..24f12a91f --- /dev/null +++ b/inst/badge-dropdown/style.css @@ -0,0 +1,61 @@ +.badge-dropdown { + padding: 0.25rem 0.5rem; + font-size: 0.75rem; + border-radius: 0.375rem; + line-height: 1.2; + min-width: auto; + width: 130px; + overflow-x: auto; + white-space: nowrap; + position: relative; + padding-right: .5rem; +} + +.badge-dropdown:has(~ * .shiny-validation-message), +.badge-dropdown:has(~ * .shiny-output-error) { + border: 2px solid red; +} + +.badge-dropdown-label { + display: block; + max-width: calc(100% - .5rem); + overflow-x: auto; + white-space: nowrap; + scrollbar-width: none; + -ms-overflow-style: none; + text-align: left; +} + +.badge-dropdown-label::-webkit-scrollbar { + display: none; +} + +.badge-dropdown-icon { + position: absolute; + top: 50%; + right: 0.5rem; + transform: translateY(-50%); + background: inherit; + z-index: 1; + pointer-events: none; + opacity: 0; + transition: opacity 0.2s ease; +} + +.badge-dropdown:hover .badge-dropdown-icon { + opacity: 1; +} + + +.badge-dropdown .btn { + padding: 0.25rem 0.5rem; + font-size: 0.75rem; + border-radius: 0.375rem; + line-height: 1.2; + min-width: auto; +} + +.badge-dropdown .btn::after { + margin-left: 0.25rem; + vertical-align: 0.1em; +} \ No newline at end of file diff --git a/man/as.picks.Rd b/man/as.picks.Rd new file mode 100644 index 000000000..2975d143c --- /dev/null +++ b/man/as.picks.Rd @@ -0,0 +1,92 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-as_picks.R +\name{as.picks} +\alias{as.picks} +\alias{teal_transform_filter} +\title{Convert data_extract_spec to picks} +\usage{ +as.picks(x) + +teal_transform_filter(x, label = "Filter") +} +\arguments{ +\item{x}{(\code{data_extract_spec}, \code{select_spec}, \code{filter_spec}) object to convert to \code{\link{picks}}} + +\item{label}{(\code{character(1)}) Label of the module.} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Helper functions to ease transition between \code{\link[=data_extract_spec]{data_extract_spec()}} and \code{\link[=picks]{picks()}}. +} +\details{ +With introduction of \code{\link{picks}}, \code{\link{data_extract_spec}} will no longer serve a primary tool to +define variable choices and default selection in teal-modules and eventually \code{\link{data_extract_spec}} +will be deprecated. +To ease the transition to the new tool, we provide \code{as.picks} method which can handle 1:1 +conversion from \code{\link{data_extract_spec}} to \code{\link{picks}}. Unfortunately, when \code{\link{data_extract_spec}} +contains \code{\link{filter_spec}} then \code{as.picks} is unable to provide reliable \code{\link{picks}} equivalent. +} +\examples{ +# convert des with eager select_spec +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = c("Sepal.Length", "Sepal.Width", "Species"), + selected = c("Sepal.Length", "Species"), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +# convert des with delayed select_spec +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris"), + selected = first_choice(), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris", subset = function(data) names(Filter(is.numeric, data))), + selected = first_choice(), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +# teal_transform_module build on teal.transform + +teal_transform_filter( + data_extract_spec( + dataname = "iris", + filter = filter_spec( + vars = "Species", + choices = c("setosa", "versicolor", "virginica"), + selected = c("setosa", "versicolor") + ) + ) +) + +teal_transform_filter( + picks( + datasets(choices = "iris", select = "iris"), + variables(choices = "Species", "Species"), + values( + choices = c("setosa", "versicolor", "virginica"), + selected = c("setosa", "versicolor") + ) + ) +) + +} diff --git a/man/badge_dropdown.Rd b/man/badge_dropdown.Rd new file mode 100644 index 000000000..fb6c66e07 --- /dev/null +++ b/man/badge_dropdown.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-badge_dropdown.R +\name{badge_dropdown} +\alias{badge_dropdown} +\title{Drop-down badge} +\usage{ +badge_dropdown(id, label, content) +} +\arguments{ +\item{id}{(\code{character(1)}) shiny module's id} + +\item{label}{(\code{shiny.tag}) Label displayed on a badge.} + +\item{content}{(\code{shiny.tag}) Content of a drop-down.} +} +\description{ +Drop-down button in a form of a badge with \code{bg-primary} as default style +Clicking badge shows a drop-down containing any \code{HTML} element. Folded drop-down +doesn't trigger display output which means that items rendered using \verb{render*} +will be recomputed only when drop-down is show. +} +\keyword{internal} diff --git a/man/call_check_parse_varname.Rd b/man/call_check_parse_varname.Rd index ac3cc6175..b872dbdf6 100644 --- a/man/call_check_parse_varname.Rd +++ b/man/call_check_parse_varname.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_check_parse_varname} \alias{call_check_parse_varname} \title{Checks \code{varname} argument and convert to call} diff --git a/man/call_condition_choice.Rd b/man/call_condition_choice.Rd index 5e005c860..635e16053 100644 --- a/man/call_condition_choice.Rd +++ b/man/call_condition_choice.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_choice} \alias{call_condition_choice} \title{Choices condition call} diff --git a/man/call_condition_logical.Rd b/man/call_condition_logical.Rd index 44c2dd4d3..5ce91ef52 100644 --- a/man/call_condition_logical.Rd +++ b/man/call_condition_logical.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_logical} \alias{call_condition_logical} \title{\code{logical} variable condition call} diff --git a/man/call_condition_range.Rd b/man/call_condition_range.Rd index 6fc816a82..28921c720 100644 --- a/man/call_condition_range.Rd +++ b/man/call_condition_range.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range} \alias{call_condition_range} \title{\code{numeric} range condition call} diff --git a/man/call_condition_range_date.Rd b/man/call_condition_range_date.Rd index ec16327e8..0e7445204 100644 --- a/man/call_condition_range_date.Rd +++ b/man/call_condition_range_date.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range_date} \alias{call_condition_range_date} \title{\code{Date} range condition call} diff --git a/man/call_condition_range_posixct.Rd b/man/call_condition_range_posixct.Rd index 3f2bc9674..02b775085 100644 --- a/man/call_condition_range_posixct.Rd +++ b/man/call_condition_range_posixct.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range_posixct} \alias{call_condition_range_posixct} \title{\code{POSIXct} range condition call} diff --git a/man/call_extract_array.Rd b/man/call_extract_array.Rd deleted file mode 100644 index 1cad599f7..000000000 --- a/man/call_extract_array.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R -\name{call_extract_array} -\alias{call_extract_array} -\title{Get call to subset and select array} -\usage{ -call_extract_array(dataname = ".", row = NULL, column = NULL, aisle = NULL) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}).} - -\item{row}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} - -\item{column}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{column} or condition.} - -\item{aisle}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} for 3-dimensional array in \code{x[i, j, k]} notation. -} -\description{ -Get call to subset and select array -} -\keyword{internal} diff --git a/man/call_extract_list.Rd b/man/call_extract_list.Rd deleted file mode 100644 index 49029ae88..000000000 --- a/man/call_extract_list.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R -\name{call_extract_list} -\alias{call_extract_list} -\title{Compose extract call with \code{$} operator} -\usage{ -call_extract_list(dataname, varname, dollar = TRUE) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}) name of the object.} - -\item{varname}{(\code{character(1)} or \code{name}) name of the slot in data.} - -\item{dollar}{(\code{logical(1)}) whether returned call should use \code{$} or \code{[[} operator.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} in \code{$} or \code{[[} notation (depending on parameters). -} -\description{ -Compose extract call with \code{$} operator -} -\keyword{internal} diff --git a/man/call_extract_matrix.Rd b/man/call_extract_matrix.Rd deleted file mode 100644 index 6ae8514d2..000000000 --- a/man/call_extract_matrix.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R -\name{call_extract_matrix} -\alias{call_extract_matrix} -\title{Get call to subset and select matrix} -\usage{ -call_extract_matrix(dataname = ".", row = NULL, column = NULL) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}).} - -\item{row}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} - -\item{column}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{column} or condition.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} for matrix in \code{x[i, j]} notation. -} -\description{ -Get call to subset and select matrix -} -\keyword{internal} diff --git a/man/call_with_colon.Rd b/man/call_with_colon.Rd deleted file mode 100644 index 42f4e6cee..000000000 --- a/man/call_with_colon.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R -\name{call_with_colon} -\alias{call_with_colon} -\title{Create a call using a function in a given namespace} -\usage{ -call_with_colon(name, ..., unlist_args = list()) -} -\arguments{ -\item{name}{\code{character} function name, possibly using namespace colon \code{::}, also -works with \code{:::} (sometimes needed, but strongly discouraged).} - -\item{...}{arguments to pass to function with name \code{name}.} - -\item{unlist_args}{\code{list} extra arguments passed in a single list, -avoids the use of \code{do.call} with this function.} -} -\value{ -\code{call}. -} -\description{ -The dot arguments in \code{...} need to be quoted because they will be evaluated otherwise. -} -\keyword{internal} diff --git a/man/calls_combine_by.Rd b/man/calls_combine_by.Rd index 8d3fa9f6d..7345b409a 100644 --- a/man/calls_combine_by.Rd +++ b/man/calls_combine_by.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{calls_combine_by} \alias{calls_combine_by} \title{Combine calls by operator} diff --git a/man/choices_selected.Rd b/man/choices_selected.Rd index 028bdd547..fa645d20f 100644 --- a/man/choices_selected.Rd +++ b/man/choices_selected.Rd @@ -119,11 +119,11 @@ choices_selected(choices = letters, selected = letters) choices_selected(choices = letters, selected = all_choices()) choices_selected( - choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), + choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), selected = "E" ) choices_selected( - choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), + choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), selected = last_choice() ) diff --git a/man/determine.Rd b/man/determine.Rd new file mode 100644 index 000000000..24a6dcc43 --- /dev/null +++ b/man/determine.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-resolver.R +\name{determine} +\alias{determine} +\title{A method that should take a type and resolve it.} +\usage{ +determine(x, data) +} +\arguments{ +\item{x}{The specification to resolve.} + +\item{data}{The minimal data required.} +} +\value{ +A list with two elements, the \code{type} resolved and the data extracted. +} +\description{ +Generic that makes the minimal check on spec. +Responsible of subsetting/extract the data received and check that the type matches +} +\keyword{internal} diff --git a/man/dot-determine_choices.Rd b/man/dot-determine_choices.Rd new file mode 100644 index 000000000..fb2c22bb1 --- /dev/null +++ b/man/dot-determine_choices.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-resolver.R +\name{.determine_choices} +\alias{.determine_choices} +\alias{.determine_selected} +\alias{.determine_delayed} +\alias{.possible_choices} +\title{Evaluate delayed choices} +\usage{ +.determine_choices(x, data) + +.determine_selected(x, data, multiple = FALSE) + +.determine_delayed(x, data) + +.possible_choices(data) +} +\arguments{ +\item{x}{(\code{character}, \code{quosure}, \verb{function(x)}) to determine \code{data} elements to extract.} + +\item{data}{(\code{list}, \code{data.frame}, \code{vector})} + +\item{multiple}{(\code{logical(1)}) whether multiple selection is possible.} +} +\value{ +\code{character} containing names/levels of \code{data} elements which match \code{x}, with two differences: +\itemize{ +\item \code{.determine_choices} returns vector named after data labels +\item \code{.determine_selected} cuts vector to scalar when \code{multiple = FALSE} +} +} +\description{ +Evaluate delayed choices +} +\details{ +\subsection{Various ways to evaluate choices/selected.}{ + +Function resolves \code{x} to determine \code{choices} or \code{selected}. \code{x} is matched in multiple ways with +\code{data} to return valid choices: +\itemize{ +\item \code{x (character)}: values are matched with names of data and only intersection is returned. +\item \code{x (tidyselect-helper)}: using \link[tidyselect:eval_select]{tidyselect::eval_select} +\item \verb{x (function)}: function is executed on each element of \code{data} to determine where function returns TRUE +} + +Mechanism is robust in a sense that it never fails (\code{tryCatch}) and returns \code{NULL} if no-match found. \code{NULL} +in \code{\link[=determine]{determine()}} is handled gracefully, by setting \code{NULL} to all following components of \code{picks}. + +In the examples below you can replace \code{.determine_delayed} with \code{.determine_choices} or \code{.determine_selected}. +\itemize{ +\item \code{character}: refers to the object name in \code{data}, for example + +\if{html}{\out{
}}\preformatted{.determine_delayed(data = iris, x = "Species") +.determine_delayed(data = iris, x = c("Species", "inexisting")) +.determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris") +}\if{html}{\out{
}} +\item \code{quosure}: delayed (quoted) \code{tidyselect-helper} to be evaluated through \code{tidyselect::eval_select}. For example + +\if{html}{\out{
}}\preformatted{.determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal"))) +.determine_delayed(data = iris, x = rlang::quo(1:2)) +.determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length)) +}\if{html}{\out{
}} +\item \verb{function(x)}: predicate function returning a logical flag. Evaluated for each \code{data} element. For example + +\if{html}{\out{
}}\preformatted{ +.determine_delayed(data = iris, x = is.numeric) +.determine_delayed(data = letters, x = function(x) x > "c") +.determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame) +}\if{html}{\out{
}} +} +} +} +\keyword{internal} diff --git a/man/dot-is_delayed.Rd b/man/dot-is_delayed.Rd new file mode 100644 index 000000000..2c5614962 --- /dev/null +++ b/man/dot-is_delayed.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-picks.R +\name{.is_delayed} +\alias{.is_delayed} +\title{Is picks delayed} +\usage{ +.is_delayed(x) +} +\arguments{ +\item{x}{(\code{list}, \verb{list of picks}, \code{picks}, \code{pick}, \verb{$choices}, \verb{$selected})} +} +\description{ +Determine whether list of picks/picks or pick are delayed. +When \code{\link[dplyr:pick]{dplyr::pick()}} is created it could be either: +\itemize{ +\item \code{quosure} when \code{tidyselect} helper used (delayed) +\item \code{function} when predicate function provided (delayed) +\item \code{atomic} when vector of choices/selected provided (eager) +} +} +\keyword{internal} diff --git a/man/dot-is_tidyselect.Rd b/man/dot-is_tidyselect.Rd new file mode 100644 index 000000000..49cfccc69 --- /dev/null +++ b/man/dot-is_tidyselect.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-picks.R +\name{.is_tidyselect} +\alias{.is_tidyselect} +\title{Is an object created using \code{tidyselect}} +\usage{ +.is_tidyselect(x) +} +\arguments{ +\item{x}{\code{choices} or \code{selected}} +} +\value{ +\code{logical(1)} +} +\description{ +\code{choices} and \code{selected} can be provided using \code{tidyselect}, (e.g. \code{\link[tidyselect:everything]{tidyselect::everything()}} +\code{\link[tidyselect:where]{tidyselect::where()}}, \code{\link[tidyselect:starts_with]{tidyselect::starts_with()}}). These functions can't be called +independently but rather as an argument of function which consumes them. +\code{.is_tidyselect} safely determines if \code{x} can be evaluated with \code{tidyselect::eval_select()} +} +\keyword{internal} diff --git a/man/dot-merge_summary_list.Rd b/man/dot-merge_summary_list.Rd new file mode 100644 index 000000000..27b0a1e1b --- /dev/null +++ b/man/dot-merge_summary_list.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{.merge_summary_list} +\alias{.merge_summary_list} +\title{Analyse selectors and concludes a merge parameters} +\usage{ +.merge_summary_list(selectors, join_keys) +} +\value{ +list containing: +\itemize{ +\item mapping (\verb{named list}) containing selected values in each selector. This \code{mapping} +is sorted according to correct datasets merge order. \code{variables} contains names of the +variables in \code{ANL} +\item join_keys (\code{join_keys}) updated \code{join_keys} containing keys of \code{ANL} +} +} +\description{ +Analyse selectors and concludes a merge parameters +} +\keyword{internal} diff --git a/man/dot-picker_icon.Rd b/man/dot-picker_icon.Rd new file mode 100644 index 000000000..c99c3a813 --- /dev/null +++ b/man/dot-picker_icon.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{.picker_icon} +\alias{.picker_icon} +\title{\code{pickerInput} choices icons} +\usage{ +.picker_icon(x) +} +\arguments{ +\item{x}{(\code{any}) object which class will determine icon} +} +\value{ +html-tag in form of \code{character(1)} +} +\description{ +Icons describing a class of the choice +} +\keyword{internal} diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd new file mode 100644 index 000000000..0083e011f --- /dev/null +++ b/man/dot-resolve.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{.resolve} +\alias{.resolve} +\title{Resolve downstream after selected changes} +\usage{ +.resolve(selected, slot_name, picks_resolved, old_picks, data) +} +\arguments{ +\item{selected}{(\code{vector}) rather \code{character}, or \code{factor}. \code{numeric(2)} for \code{values()} based on numeric column.} + +\item{slot_name}{(\code{character(1)}) one of \code{c("datasets", "variables", "values")}} + +\item{picks_resolved}{(\code{reactiveVal})} + +\item{old_picks}{(\code{picks})} + +\item{data}{(\code{any} asserted further in \code{resolver})} +} +\description{ +@description +When i-th select input changes then +\itemize{ +\item picks_resolved containing current state is being unresolved but only after the i-th element as +values are sequentially dependent. For example if variables (i=2) is selected we don't want +to unresolve (restart) dataset. +\item new value (selected) is replacing old value in current slot (i) +\item we call resolve which resolves only "unresolved" (delayed) values +\item new picks is replacing \code{reactiveValue} +Thanks to this design reactive values are triggered only once +} +} +\keyword{internal} diff --git a/man/dot-update_rv.Rd b/man/dot-update_rv.Rd new file mode 100644 index 000000000..7fba79dc3 --- /dev/null +++ b/man/dot-update_rv.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{.update_rv} +\alias{.update_rv} +\title{Update reactive values with log} +\usage{ +.update_rv(rv, value, log) +} +\arguments{ +\item{rv}{(\code{reactiveVal})} + +\item{value}{(\code{vector})} + +\item{log}{(\code{character(1)}) message to \code{log_debug}} +} +\description{ +Update reactive values only if values differ to avoid unnecessary reactive trigger +} +\keyword{internal} diff --git a/man/dot-validate_join_keys.Rd b/man/dot-validate_join_keys.Rd new file mode 100644 index 000000000..3ec70c69a --- /dev/null +++ b/man/dot-validate_join_keys.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{.validate_join_keys} +\alias{.validate_join_keys} +\title{Check if datasets can be merged in topological order} +\usage{ +.validate_join_keys(selectors, join_keys) +} +\arguments{ +\item{selectors}{(\verb{named list}) A named list of selector objects. Each element can be: +\itemize{ +\item A \code{picks} object defining dataset and variable selections +\item A \code{reactive} expression returning a \code{picks} object +The names of this list are used as identifiers for tracking which variables come from which selector. +}} + +\item{join_keys}{(\code{join_keys}) The join keys object} +} +\description{ +Determines the topological order from join_keys, then checks that each dataset +can be joined with at least one of the previously accumulated datasets. +} +\keyword{internal} diff --git a/man/merge_srv.Rd b/man/merge_srv.Rd new file mode 100644 index 000000000..d19318e8c --- /dev/null +++ b/man/merge_srv.Rd @@ -0,0 +1,238 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{merge_srv} +\alias{merge_srv} +\title{Merge Server Function for Dataset Integration} +\usage{ +merge_srv( + id, + data, + selectors, + output_name = "anl", + join_fun = "dplyr::inner_join" +) +} +\arguments{ +\item{id}{(\code{character(1)}) Module ID for the Shiny module namespace} + +\item{data}{(\code{reactive}) A reactive expression returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing +the source datasets to be merged. This object must have join keys defined via +\code{\link[teal.data:join_keys]{teal.data::join_keys()}} to enable proper dataset relationships.} + +\item{selectors}{(\verb{named list}) A named list of selector objects. Each element can be: +\itemize{ +\item A \code{picks} object defining dataset and variable selections +\item A \code{reactive} expression returning a \code{picks} object +The names of this list are used as identifiers for tracking which variables come from which selector. +}} + +\item{output_name}{(\code{character(1)}) Name of the merged dataset that will be created in the +returned \code{teal_data} object. Default is \code{"anl"}. This name will be used in the generated R code.} + +\item{join_fun}{(\code{character(1)}) The joining function to use for merging datasets. Must be a +qualified function name (e.g., \code{"dplyr::left_join"}, \code{"dplyr::inner_join"}, \code{"dplyr::full_join"}). +Default is \code{"dplyr::inner_join"}. The function must accept \code{by} and \code{suffix} parameters.} +} +\value{ +A \code{list} with two reactive elements: +\itemize{ +\item \code{data}A \code{reactive} returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing the merged dataset. +The merged dataset is named according to \code{output_name} parameter. The \code{teal_data} object includes: +\itemize{ +\item The merged dataset with all selected variables +\item Complete R code to reproduce the merge operation +\item Updated join keys reflecting the merged dataset structure +} +\item \code{variables} A \code{reactive} returning a named list mapping selector names to their selected +variables in the merged dataset. The structure is: +\code{list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)}. +Variable names reflect any renaming that occurred during the merge to avoid conflicts. +} +} +\description{ +\code{merge_srv} is a powerful Shiny server function that orchestrates the merging of multiple datasets +based on user selections from \code{picks} objects. It creates a reactive merged dataset (\code{teal_data} object) +and tracks which variables from each selector are included in the final merged output. + +This function serves as the bridge between user interface selections (managed by selectors) and +the actual data merging logic. It automatically handles: +\itemize{ +\item Dataset joining based on join keys +\item Variable selection and renaming to avoid conflicts +\item Reactive updates when user selections change +\item Generation of reproducible R code for the merge operation +} +} +\section{How It Works}{ + + +The \code{merge_srv} function performs the following steps: +\enumerate{ +\item \strong{Receives Input Data}: Takes a reactive \code{teal_data} object containing source datasets with +defined join keys +\item \strong{Processes Selectors}: Evaluates each selector (whether static \code{picks} or reactive) to +determine which datasets and variables are selected +\item \strong{Determines Merge Order}: Uses topological sort based on the \code{join_keys} to determine +the optimal order for merging datasets. +\item \strong{Handles Variable Conflicts}: Automatically renames variables when: +\itemize{ +\item Multiple selectors choose variables with the same name from different datasets +\item Foreign key variables would conflict with existing variables +\item Renaming follows the pattern \verb{\{column-name\}_\{dataset-name\}} +} +\item \strong{Performs Merge}: Generates and executes merge code that: +\itemize{ +\item Selects only required variables from each dataset +\item Applies any filters defined in selectors +\item Joins datasets using specified join function and join keys +\item Maintains reproducibility through generated R code +} +\item \strong{Updates Join Keys}: Creates new join key relationships for the merged dataset (\code{"anl"}) +relative to remaining datasets in the \code{teal_data} object +\item \strong{Tracks Variables}: Keeps track of the variable names in the merged dataset +} +} + +\section{Usage Pattern}{ + + +\if{html}{\out{
}}\preformatted{# In your Shiny server function +merged <- merge_srv( + id = "merge", + data = reactive(my_teal_data), + selectors = list( + selector1 = picks(...), + selector2 = reactive(picks(...)) + ), + output_name = "anl", + join_fun = "dplyr::left_join" +) + +# Access merged data +merged_data <- merged$data() # teal_data object with merged dataset +anl <- merged_data[["anl"]] # The actual merged data.frame/tibble + +# Get variable mapping +vars <- merged$variables() +# Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) + +# Get reproducible code +code <- teal.code::get_code(merged_data) +}\if{html}{\out{
}} +} + +\section{Merge Logic Details}{ + + +\strong{Dataset Order}: Datasets are merged in topological order based on join keys. The first dataset +acts as the "left" side of the join, and subsequent datasets are joined one by one. + +\strong{Join Keys}: The function uses join keys from the source \code{teal_data} object to determine: +\itemize{ +\item Which datasets can be joined together +\item Which columns to use for joining (the \code{by} parameter) +\item Whether datasets need intermediate joins (not yet implemented) +} + +\strong{Variable Selection}: For each dataset being merged: +\itemize{ +\item Selects user-chosen variables from selectors +\item Includes foreign key variables needed for joining (even if not explicitly selected) +\item Removes duplicate foreign keys after join (they're already in the left dataset) +} + +\strong{Conflict Resolution}: When variable names conflict: +\itemize{ +\item Variables from later datasets get suffixed with \verb{_dataname} +\item Foreign keys that match are merged (not duplicated) +\item The mapping returned in \code{merge_vars} reflects the final names +} +} + +\section{Integration with Selectors}{ + + +\code{merge_srv} is designed to work with \code{\link[=picks_srv]{picks_srv()}} which creates selector objects: + +\if{html}{\out{
}}\preformatted{# Create selectors in server +selectors <- picks_srv( + picks = list( + adsl = picks(...), + adae = picks(...) + ), + data = data +) + +# Pass to merge_srv +merged <- merge_srv( + id = "merge", + data = data, + selectors = selectors +) +}\if{html}{\out{
}} +} + +\examples{ +# Complete example with CDISC data +library(teal.transform) +library(teal.data) +library(shiny) + +# Prepare data with join keys +data <- teal_data() +data <- within(data, { + ADSL <- teal.data::rADSL + ADAE <- teal.data::rADAE +}) +join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")] + +# Create Shiny app +ui <- fluidPage( + picks_ui("adsl", picks(datasets("ADSL"), variables())), + picks_ui("adae", picks(datasets("ADAE"), variables())), + verbatimTextOutput("code"), + verbatimTextOutput("vars") +) + +server <- function(input, output, session) { + # Create selectors + selectors <- list( + adsl = picks_srv("adsl", + data = reactive(data), + picks = picks(datasets("ADSL"), variables()) + ), + adae = picks_srv("adae", + data = reactive(data), + picks = picks(datasets("ADAE"), variables()) + ) + ) + + # Merge datasets + merged <- merge_srv( + id = "merge", + data = reactive(data), + selectors = selectors, + output_name = "anl", + join_fun = "dplyr::left_join" + ) + + # Display results + output$code <- renderPrint({ + cat(teal.code::get_code(merged$data())) + }) + + output$vars <- renderPrint({ + merged$variables() + }) +} +if (interactive()) { + shinyApp(ui, server) +} + +} +\seealso{ +\itemize{ +\item \code{\link[=picks_srv]{picks_srv()}} for creating selectors +\item \code{\link[teal.data:join_keys]{teal.data::join_keys()}} for defining dataset relationships +} +} diff --git a/man/picks.Rd b/man/picks.Rd new file mode 100644 index 000000000..c7751d18c --- /dev/null +++ b/man/picks.Rd @@ -0,0 +1,278 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-picks.R +\name{picks} +\alias{picks} +\alias{datasets} +\alias{variables} +\alias{values} +\title{Choices/selected settings} +\usage{ +picks(...) + +datasets(choices = tidyselect::everything(), selected = 1L, fixed = NULL, ...) + +variables( + choices = tidyselect::everything(), + selected = 1L, + multiple = NULL, + fixed = NULL, + ordered = FALSE, + ... +) + +values( + choices = function(x) !is.na(x), + selected = function(x) !is.na(x), + multiple = TRUE, + fixed = NULL, + ... +) +} +\arguments{ +\item{...}{additional arguments delivered to \code{pickerInput}} + +\item{choices}{(\code{tidyselect::language} or \code{character}) +Available values to choose.} + +\item{selected}{(\code{tidyselect::language} or \code{character}) +Choices to be selected.} + +\item{fixed}{(\code{logical(1)}) selection will be fixed and not possible to change interactively.} + +\item{multiple}{(\code{logical(1)}) if more than one selection is possible.} + +\item{ordered}{(\code{logical(1)}) if the selected should follow the selection order. If \code{FALSE} +\code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} +} +\description{ +Define choices and default selection for variables. \code{picks} allows app-developer to specify +\code{datasets}, \code{variables} and \code{values} to be selected by app-user during Shiny session. +Functions are based on the idea of \code{choices/selected} where app-developer provides \code{choices} +and what is \code{selected} by default. App-user changes \code{selected} interactively (see \code{\link{picks_module}}). +} +\section{\code{tidyselect} support}{ +Both \code{choices} and \code{selected} parameters support \code{tidyselect} syntax, enabling dynamic +and flexible variable selection patterns. This allows choices to be determined at runtime +based on data characteristics rather than hard-coded values. +\subsection{Using \code{tidyselect} for \code{choices} and \code{selected}}{ + +When \code{choices} uses \code{tidyselect}, the available options are determined dynamically based on actually +selected data: +\itemize{ +\item \code{tidyselect::everything()} - All variables/datasets +\item \code{tidyselect::starts_with("prefix")} - Variables starting with a prefix +\item \code{tidyselect::ends_with("suffix")} - Variables ending with a suffix +\item \code{tidyselect::contains("pattern")} - Variables containing a pattern +\item \code{tidyselect::matches("regex")} - Variables matching a regular expression +\item \code{tidyselect::where(predicate)} - Variables/datasets satisfying a predicate function +\item \code{tidyselect::all_of(vars)} - All specified variables (error if missing) +\item \code{tidyselect::any_of(vars)} - Any specified variables (silent if missing) +\item Range selectors like \code{Sepal.Length:Petal.Width} - Variables between two positions +\item Integer indices (e.g., \code{1L}, \code{1L:3L}, \code{c(1L, 3L, 5L)}) - Select by position. Be careful, must be integer! +} + +The \code{selected} parameter can use the same syntax but it will be applied to the subset defined in choices. This +means that \verb{choices = is.numeric, selected = is.factor} or \verb{choices = c("a", "b", "c"), selected = c("d", "e")} +will imply en empty \code{selected}. + +\strong{Warning:} Using explicit character values for \code{selected} with dynamic \code{choices} may +cause issues if the selected values are not present in the dynamically determined choices. +Prefer using numeric indices (e.g., \code{1} for first variable) when \code{choices} is dynamic. +} +} + +\section{Structure and element dependencies}{ +The \code{picks()} function creates a hierarchical structure where elements depend on their +predecessors, enabling cascading reactive updates during Shiny sessions. +\subsection{Element hierarchy}{ + +A \code{picks} object must follow this order: +\enumerate{ +\item \strong{\code{datasets()}} - to select a dataset. Always the first element (required). +\item \strong{\code{variables()}} - To select columns from the chosen dataset. +\item \strong{\code{values()}} - To select specific values from the chosen variable(s). +} + +Each element's choices are evaluated within the context of its predecessor's selection. +} + +\subsection{How dependencies work}{ +\itemize{ +\item \strong{Fixed dataset}: When \code{datasets(choices = "iris")} specifies one dataset, the +\code{variables()} choices are evaluated against that dataset columns. +\item \strong{Multiple dataset choices}: When \code{datasets(choices = c("iris", "mtcars"))} allows multiple +options, \code{variables()} choices are re-evaluated each time the user selects a different +dataset. This creates a reactive dependency where variable choices update automatically. +\item \strong{Dynamic dataset choices}: When using \code{datasets(choices = tidyselect::where(is.data.frame))}, +all available data frames are discovered at runtime, and variable choices adapt to +whichever dataset the user selects. +\item \strong{Variable to values}: Similarly, \code{values()} choices are evaluated based on the +selected variable(s), allowing users to filter specific levels or values. When multiple +variables are selected, then values will be a concatenation of the columns. +} +} + +\subsection{Best practices}{ +\itemize{ +\item Always start with \code{datasets()} - this is enforced by validation +\item Use dynamic \code{choices} in \code{variables()} when working with multiple datasets to ensure +compatibility across different data structures +\item Prefer \code{tidyselect::everything()} or \code{tidyselect::where()} predicates for flexible +variable selection that works across datasets with different schemas +\item Use numeric indices for \code{selected} when \code{choices} are dynamic to avoid referencing +variables that may not exist in all datasets +} +} + +\subsection{Important: \code{values()} requires type-aware configuration}{ +\subsection{Why \code{values()} is different from \code{datasets()} and \code{variables()}}{ + +\code{datasets()} and \code{variables()} operate on named lists of objects, meaning they work with character-based +identifiers. This allows you to use text-based selectors like \code{starts_with("S")} or \code{contains("prefix")} +consistently for both datasets and variable names. + +\code{values()} is fundamentally different because it operates on the \strong{actual data content} within a +selected variable (column). The type of data in the column determines what kind of filtering makes sense: +\itemize{ +\item \strong{\code{numeric} columns} (e.g., \code{age}, \code{height}, \code{price}) contain numbers +\item \strong{\code{character}/\code{factor} columns} (e.g., \code{country}, \code{category}, \code{status}) contain categorical values +\item \strong{\code{Date}/\code{POSIXct} columns} contain temporal data +\item \strong{\code{logical} columns} contain TRUE/FALSE values +} +} + +\subsection{Type-specific UI controls}{ + +The \code{values()} function automatically renders different UI controls based on data type: +\itemize{ +\item \strong{\code{numeric} data}: Creates a \code{sliderInput} for range selection +\itemize{ +\item \code{choices} must be a numeric vector of length 2: \code{c(min, max)} +\item \code{selected} must be a numeric vector of length 2: \code{c(selected_min, selected_max)} +} +\item \strong{Categorical data} (\code{character}/\code{factor}): Creates a \code{pickerInput} for discrete selection +\itemize{ +\item \code{choices} can be a character vector or predicate function +\item \code{selected} can be specific values or a predicate function +} +\item \strong{\code{Date}/\code{POSIXct} data}: Creates date/datetime range selectors +\itemize{ +\item \code{choices} must be a Date or \code{POSIXct} vector of length 2 +} +\item \strong{\code{logical} data}: Creates a checkbox or picker for TRUE/FALSE selection +} +} + +\subsection{Developer responsibility}{ + +\strong{App developers must ensure \code{values()} configuration matches the variable type:} +\enumerate{ +\item \strong{Know your data}: Understand what type of variable(s) users might select +\item \strong{Configure appropriately}: Set \code{choices} and \code{selected} to match expected data types +\item \strong{Use predicates for flexibility}: When variable type is dynamic, use predicate functions +like \code{function(x) !is.na(x)} (the default) to handle multiple types safely +} +} + +\subsection{Examples of correct usage}{ + +\if{html}{\out{
}}\preformatted{# For a numeric variable (e.g., age) +picks( + datasets(choices = "demographic"), + variables(choices = "age", multiple = FALSE), + values(choices = c(0, 100), selected = c(18, 65)) +) + +# For a categorical variable (e.g., country) +picks( + datasets(choices = "demographic"), + variables(choices = "country", multiple = FALSE), + values(choices = c("USA", "Canada", "Mexico"), selected = "USA") +) + +# Safe approach when variable type is unknown - use predicates +picks( + datasets(choices = "demographic"), + variables(choices = tidyselect::everything(), selected = 1L), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) +) +}\if{html}{\out{
}} +} + +\subsection{Common mistakes to avoid}{ + +\if{html}{\out{
}}\preformatted{# WRONG: Using string selectors for numeric data +values(choices = starts_with("5")) # Doesn't make sense for numeric data! + +# WRONG: Providing categorical choices for a numeric variable +values(choices = c("low", "medium", "high")) # Won't work if variable is numeric! + +# WRONG: Providing numeric range for categorical variable +values(choices = c(0, 100)) # Won't work if variable is factor/character! +}\if{html}{\out{
}} +} + +} + +\subsection{Example: Three-level hierarchy}{ + +\if{html}{\out{
}}\preformatted{picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::where(is.numeric), selected = 1L), + values(choices = tidyselect::everything(), selected = seq_len(10)) +) +}\if{html}{\out{
}} + +In this example: +\itemize{ +\item User first selects a dataset (\code{iris} or \code{mtcars}) +\item Variable choices update to show only numeric columns from selected dataset +\item After selecting a variable, value choices show all unique values from that column +} +} +} + +\examples{ +# Select columns from iris dataset using range selector +picks( + datasets(choices = "iris"), + variables(choices = Sepal.Length:Petal.Width, selected = 1L) +) + +# Single variable selection from iris dataset +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) +) + +# Dynamic selection: any variable from iris, first selected by default +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +) + +# Multiple dataset choices: variable choices will update when dataset changes +picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +) + +# Select from any dataset, filter by numeric variables +picks( + datasets(choices = c("iris", "mtcars"), selected = 1L), + variables(choices = tidyselect::where(is.numeric), selected = 1L) +) + +# Fully dynamic: auto-discover datasets and variables +picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) +) + +# Select categorical variables with length constraints +picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = is_categorical(min.len = 2, max.len = 15), selected = seq_len(2)) +) + +} diff --git a/man/picks_module.Rd b/man/picks_module.Rd new file mode 100644 index 000000000..68b3c2ace --- /dev/null +++ b/man/picks_module.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{picks_module} +\alias{picks_module} +\alias{picks_ui} +\alias{picks_ui.list} +\alias{picks_ui.picks} +\alias{picks_srv} +\alias{picks_srv.list} +\alias{picks_srv.picks} +\title{Interactive picks} +\usage{ +picks_ui(id, picks, container = "badge_dropdown") + +\method{picks_ui}{list}(id, picks, container) + +\method{picks_ui}{picks}(id, picks, container) + +picks_srv(id = "", picks, data) + +\method{picks_srv}{list}(id, picks, data) + +\method{picks_srv}{picks}(id, picks, data) +} +\arguments{ +\item{id}{(\code{character(1)}) Shiny module ID} + +\item{picks}{(\code{picks} or \code{list}) object created by \code{picks()} or a named list of such objects} + +\item{container}{(\code{character(1)} or \code{function}) UI container type. Can be one of \code{htmltools::tags} +functions. By default, elements are wrapped in a package-specific drop-down.} + +\item{data}{(\code{reactive}) Reactive expression returning the data object to be used for populating choices} +} +\value{ +\itemize{ +\item \code{picks_ui()}: UI elements for the input controls +\item \code{picks_srv()}: Server-side reactive logic returning the processed data +} +} +\description{ +Creates UI and server components for interactive \code{\link[=picks]{picks()}} in Shiny modules. The module is based on +configuration provided via \code{\link[=picks]{picks()}} and its responsibility is to determine relevant input +values + +The module supports both single and combined \code{picks}: +\itemize{ +\item Single \code{picks} objects for a single input +\item Named lists of \code{picks} objects for multiple inputs +} +} +\details{ +The module uses S3 method dispatch to handle different ways to provide \code{picks}: +\itemize{ +\item \code{.picks} methods handle single `picks`` object +\item \code{.list} methods handle multiple \code{picks} objects +} + +The UI component (\code{picks_ui}) creates the visual elements, while the +server component (\code{picks_srv}) manages the reactive logic, +} +\seealso{ +\code{\link[=picks]{picks()}} for creating `picks`` objects +} diff --git a/man/resolver.Rd b/man/resolver.Rd new file mode 100644 index 000000000..564b53c20 --- /dev/null +++ b/man/resolver.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-resolver.R +\name{resolver} +\alias{resolver} +\title{Resolve \code{picks}} +\usage{ +resolver(x, data) +} +\arguments{ +\item{x}{(\code{\link[=picks]{picks()}}) settings for picks.} + +\item{data}{(\code{\link[teal.data:teal_data]{teal.data::teal_data()}} \code{environment} or \code{list}) any data collection supporting object extraction with \code{[[}. +Used to determine values of unresolved \code{picks}.} +} +\value{ +resolved \code{picks}. +} +\description{ +Resolve iterates through each \code{picks} element and determines values . +} +\examples{ +x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a")) +data <- list( + df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]), + df2 = data.frame(a = LETTERS[1:5], b = 1:5), + m = matrix() +) +resolver(x = x, data = data) +} diff --git a/man/restoreValue.Rd b/man/restoreValue.Rd new file mode 100644 index 000000000..2b0ca13a1 --- /dev/null +++ b/man/restoreValue.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{restoreValue} +\alias{restoreValue} +\title{Restore value from bookmark.} +\usage{ +restoreValue(value, default) +} +\arguments{ +\item{value}{(\code{character(1)}) name of value to restore} + +\item{default}{fallback value} +} +\value{ +In an application restored from a server-side bookmark, +the variable specified by \code{value} from the \code{values} environment. +Otherwise \code{default}. +} +\description{ +Get value from bookmark or return default. +} +\details{ +Bookmarks can store not only inputs but also arbitrary values. +These values are stored by \code{onBookmark} callbacks and restored by \code{onBookmarked} callbacks, +and they are placed in the \code{values} environment in the \code{session$restoreContext} field. +Using \code{teal_data_module} makes it impossible to run the callbacks +because the app becomes ready before modules execute and callbacks are registered. +In those cases the stored values can still be recovered from the \code{session} object directly. + +Note that variable names in the \code{values} environment are prefixed with module name space names, +therefore, when using this function in modules, \code{value} must be run through the name space function. +} +\keyword{internal} diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd new file mode 100644 index 000000000..58cdb0cdd --- /dev/null +++ b/man/tidyselectors.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-tidyselect-helpers.R +\name{tidyselectors} +\alias{tidyselectors} +\alias{is_categorical} +\title{\code{tidyselect} helpers} +\usage{ +is_categorical(min.len, max.len) +} +\arguments{ +\item{min.len}{(\code{integer(1)}) minimal number of unique values} + +\item{max.len}{(\code{integer(1)}) maximal number of unique values} +} +\description{ +#' \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Predicate functions simplifying \code{picks} specification. +} +\examples{ +# select factor column but exclude foreign keys +variables(choices = is_categorical(min.len = 2, max.len = 10)) + +} diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd new file mode 100644 index 000000000..1d735486f --- /dev/null +++ b/man/tm_merge.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-tm_merge.R +\name{tm_merge} +\alias{tm_merge} +\title{Merge module} +\usage{ +tm_merge(label = "merge-module", picks, transformators = list()) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{picks}{(\code{list} of \code{picks})} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} +} +\description{ +Example \code{\link[teal:teal_modules]{teal::module}} containing interactive inputs and displaying results of merge. +} +\examples{ +library(teal) + +data <- within(teal.data::teal_data(), { + iris <- iris + mtcars <- mtcars +}) + +app <- init( + data = data, + modules = modules( + modules( + label = "Testing modules", + tm_merge( + label = "non adam", + picks = list( + a = picks( + datasets("iris", "iris"), + variables( + choices = c("Sepal.Length", "Species"), + selected = + ), + values() + ) + ) + ) + ) + ) +) +if (interactive()) { + shinyApp(app$ui, app$server, enableBookmarking = "server") +} + +} diff --git a/tests/testthat/test-0-as_picks.R b/tests/testthat/test-0-as_picks.R new file mode 100644 index 000000000..de4fc4784 --- /dev/null +++ b/tests/testthat/test-0-as_picks.R @@ -0,0 +1,51 @@ +testthat::describe("as.picks turns select_spec to variables", { + testthat::it("eager select_spec is convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = "a", multiple = TRUE, ordered = TRUE)), + variables(choices = c(a = "a", b = "b", c = "c"), selected = "a", multiple = TRUE, ordered = TRUE) + ) + }) + + testthat::it("select_spec with selected=NULL is convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = NULL)), + variables(choices = c(a = "a", b = "b", c = "c"), selected = NULL) + ) + }) + + testthat::it("select_spec with multiple selected convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = c("a", "b"))), + variables(choices = c(a = "a", b = "b", c = "c"), selected = c("a", "b")) + ) + }) + + testthat::it("delayed select_spec is convertible to variables", { + choices <- variable_choices("anything", function(data) names(Filter(is.factor, data))) + selected <- first_choice() + test <- as.picks(select_spec(choices = choices, selected = selected)) + + expected_choices <- choices$subset + expected_selected <- selected(choices)$subset + class(expected_choices) <- "des-delayed" + class(expected_selected) <- "des-delayed" + testthat::expect_equal( + test, + variables(choices = expected_choices, expected_selected) + ) + }) +}) + + +testthat::describe("as.picks doesn't convert filter_spec to picks", { + testthat::it("throws warning with teal_tranform_filter instruction for eager filter_spec", { + testthat::expect_warning( + as.picks( + data_extract_spec( + dataname = "iris", + filter = filter_spec(vars = "Species", choices = levels(iris$Species), selected = levels(iris$Species)), + ) + ) + ) + }) +}) diff --git a/tests/testthat/test-0-module_merge.R b/tests/testthat/test-0-module_merge.R new file mode 100644 index 000000000..0a94c19f9 --- /dev/null +++ b/tests/testthat/test-0-module_merge.R @@ -0,0 +1,987 @@ +testthat::describe("merge_srv accepts selectors argument", { + it("accepts named list of shiny::reactive picks", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + adae <- data.frame(studyid = "A", usubjid = c("1", "2"), AVAL = c(1.5, 2.5)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")), + teal.data::join_key("adae", "adae", c("studyid", "usubjid", "paramcd", "avisit")), + teal.data::join_key("adsl", "adae", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))), + b = shiny::reactive(picks(datasets("adae", "adae"), variables("AVAL", "AVAL"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("doesn't accept non-reactive list elements", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = picks( + datasets(choices = "adsl", selected = "adsl"), + variables(choices = "age", selected = "age") + ) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ), + "reactive" + ) + ) + }) + + it("doesn't accept unnamed list of selectors", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("accepts empty list of selectors", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list() + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) +}) + +testthat::describe("merge_srv accepts data argument", { + it("accepts shiny::reactive teal_data", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("doesn't accept non-reactive teal_data", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + adsl = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = data, + selectors = selectors + ) + ) + ) + }) +}) + +testthat::describe("merge_srv returns list with data (teal_data with anl) and variables (selected anl variables)", { + it("returns list with two reactives: variables and data", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list(a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age")))) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + testthat::expect_named(out, c("data", "variables")) + checkmate::expect_class(out$variables, "reactive") + checkmate::expect_class(out$data, "reactive") + }) + + it("$data returns reactive containing teal_data with object `output_name`", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list(a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age")))) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "abcd") + ) + checkmate::expect_class(out$data(), "teal_data") + testthat::expect_named(out$data(), c("abcd", "adsl")) + }) + + it("$data() returns teal_data with merged anl using join_fun", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("customers", "customers"), variables("name", "name"))), + b = shiny::reactive(picks(datasets("orders", "orders"), variables("date", "date"))) + ) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, join_fun = "dplyr::left_join") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name) %>% + dplyr::left_join(y = dplyr::select(orders, customer_id, date), by = c(id = "customer_id")) + }) + ) + }) + + it("$variables returns reactive list named after selectors", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))), + b = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "abcd") + ) + checkmate::expect_list(out$variables()) + testthat::expect_named(out$variables(), c("a", "b")) + }) + + it("anl contains selected colnames with original names if variables are selected from a single dataset", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = "Species") + )), + b = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = c("Sepal.Length", "Sepal.Width")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, anl <- dplyr::select(iris, Species, Sepal.Length, Sepal.Width)) + ) + testthat::expect_identical(out$variables(), list(a = "Species", b = c("Sepal.Length", "Sepal.Width"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains selected colnames with original names if selected from a multiple datasets and not duplicated", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, age) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, date, total_amount), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) + }) + ) + testthat::expect_identical(out$variables(), list(a = c("name", "age"), b = c("date", "total_amount"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains selected colnames with suffixes names if duplicated across datasets", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "status")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, status) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, date, status), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) + }) + ) + testthat::expect_identical(out$variables(), list(a = c("name", "status"), b = c("date", "status_orders"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains colnames with original names when duplicated for the same dataset", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("id", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("id", "status")) + )), + c = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "id")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, status, name) + }) + ) + testthat::expect_identical( + out$variables(), + list(a = c("id", "status"), b = c("id", "status"), c = c("name", "id")) + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl can merge deep join tree by pair keys and finds correct merge order", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("shipments", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), + teal.data::join_key("order_items", "shipments", keys = c(id = "item_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "shipments", selected = "shipments"), + variables(choices = colnames(data$shipments), selected = c("tracking_number", "carrier")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = c("product", "quantity")) + )), + d = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, age) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, id, date, total_amount), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) %>% + dplyr::inner_join( + y = dplyr::select(order_items, order_id, id, product, quantity), + by = c(id_orders = "order_id"), + suffix = c("", "_order_items") + ) %>% + dplyr::inner_join( + y = dplyr::select(shipments, item_id, tracking_number, carrier), + by = c(id_order_items = "item_id"), + suffix = c("", "_shipments") + ) + }) + ) + testthat::expect_identical( + out$variables(), + list( + b = c("name", "age"), + d = c("date", "total_amount"), + c = c("product", "quantity"), + a = c("tracking_number", "carrier") + ) + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("selected join_keys across multiple datasets refers to the same column in anl c( O.O )ɔ", { + # ie. when `*_join(a, b, by = c(id = "id_parent"))` the second column won't be included as it is + # referring to the same column + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = "id") + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("id", "customer_id")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = "order_id", ) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, id), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) %>% + dplyr::inner_join( + y = dplyr::select(order_items, order_id), + by = c(id_orders = "order_id"), + suffix = c("", "_order_items") + ) + }) + ) + testthat::expect_identical( + out$variables(), + list(a = "id", b = c("id_orders", "id"), c = "id_orders") # + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("join_keys are updated to contains anl <-> anl-components", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("shipments", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), + teal.data::join_key("order_items", "shipments", keys = c(id = "item_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "shipments", selected = "shipments"), + variables(choices = colnames(data$shipments), selected = c("tracking_number", "carrier")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = c("product", "quantity")) + )), + d = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_identical( + teal.data::join_keys(out$data())$anl, + list( + shipments = c(id_order_items = "item_id"), + order_items = c(id_orders = "order_id"), + orders = c(id = "customer_id") + ) + ) + }) + + it("anl is filtered by factor variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + factor_var = factor(c("A", "B", "C", "A", "B"), levels = c("A", "B", "C")), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "factor_var"), + values(choices = c("A", "B", "C"), selected = c("A", "B")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, factor_var) %>% + dplyr::filter(factor_var %in% c("A", "B")) + }) + ) + }) + + it("anl is filtered by numeric variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + numeric_var = c(1.5, 2.5, 3.5, 4.5, 5.5), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "numeric_var"), + values(choices = range(data$test_data$numeric_var), selected = c(2.0, 4.0)) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, numeric_var) %>% + dplyr::filter(numeric_var >= 2.0 & numeric_var <= 4.0) + }) + ) + }) + + it("anl is filtered by date variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + date_var = as.Date(c("2024-01-01", "2024-02-01", "2024-03-01", "2024-04-01", "2024-05-01")), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "date_var"), + values(choices = range(data$test_data$date_var), selected = as.Date(c("2024-01-15", "2024-03-15"))) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, date_var) %>% + dplyr::filter(date_var >= as.Date("2024-01-15") & date_var <= as.Date("2024-03-15")) + }) + ) + }) + + it("anl is filtered by POSIXct variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + posixct_var = as.POSIXct(c( + "2024-01-01 10:00:00", "2024-02-01 11:00:00", "2024-03-01 12:00:00", + "2024-04-01 13:00:00", "2024-05-01 14:00:00" + )), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "posixct_var"), + values( + choices = range(data$test_data$posixct_var), + selected = as.POSIXct(c("2024-01-15 00:00:00", "2024-04-15 00:00:00")) + ) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, posixct_var) %>% + dplyr::filter( + posixct_var >= as.POSIXct("2024-01-15 00:00:00") & + posixct_var <= as.POSIXct("2024-04-15 00:00:00") + ) + }) + ) + }) + + it("anl is filtered by logical variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + logical_var = c(TRUE, FALSE, TRUE, FALSE, TRUE), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "logical_var"), + values(choices = c(TRUE, FALSE), selected = TRUE) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, logical_var) %>% + dplyr::filter(logical_var) + }) + ) + }) + + it("fails when selected from multiple datasets and no join-keys/primary-keys", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + mtcars <- mtcars + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = colnames(mtcars), selected = "mpg") + )), + b = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = c("Sepal.Length", "Sepal.Width")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "no join keys defined", class = "validation") + testthat::expect_error(out$data(), regexp = "no join keys defined", class = "validation") + }) + + it("fails when selected from multiple datasets and no join-keys between selected datasets", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")) + ) + + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "status")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "No join keys found between", class = "validation") + testthat::expect_error(out$data(), regexp = "No join keys found between", class = "validation") + }) + + it("fails when unresolved picks are passed to the module", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + }) + + selectors <- list( + a = shiny::reactive(picks(datasets(choices = "iris", selected = "iris"), variables(selected = 1L))), + b = shiny::reactive(picks(datasets(choices = "iris", selected = "iris"), variables(selected = 1L))) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "have not been resolved correctly", class = "validation") + testthat::expect_error(out$data(), regexp = "have not been resolved correctly", class = "validation") + }) +}) diff --git a/tests/testthat/test-0-module_picks.R b/tests/testthat/test-0-module_picks.R new file mode 100644 index 000000000..3276971df --- /dev/null +++ b/tests/testthat/test-0-module_picks.R @@ -0,0 +1,1064 @@ +testthat::describe("picks_srv accepts picks", { + it("as single picks object", { + test_data <- list(iris = iris, mtcars = mtcars) + test_picks <- picks(datasets(choices = c("iris", "mtcars"), selected = "iris")) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("as list of picks objects", { + test_data <- list(iris = iris, mtcars = mtcars) + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) + + it("accepts empty list", { + test_data <- list(iris = iris) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = list(), data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept list of non-picks", { + test_data <- list(iris = iris) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = list(a = 1, b = 2), data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept NULL picks", { + test_data <- list(iris = iris) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = NULL, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept unnamed list of picks", { + test_picks_list <- list( + picks(datasets(choices = "iris")), + picks(datasets(choices = "iris")) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept list of picks with duplicated names", { + test_picks_list <- list( + a = picks(datasets(choices = "iris")), + a = picks(datasets(choices = "iris")) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) +}) + +testthat::describe("picks_srv accepts data", { + it("as reactive (named) list", { + test_data <- list(iris = iris) + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("as reactive environment", { + test_data <- list2env(list(iris = iris)) + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept non-reactive list/environment/teal_data", { + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = iris), + "reactive" + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = list(iris = iris)), + "reactive" + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = teal.data::teal_data(iris = iris)), + "reactive" + ) + } + ) + }) + + it("doesn't accept reactive non-named-list or non-environment", { + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(iris)) + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(letters)) + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(list(iris))) + ) + } + ) + }) +}) + +testthat::describe("picks_srv return a named list of reactive picks", { + testthat::it("each list element is reactiveVal", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = checkmate::expect_list( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + types = "reactiveVal", + names = "unique" + ) + ) + }) + + testthat::it("list is named as pick argument", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_named( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + c("pick1", "pick2") + ) + ) + }) + + testthat::it("each list element is reactiveVal containing picks", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + out <- picks_srv( + id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars)) + ) + checkmate::expect_list(out, "reactiveVal") + lapply(out, function(x) checkmate::assert_class(shiny::isolate(x()), "picks")) + } + ) + }) +}) + +testthat::describe("picks_srv resolves datasets", { + it("provided non-delayed datasets are adjusted to possible datanames", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars", notexisting = "notexisting"), selected = "mtcars") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$datasets$choices <- c(mtcars = "mtcars") + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("datasets() are resolved on init", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = tidyselect::last_col()) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars, a = "a"))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars", a = "a"), selected = "a") + ) + ) + } + ) + }) + + it("datasets() are resolved on init", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks(datasets(choices = is.data.frame, selected = 1L)) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars, a = "a"))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars"), selected = "iris") + ) + ) + } + ) + }) +}) + +testthat::describe("picks_srv resolves variables", { + it("variables() are adjusted to possible column names", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg", cyl = "cyl", inexisting = "inexisting"), selected = c("mpg", "inexisting")) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$variables$choices <- c(mpg = "mpg", cyl = "cyl") + test_picks$variables$selected <- "mpg" + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("variables() are resolved on init", { + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg") + ) + ) + } + ) + }) + + it("variables() are resolved on init", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = function(x) mean(x) > 20, selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg", disp = "disp", hp = "hp"), selected = "mpg") + ) + ) + } + ) + }) + + it("variables() are nullified with warning when selected dataset has no columns", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks( + datasets(choices = c(test = "test"), selected = "test"), + variables(choices = "doesn't matter", selected = "doesn't matter") + ) + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(test = data.frame()))), + expr = { + test_picks$variables$choices <- NULL + test_picks$variables$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "Selected dataset has no columns" + ) + }) +}) + +testthat::describe("picks_srv resolves values", { + it("values() are resolved on init", { + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = "mpg", selected = "mpg"), + values(choices = function(x) x > 20) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg"), selected = "mpg"), + values( + choices = range(mtcars$mpg[mtcars$mpg > 20]), + selected = range(mtcars$mpg[mtcars$mpg > 20]) + ) + ) + ) + } + ) + }) + + it("values() are adjusted to possible levels", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Species = "Species"), selected = "Species"), + values( + choices = c(setosa = "setosa", versicolor = "versicolor", inexisting = "inexisting"), + selected = c("setosa", "versicolor", "inexisting") + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- c(setosa = "setosa", versicolor = "versicolor") + test_picks$values$selected <- c("setosa", "versicolor") + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are adjusted to possible range", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values( + choices = c(min(iris$Sepal.Length) - 1, max(iris$Sepal.Length) + 1), + selected = c(min(iris$Sepal.Length) - 1, max(iris$Sepal.Length) + 1) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are preserved when related data lacks finite values", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(choices = c(1, 10), selected = c(1, 10)) + ) + iris$Sepal.Length <- NA_real_ + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are emptied (with warning) when data returns infinite", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) !is.finite(x)) + ) + iris$Sepal.Length[1] <- Inf + + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "Emptying choices..." + ) + }) + + it("values() are set to delayed range when data-range returns infinite", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) is.finite(x)) + ) + iris$Sepal.Length[1] <- Inf + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length[-1]) + test_picks$values$selected <- range(iris$Sepal.Length[-1]) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are set to data-range when predicate doesn't match anything", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) FALSE) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are set to data-range when column is numeric", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(c("5.1", "4.9")) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are emptied with warning when column is not numeric", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Species = "Species"), selected = "Species"), + values(choices = c(1, 10), selected = c(1, 10)) + ) + + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + ) + }) + + it("values() on multiple columns are resolved to be concatenated choices", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(vs = "mpg", cyl = "cyl"), selected = c("mpg", "cyl")), + values() + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$values$choices <- unique(paste(mtcars$mpg, mtcars$cyl, sep = ", ")) + test_picks$values$selected <- unique(paste(mtcars$mpg, mtcars$cyl, sep = ", ")) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) +}) + +testthat::describe("picks_srv resolves picks", { + it("non-delayed-picks are returned unchanged", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("named non-delayed-picks preserve names", { + test_picks <- picks( + datasets(choices = c(dataset = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), letters[1:5]), selected = "Species") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("non-delayed-picks with values are returned unchanged if within a possible choices", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg"), + values(choices = c(10.4, 33.9), selected = c(10.4, 33.9)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("pick elements are resolved sequentially", { + test_picks <- picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L), + values(choices = function(x) x > 5) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = "Sepal.Length"), + values( + choices = range(iris$Sepal.Length[iris$Sepal.Length > 5]), + selected = range(iris$Sepal.Length[iris$Sepal.Length > 5]) + ) + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) + + it("pick elements are nullified if $selected=NULL", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = NULL), + values(choices = function(x) x > 5) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + test_picks$variables$selected <- NULL + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("picks with multiple=FALSE defaults to single value even if multiple values provided", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = colnames(iris), multiple = FALSE) + ) + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$variables$selected <- test_picks$variables$selected[1] + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "`multiple` has been set to `FALSE`" + ) + }) + + it("picks converted from des with variable_choices are resolved", { + test_picks <- as.picks( + data_extract_spec( + dataname = "iris", + select_spec(choices = variable_choices("iris"), selected = first_choice()) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = "Sepal.Length") + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) + + it("picks converted from variable_choices(fun) are resolved", { + test_picks <- as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris", function(data) { + names(Filter(is.numeric, data)) + }), + selected = first_choice() + ) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris)[-5], colnames(iris)[-5]), selected = "Sepal.Length") + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) +}) + + +testthat::describe("picks_srv resolves picks interactively", { + it("change of dataset-input resolves variables", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars", iris = "iris"), selected = "mtcars"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + session$setInputs(`datasets-selected` = "iris") + session$setInputs(`datasets-selected_open` = FALSE) # close dropdown to trigger + test_picks$datasets$selected <- "iris" + test_picks$variables$choices <- setNames(colnames(iris), colnames(iris)) + test_picks$variables$selected <- "Sepal.Length" + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("current datasets-choices/selected are produced in picker inputs", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_value <- rvest::html_attr(rvest::html_nodes(html, "option"), "value") + selected_value <- rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value") + testthat::expect_identical(choices_value, c("mtcars", "iris")) + testthat::expect_identical(selected_value, "iris") + } + ) + }) + + it("custom choices label set in picks is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c(`mtcars dataset` = "mtcars", `iris dataset` = "iris"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars dataset", "iris dataset")) + } + ) + }) + + it("custom choices label set in data is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris") + ) + attr(mtcars, "label") <- "mtcars dataset" + attr(iris, "label") <- "iris dataset" + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars dataset", "iris dataset")) + } + ) + }) + + it("custom choices label set in picks has priority over data label is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c(`mtcars picks` = "mtcars", `iris picks` = "iris"), selected = "iris") + ) + attr(mtcars, "label") <- "mtcars label" + attr(iris, "label") <- "iris label" + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars picks", "iris picks")) + } + ) + }) + + it("picker input choices produces class-specific-icons for variable", { + test_dataset <- data.frame( + col_numeric = c(1.5, 2.5, 3.5), + col_integer = 1L:3L, + col_logical = c(TRUE, FALSE, TRUE), + col_character = c("a", "b", "c"), + col_factor = factor(c("x", "y", "z")), + col_date = as.Date(c("2024-01-01", "2024-01-02", "2024-01-03")), + col_datetime = as.POSIXct(c("2024-01-01 12:00:00", "2024-01-02 12:00:00", "2024-01-03 12:00:00")) + ) + + test_picks <- picks( + datasets(choices = "test", selected = "test"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(test = test_dataset))), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + icons <- gsub( + "^.+fa-((\\w|-)+).+$", "\\1", + rvest::html_attr(rvest::html_nodes(html, "option"), "data-content") + ) + + testthat::expect_identical( + icons, c("arrow-up-1-9", "arrow-up-1-9", "pause", "font", "chart-bar", "calendar", "calendar") + ) + } + ) + }) + + it("picker input choices produces class-specific-icons for datasets", { + skip("todo") + }) + + it("switching dataset-input changes variables-input", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), "Sepal.Length" + ) + session$setInputs(`datasets-selected` = "mtcars") + session$setInputs(`datasets-selected_open` = FALSE) + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), "mpg" + ) + } + ) + }) + + it("Setting numeric variable resolves values to be a slider input with variable range", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = "Sepal.Length", selected = "Sepal.Length"), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "input[type='number']"), "value"), + as.character(range(iris$Sepal.Length)) + ) + } + ) + }) + + it("switching variables-input changes values-input", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("Sepal.Length", "Species"), selected = "Species"), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), + c("setosa", "versicolor", "virginica") + ) + session$setInputs(`variables-selected` = "Sepal.Length") + session$setInputs(`variables-selected_open` = FALSE) + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "input[type='number']"), "value"), + as.character(range(iris$Sepal.Length)) + ) + } + ) + }) + + it("changing picks_resolved doesn't change picker input", { + test_picks <- picks( + datasets(choices = c("iris", "mtcars"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + current_picks <- picks_resolved() + current_picks$datasets$selected <- "mtcars" + picks_resolved(current_picks) + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), + "iris" + ) + } + ) + }) + + it("adding a dataset to data adds new choice to dataset choices", { + skip("todo: tests can't trigger data()") + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("iris", "mtcars")) + reactive_data( + list( + a = data.frame(a = 1:10, b = letters[1:10]), + iris = iris, + mtcars = mtcars + ) + ) + + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option"), "value"), + c("a", "iris", "mtcars") + ) + } + ) + }) + + it("adding a column to data adds new choice to variables-choices", { + skip("todo: tests can't trigger data()") + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + reactive_data( + list( + iris = transform(iris, new = 1:150), + mtcars = mtcars + ) + ) + session$flushReact() + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option"), "value"), + c("a", "mtcars") + ) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "iris" + ) + } + ) + }) + + it("removing a (selected) dataset from data removes choice from dataset choices and from selection with warning", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("iris", "mtcars")) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "iris" + ) + reactive_data( + list( + a = data.frame(a = 1:10, b = letters[1:10]), + mtcars = mtcars + ) + ) + + testthat::expect_warning(session$flushReact()) + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("a", "mtcars")) + testthat::expect_length( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + 0 + ) + } + ) + }) + + it("removing a (selected) variable from data removes choice from dataset choices and from selection", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = tidyselect::starts_with("Sepal"), multiple = TRUE) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + c("Sepal.Length", "Sepal.Width") + ) + reactive_data( + list( + iris = iris[-1], + mtcars = mtcars + ) + ) + session$flushReact() + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), colnames(iris)[-1]) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "Sepal.Width" + ) + } + ) + }) + + it("variables(ordered=TRUE) returns input following a selection-order instead of choices-order", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 3L, multiple = TRUE, ordered = TRUE) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 3L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 2L, 3L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 2L, 3L, 4L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + testthat::expect_identical(picks_resolved()$variables$selected, colnames(iris)[c(3L, 1L, 2L, 4L)]) + } + ) + }) + + it("changing numeric range in slider input updates picks_resolved") + it("changing integer range in slider input updates picks_resolved") + it("changing date range in slider input updates picks_resolved") + it("changing date range in slider input updates picks_resolved") + it("setting picks_resolved$selected outside of range adjust to the available range") +}) diff --git a/tests/testthat/test-0-picks.R b/tests/testthat/test-0-picks.R new file mode 100644 index 000000000..253a27655 --- /dev/null +++ b/tests/testthat/test-0-picks.R @@ -0,0 +1,482 @@ +testthat::describe("picks() assertions", { + it("fails when first element is not datasets", { + testthat::expect_error(picks(variables()), "datasets") + }) + + it("succeeds when first element is datasets", { + testthat::expect_no_error(picks(datasets())) + }) + + it("fails with empty input", { + testthat::expect_error(picks()) + }) + + it("fails when input is not of class 'type'", { + testthat::expect_error(picks(list(a = 1, b = 2))) + }) + + it("fails when mixing valid and invalid types", { + testthat::expect_error( + picks(datasets(), list(invalid = "test")) + ) + }) + + it("fails when values exists without variables", { + testthat::expect_error( + picks(datasets(), values()), + "requires variables\\(\\) before values\\(\\)" + ) + }) + + it("succeeds when values immediately follows variables", { + testthat::expect_no_error( + picks(datasets(), variables(), values()) + ) + }) + + it("fails when values doesn't immediately follow variables", { + testthat::expect_error( + picks(datasets(), values(), variables()) + ) + }) + + it("succeeds with only datasets and variables (no values)", { + testthat::expect_no_error( + picks(datasets(), variables()) + ) + }) + + it("warns when element with dynamic choices is followed by element with eager choices", { + testthat::expect_warning( + picks( + datasets(c("iris", "mtcars")), + variables(c("Species")) + ), + "eager" + ) + }) +}) + +testthat::describe("picks() basic structure", { + it("returns an object of class 'picks' and 'list'", { + result <- picks(datasets()) + testthat::expect_s3_class(result, "picks") + testthat::expect_type(result, "list") + }) + + it("creates a picks object with single datasets element", { + result <- picks(datasets()) + checkmate::expect_list(result, len = 1, types = "datasets") + }) + + it("creates a picks object with datasets and variables", { + result <- picks(datasets(), variables()) + checkmate::expect_list(result, len = 2, types = c("datasets", "variables")) + testthat::expect_named(result, c("datasets", "variables")) + }) + + it("creates a picks object with datasets, variables and values", { + result <- picks(datasets(), variables(), values()) + checkmate::expect_list(result, len = 3, types = c("datasets", "variables", "values")) + testthat::expect_named(result, c("datasets", "variables", "values")) + }) + + it("ignores trailing empty arguments", { + result <- picks(datasets(), variables(), ) + checkmate::expect_list(result, len = 2, types = c("datasets", "variables")) + }) +}) + +testthat::describe("datasets() basic asserts:", { + it("datasets(choices) argument accepts character, integer, predicate function and tidyselect", { + testthat::expect_no_error(datasets(choices = "test")) + testthat::expect_no_error(datasets(choices = 1L)) + testthat::expect_no_error(datasets(choices = tidyselect::everything())) + testthat::expect_no_error(datasets(choices = tidyselect::where(is.data.frame))) + testthat::expect_no_error(datasets(choices = c(test:test, test))) + testthat::expect_no_error(datasets(choices = tidyselect::starts_with("Petal") | tidyselect::ends_with("Width"))) + testthat::expect_no_error(datasets(choices = tidyselect::all_of(c("test", "test2")))) + testthat::expect_error(datasets(choices = c(1.2))) # double + testthat::expect_error(datasets(choices = c(1.0))) # integerish + testthat::expect_error(datasets(choices = as.Date(1))) # Date + }) + + it("datasets(choices) can't be empty", { + testthat::expect_error(datasets(choices = character(0))) + testthat::expect_error(datasets(choices = NULL)) + testthat::expect_error(datasets(choices = list())) + }) + + it("datasets(selected) argument character(1), integer(1), predicate and tidyselect or empty", { + testthat::expect_no_error(datasets(selected = 1L)) + testthat::expect_no_error(datasets(selected = tidyselect::everything())) + testthat::expect_no_error(datasets(selected = function(x) TRUE)) + testthat::expect_no_error(datasets(selected = NULL)) + testthat::expect_error(datasets(choices = c("iris", "mtcars"), selected = c("iris", "mtcars"))) + }) + + + it("datasets(selected) must be a subset of choices", { + testthat::expect_error(datasets(choices = c("a", "b"), selected = "c"), "subset of `choices`") + }) + + it("datasets(selected) warns if choices are delayed and selected eager", { + testthat::expect_warning(datasets(choices = tidyselect::everything(), selected = "c"), "subset of `choices`") + testthat::expect_warning(datasets(choices = 1L, selected = "c"), "subset of `choices`") + }) +}) + +testthat::describe("datasets() returns datasets", { + it("returns an object of class 'datasets' and 'type'", { + result <- datasets(choices = "iris") + testthat::expect_s3_class(result, "datasets") + }) + + it("returns a list with 'choices' and 'selected' elements", { + result <- datasets(choices = "iris") + testthat::expect_type(result, "list") + testthat::expect_named(result, c("choices", "selected")) + }) + + it("stores static character vector in $choices", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_equal(result$choices, c("iris", "mtcars")) + }) + + it("defaults selected to 1'st when not specified", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_s3_class(result$selected, "quosure") + testthat::expect_equal(rlang::quo_get_expr(result$selected), 1) + }) + + it("stores custom selected value", { + result <- datasets(choices = c("iris", "mtcars"), selected = "mtcars") + testthat::expect_equal(result$selected, "mtcars") + }) + + it("stores integer selected value as quosure", { + result <- datasets(choices = c("iris", "mtcars"), selected = 2L) + testthat::expect_s3_class(result$selected, "quosure") + testthat::expect_equal(rlang::quo_get_expr(result$selected), 2L) + }) + + it("sets fixed to TRUE when single choice", { + testthat::expect_true(attr(datasets(choices = "test"), "fixed")) + }) +}) + +testthat::describe("datasets() returns quosures for delayed evaluation", { + it("stores tidyselect::everything() as a quosure in $choices", { + result <- datasets(choices = tidyselect::everything()) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::where() as a predicate function in $choices", { + result <- datasets(choices = tidyselect::where(is.data.frame)) + testthat::expect_true(is.function(result$choices)) + }) + + it("stores symbol range (a:b) as a quosure in $choices", { + result <- datasets(choices = c(a:b)) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores numeric range (1:5) as a quosure in $choices", { + result <- datasets(choices = seq(1, 5)) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::starts_with() as a quosure in $choices", { + result <- datasets(choices = tidyselect::starts_with("test")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::ends_with() as a quosure in $choices", { + result <- datasets(choices = tidyselect::ends_with("test")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores combined tidyselect expressions as a quosure in $choices", { + result <- datasets(choices = tidyselect::starts_with("a") | tidyselect::ends_with("b")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("does not store static character vector as a quosure in $choices", { + result <- datasets(choices = c("a", "b", "c")) + testthat::expect_false(inherits(result$choices, "quosure")) + testthat::expect_type(result$choices, "character") + }) +}) + +testthat::describe("datasets() attributes", { + it("sets multiple attribute to FALSE (always single selection)", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets fixed to TRUE for single non-delayed choice", { + result <- datasets(choices = "iris") + testthat::expect_true(attr(result, "fixed")) + }) + + it("sets fixed to FALSE for multiple choices", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_false(attr(result, "fixed")) + }) + + it("sets fixed to FALSE for delayed choices (tidyselect)", { + result <- datasets(choices = tidyselect::everything()) + testthat::expect_false(attr(result, "fixed")) + }) + + it("allows explicit fixed = TRUE override", { + result <- datasets(choices = c("iris", "mtcars"), fixed = TRUE) + testthat::expect_true(attr(result, "fixed")) + }) + + it("allows explicit fixed = FALSE override", { + result <- datasets(choices = "iris", fixed = FALSE) + testthat::expect_false(attr(result, "fixed")) + }) + + it("passes additional arguments via ...", { + result <- datasets(choices = "iris", custom_attr = "test_value") + testthat::expect_equal(attr(result, "custom_attr"), "test_value") + }) +}) + +testthat::describe("datasets() validation and warnings", { + it("warns when selected is explicit and choices are delayed", { + testthat::expect_warning( + datasets(choices = tidyselect::everything(), selected = "iris"), + "Setting explicit `selected` while `choices` are delayed" + ) + }) + + it("does not warn when selected is numeric and choices are delayed", { + testthat::expect_no_warning( + datasets(choices = tidyselect::everything(), selected = 1L) + ) + }) + + it("does not warn when both choices and selected are static", { + testthat::expect_no_warning( + datasets(choices = c("iris", "mtcars"), selected = "iris") + ) + }) +}) + +testthat::describe("datasets() integration with tidyselect helpers", { + it("accepts tidyselect::all_of()", { + testthat::expect_no_error( + datasets(choices = tidyselect::all_of(c("iris", "mtcars"))) + ) + }) + + it("accepts tidyselect::any_of()", { + testthat::expect_no_error( + datasets(choices = tidyselect::any_of(c("iris", "mtcars"))) + ) + }) + + it("stores tidyselect::starts_with() as a quosure", { + result <- datasets(choices = tidyselect::starts_with("ir")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::ends_with() as a quosure", { + result <- datasets(choices = tidyselect::ends_with("s")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::contains() as a quosure", { + result <- datasets(choices = tidyselect::contains("car")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::matches() as a quosure", { + result <- datasets(choices = tidyselect::matches("^i")) + testthat::expect_s3_class(result$choices, "quosure") + }) +}) + +testthat::describe("variables() multiple attribute", { + it("sets multiple to FALSE for single selected value", { + result <- variables(choices = c("a", "b", "c"), selected = "a") + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets multiple to TRUE for multiple selected values", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b")) + testthat::expect_true(attr(result, "multiple")) + }) + + it("sets multiple to FALSE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), selected = "a", multiple = FALSE) + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets multiple to TRUE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), selected = "a", multiple = TRUE) + testthat::expect_true(attr(result, "multiple")) + }) + + it("auto-detects multiple = TRUE from selected vector length", { + result <- variables(choices = c("a", "b", "c", "d"), selected = c("a", "b", "c")) + testthat::expect_true(attr(result, "multiple")) + }) + + it("auto-detects multiple = FALSE from single selected", { + result <- variables(choices = c("a", "b", "c"), selected = "b") + testthat::expect_false(attr(result, "multiple")) + }) + + it("defaults to NULL for tidyselect selected", { + result <- variables(choices = c("a", "b"), selected = tidyselect::everything()) + testthat::expect_false(attr(result, "multiple")) + }) + + it("explicit multiple overrides auto-detection", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b"), multiple = FALSE) + testthat::expect_false(attr(result, "multiple")) + }) +}) + +testthat::describe("variables() ordered attribute", { + it("defaults to FALSE", { + result <- variables(choices = c("a", "b", "c")) + testthat::expect_false(attr(result, "ordered")) + }) + + it("sets ordered to TRUE when specified", { + result <- variables(choices = c("a", "b", "c"), ordered = TRUE) + testthat::expect_true(attr(result, "ordered")) + }) + + it("sets ordered to FALSE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), ordered = FALSE) + testthat::expect_false(attr(result, "ordered")) + }) +}) + +testthat::describe("variables() allow-clear attribute", { + it("sets allow-clear to FALSE for single non-NULL selected", { + result <- variables(choices = c("a", "b", "c"), selected = "a") + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to TRUE for multiple selected", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b")) + testthat::expect_true(attr(result, "allow-clear")) + }) + + it("sets allow-clear to TRUE when selected is NULL", { + result <- variables(choices = c("a", "b", "c"), selected = NULL) + testthat::expect_true(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for tidyselect selected", { + result <- variables(choices = c("a", "b"), selected = tidyselect::everything()) + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for single numeric selected", { + result <- variables(choices = c("a", "b", "c"), selected = 1L) + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for multiple numeric selected (tidyselect)", { + result <- variables(choices = c("a", "b", "c"), selected = c(1L, 2L)) + testthat::expect_false(attr(result, "allow-clear")) + }) +}) + +testthat::describe("variables() attribute interactions", { + it("multiple = TRUE and ordered = TRUE work together", { + result <- variables( + choices = c("a", "b", "c"), + selected = c("a", "c"), + multiple = TRUE, + ordered = TRUE + ) + testthat::expect_true(attr(result, "multiple")) + testthat::expect_true(attr(result, "ordered")) + }) + + it("multiple = FALSE and ordered = FALSE work together", { + result <- variables( + choices = c("a", "b", "c"), + selected = "a", + multiple = FALSE, + ordered = FALSE + ) + testthat::expect_false(attr(result, "multiple")) + testthat::expect_false(attr(result, "ordered")) + }) + + it("allow-clear depends on multiple when selected is character", { + result_single <- variables(choices = c("a", "b"), selected = "a", multiple = FALSE) + result_multi <- variables(choices = c("a", "b"), selected = "a", multiple = TRUE) + + testthat::expect_false(attr(result_single, "allow-clear")) + testthat::expect_true(attr(result_multi, "allow-clear")) + }) + + it("all three attributes can be set independently", { + result <- variables( + choices = c("a", "b", "c"), + selected = c("b", "c"), + multiple = TRUE, + ordered = TRUE + ) + testthat::expect_true(attr(result, "multiple")) + testthat::expect_true(attr(result, "ordered")) + testthat::expect_true(attr(result, "allow-clear")) + }) +}) + +testthat::describe("values() assertions", { + it("values() succeeds by default", { + testthat::expect_no_error(values()) + }) + + it("values(choices) accepts predicate functions, character, numeric(2), date(2) and posixct(2). No tidyselect", { + testthat::expect_no_error(values(choices = "test")) + testthat::expect_no_error(values(choices = c("test", "test2"))) + testthat::expect_error(values(choices = c("test", "test"))) + testthat::expect_no_error(values(choices = c(1, 2))) + testthat::expect_error(values(choices = 1)) + testthat::expect_error(values(choices = c(1, 2, 3))) + testthat::expect_error(values(choices = c(-Inf, Inf))) + testthat::expect_no_error(values(choices = as.Date(1:2))) + testthat::expect_error(values(choices = as.Date(1))) + testthat::expect_error(values(choices = as.Date(1:3))) + testthat::expect_no_error(values(choices = as.POSIXct(1:2))) + testthat::expect_error(values(choices = as.POSIXct(1))) + testthat::expect_error(values(choices = as.POSIXct(1:3))) + testthat::expect_no_error(values(choices = tidyselect::where(~ .x > 1))) # this is predicate, not tidyselect + testthat::expect_no_error(values(choices = function(x) !is.na(x))) + testthat::expect_no_error(values(choices = function(x, ...) !is.na(x))) + testthat::expect_error(values(choices = function(x, y, ...) x > y)) + testthat::expect_error(values(choices = tidyselect::everything())) + testthat::expect_error(values(choices = c(test:test, test))) + }) +}) + +testthat::describe("values() attributes", { + it("multiple set to TRUE by default", { + testthat::expect_true(attr(values(), "multiple")) + }) + + it("fixed=TRUE when single choice is provided", { + testthat::expect_true(attr(values(choices = "test"), "fixed")) + }) + + it("fixed=FALSE when choices is a predicate", { + testthat::expect_false(attr(values(choices = function(x) TRUE), "fixed")) + }) + + it("fixed=FALSE when choices length > 1", { + testthat::expect_false(attr(values(choices = c("test", "test2")), "fixed")) + }) +}) diff --git a/tests/testthat/test-0-print.R b/tests/testthat/test-0-print.R new file mode 100644 index 000000000..9569b1517 --- /dev/null +++ b/tests/testthat/test-0-print.R @@ -0,0 +1,90 @@ +testthat::describe("format.type() for datasets", { + it("formats datasets with character choices by printing them explicitly", { + ds <- datasets(choices = c("iris", "mtcars"), selected = "iris") + expected <- " \033[1m\033[0m\n choices: iris, mtcars\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" # nolint + testthat::expect_identical(format(ds), expected) + }) + + it("formats datasets with tidyselect choices by printing matched call's argument", { + ds <- datasets(choices = tidyselect::everything(), selected = 1L) + result <- format(ds) + testthat::expect_match(result, "") + testthat::expect_match(result, "choices:.*everything\\(\\)") + testthat::expect_match(result, "selected:.*1") + }) +}) + +testthat::describe("print.type() for variables", { + it("prints variables with character choices by printing them explicitly", { + vars <- variables(choices = c("a", "b", "c"), selected = c("a", "b"), multiple = TRUE) + expected <- " \033[1m\033[0m\n choices: a, b, c\n selected: a, b\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE, allow-clear=TRUE\033[0m\n" # nolint + testthat::expect_identical(format(vars), expected) + }) + + + it("formats variables with ordered attribute correctly", { + vars <- variables(choices = c("x", "y", "z"), selected = c("x", "y"), ordered = TRUE) + result <- format(vars) + testthat::expect_match(result, "ordered=TRUE") + }) +}) + +testthat::describe("format.type() for values", { + it("formats values with character choices by printing them explicitly with their attributes", { + vals <- values(choices = c("1", "2", "3"), selected = c("1", "2"), multiple = TRUE) + expected <- " \033[1m\033[0m\n choices: 1, 2, 3\n selected: 1, 2\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE\033[0m\n" # nolint + testthat::expect_identical(format(vals), expected) + }) +}) + + +testthat::describe("format.picks() for picks collection", { + it("formats picks with datasets, variables and values by showing them all explicitly", { + p <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = "a", selected = "a", multiple = FALSE), + values(choices = c("1", "2"), selected = "1", multiple = FALSE) + ) + expected <- paste( + c( + " \033[1m\033[0m", + " \033[1m\033[0m:", + " choices: iris", + " selected: iris", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE\033[0m", + " \033[1m\033[0m:", + " choices: a", + " selected: a", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE, allow-clear=FALSE\033[0m", + " \033[1m\033[0m:", + " choices: 1, 2", + " selected: 1", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + ), + collapse = "\n" + ) + + testthat::expect_identical(format(p), expected) + }) +}) + +testthat::describe("print methods output correctly", { + it("print.type() outputs datasets to console with class name, choices and selected", { + ds <- datasets(choices = "iris", selected = "iris") + testthat::expect_output(print(ds), "") + testthat::expect_output(print(ds), "choices:") + testthat::expect_output(print(ds), "selected:") + }) + + it("print.picks() outputs picks to console with its class and elements", { + p <- picks(datasets(choices = "iris")) + testthat::expect_output(print(p), "") + testthat::expect_output(print(p), "") + }) + + it("print returns invisibly", { + ds <- datasets(choices = "iris", selected = "iris") + result <- print(ds) + testthat::expect_identical(result, ds) + }) +}) diff --git a/tests/testthat/test-Queue.R b/tests/testthat/test-Queue.R deleted file mode 100644 index fb508ebd6..000000000 --- a/tests/testthat/test-Queue.R +++ /dev/null @@ -1,78 +0,0 @@ -testthat::test_that("Queue can be initialized", { - testthat::expect_true(is.environment(Queue$new())) - testthat::expect_identical(class(Queue$new()), c("Queue", "R6")) -}) - -testthat::test_that("size method returns number of elements in queue", { - queue <- Queue$new() - testthat::expect_identical(queue$size(), 0L) -}) - -testthat::test_that("push method adds elements to queue", { - queue <- Queue$new() - testthat::expect_equal(queue$size(), 0L) - testthat::expect_no_error(queue$push(7)) - testthat::expect_equal(queue$size(), 1L) -}) - -testthat::test_that("push method can add multiple elements", { - queue <- Queue$new() - testthat::expect_no_error(queue$push(c(1, "2"))) -}) - -testthat::test_that("get method returns elements of queue", { - queue <- Queue$new() - queue$push(letters) - testthat::expect_identical(queue$get(), letters) -}) - -testthat::test_that("pop method removes first element from queue", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_equal(queue$pop(), 7) - testthat::expect_equal(queue$get(), 8) -}) - -testthat::test_that("remove method removes specified element from queue", { - queue <- Queue$new() - queue$push(c(7, 8, 7, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 7, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 8)) -}) - -testthat::test_that("remove method can remove several elements", { - queue <- Queue$new() - queue$push(c(6, 7, 8, 6, 7, 8, 6, 7, 8, 6)) - testthat::expect_no_error(queue$remove(c(7, 7))) - testthat::expect_equal(queue$get(), c(6, 8, 6, 8, 6, 7, 8, 6)) -}) - -testthat::test_that("empty method removes all elements from queue", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_no_error(queue$empty()) - testthat::expect_equal(queue, Queue$new()) -}) - -testthat::test_that("print method- displays proper format", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_identical( - testthat::capture_output( - queue$print() - ), - testthat::capture_output( - cat( - "", - "Size: 2", - "Elements:", - "7 8", - sep = "\n" - ) - ) - ) -})