233 delayed value choices (#237)

Closes #233 

Opened `value_choices(var_choices)` to accept `delayed_data`.
Added a step in `resolve.delayed_value_choices` to resolve
`var_choices`.
Added `delayed_data` class to `delayed_choices` functions.
Modified `delayed_choices` functions to return `delayed_choices` as is.
Modified `delayed_choices` functions to return arguments where
`x$subset` is `NULL` as is.

Some minor adjustments.

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
 

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]
 

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

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