Adds interaction variable to picks

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)

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]))
+      ))
+    )
+  )
+}

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())

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)
 }
 

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))],

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")
+    )
+    )
+})

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),