diff --git a/NAMESPACE b/NAMESPACE index dd6ca8d6..bb2785d0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -81,6 +81,7 @@ export(get_dataset_prefixed_col_names) export(get_extract_datanames) export(get_merge_call) export(get_relabel_call) +export(interaction_vars) export(is.choices_selected) export(is_categorical) export(is_single_dataset) diff --git a/R/0-call_utils.R b/R/0-call_utils.R index 65a2347a..e9c0af50 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) } } @@ -275,3 +275,29 @@ calls_combine_by <- function(operator, calls) { ) ) } + +.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)) + ) + + mutate_args <- lapply(select_new, function(new_var) { + .operator_mutate_args(operators[[new_var]]) + }) + + calls_combine_by( + "%>%", + c( + select_call, + as.call(rlang::list2(str2lang("dplyr::mutate"), !!!mutate_args)), + as.call(rlang::list2( + str2lang("dplyr::select"), + substitute(!all_of(vars), env = list(vars = select_tmp[!select_tmp %in% variables])) + )) + ) + ) +} \ No newline at end of file diff --git a/R/0-interaction.R b/R/0-interaction.R new file mode 100644 index 00000000..4b11b5b3 --- /dev/null +++ b/R/0-interaction.R @@ -0,0 +1,63 @@ +#' 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 <- vctrs::vec_match(new_var, vars) + new_operator <- structure( + new_var, + class = "interaction", + 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 + 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)) + ) +} + +.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()) diff --git a/R/0-module_merge.R b/R/0-module_merge.R index 664edca8..47de38eb 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -290,8 +290,16 @@ merge_srv <- function(id, unlist(lapply(unname(this_mapping), `[[`, "variables")) ) this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names + operators <- unlist(lapply(unname(this_mapping), "[[", i = "operators"), recursive = FALSE) + operators_ix <- this_variables %in% + vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)) + + this_call <- if (any(operators_ix)) { + .call_mutate_operators(this_variables, operators_ix, dataname, operators) + } else { + .call_dplyr_select(dataname = dataname, variables = this_variables) + } - 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) { @@ -338,9 +346,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 } ) @@ -401,7 +411,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( @@ -429,7 +438,6 @@ merge_srv <- function(id, anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) } - list(mapping = mapping, join_keys = join_keys) } diff --git a/R/0-resolver.R b/R/0-resolver.R index 034d6521..4d7e071d 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -67,7 +67,20 @@ determine.variables <- function(x, data) { return(list(x = .nullify_pick(x))) } + old <- select_env$operators + on.exit(select_env$operators <- old) + x$choices <- .determine_choices(x$choices, data = data) + # change data to add columns that combine interaction vars + custom_operators <- select_env$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/man/interaction_vars.Rd b/man/interaction_vars.Rd new file mode 100644 index 00000000..980b3d53 --- /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 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 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..e55c2385 --- /dev/null +++ b/tests/testthat/test-0-interaction.R @@ -0,0 +1,29 @@ +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")) + ) +}) + +testthat::test_that("interaction_vars stores interactions in environment", { + old <- select_env$operators + withr::defer(select_env$operators <- old) + 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 = "interaction", var_name = "AGE:RACE"), + structure(c("AGE", "COUNTRY"), class = "interaction", var_name = "AGE:COUNTRY") + ) + ) +}) diff --git a/tests/testthat/test-0-module_picks.R b/tests/testthat/test-0-module_picks.R index 3276971d..7deb32e4 100644 --- a/tests/testthat/test-0-module_picks.R +++ b/tests/testthat/test-0-module_picks.R @@ -567,6 +567,37 @@ testthat::describe("picks_srv resolves picks", { ) }) + it("picks with delayed interaction_vars are resolved", { + test_picks <- suppressWarnings( + picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = interaction_vars("Species", "Petal.Length"), selected = "Species:Petal.Length") + ) + ) + + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables( + choices = rlang::set_names(c("Species", "Petal.Length", "Species:Petal.Length")), + selected = "Species:Petal.Length" + ) + ) + ) + picks_expected$variables$operators <- list( + structure( + c("Species", "Petal.Length"), class = "interaction", var_name = "Species:Petal.Length" + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) + it("pick elements are resolved sequentially", { test_picks <- picks( datasets(choices = tidyselect::where(is.data.frame), selected = 1L),