merge fix

R/data_extract_module.R

@@ -576,6 +576,11 @@ data_extract_srv.list <- function(id, datasets, data_extract_spec, join_keys = N
 #' }
 data_extract_multiple_srv <- function(data_extract, datasets, ...) {
   checkmate::assert_list(data_extract, names = "named")
+  lapply(data_extract, function(x) {
+    if (is.list(x) && !inherits(x, "data_extract_spec")) {
+      checkmate::assert_list(x, "data_extract_spec")
+    }
+  })
   checkmate::assert_multi_class(datasets, classes = c("FilteredData", "list"))
   UseMethod("data_extract_multiple_srv", datasets)
 }

R/data_merge_module.R

@@ -100,7 +100,12 @@ data_merge_module <- function(datasets,
                               id = "merge_id") {
   logger::log_trace("data_merge_module called with: { paste(datasets$datanames(), collapse = ', ') } datasets.")
 
-  checkmate::assert_list(data_extract)
+  checkmate::assert_list(data_extract, c("list", "data_extract_spec"))
+  lapply(data_extract, function(x) {
+    if (is.list(x) && !inherits(x, "data_extract_spec")) {
+      checkmate::assert_list(x, "data_extract_spec")
+    }
+  })
 
   selector_list <- data_extract_multiple_srv(data_extract, datasets)
 
@@ -254,6 +259,8 @@ data_merge_srv <- function(id = "merge_id",
         )
         ch <- teal.code::chunks_new()
         datasets_list_nr <- sapply(datasets$datanames(), simplify = FALSE, datasets$get_data, filtered = TRUE)
+        names(datasets_list_nr) <- paste0(names(datasets_list_nr), "_FILTERED")
+
         teal.code::chunks_reset(envir = list2env(datasets_list_nr), chunks = ch)
         for (chunk in merged_data$expr) teal.code::chunks_push(expression = chunk, chunks = ch)
         teal.code::chunks_safe_eval(chunks = ch)

R/merge_datasets.R

@@ -80,15 +80,6 @@ merge_datasets <- function(selector_list, datasets, join_keys, merge_function =
 
   selector_datanames <- unique(vapply(merged_selector_list, `[[`, character(1), "dataname"))
 
-  filtered_data_call <- lapply(selector_datanames, function(i) {
-    logger::log_trace("merge_datasets { paste0(i, \"_FILTERED\") } assigned.")
-    call(
-      "<-",
-      as.name(paste0(i, "_FILTERED")),
-      as.name(i)
-    )
-  })
-
   dplyr_calls <- lapply(seq_along(merged_selector_list), function(idx) {
     dplyr_call <- get_dplyr_call(
       selector_list = merged_selector_list,
@@ -113,7 +104,7 @@ merge_datasets <- function(selector_list, datasets, join_keys, merge_function =
     anl_name = anl_name
   )
 
-  all_calls_expression <- c(filtered_data_call, dplyr_calls, anl_merge_calls, anl_relabel_call)
+  all_calls_expression <- c(dplyr_calls, anl_merge_calls, anl_relabel_call)
 
   # keys in each merged_selector_list element should be identical
   # so take first one

R/merge_expression_module.R

@@ -146,7 +146,12 @@ merge_expression_module <- function(datasets,
                                     id = "merge_id") {
   logger::log_trace("merge_expression_module called with: { paste(names(datasets), collapse = ', ') } datasets.")
 
-  checkmate::assert_list(data_extract, types = "data_extract_spec", names = "named")
+  checkmate::assert_list(data_extract, names = "named", types = c("list", "data_extract_spec"))
+  lapply(data_extract, function(x) {
+    if (is.list(x) && !inherits(x, "data_extract_spec")) {
+      checkmate::assert_list(x, "data_extract_spec")
+    }
+  })
 
   selector_list <- data_extract_multiple_srv(data_extract, datasets, join_keys)
 

tests/testthat/test-dplyr_call_examples.R

@@ -3454,9 +3454,6 @@ testthat::test_that("Universal example", {
     paste(merged_datasets$expr),
     paste(
       c(
-        "X_FILTERED <- X",
-        "Y_FILTERED <- Y",
-        "Z_FILTERED <- Z",
         "ANL_1 <- X_FILTERED %>% dplyr::select(A, B, D, E)",
         "ANL_2 <- Y_FILTERED %>% dplyr::select(A, B, C, G) %>% dplyr::rename(y.G = G)",
         "ANL_3 <- Z_FILTERED %>% dplyr::select(D, C, F, G) %>% dplyr::rename(z.G = G)",

tests/testthat/test-merge_expression_module.R

@@ -74,17 +74,19 @@ testthat::test_that("merge_expression_module returns a reactive containing a lis
 })
 
 testthat::test_that("merge_expression_module throws error if data_extract is not a list of data_extract_spec", {
-  shiny::withReactiveDomain(
-    domain = shiny::MockShinySession$new(),
-    expr = testthat::expect_error(
-      merge_expression_module(
-        data_extract = list(adsl_var = adsl_extract, adlb_var = "aa"),
-        datasets = data_list,
-        join_keys = join_keys
-      ),
-      "May only contain the following types: {data_extract_spec}, but element 2 has type 'character'",
-      fixed = TRUE
-    )
+  testthat::expect_error(
+    shiny::withReactiveDomain(
+      domain = shiny::MockShinySession$new(),
+      expr = {
+        merge_expression_module(
+          data_extract = list(adsl_var = adsl_extract, adlb_var = "aa"),
+          datasets = data_list,
+          join_keys = join_keys
+        )
+      }
+    ),
+    "May only contain the following types: {list,data_extract_spec}, but element 2 has type 'character'",
+    fixed = TRUE
   )
 })
 

tests/testthat/test-merge_expression_srv.R

@@ -225,8 +225,6 @@ testthat::test_that("merge_expression_srv returns merge expression when passing
       testthat::expect_true(inherits(session$returned()$expr[[1]], "<-"))
       testthat::expect_identical(
         c(
-          "ADSL_FILTERED <- ADSL",
-          "ADLB_FILTERED <- ADLB",
           "ANL_1 <- ADSL_FILTERED %>% dplyr::select(STUDYID, USUBJID, AGE)",
           "ANL_2 <- ADLB_FILTERED %>% dplyr::select(STUDYID, USUBJID, AVAL, CHG)",
           "ANL <- ANL_1",