All datanames to transform@669 insert UI@main (#1302)

Changed the way how datanames are passed between teal_data instances

DESCRIPTION

@@ -45,7 +45,6 @@ Imports:
     jsonlite,
     lifecycle (>= 0.2.0),
     logger (>= 0.2.0),
-    magrittr (>= 1.5),
     methods,
     promises (>= 1.3.0),
     renv (>= 1.0.7),
@@ -114,6 +113,7 @@ Collate:
     'teal_data_module.R'
     'teal_data_module-eval_code.R'
     'teal_data_module-within.R'
+    'teal_data_utils.R'
     'teal_lockfile.R'
     'teal_reporter.R'
     'teal_slices-store.R'

NAMESPACE

@@ -16,7 +16,6 @@ S3method(ui_teal_module,shiny.tag)
 S3method(ui_teal_module,teal_module)
 S3method(ui_teal_module,teal_modules)
 S3method(within,teal_data_module)
-export("%>%")
 export(TealReportCard)
 export(as.teal_slices)
 export(as_tdata)
@@ -49,7 +48,6 @@ export(validate_one_row_per_id)
 import(shiny)
 import(teal.data)
 import(teal.slice)
-importFrom(magrittr,"%>%")
 importFrom(methods,new)
 importFrom(methods,setMethod)
 importFrom(shiny,reactiveVal)

NEWS.md

@@ -2,8 +2,10 @@
 
 ### Breaking changes
 * The `landing_popup_module()` needs to be passed as the `landing_popup` argument of `init` instead of being passed as a module of the `modules` argument of `init`
+* `teal` no longer re-export `%>%` from `magrittr`. Please load `library(magrittr)` instead or use `|>` from `base`. 
 
 ### Enhancement
+
 * Provided progress bar for modules loading and data filtering during teal app startup.
 
 ### New features

R/get_rcode_utils.R

@@ -26,47 +26,3 @@ get_rcode_str_install <- function() {
     "# Add any code to install/load your NEST environment here\n"
   }
 }
-
-#' Get datasets code
-#'
-#' Retrieve complete code to create, verify, and filter a dataset.
-#'
-#' @param datanames (`character`) names of datasets to extract code from
-#' @param datasets (`FilteredData`) object
-#' @param hashes named (`list`) of hashes per dataset
-#'
-#' @return Character string concatenated from the following elements:
-#'  - data pre-processing code (from `data` argument in `init`)
-#'  - hash check of loaded objects
-#'  - filter code (if any)
-#'
-#' @keywords internal
-get_datasets_code <- function(datanames, datasets, hashes) {
-  # preprocessing code
-  str_prepro <- attr(datasets, "preprocessing_code")
-  if (length(str_prepro) == 0) {
-    str_prepro <- "message('Preprocessing is empty')"
-  } else {
-    str_prepro <- paste(str_prepro, collapse = "\n")
-  }
-
-  # hash checks
-  str_hash <- vapply(datanames, function(dataname) {
-    sprintf(
-      "stopifnot(%s == %s)",
-      deparse1(bquote(rlang::hash(.(as.name(dataname))))),
-      deparse1(hashes[[dataname]])
-    )
-  }, character(1))
-  str_hash <- paste(str_hash, collapse = "\n")
-
-  # filter expressions
-  str_filter <- teal.slice::get_filter_expr(datasets, datanames)
-  if (str_filter == "") {
-    str_filter <- character(0)
-  }
-
-  # concatenate all code
-  str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")
-  sprintf("%s\n", str_code)
-}

R/init.R

