#2562 avoid_info_in_tests: catch message in wrapper function and reph…

…rase them
pharmaverse · Nov 15, 2024 · c17ebea · c17ebea
1 parent ebdb2f1
commit c17ebea
Show file tree

Hide file tree

Showing 10 changed files with 201 additions and 15 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -254,6 +254,7 @@ importFrom(rlang,as_string)
 importFrom(rlang,call2)
 importFrom(rlang,call_name)
 importFrom(rlang,caller_env)
+importFrom(rlang,cnd_muffle)
 importFrom(rlang,current_env)
 importFrom(rlang,enexpr)
 importFrom(rlang,enexprs)

diff --git a/R/admiral-package.R b/R/admiral-package.R
@@ -17,9 +17,9 @@
 #'             map_if map_lgl map2 modify_at modify_if pmap reduce transpose
 #'             walk
 #' @importFrom rlang := abort arg_match as_data_mask as_function as_label
-#'   as_name as_string call2 call_name caller_env current_env .data enexpr
-#'   enexprs eval_bare eval_tidy expr expr_interp exec expr_label exprs f_lhs
-#'   f_rhs  inform is_call is_expression is_missing is_named list2
+#'   as_name as_string call2 call_name caller_env cnd_muffle current_env .data
+#'   enexpr enexprs eval_bare eval_tidy expr expr_interp exec expr_label exprs
+#'   f_lhs f_rhs  inform is_call is_expression is_missing is_named list2
 #'   new_environment new_formula parse_expr parse_exprs set_names sym syms
 #'   type_of warn
 #' @importFrom stats setNames

diff --git a/R/derive_adeg_params.R b/R/derive_adeg_params.R
@@ -151,6 +151,7 @@ derive_param_qtc <- function(dataset,
     get_unit_expr = !!get_unit_expr
   )
 
+  withCallingHandlers(
   derive_param_computed(
     dataset,
     filter = !!filter,
@@ -164,6 +165,17 @@ derive_param_qtc <- function(dataset,
       ),
       !!!set_values_to
     )
+  ),
+  derive_param_computed_all_na = function(cnd) {
+    cli_inform(c(
+      paste(
+        "No computed records were added because for all potential computed",
+        "records at least one of the contributing values was {.val {NA}}."
+      ),
+      "If this is not expected, please check the input data."
+    ))
+    cnd_muffle(cnd)
+  }
   )
 }
 
@@ -343,6 +355,7 @@ derive_param_rr <- function(dataset,
     get_unit_expr = !!get_unit_expr
   )
 
+  withCallingHandlers(
   derive_param_computed(
     dataset,
     filter = !!filter,
@@ -352,6 +365,17 @@ derive_param_rr <- function(dataset,
       AVAL = compute_rr(!!sym(paste0("AVAL.", hr_code))),
       !!!set_values_to
     )
+  ),
+  derive_param_computed_all_na = function(cnd) {
+    cli_inform(c(
+      paste(
+        "No computed records were added because for all potential computed",
+        "records at least one of the contributing values was {.val {NA}}."
+      ),
+      "If this is not expected, please check the input data."
+    ))
+    cnd_muffle(cnd)
+  }
   )
 }
 

diff --git a/R/derive_advs_params.R b/R/derive_advs_params.R
@@ -150,6 +150,7 @@ derive_param_map <- function(dataset,
     )
   }
 
+  withCallingHandlers(
   derive_param_computed(
     dataset,
     filter = !!filter,
@@ -159,6 +160,17 @@ derive_param_map <- function(dataset,
       AVAL = !!analysis_value,
       !!!set_values_to
     )
+  ),
+  derive_param_computed_all_na = function(cnd) {
+    cli_inform(c(
+      paste(
+        "No computed records were added because for all potential computed",
+        "records at least one of the contributing values was {.val {NA}}."
+      ),
+      "If this is not expected, please check the input data."
+      ))
+    cnd_muffle(cnd)
+  }
   )
 }
 
@@ -428,6 +440,7 @@ derive_param_bsa <- function(dataset,
     constant_parameters <- c(height_code)
   }
 
+  withCallingHandlers(
   derive_param_computed(
     dataset,
     filter = !!filter,
@@ -439,6 +452,17 @@ derive_param_bsa <- function(dataset,
     ),
     constant_parameters = constant_parameters,
     constant_by_vars = constant_by_vars
+  ),
+  derive_param_computed_all_na = function(cnd) {
+    cli_inform(c(
+      paste(
+        "No computed records were added because for all potential computed",
+        "records at least one of the contributing values was {.val {NA}}."
+      ),
+      "If this is not expected, please check the input data."
+    ))
+    cnd_muffle(cnd)
+  }
   )
 }
 
@@ -716,6 +740,7 @@ derive_param_bmi <- function(dataset,
     constant_parameters <- c(height_code)
   }
 
