use rlang 1.0.0 errors

DESCRIPTION

@@ -20,13 +20,13 @@ Imports:
     DiceDesign,
     dplyr (>= 0.8.5),
     glue,
-    hardhat (>= 0.1.6.9000),
+    hardhat (>= 0.2.0),
     lifecycle,
     purrr,
-    rlang,
+    rlang (>= 1.0.1),
     tibble,
     utils,
-    vctrs (>= 0.3.1),
+    vctrs (>= 0.3.8),
     withr
 Suggests: 
     covr,

NAMESPACE

@@ -214,6 +214,8 @@ importFrom(purrr,map_chr)
 importFrom(purrr,map_dbl)
 importFrom(purrr,map_dfc)
 importFrom(purrr,map_lgl)
+importFrom(rlang,caller_env)
+importFrom(rlang,check_dots_empty)
 importFrom(rlang,enquo)
 importFrom(rlang,eval_tidy)
 importFrom(rlang,is_string)

R/0_imports.R

@@ -1,6 +1,7 @@
 #' @importFrom purrr map_lgl map2_dfc map_chr map map2 map_dfc map_dbl
 #' @importFrom DiceDesign dmaxDesign lhsDesign
 #' @importFrom rlang quos eval_tidy quo_get_expr is_string enquo quo_is_null
+#' @importFrom rlang caller_env check_dots_empty
 #' @importFrom tibble as_tibble is_tibble tibble type_sum
 #' @importFrom scales log2_trans is.trans log10_trans
 #' @importFrom utils installed.packages globalVariables

R/aaa_unknown.R

@@ -77,13 +77,12 @@ has_unknowns_val <- function(object) {
   any(rng_check) | any(val_check)
 }
 
