Closes #469 fix_assert_list_element: consider ... for evaluation of m…

…essage (#470)

* #469 fix_assert_list_element: consider ... for evaluation of message text

* #469 fix_assert_list_element: fix example

* #469 fix_assert_list_element: fix lintr

* #469 fix_assert_list_element: fix tests

* #2513 accept_ms: use admiraldev development version for snapshot testing

* #469 fix_assert_list_element: undo last commit

NAMESPACE

@@ -144,6 +144,7 @@ importFrom(rlang,caller_env)
 importFrom(rlang,current_env)
 importFrom(rlang,enexpr)
 importFrom(rlang,enquo)
+importFrom(rlang,env)
 importFrom(rlang,eval_bare)
 importFrom(rlang,eval_tidy)
 importFrom(rlang,expr)

NEWS.md

@@ -2,6 +2,9 @@
 
 ## Updates of Existing Functions
 
+- Objects passed to `assert_list_element()` via the `...` argument can now be
+used in the glue expression specified for the `message_text` argument. (#469)
+
 - The `required_unit` argument of `assert_unit()` has been enhanced. It is now
 possible to specify more than one unit or not specify it at all. In the latter
 case only the uniqueness of the unit is checked. (#468)

R/admiraldev-package.R

@@ -4,7 +4,7 @@
 #'   starts_with transmute ungroup n_distinct union distinct summarise coalesce
 #'   bind_cols na_if tibble %>%
 #' @importFrom rlang := abort arg_match as_function as_label as_name as_string
-#'   call2 caller_env call_name current_env .data enexpr enquo eval_bare
+#'   call2 caller_env call_name current_env .data enexpr enquo env eval_bare
 #'   eval_tidy expr expr_interp expr_label exprs f_lhs f_rhs is_named inform missing_arg
 #'   is_bare_formula is_call is_character is_expression is_formula is_integerish
 #'   is_logical is_missing is_quosure is_symbol is_symbolic new_formula

R/assertions.R

@@ -1536,9 +1536,11 @@ assert_expr_list <- function(arg, # nolint
 #'   e.g., `"Error in {arg_name}: the censor values must be zero."`.
 #'   If `message` argument is specified, that text will be displayed and `message_text`
 #'   is ignored.
-#' @param ... Objects required to evaluate the condition
-#'   If the condition contains objects apart from the element, they have to be
-#'   passed to the function. See the second example below.
+#' @param ... Objects required to evaluate the condition or the message text
+#'
+#'   If the condition or the message text contains objects apart from the
+#'   element, they have to be passed to the function. See the second example
+#'   below.
 #' @inheritParams assert_logical_scalar
 #'
 #' @return
@@ -1548,14 +1550,47 @@ assert_expr_list <- function(arg, # nolint
 #' @family assertion
 #' @export
 #'
+#' @examples
+#'
+#' death <- list(
+#'   dataset_name = "adsl",
+#'   date = "DTHDT",
+#'   censor = 0
+#' )
+#'
+#' lstalv <- list(
+#'   dataset_name = "adsl",
+#'   date = "LSTALVDT",
+#'   censor = 1
+#' )
+#'
+#' events <- list(death, lstalv)
+#'
+#' try(assert_list_element(
+#'   list = events,
+#'   element = "censor",
+#'   condition = censor == 0,
+#'   message_text = "For events the censor values must be zero."
+#' ))
+#'
+#' try(assert_list_element(
+#'   list = events,
+#'   element = "dataset_name",
+#'   condition = dataset_name %in% c("adrs", "adae"),
+#'   valid_datasets = c("adrs", "adae"),
+#'   message_text = paste(
+#'     "The dataset name must be one of the following: {.val {valid_datasets}}"
+#'   )
+#' ))
 assert_list_element <- function(list,
                                 element,
                                 condition,
                                 message_text,
                                 arg_name = rlang::caller_arg(list),
                                 message = NULL,
                                 class = "assert_list_element",
-                                call = parent.frame(), ...) {
+                                call = parent.frame(),
+                                ...) {
   assert_s3_class(list, "list")
   assert_character_scalar(element)
   condition <- assert_filter_cond(enexpr(condition))
@@ -1581,13 +1616,14 @@ assert_list_element <- function(list,
       )
       message <- c(
         message_text,
-        i = paste(" But,", info_msg)
+        i = paste("But,", info_msg)
       )
     }
 
     cli_abort(
       message = message,
       class = c(class, "assert-admiraldev"),
+      .envir = env(...),
       call = call
     )
   }

tests/testthat/_snaps/assertions.md

@@ -405,13 +405,25 @@
 
     Code
       assert_list_element(list(list(var = expr(DTHDT), val = 1), list(var = expr(
-        EOSDT), val = -1), list(var = expr(EOSDT), val = -2)), element = "val",
-      condition = val >= 0, message_text = "List element {.val val} must be `>=0` in argument {.arg {arg_name}}:",
+        EOSDT), val = -1)), element = "val", condition = val >= 0, message_text = "List element {.val val} must be `>=0` in argument {.arg {arg_name}}.",
       arg_name = "input")
     Condition
       Error:
-      ! List element "val" must be `>=0` in argument `input`:
-      i  But, `input[[2]]$val = -1`, and `input[[3]]$val = -2`
+      ! List element "val" must be `>=0` in argument `input`.
+      i But, `input[[2]]$val = -1`
+
+---
+
+    Code
+      assert_list_element(list(list(var = expr(DTHDT), val = 1), list(var = expr(
+        EOSDT), val = -1), list(var = expr(EOSDT), val = -2)), element = "val",
+      condition = val %in% valid_vals, valid_vals = c(0, 1), message_text = paste(
+        "List element {.val val} must one of {.val {valid_vals}} in argument",
+        "{.arg {arg_name}}."), arg_name = "input")
+    Condition
+      Error:
+      ! List element "val" must one of 0 and 1 in argument `input`.
+      i But, `input[[2]]$val = -1`, and `input[[3]]$val = -2`
 
 # assert_one_to_one Test 79: error if there is a one to many mapping
 

tests/testthat/test-assertions.R

@@ -1288,17 +1288,18 @@ test_that("assert_list_element Test 77: no error if the elements fulfill a certa
 
 ## Test 78: error if the elements do not fulfill the condition ----
 test_that("assert_list_element Test 78: error if the elements do not fulfill the condition", {
-  expect_error(
+  expect_snapshot(
     assert_list_element(
       list(
         list(var = expr(DTHDT), val = 1),
         list(var = expr(EOSDT), val = -1)
       ),
       element = "val",
       condition = val >= 0,
-      message_text = "List element {.val val} must be `>=0` in argument {.arg {arg_name}}:",
+      message_text = "List element {.val val} must be `>=0` in argument {.arg {arg_name}}.",
       arg_name = "input"
-    )
+    ),
+    error = TRUE
   )
 
   expect_snapshot(
@@ -1310,8 +1311,12 @@ test_that("assert_list_element Test 78: error if the elements do not fulfill the
         list(var = expr(EOSDT), val = -2)
       ),
       element = "val",
-      condition = val >= 0,
-      message_text = "List element {.val val} must be `>=0` in argument {.arg {arg_name}}:",
+      condition = val %in% valid_vals,
+      valid_vals = c(0, 1),
+      message_text = paste(
+        "List element {.val val} must one of {.val {valid_vals}} in argument",
+        "{.arg {arg_name}}."
+      ),
       arg_name = "input"
     )
   )