@@ -215,20 +215,20 @@ init <- function(data,
 
   ## `data` - `modules`
   if (inherits(data, "teal_data")) {
-    if (length(teal_data_datanames(data)) == 0) {
+    if (length(.teal_data_datanames(data)) == 0) {
       stop("The environment of `data` is empty.")
     }
 
     if (!length(teal.data::datanames(data))) {
       warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
     }
 
-    is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
+    is_modules_ok <- check_modules_datanames(modules, .teal_data_datanames(data))
     if (!isTRUE(is_modules_ok)) {
       logger::log_warn(is_modules_ok)
     }
 
-    is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
+    is_filter_ok <- check_filter_datanames(filter, .teal_data_datanames(data))
     if (!isTRUE(is_filter_ok)) {
       warning(is_filter_ok)
       # we allow app to continue if applied filters are outside

R/module_data_summary.R

@@ -24,7 +24,7 @@ ui_data_summary <- function(id) {
   ns <- NS(id)
   content_id <- ns("filters_overview_contents")
   tags$div(
-    id = id, # not used, can be used to customize CSS behavior
+    id = id,
     class = "well",
     tags$div(
       class = "row",
@@ -93,6 +93,8 @@ srv_data_summary <- function(id, teal_data) {
           if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
             stop("Error occurred during data processing. See details in the main panel.")
           }
+        } else if (is.null(summary_table_out)) {
+          "no datasets to show"
         } else {
           body_html <- apply(
             summary_table_out,
@@ -144,7 +146,7 @@ get_filter_overview <- function(teal_data) {
     simplify = FALSE
   )
   unfiltered_data_objs <- sapply(
-    datanames, function(name) teal.code::get_env(teal_data())[[paste0(name, "_raw")]],
+    datanames, function(name) teal.code::get_env(teal_data())[[paste0(name, "._raw_")]],
     simplify = FALSE
   )
 

R/module_filter_data.R

@@ -6,7 +6,8 @@
 #' this special implementation all modules' data are recalculated only for those modules which are
 #' currently displayed.
 #'
-#' @return A `eventReactive` which triggers only if all conditions are met:
+#' @return A `eventReactive` containing `teal_data` containing filtered objects and filter code.
+#' `eventReactive` triggers only if all conditions are met:
 #'  - tab is selected (`is_active`)
 #'  - when filters are changed (`get_filter_expr` is different than previous)
 #'
@@ -32,10 +33,11 @@ srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active)
         # render will be triggered only when FilteredData object changes (not when filters change)
         # technically it means that teal_data_module needs to be refreshed
         logger::log_debug("srv_filter_panel rendering filter panel.")
-        filtered_data <- datasets()
-        filtered_data$srv_active("filters", active_datanames = active_datanames)
-        # todo: make sure to bump the `teal.slice` version. Please use the branch `669_insertUI@main` in `teal.slice`.
-        filtered_data$ui_active(session$ns("filters"), active_datanames = active_datanames)
+        if (length(active_datanames())) {
+          datasets()$srv_active("filters", active_datanames = active_datanames)
+          # todo: make sure to bump the `teal.slice` version. Please use the branch `669_insertUI@main` in `teal.slice`.
+          datasets()$ui_active(session$ns("filters"), active_datanames = active_datanames)
+        }
       })
     })
 
@@ -49,33 +51,12 @@ srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active)
 
 #' @rdname module_filter_data
 .make_filtered_teal_data <- function(modules, data, datasets = NULL, datanames) {
-  new_datasets <- c(
-    # Filtered data
-    sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE),
-    # Raw (unfiltered data)
-    stats::setNames(
-      lapply(datanames, function(x) datasets$get_data(x, filtered = FALSE)),
-      sprintf("%s_raw", datanames)
-    )
-  )
-
-  data_code <- teal.data::get_code(data, datanames = datanames)
-  raw_data_code <- sprintf("%1$s_raw <- %1$s", datanames)
-  filter_code <- get_filter_expr(datasets = datasets, datanames = datanames)
-
-  all_code <- paste(unlist(c(data_code, raw_data_code, "", filter_code)), collapse = "\n")
-  tdata <- do.call(
-    teal.data::teal_data,
-    c(
-      list(code = trimws(all_code, which = "right")),
-      list(join_keys = teal.data::join_keys(data)),
-      new_datasets
-    )
-  )
-  tdata@verified <- data@verified
-  # we want to keep same datanames that app dev initially set with respect to new teal_data's @env
-  teal.data::datanames(tdata) <- intersect(teal.data::datanames(data), teal_data_ls(tdata))
-  tdata
+  data <- eval_code(data, sprintf("%1$s._raw_ <- %1$s", datanames))
+  filtered_code <- teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)
+  filtered_teal_data <- .append_evaluated_code(data, filtered_code)
+  filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
+  filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)
+  filtered_teal_data
 }
 
 #' @rdname module_filter_data