-check_for_unknowns <- function(x, label = "") {
-  err_txt <- paste0("Unknowns not allowed in `", label, "`.")
+check_for_unknowns <- function(x, ..., call = caller_env()) {
+  check_dots_empty()
   if (length(x) == 1 && is_unknown(x))
-    rlang::abort(err_txt)
+    rlang::abort("Unknowns not allowed.", call = call)
   is_ukn <- map_lgl(x, is_unknown)
   if (any(is_ukn))
-    rlang::abort(err_txt)
+    rlang::abort("Unknowns not allowed.", call = call)
   invisible(TRUE)
 }
-

R/aaa_values.R

@@ -86,9 +86,10 @@ value_validate <- function(object, values) {
 
 }
 
-value_validate_quant <- function(object, values) {
-  check_for_unknowns(object$range, "value_validate")
-  check_for_unknowns(values, "value_validate")
+value_validate_quant <- function(object, values, ..., call = caller_env()) {
+  check_dots_empty()
+  check_for_unknowns(object$range, call = call)
+  check_for_unknowns(values, call = call)
 
   is_valid <- rep(TRUE, length(values))
 
@@ -112,9 +113,10 @@ value_validate_quant <- function(object, values) {
   is_valid
 }
 
-value_validate_qual <- function(object, values) {
-  check_for_unknowns(object$range, "value_validate")
-  check_for_unknowns(values, "value_validate")
+value_validate_qual <- function(object, values, ..., call = caller_env()) {
+  check_dots_empty()
+  check_for_unknowns(object$range)
+  check_for_unknowns(values)
 
   res <- values %in% object$values
   res[is.na(res)] <- FALSE
@@ -271,7 +273,7 @@ value_samp_qual <- function(object, n) {
 #' @export
 #' @rdname value_validate
 value_transform <- function(object, values) {
-  check_for_unknowns(values, "value_transform")
+  check_for_unknowns(values)
 
   if (is.null(object$trans))
     return(values)
@@ -288,7 +290,7 @@ trans_wrap <- function(x, object) {
 #' @export
 #' @rdname value_validate
 value_inverse <- function(object, values) {
-  check_for_unknowns(values, "value_inverse")
+  check_for_unknowns(values)
 
   if (is.null(object$trans))
     return(values)
@@ -306,7 +308,7 @@ inv_wrap <- function(x, object) {
 #' @export
 #' @rdname value_validate
 value_set <- function(object, values) {
-  check_for_unknowns(values, "value_set")
+  check_for_unknowns(values)
   if (length(values) == 0)
     rlang::abort("`values` should at least one element.")
   if (!inherits(object, "param"))

R/compat-vctrs-helpers-parameters.R

@@ -107,7 +107,7 @@ tib_upcast <- function(x) {
 
 df_size <- function(x) {
   if (!is.list(x)) {
-    rlang::abort("Cannot get the df size of a non-list.")
+    rlang::abort("Cannot get the df size of a non-list.", .internal = TRUE)
   }
 
   if (length(x) == 0L) {

R/encode_unit.R

@@ -15,25 +15,26 @@
 #' @export
 encode_unit <- function(x, value, direction, ...) {
   if (!any(direction %in% c("forward", "backward"))) {
-    rlang::abort("`direction` should be either 'forward' or 'backward'")
+    rlang::abort("`direction` should be either 'forward' or 'backward'",
+                 .internal = TRUE)
   }
   UseMethod("encode_unit")
 }
 
 #' @export
 encode_unit.default <- function(x, value, direction, ...) {
-  rlang::abort("`x` should be a dials parameter object.")
+  rlang::abort("`x` should be a dials parameter object.", .internal = TRUE)
 }
 
 #' @export
 encode_unit.quant_param <- function(x, value, direction, original = TRUE, ...) {
 
   if (has_unknowns(x)) {
-    rlang::abort("The parameter object contains unknowns.")
+    rlang::abort("The parameter object contains unknowns.", .internal = TRUE)
   }
 
   if (!is.numeric(value) || is.matrix(value)) {
-    rlang::abort("`value` should be a numeric vector.")
+    rlang::abort("`value` should be a numeric vector.", .internal = TRUE)
   }
 
   param_rng <- x$range$upper - x$range$lower
@@ -45,7 +46,7 @@ encode_unit.quant_param <- function(x, value, direction, original = TRUE, ...) {
 
     compl <- value[!is.na(value)]
     if (any(compl < 0) | any(compl > 1)) {
-      rlang::abort("Values should be on [0, 1].")
+      rlang::abort("Values should be on [0, 1].", .internal = TRUE)
     }
 
     value <- (value * param_rng) + x$range$lower
@@ -68,7 +69,7 @@ encode_unit.quant_param <- function(x, value, direction, original = TRUE, ...) {
 encode_unit.qual_param <- function(x, value, direction, ...) {
 
   if (has_unknowns(x)) {
-    rlang::abort("The parameter object contains unknowns.")
+    rlang::abort("The parameter object contains unknowns.", .internal = TRUE)
   }
 
   ref_vals <- x$values
@@ -78,7 +79,7 @@ encode_unit.qual_param <- function(x, value, direction, ...) {
     # convert to [0, 1]
 
     if (!is.character(value) || is.matrix(value)) {
-      rlang::abort("`value` should be a character vector.")
+      rlang::abort("`value` should be a character vector.", .internal = TRUE)
     }
 
     compl <- value[!is.na(value)]
@@ -96,11 +97,11 @@ encode_unit.qual_param <- function(x, value, direction, ...) {
 
     compl <- value[!is.na(value)]
     if (any(compl < 0) | any(compl > 1)) {
-      rlang::abort("Values should be on [0, 1].")
+      rlang::abort("Values should be on [0, 1].", .internal = TRUE)
     }
 
     if (!is.numeric(value) || is.matrix(value)) {
-      rlang::abort("`value` should be a numeric vector.")
+      rlang::abort("`value` should be a numeric vector.", .internal = TRUE)
     }
 
     ind <- cut(value, breaks = seq(0, 1, length.out = num_lvl + 1), include.lowest = TRUE)

R/extract.R

@@ -1,8 +1,6 @@
 #' @export
 extract_parameter_dials.parameters <- function(x, parameter, ...) {
-  dots <- rlang::quos(...)
-  if (!rlang::is_empty(dots))
-    rlang::abort("The `...` are not used with `extract_parameter_dials()`.")
+  check_dots_empty()
   if (any(rlang::is_missing(parameter)) ||
       any(!is.character(parameter)) ||
       length(parameter) != 1 ||

R/finalize.R

@@ -179,6 +179,8 @@ get_log_p <- function(object, x, ...) {
 #' @export
 #' @rdname finalize
 get_n_frac <- function(object, x, log_vals = FALSE, frac = 1/3, ...) {
+  if (!inherits(object, "param"))
+    rlang::abort("`object` should be a 'param' object.")
   rngs <- range_get(object, original = FALSE)
   if (!is_unknown(rngs$upper))
     return(object)
@@ -267,4 +269,3 @@ get_batch_sizes  <- function(object, x, frac = c(1/10, 1/3), ...) {
 
   range_set(object, n_frac)
 }
-

R/grids.R

@@ -95,8 +95,8 @@ grid_regular.workflow <- function(x, ..., levels = 3, original = TRUE, filter =
   grid_regular.parameters(parameters(x), ..., levels = levels, original = original, filter = {{filter}})
 }
 
-make_regular_grid <- function(..., levels = 3, original = TRUE, filter = NULL) {
-  validate_params(...)
+make_regular_grid <- function(..., levels = 3, original = TRUE, filter = NULL, call = caller_env()) {
+  validate_params(..., call = call)
   filter_quo <- enquo(filter)
   param_quos <- quos(...)
   params <- map(param_quos, eval_tidy)
@@ -107,7 +107,8 @@ make_regular_grid <- function(..., levels = 3, original = TRUE, filter = NULL) {
   p <- length(levels)
   if (p > 1 && p != length(param_quos))
     rlang::abort(
-      paste0("`levels` should have length 1 or ", length(param_quos))
+      paste0("`levels` should have length 1 or ", length(param_quos)),
+      call = call
     )
 
   if (p == 1) {
@@ -116,7 +117,10 @@ make_regular_grid <- function(..., levels = 3, original = TRUE, filter = NULL) {
     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.")
+      rlang::abort(
+        "Elements of `levels` should either be all named or unnamed, not mixed.",
+        call = call
+      )
     }
     param_seq <- map2(params, as.list(levels), value_seq, original = original)
   }
@@ -185,8 +189,8 @@ grid_random.workflow <- function(x, ..., size = 5, original = TRUE, filter = NUL
 }
 
 
-make_random_grid <- function(..., size = 5, original = TRUE, filter = NULL) {
-  validate_params(...)
+make_random_grid <- function(..., size = 5, original = TRUE, filter = NULL, call = caller_env()) {
+  validate_params(..., call = call)
   filter_quo <- enquo(filter)
   param_quos <- quos(...)
   params <- map(param_quos, eval_tidy)

R/misc.R

@@ -45,23 +45,35 @@ check_installs <- function(x) {
 
 # checking functions -----------------------------------------------------------
 
-check_label <- function(txt) {
+check_label <- function(txt, ..., call = caller_env()) {
+  check_dots_empty()
   if (is.null(txt))
-    rlang::abort("`label` should be a single named character string or NULL.")
+    rlang::abort(
+      "`label` should be a single named character string or NULL.",
+      call = call
+    )
   if (!is.character(txt) || length(txt) > 1)
-    rlang::abort("`label` should be a single named character string or NULL.")
+    rlang::abort(
+      "`label` should be a single named character string or NULL.",
+      call = call
+    )
   if (length(names(txt)) != 1)
-    rlang::abort("`label` should be a single named character string or NULL.")
+    rlang::abort(
+      "`label` should be a single named character string or NULL.",
+      call = call
+    )
   invisible(txt)
 }
 
-check_finalize <- function(x) {
+check_finalize <- function(x, ..., call = caller_env()) {
+  check_dots_empty()
   if (!is.null(x) & !is.function(x))
-    rlang::abort("`finalize` should be NULL or a function.")
+    rlang::abort("`finalize` should be NULL or a function.", call = call)
   invisible(x)
 }
 
-check_range <- function(x, type, trans) {
+check_range <- function(x, type, trans, ..., call = caller_env()) {
+  check_dots_empty()
   if (!is.null(trans)) {
     return(invisible(x))
   }
@@ -85,15 +97,15 @@ check_range <- function(x, type, trans) {
           "An integer is required for the range and these do not appear to be ",
           "whole numbers: ", msg
         )
-        rlang::abort(msg)
+        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."
       )
-      rlang::abort(msg)
+      rlang::abort(msg, call = call)
     }
   }
   invisible(x0)

R/parameters.R

@@ -49,22 +49,26 @@ parameters.list <- function(x, ...) {
   )
 }
 
-chr_check <- function(x) {
+chr_check <- function(x, ..., call = caller_env()) {
+  check_dots_empty()
   cl <- match.call()
   if (is.null(x)) {
     rlang::abort(
-      glue::glue("Element `{cl$x}` should not be NULL.")
+      glue::glue("Element `{cl$x}` should not be NULL."),
+      call = call
     )
   }
   if (!is.character(x)) {
     rlang::abort(
-      glue::glue("Element `{cl$x}` should be a character string.")
+      glue::glue("Element `{cl$x}` should be a character string."),
+      call = call
     )
   }
   invisible(TRUE)
 }
 
-unique_check <- function(x) {
+unique_check <- function(x, ..., call = caller_env()) {
+  check_dots_empty()
   x2 <- x[!is.na(x)]
   is_dup <- duplicated(x2)
   if (any(is_dup)) {
@@ -73,7 +77,7 @@ unique_check <- function(x) {
     msg <- paste0("Element `", deparse(cl$x), "` should have unique values. Duplicates exist ",
                   "for item(s): ",
                   paste0("'", dup_list, "'", collapse = ", "))
-    rlang::abort(msg)
+    rlang::abort(msg, call = call)
   }
   invisible(TRUE)
 }

R/space_filling.R

@@ -102,8 +102,8 @@ grid_max_entropy.workflow <- function(x, ..., size = 3, original = TRUE,
 
 
 make_max_entropy_grid <- function(..., size = 3, original = TRUE,
-                             variogram_range = 0.5, iter = 1000) {
-  validate_params(...)
+                             variogram_range = 0.5, iter = 1000, call = caller_env()) {
+  validate_params(..., call = call)
   param_quos <- quos(...)
   params <- map(param_quos, eval_tidy)
   param_names <- names(param_quos)
@@ -188,8 +188,8 @@ grid_latin_hypercube.workflow <- function(x, ..., size = 3, original = TRUE) {
 
 
 
-make_latin_hypercube_grid <- function(..., size = 3, original = TRUE) {
-  validate_params(...)
+make_latin_hypercube_grid <- function(..., size = 3, original = TRUE, call = caller_env()) {
+  validate_params(..., call = call)
   param_quos <- quos(...)
   params <- map(param_quos, eval_tidy)
   param_labs <- map_chr(params, function(x) x$label)