229 delayed_choices as separate funcitons

NAMESPACE

@@ -46,6 +46,7 @@ export(data_extract_srv)
 export(data_extract_ui)
 export(datanames_input)
 export(filter_spec)
+export(first_choice)
 export(format_data_extract)
 export(get_anl_relabel_call)
 export(get_dataset_prefixed_col_names)
@@ -54,6 +55,7 @@ export(get_merge_call)
 export(get_relabel_call)
 export(is.choices_selected)
 export(is_single_dataset)
+export(last_choice)
 export(list_extract_spec)
 export(merge_datasets)
 export(merge_expression_module)

NEWS.md

@@ -1,5 +1,9 @@
 # teal.transform 0.5.0.9018
 
+### 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`.
+
 # teal.transform 0.5.0
 
 ### Breaking changes

R/choices_selected.R

@@ -24,7 +24,7 @@ no_select_keyword <- "-- no selection --"
 #' @param choices (`character`) vector of possible choices or `delayed_data` object.
 #'
 #' See [variable_choices()] and [value_choices()].
-#' @param selected (`character`) vector of preselected options, (`all_choices`) object
+#' @param selected (`character`) vector of preselected options, (`delayed_choices`) object
 #' or (`delayed_data`) object.
 #'
 #' If `delayed_data` object then `choices` must also be `delayed_data` object.
@@ -41,15 +41,6 @@ no_select_keyword <- "-- no selection --"
 #' library(shiny)
 #' library(teal.widgets)
 #'
-#' # all_choices example - semantically the same objects
-#' choices_selected(choices = letters, selected = all_choices())
-#' choices_selected(choices = letters, selected = letters)
-#'
-#' choices_selected(
-#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
-#'   selected = "C"
-#' )
-#'
 #' ADSL <- teal.data::rADSL
 #' choices_selected(variable_choices(ADSL), "SEX")
 #'
@@ -100,6 +91,19 @@ no_select_keyword <- "-- no selection --"
 #'   selected = variable_choices("ADSL", subset = c("STUDYID"))
 #' )
 #'
+#' # Passing `delayed_choices` object - semantically identical objects:
+#' choices_selected(choices = letters, selected = letters)
+#' choices_selected(choices = letters, selected = all_choices())
+#'
+#' choices_selected(
+#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
+#'   selected = "E"
+#' )
+#' choices_selected(
+#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
+#'   selected = last_choice()
+#' )
+#'
 #' # functional form (subsetting for factor variables only) of choices_selected
 #' # with delayed data loading
 #' choices_selected(variable_choices("ADSL", subset = function(data) {
@@ -136,12 +140,12 @@ choices_selected <- function(choices,
   )
   checkmate::assert(
     checkmate::check_atomic(selected),
-    checkmate::check_multi_class(selected, c("delayed_data", "all_choices"))
+    checkmate::check_multi_class(selected, c("delayed_data", "delayed_choices"))
   )
   checkmate::assert_flag(keep_order)
   checkmate::assert_flag(fixed)
 