@@ -84,8 +65,8 @@ srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active)
   filter_changed <- reactive({
     req(inherits(datasets(), "FilteredData"))
     new_signature <- c(
-      get_code(data_rv()),
-      get_filter_expr(datasets = datasets(), datanames = active_datanames())
+      teal.data::get_code(data_rv()),
+      teal.slice::get_filter_expr(datasets = datasets(), datanames = active_datanames())
     )
     if (!identical(previous_signature(), new_signature)) {
       previous_signature(new_signature)

R/module_init_data.R

@@ -107,7 +107,7 @@ srv_init_data <- function(id, data, modules, filter = teal_slices()) {
         )
       }
 
-      is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data_validated()))
+      is_filter_ok <- check_filter_datanames(filter, .teal_data_datanames(data_validated()))
       if (!isTRUE(is_filter_ok)) {
         showNotification(
           "Some filters were not applied because of incompatibility with data. Contact app developer.",
@@ -172,7 +172,7 @@ srv_init_data <- function(id, data, modules, filter = teal_slices()) {
 #' @return A character vector with the code lines.
 #' @keywords internal
 #'
-.get_hashes_code <- function(data, datanames = teal_data_datanames(data)) {
+.get_hashes_code <- function(data, datanames = .teal_data_datanames(data)) {
   # todo: this should be based on data_rv object not on datasets
   vapply(
     datanames,

R/module_nested_tabs.R

@@ -228,9 +228,8 @@ srv_teal_module.teal_module <- function(id,
 
     module_teal_data <- reactive({
       all_teal_data <- transformed_teal_data()
-      # todo: create a new teal_data object with code subset, datasets and datanames (not just limit datanames)
-      teal.data::datanames(all_teal_data) <- .resolve_module_datanames(data = all_teal_data, modules = modules)
-      all_teal_data
+      module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)
+      .subset_teal_data(all_teal_data, module_datanames)
     })
 
     module_teal_data_validated <- srv_validate_reactive_teal_data(
@@ -302,11 +301,11 @@ srv_teal_module.teal_module <- function(id,
 .resolve_module_datanames <- function(data, modules) {
   stopifnot("data_rv must be teal_data object." = inherits(data, "teal_data"))
   if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
-    teal_data_datanames(data)
+    .teal_data_datanames(data)
   } else {
     intersect(
       include_parent_datanames(modules$datanames, teal.data::join_keys(data)),
-      teal_data_ls(data)
+      .teal_data_ls(data)
     )
   }
 }

R/module_teal_data.R

@@ -162,7 +162,7 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
 
     output$shiny_warnings <- renderUI({
       if (inherits(data_out_rv(), "teal_data")) {
-        is_modules_ok <- check_modules_datanames(modules = modules, datanames = teal_data_ls(data_validated()))
+        is_modules_ok <- check_modules_datanames(modules = modules, datanames = .teal_data_ls(data_validated()))
         if (!isTRUE(is_modules_ok)) {
           tags$div(is_modules_ok, class = "teal-output-warning")
         }

R/tdata.R

@@ -188,12 +188,12 @@ as_tdata <- function(x) {
   }
   if (is.reactive(x)) {
     checkmate::assert_class(isolate(x()), "teal_data")
-    datanames <- isolate(teal_data_datanames(x()))
+    datanames <- isolate(.teal_data_datanames(x()))
     datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
     code <- reactive(teal.code::get_code(x()))
     join_keys <- isolate(teal.data::join_keys(x()))
   } else if (inherits(x, "teal_data")) {
-    datanames <- teal_data_datanames(x)
+    datanames <- .teal_data_datanames(x)
     datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
     code <- reactive(teal.code::get_code(x))
     join_keys <- isolate(teal.data::join_keys(x))

R/teal.R

@@ -12,6 +12,4 @@
 #' @import shiny teal.data teal.slice
 #' @importFrom stats setNames
 #' @export
-#' @importFrom magrittr %>%
-magrittr::`%>%`
 NULL

R/teal_data_utils.R

@@ -0,0 +1,85 @@
+#' `teal_data` utils
+#'
+#' In `teal` we need to recreate the `teal_data` object due to two operations:integer.max
+#' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and
+#' we want to avoid double-evaluation.
+#' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code
+#'
+#' Due to above recreation of `teal_data` object can't be done simply by using public
+#' `teal.code` and `teal.data` methods.
+#'
+#' @param data (`teal_data`)
+#' @param code (`character`) code to append to `data@code`
+#' @param objects (`list`) objects to append to `data@env`
+#' @param datanames (`character`) names of the datasets
+#' @return modified `teal_data`
+#' @name teal_data_utilities
+NULL
+
+#' @rdname teal_data_utilities
+.append_evaluated_code <- function(data, code) {
+  checkmate::assert_class(data, "teal_data")
+  data@code <- c(data@code, code)
+  data@id <- c(data@id, max(data@id) + 1L + seq_along(code))
+  data@messages <- c(data@messages, rep("", length(code)))
+  data@warnings <- c(data@warnings, rep("", length(code)))
+  methods::validObject(data)
+  data
+}
+
+#' @rdname teal_data_utilities
+.append_modified_data <- function(data, objects) {
+  checkmate::assert_class(data, "teal_data")
+  checkmate::assert_class(objects, "list")
+  new_env <- list2env(objects, parent = .GlobalEnv)
+  rlang::env_coalesce(new_env, data@env)
+  data@env <- new_env
+  data
+}
+
+#' @rdname teal_data_utilities
+.subset_teal_data <- function(data, datanames) {
+  checkmate::assert_class(data, "teal_data")
+  checkmate::assert_class(datanames, "character")
+  datanames_corrected <- intersect(datanames, ls(data@env))
+  dataname_corrected_with_raw <- intersect(c(datanames, sprintf("%s._raw_", datanames)), ls(data@env))
+
+  if (!length(datanames)) {
+    return(teal_data())
+  }
+
+  new_data <- do.call(
+    teal.data::teal_data,
+    args = c(
+      mget(x = dataname_corrected_with_raw, envir = data@env),
+      list(
+        code = gsub(
+          "warning('Code was not verified for reproducibility.')\n",
+          "",
+          teal.data::get_code(data, datanames = dataname_corrected_with_raw),
+          fixed = TRUE
+        ),
+        join_keys = teal.data::join_keys(data)[datanames_corrected]
+      )
+    )
+  )
+  new_data@verified <- data@verified
+  teal.data::datanames(new_data) <- datanames_corrected
+  new_data
+}
+
+#' @rdname teal_data_utilities
+.teal_data_datanames <- function(data) {
+  checkmate::assert_class(data, "teal_data")
+  datanames <- teal.data::datanames(data)
+  if (length(datanames)) {
+    datanames
+  } else {
+    .teal_data_ls(data)
+  }
+}
+
+#' @rdname teal_data_utilities
+.teal_data_ls <- function(data) {
+  grep("._raw_", ls(teal.code::get_env(data), all.names = TRUE), value = TRUE, invert = TRUE)
+}