tdata to teal_data (#163)

insightsengineering · Dec 8, 2023 · 2d9b202 · 2d9b202
1 parent bd18048
commit 2d9b202
Show file tree

Hide file tree

Showing 63 changed files with 985 additions and 2,236 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -32,15 +32,14 @@ Imports:
     shinyjs,
     shinyvalidate,
     stats,
-    teal.data (>= 0.3.0.9010),
+    teal.data (>= 0.3.0.9017),
     teal.logger (>= 0.1.1),
-    teal.slice (>= 0.4.0.9023),
     teal.widgets (>= 0.4.0),
     tidyr (>= 0.8.3),
     tidyselect
 Suggests:
     knitr (>= 1.42),
-    shinytest (>= 1.5.1),
+    rmarkdown (>= 2.19),
     teal.code (>= 0.4.0),
     testthat (>= 3.1.5)
 VignetteBuilder:
@@ -49,10 +48,10 @@ RdMacros:
     lifecycle
 Config/Needs/verdepcheck: tidyverse/magrittr, mllg/checkmate,
     tidyverse/dplyr, r-lib/lifecycle, daroczig/logger, r-lib/rlang,
-    rstudio/shiny, daattali/shinyjs, rstudio/shinyvalidate,
+    rstudio/rmarkdown, rstudio/shiny, daattali/shinyjs, rstudio/shinyvalidate,
     insightsengineering/teal.data, insightsengineering/teal.logger,
-    insightsengineering/teal.slice, insightsengineering/teal.widgets,
-    tidyverse/tidyr, r-lib/tidyselect, yihui/knitr, rstudio/shinytest,
+    insightsengineering/teal.widgets,
+    tidyverse/tidyr, r-lib/tidyselect, yihui/knitr,
     insightsengineering/teal.code, r-lib/testthat
 Config/Needs/website: insightsengineering/nesttemplate
 Encoding: UTF-8

diff --git a/NAMESPACE b/NAMESPACE
@@ -2,10 +2,15 @@
 
 S3method(data_extract_multiple_srv,FilteredData)
 S3method(data_extract_multiple_srv,list)
+S3method(data_extract_multiple_srv,reactive)
 S3method(data_extract_srv,FilteredData)
 S3method(data_extract_srv,list)
 S3method(filter_spec_internal,default)
 S3method(filter_spec_internal,delayed_data)
+S3method(merge_expression_module,list)
+S3method(merge_expression_module,reactive)
+S3method(merge_expression_srv,list)
+S3method(merge_expression_srv,reactive)
 S3method(print,choices_labeled)
 S3method(print,delayed_choices_selected)
 S3method(print,delayed_data_extract_spec)
@@ -24,12 +29,8 @@ S3method(resolve,delayed_variable_choices)
 S3method(resolve,list)
 S3method(resolve_delayed,FilteredData)
 S3method(resolve_delayed,list)
-S3method(value_choices,TealDataset)
-S3method(value_choices,TealDatasetConnector)
 S3method(value_choices,character)
 S3method(value_choices,data.frame)
-S3method(variable_choices,TealDataset)
-S3method(variable_choices,TealDatasetConnector)
 S3method(variable_choices,character)
 S3method(variable_choices,data.frame)
 export(add_no_selected_choices)
@@ -42,8 +43,6 @@ export(data_extract_multiple_srv)
 export(data_extract_spec)
 export(data_extract_srv)
 export(data_extract_ui)
-export(data_merge_module)
-export(data_merge_srv)
 export(datanames_input)
 export(filter_spec)
 export(format_data_extract)

diff --git a/R/Queue.R b/R/Queue.R
@@ -105,6 +105,5 @@ Queue <- R6::R6Class( # nolint
   private = list(
     array = c()
   ),
-
   lock_class = TRUE
 )
diff --git a/R/check_selector.R b/R/check_selector.R
@@ -21,9 +21,10 @@ check_selector_filters <- function(filters) {
     is.list(x) &&
       all(c("columns", "selected") %in% names(x)) &&
       checkmate::test_character(x$columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) &&
-      (is.null(x$selected) ||
-        all(vapply(x$selected, is.character, logical(1))) ||
-        all(vapply(x$selected, is.numeric, logical(1)))
+      (
+        is.null(x$selected) ||
+          all(vapply(x$selected, is.character, logical(1))) ||
+          all(vapply(x$selected, is.numeric, logical(1)))
       )
   }
   stopifnot(is.null(filters) || all(vapply(filters, check_selector_filter, logical(1))))

diff --git a/R/choices_labeled.R b/R/choices_labeled.R
@@ -117,10 +117,9 @@ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
 #'
 #' @description `r lifecycle::badge("stable")`
 #'
-#' @param data (`data.frame`, `character`, `TealDataset`, `TealDatasetConnector`)
+#' @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
-#' If `TealDataset` or `TealDatasetConnector`, then raw data to extract labels from.
 #' @param subset (`character` or `function`)
 #' If `character`, then a vector of column names.
 #' If `function`, then this function is used to determine the possible columns (e.g. all factor columns).
@@ -144,22 +143,15 @@ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
 #' variable_choices(ADRS)
 #' variable_choices(ADRS, subset = c("PARAM", "PARAMCD"))
 #' variable_choices(ADRS, subset = c("", "PARAM", "PARAMCD"))
-#' variable_choices(ADRS, subset = c("", "PARAM", "PARAMCD"), key = teal.data::get_cdisc_keys("ADRS"))
+#' variable_choices(
+#'   ADRS,
+#'   subset = c("", "PARAM", "PARAMCD"),
+#'   key = teal.data::default_cdisc_join_keys["ADRS", "ADRS"]
+#' )
 #'
 #' # delayed version
 #' variable_choices("ADRS", subset = c("USUBJID", "STUDYID"))
 #'
-#' # also works with [teal.data::TealDataset] and [teal.data::TealDatasetConnector]
-#' ADRS_dataset <- teal.data::dataset("ADRS", ADRS, key = teal.data::get_cdisc_keys("ADRS"))
-#' variable_choices(ADRS_dataset)
-#'
-#' ADRS_conn <- teal.data::dataset_connector(
-#'   "ADRS",
-#'   pull_callable = teal.data::callable_code("radrs(cached = TRUE)"),
-#'   key = teal.data::get_cdisc_keys("ADRS")
-#' )
-#' variable_choices(ADRS_conn)
-#'
 #' # functional subset (with delayed data) - return only factor variables
 #' variable_choices("ADRS", subset = function(data) {
 #'   idx <- vapply(data, is.factor, logical(1))
@@ -205,7 +197,8 @@ variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key =
 
   key <- intersect(subset, key)
 
-  var_types <- stats::setNames(teal.slice:::variable_types(data = data), names(data))
+  var_types <- vapply(data, function(x) class(x)[[1]], character(1))
+
   if (length(key) != 0) {
     var_types[key] <- "primary_key"
   }
@@ -237,49 +230,13 @@ variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key =
   return(res)
 }
 
-#' @rdname variable_choices
-#' @export
-variable_choices.TealDataset <- function(data, subset = NULL, fill = FALSE, key = teal.data::get_keys(data)) {
-  variable_choices(
-    data = teal.data::get_raw_data(data),
-    subset = subset,
-    fill = fill,
-    key = key
-  )
-}
-
-#' @rdname variable_choices
-#' @export
-variable_choices.TealDatasetConnector <- function(data, # nolint
-                                                  subset = NULL,
-                                                  fill = FALSE,
-                                                  key = teal.data::get_keys(data)) {
-  if (teal.data::is_pulled(data)) {
-    variable_choices(
-      data = teal.data::get_raw_data(data),
-      subset = subset,
-      fill = fill,
-      key = key
-    )
-  } else {
-    variable_choices(
-      data = teal.data::get_dataname(data),
-      subset = subset,
-      fill = fill,
-      key = key
-    )
-  }
-}
-
-
 #' Wrapper on [choices_labeled] to label variable values basing on other variable values
 #'
 #' @description `r lifecycle::badge("stable")`
 #'
-#' @param data (`data.frame`, `character`, `TealDataset`, `TealDatasetConnector`)
-#' If `data.frame`, then data to extract labels from
-#' If `character`, then name of the dataset to extract data from once available
-#' If `TealDataset` or `TealDatasetConnector`, then raw data to extract labels from.
+#' @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_label (`character`) vector with labels column names
 #' @param subset (`character` or `function`)
@@ -407,47 +364,6 @@ value_choices.data.frame <- function(data, # nolint
   return(res)
 }
 
-#' @rdname value_choices
-#' @export
-value_choices.TealDataset <- function(data,
-                                      var_choices,
-                                      var_label = NULL,
-                                      subset = NULL,
-                                      sep = " - ") {
-  value_choices(
-    data = teal.data::get_raw_data(data),
-    var_choices = var_choices,
-    var_label = var_label,
-    subset = subset,
-    sep = sep
-  )
-}
-
-#' @rdname value_choices
-#' @export
-value_choices.TealDatasetConnector <- function(data, # nolint
-                                               var_choices,
-                                               var_label = NULL,
-                                               subset = NULL,
-                                               sep = " - ") {
-  if (teal.data::is_pulled(data)) {
-    value_choices(
-      data = teal.data::get_raw_data(data),
-      var_choices = var_choices,
-      var_label = var_label,
-      subset = subset,
-      sep = sep
-    )
-  } else {
-    value_choices(
-      data = teal.data::get_dataname(data),
-      var_choices = var_choices,
-      var_label = var_label,
-      subset = subset,
-      sep = sep
-    )
-  }
-}
 #' Print choices_labeled object
 #' @description `r lifecycle::badge("stable")`
 #' @rdname choices_labeled

diff --git a/R/choices_selected.R b/R/choices_selected.R
@@ -148,16 +148,7 @@ choices_selected <- function(choices,
   # remove duplicates
   choices <- vector_remove_dups(choices)
   selected <- vector_remove_dups(selected)
-
-  if (!all(selected %in% choices)) {
-    stop(paste(
-      paste(
-        selected[which(!selected %in% choices)],
-        collapse = ", "
-      ),
-      "'selected' but not in 'choices'"
-    ))
-  }
+  checkmate::assert_subset(selected, choices)
 
   if (!keep_order && length(choices) > 0) {
     choices_in_selected <- which(choices %in% selected)

diff --git a/R/data_extract_datanames.R b/R/data_extract_datanames.R
@@ -37,9 +37,7 @@ get_extract_datanames <- function(data_extracts) {
   stopifnot(length(data_extracts) > 0)
   stopifnot(
     checkmate::test_list(data_extracts, types = "data_extract_spec") ||
-      all(
-        vapply(data_extracts, function(x) checkmate::test_list(x, types = "data_extract_spec"), logical(1))
-      )
+      all(vapply(data_extracts, function(x) checkmate::test_list(x, types = "data_extract_spec"), logical(1)))
   )
 
   datanames <- lapply(data_extracts, function(x) {

diff --git a/R/data_extract_filter_module.R b/R/data_extract_filter_module.R
@@ -18,18 +18,18 @@ data_extract_filter_ui <- function(filter, id = "filter") {
 
   html_col <- teal.widgets::optionalSelectInput(
     inputId = ns("col"),
-    label = filter$vars_label,
-    choices = filter$vars_choices,
-    selected = filter$vars_selected,
+    label = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_label),
+    choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_choices),
+    selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_selected),
     multiple = filter$vars_multiple,
     fixed = filter$vars_fixed
   )
 
   html_vals <- teal.widgets::optionalSelectInput(
     inputId = ns("vals"),
     label = filter$label,
-    choices = filter$choices,
-    selected = filter$selected,
+    choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$choices),
+    selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$selected),
     multiple = filter$multiple,
     fixed = filter$fixed
   )
@@ -60,19 +60,31 @@ data_extract_filter_srv <- function(id, datasets, filter) {
       # We force the evaluation of filter, otherwise the observers are set up with the last element
       # of the list in data_extract_single_srv and not all of them (due to R lazy evaluation)
       force(filter)
-      logger::log_trace(
-        "data_extract_filter_srv initialized with: { filter$dataname } dataset."
-      )
+      logger::log_trace("data_extract_filter_srv initialized with: { filter$dataname } dataset.")
+
+      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
+        teal.widgets::updateOptionalSelectInput(
+          session = session,
+          inputId = "col",
+          choices = filter$vars_choices,
+          selected = filter$vars_selected
+        )
+        teal.widgets::updateOptionalSelectInput(
+          session = session,
+          inputId = "vals",
+          choices = filter$choices,
+          selected = filter$selected
+        )
+      })
 
-      observeEvent(input$col,
+      observeEvent(
+        input$col,
+        ignoreInit = TRUE, # When observeEvent is initialized input$col is still NULL as it is set few lines above
+        ignoreNULL = FALSE, # columns could be NULL, then vals should be set to NULL also
         handlerExpr = {
-          if (!filter$initialized) {
-            initial_inputs <- get_initial_filter_values(filter, datasets)
-            choices <- initial_inputs$choices
-            selected <- initial_inputs$selected
-            filter$initialized <- TRUE
-            filter <<- filter
-          } else if (!rlang::is_empty(input$col)) {
+          if (!rlang::is_empty(input$col)) {
             choices <- value_choices(
               datasets[[filter$dataname]](),
               input$col,
@@ -108,9 +120,7 @@ data_extract_filter_srv <- function(id, datasets, filter) {
             choices = choices,
             selected = selected
           )
-        },
-        ignoreInit = FALSE,
-        ignoreNULL = FALSE
+        }
       )
     }
   )