-  if (inherits(selected, "all_choices")) selected <- choices
+  if (inherits(selected, "delayed_choices")) selected <- selected(choices)
 
   if (inherits(selected, "delayed_data") && !inherits(choices, "delayed_data")) {
     stop("If 'selected' is of class 'delayed_data', so must be 'choices'.")

R/data_extract_filter_module.R

@@ -69,6 +69,10 @@ data_extract_filter_srv <- function(id, datasets, filter) {
       isolate({
         # when the filter is initialized with a delayed spec, the choices and selected are NULL
         # here delayed are resolved and the values are set up
+        # Begin by resolving delayed choices.
+        if (inherits(filter$selected, "delayed_choices"))  {
+          filter$selected <- filter$selected(filter$choices)
+        }
         teal.widgets::updateOptionalSelectInput(
           session = session,
           inputId = "col",
@@ -102,6 +106,7 @@ data_extract_filter_srv <- function(id, datasets, filter) {
             } else {
               choices[1]
             }
+
           } else {
             choices <- character(0)
             selected <- character(0)
@@ -148,8 +153,8 @@ get_initial_filter_values <- function(filter, datasets) {
       datasets[[filter$dataname]](),
       as.character(filter$vars_selected)
     )
-    initial_values$selected <- if (inherits(filter$selected, "all_choices")) {
-      initial_values$choices
+    initial_values$selected <- if (inherits(filter$selected, "delayed_choices")) {
+      filter$selected(initial_values$choices)
     } else {
       filter$selected
     }

R/delayed_choices.R

@@ -0,0 +1,89 @@
+#' Bare constructor for `delayed_choices` object
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' Special S3 structures that delay selection of possible choices in a
+#' `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.
+#'
+#' @examples
+#' # These pairs of structures represent semantically identical specifications:
+#' choices_selected(choices = letters, selected = letters)
+#' choices_selected(choices = letters, selected = all_choices())
+#'
+#' choices_selected(choices = letters, selected = letters[1])
+#' choices_selected(choices = letters, selected = first_choice())
+#'
+#' filter_spec(
+#'   vars = c("selected_variable"),
+#'   choices = c("value1", "value2", "value3"),
+#'   selected = "value3"
+#' )
+#' filter_spec(
+#'   vars = c("selected_variable"),
+#'   choices = c("value1", "value2", "value3"),
+#'   selected = last_choice()
+#' )
+#'
+#' @name delayed_choices
+
+#' @export
+#' @rdname delayed_choices
+all_choices <- function() {
+  structure(
+    function(x) {
+      x
+    },
+    class = c("all_choices", "delayed_choices")
+  )
+}
+
+#' @export
+#' @rdname delayed_choices
+first_choice <- function() {
+  structure(
+    function(x) {
+      if (length(x) == 0L) {
+        x
+      } else if (is.atomic(x)) {
+        x[1L]
+      } else if (inherits(x, "delayed_data")) {
+        original_fun <- x$subset
+        added_fun <- function(x) x[1L]
+        x$subset <- function(data) {
+          added_fun(original_fun(x))
+          x
+        }
+      }
+    },
+    class = c("delayed_choices")
+  )
+}
+
+#' @export
+#' @rdname delayed_choices
+last_choice <- function() {
+  structure(
+    function(x) {
+      if (length(x) == 0L) {
+        x
+      } else if (is.atomic(x)) {
+        x[length(x)]
+      } else if (inherits(x, "delayed_data")) {
+        original_fun <- x$subset
+        added_fun <- function(x) x[length(x)]
+        x$subset <- function(data) {
+          added_fun(original_fun(x))
+          x
+        }
+
+      }
+    },
+    class = c("delayed_choices")
+  )
+}

R/filter_spec.R

@@ -36,11 +36,11 @@
 #' The `sep` input has to be `" - "` in this case.
 #'
 #' `delayed_data` objects can be created via [variable_choices()] or [value_choices()].
-#' @param selected (`character` or `numeric` or `logical` or (`delayed_data` or `all_choices`) object.
+#' @param selected (`character` or `numeric` or `logical` or (`delayed_data` or `delayed_choices`) object.
 #' Named character vector to define the selected values of a shiny [shiny::selectInput()]
 #' (default values).
 #' This value will be displayed inside the shiny app upon start.
-#' The `all_choices` object indicates selecting all possible choices.
+#' `delayed_choices` objects resolve selection when choices become available.
 #' @param drop_keys (`logical`) optional, whether to drop filter column from the
 #' dataset keys, `TRUE` on default.
 #' @param label (`character`) optional, defines a label on top of this specific
@@ -133,7 +133,7 @@ filter_spec <- function(vars,
     checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
     checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
     checkmate::check_class(selected, "delayed_data"),
-    checkmate::check_class(selected, "all_choices")
+    checkmate::check_class(selected, "delayed_choices")
   )
 
   checkmate::assert_flag(multiple)
@@ -142,7 +142,7 @@ filter_spec <- function(vars,
   checkmate::assert_flag(drop_keys)
   stopifnot(multiple || !inherits(selected, "all_choices"))
 
-  if (inherits(selected, "all_choices") && !is.null(choices)) selected <- choices
+  if (inherits(selected, "delayed_choices") && !is.null(choices)) selected <- selected(choices)
 
   if (inherits(vars, "choices_selected")) {
     filter_spec_internal(
@@ -307,7 +307,7 @@ filter_spec_internal.delayed_data <- function(vars_choices,
     checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
     checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
     checkmate::check_class(selected, "delayed_data"),
-    checkmate::check_class(selected, "all_choices")
+    checkmate::check_class(selected, "delayed_choices")
   )
 
   structure(
@@ -376,7 +376,7 @@ filter_spec_internal.default <- function(vars_choices,
     stopifnot(all(vapply(split_choices, length, integer(1)) == length(vars_selected)))
   }
 
-  if (!is.null(selected) && !inherits(selected, "all_choices")) {
+  if (!is.null(selected) && !inherits(selected, "delayed_choices")) {
     stopifnot(multiple || length(selected) == 1)
     checkmate::assert(
       checkmate::check_character(selected, min.len = 1, any.missing = FALSE),

R/select_spec.R

@@ -13,9 +13,9 @@
 #' These have to be columns in the dataset defined in the [data_extract_spec()]
 #' where this is called.
 #' `delayed_data` objects can be created via [variable_choices()] or [value_choices()].
-#' @param selected (`character` or `NULL` or `all_choices` or `delayed_data`) optional
+#' @param selected (`character` or `NULL` or `delayed_choices` or `delayed_data`) optional
 #' named character vector to define the selected values of a shiny [shiny::selectInput()].
-#' Passing an `all_choices()` object indicates selecting all possible choices.
+#' Passing a `delayed_choices` object defers selection until data is available.
 #' Defaults to the first value of `choices` or `NULL` for delayed data loading.
 #' @param multiple (`logical`) Whether multiple values shall be allowed in the
 #' shiny [shiny::selectInput()].
@@ -71,7 +71,7 @@
 #'   fixed = FALSE
 #' )
 #'
-#' # all_choices passed to selected
+#' # delayed_choices passed to selected
 #' select_spec(
 #'   label = "Select variable:",
 #'   choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
@@ -98,7 +98,7 @@ select_spec <- function(choices,
   stopifnot(multiple || !inherits(selected, "all_choices"))
   if (fixed) stopifnot(is.null(always_selected))
 
-  if (inherits(selected, "all_choices")) selected <- choices
+  if (inherits(selected, "delayed_choices")) selected <- selected(choices)
   if (inherits(choices, "delayed_data") || inherits(selected, "delayed_data")) {
     select_spec.delayed_data(choices, selected, multiple, fixed, always_selected, ordered, label)
   } else {

_pkgdown.yml

@@ -29,6 +29,8 @@ reference:
     contents:
       - add_no_selected_choices
       - all_choices
+      - first_choice
+      - last_choice
       - check_no_multiple_selection
       - choices_labeled
       - choices_selected