From a8f0db398c615854d8bd86ab5a9f0d9ddecd5d5c Mon Sep 17 00:00:00 2001
From: Emil Hvitfeldt <emilhhvitfeldt@gmail.com>
Date: Thu, 19 Sep 2024 12:41:58 -0700
Subject: [PATCH 1/4] rlang::abort() -> cli::cli_abort() in parameters.R

---
 R/parameters.R                      | 55 +++++++++++++++--------------
 man/parameters_constr.Rd            |  2 +-
 tests/testthat/_snaps/grids.md      |  2 +-
 tests/testthat/_snaps/parameters.md | 10 +++---
 4 files changed, 36 insertions(+), 33 deletions(-)

diff --git a/R/parameters.R b/R/parameters.R
index befc8ac4..725f9417 100644
--- a/R/parameters.R
+++ b/R/parameters.R
@@ -12,11 +12,8 @@ parameters <- function(x, ...) {
 #' @export
 #' @rdname parameters
 parameters.default <- function(x, ...) {
-  rlang::abort(
-    glue(
-      "`parameters` objects cannot be created from objects ",
-      "of class `{class(x)[1]}`."
-    )
+  cli::cli_abort(
+    "{.cls parameters} objects cannot be created from {.obj_type_friendly {x}}."
   )
 }
 
@@ -34,7 +31,7 @@ parameters.param <- function(x, ...) {
 parameters.list <- function(x, ...) {
   elem_param <- purrr::map_lgl(x, inherits, "param")
   if (any(!elem_param)) {
-    rlang::abort("The objects should all be `param` objects.")
+    cli::cli_abort("The objects should all be {.cls param} objects.")
   }
   elem_name <- purrr::map_chr(x, ~ names(.x$label))
   elem_id <- names(x)
@@ -61,12 +58,14 @@ unique_check <- function(x, ..., call = caller_env()) {
   if (any(is_dup)) {
     dup_list <- x2[is_dup]
     cl <- match.call()
-    msg <- paste0(
-      "Element `", deparse(cl$x), "` should have unique values. Duplicates exist ",
-      "for item(s): ",
-      paste0("'", dup_list, "'", collapse = ", ")
+
+    cli::cli_abort(
+      c(
+        x = "Element {.field {deparse(cl$x)}} should have unique values.",
+        i = "Duplicates exist for {cli::qty(dup_list)} item{?s}: {dup_list}"
+      ),
+      call = call
     )
-    rlang::abort(msg, call = call)
   }
   invisible(TRUE)
 }
@@ -78,16 +77,18 @@ param_or_na <- function(x) {
 check_list_of_param <- function(x, ..., call = caller_env()) {
   check_dots_empty()
   if (!is.list(x)) {
-    abort("`object` must be a list of `param` objects.", call = call)
+    cli::cli_abort(
+      "{.arg object} must be a list of {.cls param} objects.",
+      call = call
+    )
   }
   is_good_boi <- map_lgl(x, param_or_na)
   if (any(!is_good_boi)) {
-    rlang::abort(
-      paste0(
-        "`object` elements in the following positions must be `NA` or a ",
-        "`param` object:",
-        paste0(which(!is_good_boi), collapse = ", ")
-      ),
+    offenders <- which(!is_good_boi)
+
+    cli::cli_abort(
+      "{.arg object} elements in the following positions must be {.code NA} or a 
+      {.cls param} object: {offenders}.",
       call = call
     )
   }
@@ -99,7 +100,7 @@ check_list_of_param <- function(x, ..., call = caller_env()) {
 #' length.
 #' @param object A list of `param` objects or NA values.
 #' @inheritParams rlang::args_dots_empty
-#' @param call The call passed on to [rlang::abort()].
+#' @param call The call passed on to [cli::cli_abort()].
 #'
 #' @return A tibble that encapsulates the input vectors into a tibble with an
 #' additional class of "parameters".
@@ -129,7 +130,7 @@ parameters_constr <- function(name,
     )
   n_elements_unique <- unique(n_elements)
   if (length(n_elements_unique) > 1) {
-    abort(
+    cli::cli_abort(
       "All inputs must contain contain the same number of elements.",
       call = call
     )
@@ -261,21 +262,21 @@ print.parameters <- function(x, ...) {
 update.parameters <- function(object, ...) {
   args <- rlang::list2(...)
   if (length(args) == 0) {
-    rlang::abort("Please supply at least one parameter object.")
+    cli::cli_abort("Please supply at least one parameter object.")
   }
   nms <- names(args)
   if (length(nms) == 0 || any(nms == "")) {
-    rlang::abort("All arguments should be named.")
+    cli::cli_abort("All arguments should be named.")
   }
 
   in_set <- nms %in% object$id
   if (!all(in_set)) {
-    msg <- paste0("'", nms[!in_set], "'", collapse = ", ")
-    msg <- paste(
-      "At least one parameter does not match any id's in the set:",
-      msg
+    offenders <- nms[!in_set]
+
+    cli::cli_abort(
+      "At least one parameter does not match any id's in the set:
+      {offenders}."
     )
-    rlang::abort(msg)
   }
   not_param <- !purrr::map_lgl(args, inherits, "param")
   not_null <- !purrr::map_lgl(args, ~ all(is.na(.x)))
diff --git a/man/parameters_constr.Rd b/man/parameters_constr.Rd
index d397cd98..ddab9065 100644
--- a/man/parameters_constr.Rd
+++ b/man/parameters_constr.Rd
@@ -23,7 +23,7 @@ length.}
 
 \item{...}{These dots are for future extensions and must be empty.}
 
-\item{call}{The call passed on to \code{\link[rlang:abort]{rlang::abort()}}.}
+\item{call}{The call passed on to \code{\link[cli:cli_abort]{cli::cli_abort()}}.}
 }
 \value{
 A tibble that encapsulates the input vectors into a tibble with an
diff --git a/tests/testthat/_snaps/grids.md b/tests/testthat/_snaps/grids.md
index fc9d5ab3..330df0c5 100644
--- a/tests/testthat/_snaps/grids.md
+++ b/tests/testthat/_snaps/grids.md
@@ -14,7 +14,7 @@
       Warning:
       `size` is not an argument to `grid_regular()`. Did you mean `levels`?
       Error in `parameters()`:
-      ! The objects should all be `param` objects.
+      ! The objects should all be <param> objects.
 
 # wrong argument name
 
diff --git a/tests/testthat/_snaps/parameters.md b/tests/testthat/_snaps/parameters.md
index d1979eb9..1404eeca 100644
--- a/tests/testthat/_snaps/parameters.md
+++ b/tests/testthat/_snaps/parameters.md
@@ -13,7 +13,8 @@
       parameters_constr(ab, c("a", "a"), ab, ab, ab)
     Condition
       Error:
-      ! Element `id` should have unique values. Duplicates exist for item(s): 'a'
+      x Element id should have unique values.
+      i Duplicates exist for item: a
 
 ---
 
@@ -22,7 +23,7 @@
       parameters_constr(ab, ab, ab, ab, ab, "not a params list")
     Condition
       Error:
-      ! `object` must be a list of `param` objects.
+      ! `object` must be a list of <param> objects.
 
 ---
 
@@ -48,7 +49,8 @@
       parameters(list(a = mtry(), a = penalty()))
     Condition
       Error in `parameters()`:
-      ! Element `id` should have unique values. Duplicates exist for item(s): 'a'
+      x Element id should have unique values.
+      i Duplicates exist for item: a
 
 # updating
 
@@ -142,5 +144,5 @@
       parameters(tibble::as_tibble(mtcars))
     Condition
       Error in `parameters()`:
-      ! `parameters` objects cannot be created from objects of class `tbl_df`.
+      ! <parameters> objects cannot be created from a tibble.
 

From ba5a69870e2fca5b4603a4018efc112f0e8c3948 Mon Sep 17 00:00:00 2001
From: Emil Hvitfeldt <emilhhvitfeldt@gmail.com>
Date: Thu, 19 Sep 2024 13:05:01 -0700
Subject: [PATCH 2/4] rlang::abort() -> rlang::abort() in grids.R and misc.R

---
 R/grids.R                             | 13 ++++++++-----
 R/misc.R                              | 23 ++++++++++++-----------
 tests/testthat/_snaps/constructors.md | 14 +++++++-------
 tests/testthat/_snaps/grids.md        |  2 +-
 4 files changed, 28 insertions(+), 24 deletions(-)

diff --git a/R/grids.R b/R/grids.R
index e2e89d56..e2f05619 100644
--- a/R/grids.R
+++ b/R/grids.R
@@ -130,8 +130,8 @@ make_regular_grid <- function(...,
   # check levels
   p <- length(levels)
   if (p > 1 && p != length(param_quos)) {
-    rlang::abort(
-      paste0("`levels` should have length 1 or ", length(param_quos)),
+    cli::cli_abort(
+      "{.arg levels} should have length 1 or {length(param_quos)}, not {p}.",
       call = call
     )
   }
@@ -142,8 +142,9 @@ make_regular_grid <- function(...,
     if (all(rlang::has_name(levels, names(params)))) {
       levels <- levels[names(params)]
     } else if (any(rlang::has_name(levels, names(params)))) {
-      rlang::abort(
-        "Elements of `levels` should either be all named or unnamed, not mixed.",
+      cli::cli_abort(
+        "Elements of {.arg levels} should either be all named or unnamed, 
+        not mixed.",
         call = call
       )
     }
@@ -252,7 +253,9 @@ make_random_grid <- function(...,
 
 new_param_grid <- function(x = new_data_frame()) {
   if (!is.data.frame(x)) {
-    rlang::abort("`x` must be a data frame to construct a new grid from.")
+    cli::cli_abort(
+      "{.arg x} must be a data frame to construct a new grid from."
+    )
   }
 
   x <- vctrs::vec_unique(x)
diff --git a/R/misc.R b/R/misc.R
index 5aa118bc..86c54923 100644
--- a/R/misc.R
+++ b/R/misc.R
@@ -70,20 +70,21 @@ check_range <- function(x, type, trans, ..., call = caller_env()) {
       whole <-
         purrr::map_lgl(x0[known], ~ abs(.x - round(.x)) < .Machine$double.eps^0.5)
       if (!all(whole)) {
-        msg <- paste(x0[known][!whole], collapse = ", ")
-        msg <- paste0(
-          "An integer is required for the range and these do not appear to be ",
-          "whole numbers: ", msg
+        offenders <- x0[known][!whole]
+        cli::cli_abort(
+          "An integer is required for the range and these do not appear to be
+          whole numbers: {offenders}.",
+          call = call
         )
-        rlang::abort(msg, call = call)
       }
 
       x0[known] <- as.integer(x0[known])
     } else {
-      msg <- paste0(
-        "Since `type = '", type, "'`, please use that data type for the range."
+      cli::cli_abort(
+        "Since {.code type = \"{type}\"}, please use that data type for the 
+        range.",
+        call = call
       )
-      rlang::abort(msg, call = call)
     }
   }
   invisible(x0)
@@ -97,13 +98,13 @@ check_values_quant <- function(x, ..., call = caller_env()) {
   }
 
   if (!is.numeric(x)) {
-    rlang::abort("`values` must be numeric.", call = call)
+    cli::cli_abort("{.arg values} must be numeric.", call = call)
   }
   if (anyNA(x)) {
-    rlang::abort("`values` can't be `NA`.", call = call)
+    cli::cli_abort("{.arg values} can't be {.code NA}.", call = call)
   }
   if (length(x) == 0) {
-    rlang::abort("`values` can't be empty.", call = call)
+    cli::cli_abort("{.arg values} can't be empty.", call = call)
   }
 
   invisible(x)
diff --git a/tests/testthat/_snaps/constructors.md b/tests/testthat/_snaps/constructors.md
index 0537486f..9fbdae33 100644
--- a/tests/testthat/_snaps/constructors.md
+++ b/tests/testthat/_snaps/constructors.md
@@ -170,7 +170,7 @@
       mixture(c(1L, 3L))
     Condition
       Error in `mixture()`:
-      ! Since `type = 'double'`, please use that data type for the range.
+      ! Since `type = "double"`, please use that data type for the range.
 
 ---
 
@@ -178,7 +178,7 @@
       mixture(c(1L, unknown()))
     Condition
       Error in `mixture()`:
-      ! Since `type = 'double'`, please use that data type for the range.
+      ! Since `type = "double"`, please use that data type for the range.
 
 ---
 
@@ -186,7 +186,7 @@
       mixture(c(unknown(), 1L))
     Condition
       Error in `mixture()`:
-      ! Since `type = 'double'`, please use that data type for the range.
+      ! Since `type = "double"`, please use that data type for the range.
 
 ---
 
@@ -194,7 +194,7 @@
       mixture(letters[1:2])
     Condition
       Error in `mixture()`:
-      ! Since `type = 'double'`, please use that data type for the range.
+      ! Since `type = "double"`, please use that data type for the range.
 
 ---
 
@@ -202,7 +202,7 @@
       mtry(c(0.1, 0.5))
     Condition
       Error in `mtry()`:
-      ! An integer is required for the range and these do not appear to be whole numbers: 0.1, 0.5
+      ! An integer is required for the range and these do not appear to be whole numbers: 0.1 and 0.5.
 
 ---
 
@@ -210,7 +210,7 @@
       mtry(c(0.1, unknown()))
     Condition
       Error in `mtry()`:
-      ! An integer is required for the range and these do not appear to be whole numbers: 0.1
+      ! An integer is required for the range and these do not appear to be whole numbers: 0.1.
 
 ---
 
@@ -218,7 +218,7 @@
       mtry(c(unknown(), 0.5))
     Condition
       Error in `mtry()`:
-      ! An integer is required for the range and these do not appear to be whole numbers: 0.5
+      ! An integer is required for the range and these do not appear to be whole numbers: 0.5.
 
 # `values` must be compatible with `range` and `inclusive`
 
diff --git a/tests/testthat/_snaps/grids.md b/tests/testthat/_snaps/grids.md
index 330df0c5..8ea2410e 100644
--- a/tests/testthat/_snaps/grids.md
+++ b/tests/testthat/_snaps/grids.md
@@ -4,7 +4,7 @@
       grid_regular(mixture(), trees(), levels = 1:4)
     Condition
       Error in `grid_regular()`:
-      ! `levels` should have length 1 or 2
+      ! `levels` should have length 1 or 2, not 4.
 
 ---
 

From 0f5f2dfa85caad1afeffc6820592c2f367e23387 Mon Sep 17 00:00:00 2001
From: Emil Hvitfeldt <emilhhvitfeldt@gmail.com>
Date: Fri, 20 Sep 2024 10:52:07 -0700
Subject: [PATCH 3/4] pass calls and test aborts in grids.R

---
 R/grids.R                      | 6 +++---
 R/space_filling.R              | 2 +-
 tests/testthat/_snaps/grids.md | 8 ++++++++
 tests/testthat/test-grids.R    | 5 +++++
 4 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/R/grids.R b/R/grids.R
index e2f05619..9f9a28ea 100644
--- a/R/grids.R
+++ b/R/grids.R
@@ -157,7 +157,7 @@ make_regular_grid <- function(...,
     parameters <- dplyr::filter(parameters, !!filter_quo)
   }
 
-  new_param_grid(parameters)
+  new_param_grid(parameters, call = call)
 }
 
 # ------------------------------------------------------------------------------
@@ -246,12 +246,12 @@ make_random_grid <- function(...,
     parameters <- dplyr::filter(parameters, !!filter_quo)
   }
 
-  new_param_grid(parameters)
+  new_param_grid(parameters, call = call)
 }
 
 # ------------------------------------------------------------------------------
 
-new_param_grid <- function(x = new_data_frame()) {
+new_param_grid <- function(x = new_data_frame(), call = caller_env()) {
   if (!is.data.frame(x)) {
     cli::cli_abort(
       "{.arg x} must be a data frame to construct a new grid from."
diff --git a/R/space_filling.R b/R/space_filling.R
index 79c46e0a..85f2105e 100644
--- a/R/space_filling.R
+++ b/R/space_filling.R
@@ -235,7 +235,7 @@ make_sfd <- function(...,
       )
   }
 
-  new_param_grid(grid)
+  new_param_grid(grid, call = call)
 }
 
 base_recycle <- function(x, size) {
diff --git a/tests/testthat/_snaps/grids.md b/tests/testthat/_snaps/grids.md
index 8ea2410e..5ee72bf9 100644
--- a/tests/testthat/_snaps/grids.md
+++ b/tests/testthat/_snaps/grids.md
@@ -16,6 +16,14 @@
       Error in `parameters()`:
       ! The objects should all be <param> objects.
 
+---
+
+    Code
+      grid_regular(mixture(), trees(), levels = c(2, trees = 4))
+    Condition
+      Error in `grid_regular()`:
+      ! Elements of `levels` should either be all named or unnamed, not mixed.
+
 # wrong argument name
 
     Code
diff --git a/tests/testthat/test-grids.R b/tests/testthat/test-grids.R
index 31b232bd..63a332d1 100644
--- a/tests/testthat/test-grids.R
+++ b/tests/testthat/test-grids.R
@@ -44,6 +44,11 @@ test_that("regular grid", {
     grid_regular(list(mixture(), trees()), levels = 3),
     grid_regular(mixture(), trees(), levels = 3)
   )
+
+  expect_snapshot(
+    error = TRUE,
+    grid_regular(mixture(), trees(), levels = c(2, trees = 4))
+  )
 })
 
 test_that("random grid", {

From 7f83d3d842ad1c8c6b9757a2f3b1f38e512cd404 Mon Sep 17 00:00:00 2001
From: Emil Hvitfeldt <emilhhvitfeldt@gmail.com>
Date: Fri, 20 Sep 2024 11:15:23 -0700
Subject: [PATCH 4/4] add tests for parameters.R

---
 tests/testthat/_snaps/parameters.md | 24 ++++++++++++++++++++++++
 tests/testthat/test-parameters.R    |  3 +++
 2 files changed, 27 insertions(+)

diff --git a/tests/testthat/_snaps/parameters.md b/tests/testthat/_snaps/parameters.md
index 1404eeca..5e84bdf6 100644
--- a/tests/testthat/_snaps/parameters.md
+++ b/tests/testthat/_snaps/parameters.md
@@ -52,6 +52,14 @@
       x Element id should have unique values.
       i Duplicates exist for item: a
 
+---
+
+    Code
+      parameters(list(a = mtry, a = penalty()))
+    Condition
+      Error in `parameters()`:
+      ! The objects should all be <param> objects.
+
 # updating
 
     Code
@@ -68,6 +76,14 @@
       Error in `update()`:
       ! At least one parameter is not a dials parameter object or NA: penalty.
 
+---
+
+    Code
+      update(p_1, not_penalty = 1:2)
+    Condition
+      Error in `update()`:
+      ! At least one parameter does not match any id's in the set: not_penalty.
+
 ---
 
     Code
@@ -76,6 +92,14 @@
       Error in `update()`:
       ! All arguments should be named.
 
+---
+
+    Code
+      update(p_1)
+    Condition
+      Error in `update()`:
+      ! Please supply at least one parameter object.
+
 # printing
 
     Code
diff --git a/tests/testthat/test-parameters.R b/tests/testthat/test-parameters.R
index b93aa5a2..aa4b6953 100644
--- a/tests/testthat/test-parameters.R
+++ b/tests/testthat/test-parameters.R
@@ -46,6 +46,7 @@ test_that("create from lists of param objects", {
   expect_equal(p_3$id, c("a", "some name"))
 
   expect_snapshot(error = TRUE, parameters(list(a = mtry(), a = penalty())))
+  expect_snapshot(error = TRUE, parameters(list(a = mtry, a = penalty())))
 })
 
 test_that("updating", {
@@ -61,8 +62,10 @@ test_that("updating", {
 
   expect_snapshot(error = TRUE, update(p_1, new_pen))
   expect_snapshot(error = TRUE, update(p_1, penalty = 1:2))
+  expect_snapshot(error = TRUE, update(p_1, not_penalty = 1:2))
   expect_snapshot(error = TRUE, update(p_1, penalty(), mtry = mtry(3:4)))
   expect_error(update(p_1, penalty = NA), NA)
+  expect_snapshot(error = TRUE, update(p_1))
 })
 
 test_that("printing", {