diff --git a/DESCRIPTION b/DESCRIPTION index e3dc4f1e..9e99675b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,8 @@ Suggests: shinytest2, teal.transform, testthat (>= 3.0), - tibble + tibble, + withr (>= 3.0.0) VignetteBuilder: knitr Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 9f95971f..172ac341 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,7 @@ export(as.picks) export(assert_last_level) export(check_last_level) export(datasets) +export(interaction_vars) export(is_categorical) export(merge_srv) export(picks) @@ -41,3 +42,4 @@ export(tm_merge) export(values) export(variables) import(shiny) +importFrom(rlang,":=") diff --git a/R/0-call_utils.R b/R/0-call_utils.R index f1786c2e..21763bdb 100644 --- a/R/0-call_utils.R +++ b/R/0-call_utils.R @@ -18,7 +18,7 @@ call_check_parse_varname <- function(varname) { if (is.character(varname)) { parsed <- parse(text = varname, keep.source = FALSE) if (length(parsed) == 1) { - varname <- parsed[[1]] + varname <- as.name(varname) } else { stop( sprintf( @@ -80,7 +80,7 @@ call_condition_choice <- function(varname, choices) { # c_call needed because it needs to be vector call # instead of vector. SummarizedExperiment.subset # handles only vector calls - call("%in%", varname, c_call) + call("%in%", as.name(varname), c_call) } } @@ -271,6 +271,22 @@ calls_combine_by <- function(operator, calls) { 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 ( + checkmate::test_list(x$operators, types = "operator", min.len = 1) && + .is_operator_selected(x$operators, x$variables) + ) { + if (length(x$operators) > 1) { + showNotification("Only a single complex operator can be used at a time when filtering by values.", type = "error") + return(NULL) + } + if (length(x$variables) > 1) { + showNotification( + "A complex operator filter cannot be combined with other variables. Filtering by the first variable only.", + type = "error" + ) + return(NULL) + } + call_condition_operators(x$operators[[1]], choices = x$values) } else if (length(x$variables)) { if (is.factor(x$values)) { x$values <- as.numeric(levels(x$values))[x$values] @@ -296,3 +312,15 @@ calls_combine_by <- function(operator, calls) { call_condition_choice(varname = variable, choices = x$values) } } + +.call_mutate_operators <- function(variables, operators_ix, dataname, operators) { + operators <- rlang::set_names(operators, vapply(operators, attr, which = "var_name", FUN.VALUE = character(1))) + select_new <- variables[operators_ix] + select_tmp <- unname(unlist(operators[select_new])) + select_call <- .call_dplyr_select( + dataname = dataname, + variables = unique(c(variables[!operators_ix], select_tmp)) + ) + + select_call +} diff --git a/R/0-interaction.R b/R/0-interaction.R new file mode 100644 index 00000000..3f126f83 --- /dev/null +++ b/R/0-interaction.R @@ -0,0 +1,98 @@ +#' Declare interaction variable pairs for `tidyselect` +#' +#' Used inside `tidyselect` expressions to declare a pair of variables that +#' interact with each other. The pair is recorded in the selection environment +#' and the positions of both variables within the available variables are +#' returned. +#' +#' @param var1 An unquoted variable name. +#' @param var2 An unquoted variable name that interacts with `var1`. +#' @param vars Character vector of available variable names, retrieved +#' automatically via [tidyselect::peek_vars()]. +#' +#' @return An integer vector of length 2 giving the positions of `var1` and +#' `var2` in `vars`, or `NA` where a variable is not found. +#' +#' @export +interaction_vars <- function(var1, var2, vars = tidyselect::peek_vars(fn = "interaction_vars")) { + new_var <- c(as.character(substitute(var1)), as.character(substitute(var2))) + result <- match(new_var, vars) + if (isTRUE(select_env$active)) { # Only set operators under `teal.picks` evaluation context + new_operator <- structure( + new_var, + class = c("interaction", "operator"), + var_name = sprintf("%s:%s", new_var[[1]], new_var[[2]]) + ) + select_env$operators <- select_env$operators %||% list() + select_env$operators[[length(select_env$operators) + 1]] <- new_operator + } else { + warning( + "interaction_vars() should only be used within a tidyselect context in teal.picks.", + " The interaction will not be recorded, and the variables will be treated as independent.", + call. = FALSE + ) + } + result +} + +.operator_mutate <- function(x, new_choice, data) { + UseMethod(".operator_mutate") +} + +#' @method .operator_mutate interaction +#' @keywords internal +.operator_mutate.interaction <- function(x, new_choice, data) { + checkmate::assert_character(x, len = 2) + checkmate::assert_string(new_choice) + checkmate::assert_data_frame(data) + dplyr::mutate( + data, + !!new_choice := rlang::eval_bare(.operator_mutate_args(x)) + ) +} + +#' @method call_condition_operators interaction +#' @keywords internal +call_condition_operators.interaction <- function(x, choices) { + checkmate::assert_character(x, len = 2) + checkmate::assert_character(choices) + as.call( + list( + quote(`%in%`), + as.call( + list(quote(paste), as.name(x[1]), as.name(x[2]), sep = ":") + ), + unname(choices) + ) + ) +} + +call_condition_operators <- function(x, choices) { + UseMethod("call_condition_operators") +} + +.operator_mutate_args <- function(x) { + UseMethod(".operator_mutate_args") +} + +#' @method .operator_mutate interaction +#' @keywords internal +.operator_mutate_args.interaction <- function(x) { + checkmate::assert_character(x, len = 2) + as.call(c(list(quote(paste)), lapply(x, as.name), list(sep = ":"))) +} + + +# Environment to store interaction variable pairs during `tidyselect` evaluation +# This is used to communicate between the `interaction_vars()` function and the resolver that +# processes the picks with variables that interact. +# The resolver will look for this information in the environment to know which variables are +# meant to interact and need to be combined in the data. +select_env <- new.env(parent = emptyenv()) + +.is_operator_selected <- function(operators, x) { + if (length(operators) == 0L || length(x) == 0L) { + return(FALSE) + } + any(vapply(operators, attr, "var_name", FUN.VALUE = character(1L), USE.NAMES = FALSE) %in% x) +} diff --git a/R/0-module_merge.R b/R/0-module_merge.R index f7b8f325..7ed0b60d 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -288,12 +288,6 @@ merge_srv <- function(id, }, mapping) this_mapping <- datasets_vars[[dataname]] - selector_filter_dataset <- lapply(selectors_dataset, .trim_filter_mapping, dataname = dataname, data = x) - filter_datset_value <- vapply(selector_filter_dataset, function(x) { - !is.null(x$values) - }, TRUE) - selector_filter_dataset <- selector_filter_dataset[filter_datset_value & lengths(selector_filter_dataset) > 1L] - this_foreign_keys <- .fk(join_keys, dataname) this_primary_keys <- join_keys[dataname, dataname] this_variables <- if (length(this_foreign_keys) == 0L) { @@ -302,8 +296,35 @@ merge_srv <- function(id, union(this_foreign_keys, this_mapping$variables) } this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names + operators <- attr(this_mapping, "operators", exact = TRUE) + operators_names <- vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)) + operators_ix <- this_variables %in% operators_names + this_call <- if (any(operators_ix)) { + .call_mutate_operators(this_variables, operators_ix, dataname, operators) + } else { + .call_dplyr_select(dataname = dataname, variables = this_variables) + } + + # Update data with operators to determine filtering on interaction variables + for (ix in which(operators_names %in% this_variables)) { + x <- teal.code::eval_code( + x, + substitute( + obj_name <- .operator_mutate(cols, var_name, obj_name), + env = list( + cols = operators[[ix]], + var_name = attr(operators[[ix]], "var_name", TRUE), + obj_name = as.name(dataname) + ) + ) + ) + } - this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) + selector_filter_dataset <- lapply(selectors_dataset, .trim_filter_mapping, dataname = dataname, data = x) + filter_datset_value <- vapply(selector_filter_dataset, function(x) { + !is.null(x$values) + }, TRUE) + selector_filter_dataset <- selector_filter_dataset[filter_datset_value & lengths(selector_filter_dataset) > 1L] if (length(selector_filter_dataset)) { this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(selector_filter_dataset))) @@ -353,9 +374,11 @@ merge_srv <- function(id, mapping <- lapply( # what has been selected in each selector selectors, function(selector) { - lapply(selector, function(x) { + result <- lapply(selector, function(x) { stats::setNames(x$selected, x$selected) }) + result$operators <- selector$variables$operators + result } ) @@ -416,7 +439,6 @@ merge_srv <- function(id, ) 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( @@ -444,7 +466,6 @@ merge_srv <- function(id, anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) } - list(mapping = mapping, join_keys = join_keys) } @@ -605,6 +626,7 @@ merge_srv <- function(id, new_values <- c(maps[[input_dataset]]$values, input_selection$values) maps[[input_dataset]]$values <- new_values[!duplicated(unname(new_values))] } + attr(maps[[input_dataset]], "operators") <- input_selection$operators } maps } diff --git a/R/0-module_picks.R b/R/0-module_picks.R index aa721990..4cdea861 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -107,6 +107,13 @@ picks_srv.picks <- function(id, picks, data) { state$values$picks <- picks_resolved() }) + exportTestValues( + open_id_fmt = session$ns("%s-selected_open"), + selected_id_fmt = session$ns("%s-selected"), + range_id_fmt = session$ns("%s-range"), + picks_resolved = picks_resolved() + ) + badge <- shiny::reactive({ lapply( picks_resolved(), @@ -297,6 +304,7 @@ picks_srv.picks <- function(id, picks, data) { ) }) + # for non-numeric shiny::observeEvent(input$selected_open, { if (!isTRUE(input$selected_open)) { diff --git a/R/0-resolver.R b/R/0-resolver.R index 4874e471..048d5e4a 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -67,7 +67,22 @@ determine.variables <- function(x, data) { return(list(x = .nullify_pick(x))) } + old <- select_env$operators + select_env$active <- TRUE + on.exit(select_env$operators <- old, add = TRUE) + on.exit(select_env$active <- FALSE, add = TRUE) + x$choices <- .determine_choices(x$choices, data = data) + # change data to add columns that combine interaction vars + custom_operators <- unique(select_env$operators) %||% x$operators + + for (ix in seq_along(custom_operators)) { + new_choice <- rlang::set_names(attr(custom_operators[[ix]], "var_name", TRUE)) + data <- .operator_mutate(custom_operators[[ix]], new_choice, data) + x$choices <- c(x$choices, new_choice) + x$operators <- custom_operators + } + x$selected <- .determine_selected( x$selected, data = data[intersect(x$choices, colnames(data))], diff --git a/R/teal.picks.R b/R/teal.picks.R index 5c99bed5..deef9bb2 100644 --- a/R/teal.picks.R +++ b/R/teal.picks.R @@ -1,2 +1,3 @@ #' @import shiny +#' @importFrom rlang := NULL diff --git a/R/zzz.R b/R/zzz.R index aaccc0cd..f3e580be 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -2,5 +2,11 @@ # Set up the teal logger instance teal.logger::register_logger("teal.slice") teal.logger::register_handlers("teal.slice") + + # Manual import instead of using backports and adding 1 more dependency + if (getRversion() < "4.4") { + assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname)) + } + invisible() } diff --git a/_pkgdown.yaml b/_pkgdown.yaml index fb44b160..405284f1 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -21,6 +21,7 @@ reference: desc: Utility functions contents: - is_categorical + - interaction_vars - ranged - title: Shiny Modules diff --git a/man/interaction_vars.Rd b/man/interaction_vars.Rd new file mode 100644 index 00000000..4c2a2c11 --- /dev/null +++ b/man/interaction_vars.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-interaction.R +\name{interaction_vars} +\alias{interaction_vars} +\title{Declare interaction variable pairs for \code{tidyselect}} +\usage{ +interaction_vars( + var1, + var2, + vars = tidyselect::peek_vars(fn = "interaction_vars") +) +} +\arguments{ +\item{var1}{An unquoted variable name.} + +\item{var2}{An unquoted variable name that interacts with \code{var1}.} + +\item{vars}{Character vector of available variable names, retrieved +automatically via \code{\link[tidyselect:peek_vars]{tidyselect::peek_vars()}}.} +} +\value{ +An integer vector of length 2 giving the positions of \code{var1} and +\code{var2} in \code{vars}, or \code{NA} where a variable is not found. +} +\description{ +Used inside \code{tidyselect} expressions to declare a pair of variables that +interact with each other. The pair is recorded in the selection environment +and the positions of both variables within the available variables are +returned. +} diff --git a/tests/testthat/test-0-interaction.R b/tests/testthat/test-0-interaction.R new file mode 100644 index 00000000..554d912c --- /dev/null +++ b/tests/testthat/test-0-interaction.R @@ -0,0 +1,35 @@ +testthat::test_that("interaction_vars is compatible with eval_select", { + expect_equal( + unname( + tidyselect::eval_select( + interaction_vars("AGE", "RACE"), + data = teal.data::rADSL + ) + ), + which(colnames(teal.data::rADSL) %in% c("AGE", "RACE")) + ) |> + expect_warning("interaction_vars() should only be used within a tidyselect context in teal.picks.", fixed = TRUE) +}) + +testthat::test_that("interaction_vars stores interactions in environment", { + old <- select_env$operators + old_active <- select_env$active + withr::defer({ + select_env$operators <- old + select_env$active <- old_active + }) + select_env$active <- TRUE # mock a teal.picks context. + select_env$operators <- NULL + + tidyselect::eval_select( + c(interaction_vars(AGE, RACE), interaction_vars(AGE, COUNTRY)), + data = teal.data::rADSL + ) + expect_equal( + select_env$operators, + list( + structure(c("AGE", "RACE"), class = c("interaction", "operator"), var_name = "AGE:RACE"), + structure(c("AGE", "COUNTRY"), class = c("interaction", "operator"), var_name = "AGE:COUNTRY") + ) + ) +})