Adds interaction variable to picks

DESCRIPTION

@@ -35,7 +35,8 @@ Suggests:
     shinytest2,
     teal.transform,
     testthat (>= 3.0),
-    tibble
+    tibble,
+    withr (>= 3.0.0)
 VignetteBuilder:
     knitr
 Config/testthat/edition: 3

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,":=")

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

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

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
 }

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

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

R/teal.picks.R

@@ -1,2 +1,3 @@
 #' @import shiny
+#' @importFrom rlang :=
 NULL

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

_pkgdown.yaml

@@ -21,6 +21,7 @@ reference:
     desc: Utility functions
     contents:
       - is_categorical
+      - interaction_vars
       - ranged
 
   - title: Shiny Modules