Closes #2645 (fix slice_derivation on empty dataset)

NEWS.md

@@ -4,6 +4,8 @@
 
 ## Updates of Existing Functions
 
+- In `slice_derivation`, previously the derivation is not called for empty subsets, however this can lead to issues when the input dataset is empty. Now the derivation is called for all subsets.
+
 ## Breaking Changes
 
 - The following function arguments are entering the next phase of the [deprecation process](https://pharmaverse.github.io/admiraldev/articles/programming_strategy.html#deprecation): (#2487) (#2595)

R/slice_derivation.R

@@ -39,6 +39,8 @@
 #'
 #'   - Observations that match with more than one slice are only considered for
 #'   the first matching slice.
+#' 
+#'   - The derivation is called for slices with no observations.
 #'
 #'   - Observations with no match to any of the slices are included in the
 #'   output dataset but the derivation is not called for them.
@@ -109,48 +111,37 @@ slice_derivation <- function(dataset,
     dataset,
     temp_slicenr = !!slice_call
   )
-
-  # split dataset into slices
-  dataset_split <- dataset %>%
-    group_by(temp_slicenr) %>%
-    nest()
-
+  ret <- list()
   # call derivation for each slice
   for (i in seq_along(slices)) {
     # call derivation on subset
     # remove global arguments which were specified by the slice
     act_args <- args[names(args) %notin% names(slices[[i]]$args)]
 
     call <- call2(derivation, expr(data), !!!act_args, !!!slices[[i]]$args)
-    obsnr <- which(dataset_split$temp_slicenr == i)
-    if (length(obsnr) > 0) {
-      # call the derivation for non-empty slices only
-      # create environment in which the call to the derivation is evaluated
-      act_env <- attr(args, "env")
-      slice_env <- attr(slices[[i]]$args, "env")
-      if (!identical(act_env, slice_env)) {
-        # prefer objects in the slice environment to object in args environment
-        # Note: objects in any of the parent environments of the slice environment are ignored.
-        eval_env <- new_environment(
-          data = c(list(data = dataset_split$data[[obsnr]]), as.list(slice_env)),
-          parent = act_env
-        )
-      } else {
-        eval_env <- new_environment(
-          data = list(data = dataset_split$data[[obsnr]]),
-          parent = act_env
-        )
-      }
-
-      dataset_split$data[[obsnr]] <-
-        eval_tidy(call, env = eval_env)
+    obsnr <- which(dataset$temp_slicenr == i)
+    # call the derivation for non-empty slices only
+    # create environment in which the call to the derivation is evaluated
+    act_env <- attr(args, "env")
+    slice_env <- attr(slices[[i]]$args, "env")
+    if (!identical(act_env, slice_env)) {
+      # prefer objects in the slice environment to object in args environment
+      # Note: objects in any of the parent environments of the slice environment are ignored.
+      eval_env <- new_environment(
+        data = c(list(data = dataset[obsnr, , drop = FALSE]), as.list(slice_env)),
+        parent = act_env
+      )
+    } else {
+      eval_env <- new_environment(
+        data = list(data = dataset[obsnr, , drop = FALSE]),
+        parent = act_env
+      )
     }
-  }
 
+    ret[[i]] <- eval_tidy(call, env = eval_env)
+  }
   # put datasets together again
-  dataset_split %>%
-    unnest(cols = c(data)) %>%
-    ungroup() %>%
+  bind_rows(ret, dataset[is.na(dataset$temp_slicenr), , drop = FALSE]) %>%
     select(-temp_slicenr)
 }
 

tests/testthat/test-slice_derivation.R

@@ -193,3 +193,40 @@ test_that("slice_derivation Test 5: calling it in a function", {
     keys = "USUBJID"
   )
 })
+
+## Test 6: slice on 0-row dataset ----
+test_that("slice_derivation Test 6: slice on 0-row dataset", {
+  advs <- tibble::tribble(
+    ~USUBJID, ~VSDTC,       ~VSTPT,             ~VSSEQ,
+    "1",      "2020-04-16", NA_character_,      1,
+    "1",      "2020-04-16", "BEFORE TREATMENT", 2
+  )
+
+  actual <- slice_derivation(
+    advs[c(-1, -2), ],
+    derivation = derive_vars_dtm,
+    args = params(
+      dtc = VSDTC,
+      new_vars_prefix = "A"
+    ),
+    derivation_slice(
+      filter = str_detect(VSTPT, "PRE|BEFORE"),
+      args = params(time_imputation = "first")
+    ),
+    derivation_slice(
+      filter = TRUE,
+      args = params(time_imputation = "last")
+    )
+  )
+
+  expected <- mutate(
+    advs[c(-1, -2), ],
+    ADTM = as.POSIXct(numeric(0), tz = "UTC"),
+    ATMF = character(0)
+  )
+
+  expect_identical(
+    expected,
+    actual
+  )
+})