diff --git a/NEWS.md b/NEWS.md index 45d4b774..41cec3ad 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,8 @@ ### Enhancements * Added utility functions `first_choice` and `last_choice` to increase the repertoire of specifying choices in delayed data, previously only served by `all_choices`. +* Allowed `value_choices` to use `delayed_variable_choices` objects for `var_choices`. +It is now possible to define a `data_extract_spec` without naming any variables. # teal.transform 0.5.0 diff --git a/R/choices_labeled.R b/R/choices_labeled.R index bbc8bdaa..0b307cd6 100644 --- a/R/choices_labeled.R +++ b/R/choices_labeled.R @@ -253,7 +253,7 @@ variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key = #' @param data (`data.frame`, `character`) #' If `data.frame`, then data to extract labels from. #' If `character`, then name of the dataset to extract data from once available. -#' @param var_choices (`character` or `NULL`) vector with choices column names. +#' @param var_choices (`character`, `delayed_variable_choices`) Choice of column names. #' @param var_label (`character`) vector with labels column names. #' @param subset (`character` or `function`) #' If `character`, vector with values to subset. @@ -288,7 +288,10 @@ value_choices <- function(data, var_label = NULL, subset = NULL, sep = " - ") { - checkmate::assert_character(var_choices, any.missing = FALSE) + checkmate::assert( + checkmate::check_character(var_choices, any.missing = FALSE), + checkmate::check_class(var_choices, "delayed_variable_choices") + ) checkmate::assert_character(var_label, len = length(var_choices), null.ok = TRUE, any.missing = FALSE) checkmate::assert( checkmate::check_vector(subset, null.ok = TRUE), @@ -327,6 +330,7 @@ value_choices.data.frame <- function(data, checkmate::assert_subset(var_choices, names(data)) checkmate::assert_subset(var_label, names(data), empty.ok = TRUE) + var_choices <- as.vector(var_choices) df_choices <- data[var_choices] df_label <- data[var_label] diff --git a/R/delayed_choices.R b/R/delayed_choices.R index edd17424..88f8cf8c 100644 --- a/R/delayed_choices.R +++ b/R/delayed_choices.R @@ -7,9 +7,9 @@ #' `filter_spec`, `select_spec` or `choices_selected` object. #' #' @return -#' Object of class `delayed_choices`, which is a function that returns -#' the appropriate subset of its argument. The `all_choices` structure -#' also has an additional class for internal use. +#' Object of class `delayed_data, delayed_choices`, which is a function +#' that returns the appropriate subset of its argument. The `all_choices` +#' structure also has an additional class for internal use. #' #' @examples #' # These pairs of structures represent semantically identical specifications: @@ -39,7 +39,7 @@ all_choices <- function() { function(x) { x }, - class = c("all_choices", "delayed_choices") + class = c("all_choices", "delayed_choices", "delayed_data") ) } @@ -48,11 +48,14 @@ all_choices <- function() { first_choice <- function() { structure( function(x) { - if (length(x) == 0L) { + if (inherits(x, "delayed_choices")) { + x + } else if (length(x) == 0L) { x } else if (is.atomic(x)) { x[1L] } else if (inherits(x, "delayed_data")) { + if (is.null(x$subset)) return(x) original_fun <- x$subset added_fun <- function(x) x[1L] x$subset <- function(data) { @@ -61,7 +64,7 @@ first_choice <- function() { x } }, - class = c("delayed_choices") + class = c("delayed_choices", "delayed_data") ) } @@ -70,11 +73,14 @@ first_choice <- function() { last_choice <- function() { structure( function(x) { - if (length(x) == 0L) { + if (inherits(x, "delayed_choices")) { + x + } else if (length(x) == 0L) { x } else if (is.atomic(x)) { x[length(x)] } else if (inherits(x, "delayed_data")) { + if (is.null(x$subset)) return(x) original_fun <- x$subset added_fun <- function(x) x[length(x)] x$subset <- function(data) { @@ -83,6 +89,6 @@ last_choice <- function() { x } }, - class = c("delayed_choices") + class = c("delayed_choices", "delayed_data") ) } diff --git a/R/resolve.R b/R/resolve.R index e4072a89..c5682b54 100644 --- a/R/resolve.R +++ b/R/resolve.R @@ -44,6 +44,9 @@ resolve.delayed_variable_choices <- function(x, datasets, keys) { #' @export resolve.delayed_value_choices <- function(x, datasets, keys) { x$data <- datasets[[x$data]]() + if (inherits(x$var_choices, "delayed_variable_choices")) { + x$var_choices <- resolve(x$var_choices, datasets, keys) + } if (is.function(x$subset)) { x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = TRUE) }