+  withCallingHandlers(
   derive_param_computed(
     dataset,
     filter = !!filter,
@@ -727,6 +752,17 @@ derive_param_bmi <- function(dataset,
     ),
     constant_parameters = constant_parameters,
     constant_by_vars = constant_by_vars
+  ),
+  derive_param_computed_all_na = function(cnd) {
+    cli_inform(c(
+      paste(
+        "No computed records were added because for all potential computed",
+        "records at least one of the contributing values was {.val {NA}}."
+      ),
+      "If this is not expected, please check the input data."
+    ))
+    cnd_muffle(cnd)
+  }
   )
 }
 

diff --git a/R/derive_param_computed.R b/R/derive_param_computed.R
@@ -411,7 +411,8 @@ derive_param_computed <- function(dataset = NULL,
           "If this is not expected, please check the input data and the value of",
           "the {.arg keep_nas} argument."
         )
-      ))
+      ),
+      class = "derive_param_computed_all_na")
     }
   }
 

diff --git a/R/derive_param_wbc_abs.R b/R/derive_param_wbc_abs.R
@@ -151,6 +151,7 @@ derive_param_wbc_abs <- function(dataset,
   }
 
   # Create new parameter.
+  withCallingHandlers(
   dataset_new <- dataset_temp %>%
     derive_param_computed(
       parameters = c(
@@ -164,12 +165,16 @@ derive_param_wbc_abs <- function(dataset,
       )
     ) %>%
     filter(PARAMCD == !!set_values_to$PARAMCD) %>%
-    select(-starts_with("temp_"))
+    select(-starts_with("temp_")),
+  derive_param_computed_all_na = function(cnd) {
+    cnd_muffle(cnd)
+  }
+  )
 
   # If no new records are added, output note and return original dataset,
   # else append new records to the original input dataset.
   if (nrow(dataset_new) == 0L) {
-    message("No source records meet condition for calculation, therefore no new records created")
+    cli_inform("No source records meet condition for calculation, therefore no new records created")
     dataset
   } else {
     bind_rows(dataset, dataset_new)

diff --git a/tests/testthat/_snaps/derive_adeg_params.md b/tests/testthat/_snaps/derive_adeg_params.md
@@ -0,0 +1,19 @@
+# derive_param_qtc Test 4: Message if no new records
+
+    Code
+      actual <- derive_param_qtc(input, by_vars = exprs(USUBJID, VISIT), method = "Bazett",
+      get_unit_expr = AVALU)
+    Message
+      No computed records were added because for all potential computed records at least one of the contributing values was NA.
+      If this is not expected, please check the input data.
+
+# derive_param_rr Test 6: Message if no new records
+
+    Code
+      actual <- derive_param_rr(input, by_vars = exprs(USUBJID, VISIT),
+      set_values_to = exprs(PARAMCD = "RRR", PARAM = "RR Duration Rederived (ms)",
+        AVALU = "ms"), get_unit_expr = AVALU)
+    Message
+      No computed records were added because for all potential computed records at least one of the contributing values was NA.
+      If this is not expected, please check the input data.
+
diff --git a/tests/testthat/_snaps/derive_advs_params.md b/tests/testthat/_snaps/derive_advs_params.md
@@ -0,0 +1,27 @@
+# derive_param_bmi Test 36: BMI parameter NOT added
+
+    Code
+      result <- derive_param_bmi(input, by_vars = exprs(USUBJID, VISIT),
+      get_unit_expr = VSSTRESU)
+    Message
+      No computed records were added because for all potential computed records at least one of the contributing values was NA.
+      If this is not expected, please check the input data.
+
+# derive_param_bsa Test 43: BSA parameter NOT added
+
+    Code
+      result <- derive_param_bsa(input, by_vars = exprs(USUBJID, VISIT), method = "Mosteller",
+      get_unit_expr = VSSTRESU)
+    Message
+      No computed records were added because for all potential computed records at least one of the contributing values was NA.
+      If this is not expected, please check the input data.
+
+# derive_param_map Test 56: MAP parameter NOT added
+
+    Code
+      result <- derive_param_map(input, by_vars = exprs(USUBJID, VISIT), hr_code = "PULSE",
+      get_unit_expr = extract_unit(PARAM))
+    Message
+      No computed records were added because for all potential computed records at least one of the contributing values was NA.
+      If this is not expected, please check the input data.
+
diff --git a/tests/testthat/test-derive_adeg_params.R b/tests/testthat/test-derive_adeg_params.R
@@ -98,10 +98,37 @@ test_that("derive_param_qtc Test 3: Sagie's method", {
   )
 })
 
+## Test 4: Message if no new records ----
+test_that("derive_param_qtc Test 4: Message if no new records", {
+  input <- tibble::tribble(
+    ~USUBJID,      ~PARAMCD, ~PARAM,        ~AVAL, ~AVALU, ~VISIT,
+    "01-701-1015", "QT",     "QT Duration",   370, "ms",   "WEEK 2",
+    "01-701-1015", "RR",     "RR Duration",    NA, "ms",   "WEEK 2",
+    "01-701-1028", "QT",     "QT Duration",   480, "ms",   "WEEK 2",
+    "01-701-1028", "QT",     "QT Duration",   350, "ms",   "WEEK 3",
+    "01-701-1028", "RR",     "RR Duration",    NA, "ms",   "WEEK 2",
+  )
+
+  expect_snapshot(
+  actual <- derive_param_qtc(
+    input,
+    by_vars = exprs(USUBJID, VISIT),
+    method = "Bazett",
+    get_unit_expr = AVALU
+  )
+  )
+
+  expect_dfs_equal(
+    base = input,
+    compare = actual,
+    keys = c("USUBJID", "PARAMCD", "VISIT")
+  )
+})
+
 # derive_param_rr ----
 
-## Test 4: new observations are derived correctly ----
-test_that("derive_param_rr Test 4: new observations are derived correctly", {
+## Test 5: new observations are derived correctly ----
+test_that("derive_param_rr Test 5: new observations are derived correctly", {
   input <- tibble::tribble(
     ~USUBJID,      ~PARAMCD, ~PARAM,        ~AVAL, ~AVALU,      ~VISIT,
     "01-701-1015", "HR",     "Heart Rate",  70.14, "beats/min", "BASELINE",
@@ -138,3 +165,33 @@ test_that("derive_param_rr Test 4: new observations are derived correctly", {
     keys = c("USUBJID", "PARAMCD", "VISIT")
   )
 })
+
+## Test 6: Message if no new records ----
+test_that("derive_param_rr Test 6: Message if no new records", {
+  input <- tibble::tribble(
+    ~USUBJID,      ~PARAMCD, ~PARAM,        ~AVAL, ~AVALU,      ~VISIT,
+    "01-701-1015", "HR",     "Heart Rate",  NA   , "beats/min", "BASELINE",
+    "01-701-1015", "HR",     "Heart Rate",  NA   , "beats/min", "WEEK 1",
+    "01-701-1015", "RR",     "RR Duration", 710,   "ms",        "WEEK 2"
+  )
+
+
+  expect_snapshot(
+    actual <- derive_param_rr(
+      input,
+      by_vars = exprs(USUBJID, VISIT),
+      set_values_to = exprs(
+        PARAMCD = "RRR",
+        PARAM = "RR Duration Rederived (ms)",
+        AVALU = "ms"
+      ),
+      get_unit_expr = AVALU
+    )
+  )
+
+  expect_dfs_equal(
+    base = input,
+    compare = actual,
+    keys = c("USUBJID", "PARAMCD", "VISIT")
+  )
+})
diff --git a/tests/testthat/test-derive_advs_params.R b/tests/testthat/test-derive_advs_params.R
@@ -362,8 +362,16 @@ test_that("derive_param_bmi Test 36: BMI parameter NOT added", {
 
   input <- expected_output
 
+  expect_snapshot(
+    result <- derive_param_bmi(
+      input,
+      by_vars = exprs(USUBJID, VISIT),
+      get_unit_expr = VSSTRESU
+    )
+  )
+
   expect_dfs_equal(
-    derive_param_bmi(input, by_vars = exprs(USUBJID, VISIT), get_unit_expr = VSSTRESU),
+    result,
     expected_output,
     keys = c("USUBJID", "PARAMCD", "VISIT")
   )
@@ -554,13 +562,17 @@ test_that("derive_param_bsa Test 43: BSA parameter NOT added", {
 
   input <- expected_output
 
-  expect_dfs_equal(
-    derive_param_bsa(
+  expect_snapshot(
+    result <- derive_param_bsa(
       input,
       by_vars = exprs(USUBJID, VISIT),
       method = "Mosteller",
       get_unit_expr = VSSTRESU
-    ),
+    )
+  )
+
+  expect_dfs_equal(
+    result,
     expected_output,
     keys = c("USUBJID", "PARAMCD", "VISIT")
   )
@@ -965,13 +977,17 @@ test_that("derive_param_map Test 56: MAP parameter NOT added", {
 
   input <- expected_output
 
-  expect_dfs_equal(
-    derive_param_map(
+  expect_snapshot(
+    result <- derive_param_map(
       input,
       by_vars = exprs(USUBJID, VISIT),
       hr_code = "PULSE",
       get_unit_expr = extract_unit(PARAM)
-    ),
+    )
+  )
+
+  expect_dfs_equal(
+    result,
     expected_output,
     keys = c("USUBJID", "PARAMCD", "VISIT")
   )