write out ad-hoc prompting functions

DESCRIPTION

@@ -61,7 +61,7 @@ Config/Needs/website:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.1
 VignetteBuilder: knitr
 Config/testthat/edition: 3
 Remotes:

NAMESPACE

@@ -65,8 +65,12 @@ importFrom(butcher,axe_data)
 importFrom(butcher,axe_env)
 importFrom(butcher,axe_fitted)
 importFrom(butcher,butcher)
+importFrom(cli,cli_abort)
+importFrom(cli,cli_inform)
+importFrom(cli,cli_warn)
 importFrom(dplyr,"%>%")
 importFrom(ggplot2,autoplot)
+importFrom(rlang,caller_env)
 importFrom(stats,predict)
 importFrom(workflowsets,workflow_set)
 importFrom(yardstick,metric_set)

NEWS.md

@@ -9,6 +9,11 @@ To be released as stacks 1.0.1.
   `control_grid()` object. Will work as long as the object passed to `control` 
   includes the same elements as `control_grid()`.
 
+* Re-implemented package errors, warnings, and messages to make use of
+  infrastructure from the cli package; error headers now refer to the function
+  called directly by the user rather than the internal function that raised the
+  error.
+
 # stacks 1.0.0
 
 stacks 1.0.0 is the first production release of the package. While this release

R/add_candidates.R

@@ -94,9 +94,10 @@ add_candidates.workflow_set <- function(data_stack, candidates,
                                         name = deparse(substitute(candidates)), 
                                         ...) {
   if (!"result" %in% colnames(candidates)) {
-    glue_stop(
-      "The supplied workflow_set must be fitted to resamples with ",
-      "workflows::workflow_map() before being added to a data stack."
+    cli_abort(
+      "The supplied workflow_set must be fitted to resamples with 
+       workflows::workflow_map() before being added to a data stack.",
+      call = caller_env(0)
     )
   }
 
@@ -132,18 +133,22 @@ add_candidates.tune_results <- function(data_stack, candidates,
 add_candidates.default <- function(data_stack, candidates, name, ...) {
   check_add_data_stack(data_stack)
 
-  glue_stop(
-    "The second argument to add_candidates() should inherit from one of ",
-    "`tune_results` or `workflow_set`, but its class ",
-    "is {list(class(candidates))}."
+  cli_abort(
+    "The second argument to add_candidates() should inherit from one of 
+     `tune_results` or `workflow_set`, but its class 
+     is {list(class(candidates))}.",
+    call = caller_env(0)
   )
 }
 
 .set_outcome <- function(stack, candidates) {
   if (!.get_outcome(stack) %in% c("init_", tune::.get_tune_outcome_names(candidates))) {
-    glue_stop("The model definition you've tried to add to the stack has ",
-              "outcome variable {list(tune::.get_tune_outcome_names(candidates))}, ",
-              "while the stack's outcome variable is {.get_outcome(stack)}.")
+    cli_abort(
+      "The model definition you've tried to add to the stack has 
+       outcome variable {list(tune::.get_tune_outcome_names(candidates))}, 
+       while the stack's outcome variable is {.get_outcome(stack)}.",
+      call = caller_env(1)
+    )
   }
 
   attr(stack, "outcome") <- tune::.get_tune_outcome_names(candidates)
@@ -159,9 +164,10 @@ add_candidates.default <- function(data_stack, candidates, name, ...) {
   hash_matches <- .get_rs_hash(stack) %in% c("init_", new_hash)
 
   if (!hash_matches) {
-    glue_stop(
-      "It seems like the new candidate member '{name}' doesn't make use ",
-      "of the same resampling object as the existing candidates."
+    cli_abort(
+      "It seems like the new candidate member '{name}' doesn't make use 
+       of the same resampling object as the existing candidates.",
+      call = caller_env()
     )
   }
 
@@ -201,9 +207,10 @@ add_candidates.default <- function(data_stack, candidates, name, ...) {
 # and then appends the model definition, hash, and metrics
 .set_model_defs_candidates <- function(stack, candidates, name) {
   if (name %in% .get_model_def_names(stack)) {
-    glue_stop(
-      "The new model definition has the ",
-      "same name '{name}' as an existing model definition."
+    cli_abort(
+      "The new model definition has the 
+       same name '{name}' as an existing model definition.",
+      call = caller_env(1)
     )
   }
 
@@ -219,18 +226,21 @@ add_candidates.default <- function(data_stack, candidates, name, ...) {
       unname()
 
     if (!"prob_metric" %in% metric_types) {
-      glue_stop(
-        "The supplied candidates were tuned/fitted using only metrics that ",
-        "rely on hard class predictions. Please tune/fit with at least one ",
-        "class probability-based metric, such as `yardstick::roc_auc()`."        
+      cli_abort(
+        "The supplied candidates were tuned/fitted using only metrics that 
+         rely on hard class predictions. Please tune/fit with at least one 
+         class probability-based metric, such as `yardstick::roc_auc()`.",
+        call = caller_env(1)
       )
     }
   }
 
   model_defs <- attr(stack, "model_defs")
   model_metrics <- attr(stack, "model_metrics")
 
-  model_defs[[name]] <- attr(candidates, "workflow") %>% stack_workflow()
+  model_defs[[name]] <- 
+    attr(candidates, "workflow") %>% 
+    stack_workflow(call = caller_env())
   model_metrics[[name]] <- tune::collect_metrics(candidates)
 
   attr(stack, "model_defs") <- model_defs
@@ -248,8 +258,11 @@ add_candidates.default <- function(data_stack, candidates, name, ...) {
 
   if ((!identical(training_data, tibble::tibble())) &&
       (!identical(training_data, new_data))) {
-    glue_stop("The newly added candidate member, `{name}`, ",
-              "uses different training data than the existing candidates.")
+    cli_abort(
+      "The newly added candidate member, `{name}`, 
+       uses different training data than the existing candidates.",
+      call = caller_env(1)
+    )
   }
 
   attr(stack, "train") <- new_data
@@ -332,9 +345,9 @@ rm_duplicate_cols <- function(df) {
       n_candidates <- "1 candidate"
     }
 
-    glue_warn(
-      "Predictions from {n_candidates} were identical to ",
-      "those from existing candidates and were removed from the data stack."
+    cli_warn(
+      "Predictions from {n_candidates} were identical to 
+       those from existing candidates and were removed from the data stack."
     )
 
     df <- df %>% dplyr::select(-any_of(exclude))
@@ -362,7 +375,7 @@ update_stack_data <- function(stack, new_data) {
 
 # takes in a workflow and returns a minimal workflow for
 # use in the stack
-stack_workflow <- function(x) {
+stack_workflow <- function(x, call) {
   res <-
     workflows::workflow() %>%
     workflows::add_model(workflows::extract_spec_parsnip(x))
@@ -376,7 +389,10 @@ stack_workflow <- function(x) {
   } else if (inherits(pre, "workflow_variables")) {
     res <- res %>% workflows::add_variables(variables = pre)
   } else {
-    rlang::abort(paste0("Can't add a preprocessor of class '", class(pre)[1], "'"))
+    cli_abort(
+      "Can't add a preprocessor of class '{class(pre)[1]}'",
+      call = call
+    )
   }
 
   res
@@ -387,12 +403,13 @@ check_add_data_stack <- function(data_stack) {
     data_stack, 
     c("tune_results", "tune_bayes", "resample_results")
   )) {
-    glue_stop(
-      "It looks like the first argument inherits from {list(class(data_stack))} ",
-      "rather than `data_stack`. ",
-      "Did you accidentally supply the candidate members as the first argument? ",
-      "If so, please supply the output of `stacks()` or another `add_candidates()` as ",
-      "the argument to `data_stack`."
+    cli_abort(
+      "It looks like the first argument inherits from {list(class(data_stack))} 
+       rather than `data_stack`. 
+       Did you accidentally supply the candidate members as the first argument? 
+       If so, please supply the output of `stacks()` or another `add_candidates()` as 
+       the argument to `data_stack`.",
+      call = caller_env()
     )
   } else {
     check_inherits(data_stack, "data_stack")
@@ -404,26 +421,28 @@ check_candidates <- function(candidates, name) {
     candidates, 
     c("tune_results", "tune_bayes", "resample_results")
   )) {
-    glue_stop(
-      "The inputted `candidates` argument has class `{list(class(candidates))}`",
-      ", but it should inherit from one of 'tune_results', 'tune_bayes', ",
-      "or 'resample_results'."
+    cli_abort(
+      "The inputted `candidates` argument has class `{list(class(candidates))}`, 
+       but it should inherit from one of 'tune_results', 'tune_bayes', 
+       or 'resample_results'.",
+      call = caller_env()
     )
   }
 
   if (nrow(tune::collect_notes(candidates)) != 0) {
-    glue_warn(
-      "The inputted `candidates` argument `{name}` generated notes during ",
-      "tuning/resampling. Model stacking may fail due to these ",
-      "issues; see `?collect_notes` if so."
+    cli_warn(
+      "The inputted `candidates` argument `{name}` generated notes during 
+       tuning/resampling. Model stacking may fail due to these 
+       issues; see `?collect_notes` if so."
     )
   }
 
   if ((!".predictions" %in% colnames(candidates)) | 
       is.null(attributes(candidates)$workflow)) {
-    glue_stop(
-      "The inputted `candidates` argument was not generated with the ",
-      "appropriate control settings. Please see ?control_stack."
+    cli_abort(
+      "The inputted `candidates` argument was not generated with the 
+       appropriate control settings. Please see ?control_stack.",
+      call = caller_env()
     )
   }
 }
@@ -433,19 +452,20 @@ check_name <- function(name) {
     name, 
     c("tune_results", "tune_bayes", "resample_results")
   )) {
-    glue_stop(
-      "The inputted `name` argument looks like a tuning/fitting results object ",
-      "that might be supplied as a `candidates` argument. Did you try to add ",
-      "more than one set of candidates in one `add_candidates()` call?"
+    cli_abort(
+      "The inputted `name` argument looks like a tuning/fitting results object 
+       that might be supplied as a `candidates` argument. Did you try to add 
+       more than one set of candidates in one `add_candidates()` call?",
+      call = caller_env()
     )
   } else {
     check_inherits(name, "character")
 
     if (make.names(name) != name) {
-      glue_message(
-        "The inputted `name` argument cannot prefix a valid column name. The ", 
-        'data stack will use "{make.names(name)}" rather than "{name}" in ',
-        "constructing candidate names."
+      cli_inform(
+        "The inputted `name` argument cannot prefix a valid column name. The  
+         data stack will use '{make.names(name)}' rather than '{name}' in 
+         constructing candidate names."
       )
     }
   }

R/blend_predictions.R

@@ -247,25 +247,29 @@ blend_predictions <- function(data_stack,
 
 check_regularization <- function(x, arg) {
   if (!is.numeric(x)) {
-    glue_stop(
-      "The argument to '{arg}' must be a numeric, but the supplied {arg}'s ",
-      "class is `{list(class(x))}`"
+    cli_abort(
+      "The argument to '{arg}' must be a numeric, but the supplied {arg}'s 
+       class is `{list(class(x))}`",
+      call = caller_env()
     )
   }
 
   if (length(x) == 0) {
-    glue_stop("Please supply one or more {arg} values.")
+    cli_abort("Please supply one or more {arg} values.",
+                   call = caller_env())
   }
 
   if (arg == "penalty") {
     if (any(x < 0)) {
-      glue_stop("Please supply only nonnegative values to the {arg} argument.")
+      cli_abort("Please supply only nonnegative values to the {arg} argument.",
+                     call = caller_env())
     }
   }
 
   if (arg == "mixture") {
     if (any(x < 0 || x > 1)) {
-      glue_stop("Please supply only values in [0, 1] to the {arg} argument.")
+      cli_abort("Please supply only values in [0, 1] to the {arg} argument.",
+                     call = caller_env())
     }
   }
 }
@@ -337,16 +341,18 @@ check_blend_data_stack <- function(data_stack) {
   if (!inherits(data_stack, "data_stack")) {
     check_inherits(data_stack, "data_stack")
   } else if (ncol(data_stack) == 0) {
-      glue_stop(
-        "The data stack supplied as the argument to `data_stack` has no ",
-        "candidate members. Please first add candidates with ",
-        "the `add_candidates()` function."
+      cli_abort(
+        "The data stack supplied as the argument to `data_stack` has no 
+         candidate members. Please first add candidates with 
+         the `add_candidates()` function.",
+        call = caller_env()
       )
   } else if ((ncol(data_stack) == 2 && attr(data_stack, "mode") == "regression") || 
              ncol(data_stack) == length(levels(data_stack[[1]])) + 1) {
-    glue_stop(
-      "The supplied data stack only contains one candidate member. Please ",
-      "add more candidate members using `add_candidates()` before blending."
+    cli_abort(
+      "The supplied data stack only contains one candidate member. Please 
+       add more candidate members using `add_candidates()` before blending.",
+      call = caller_env()
     )
   }
 
@@ -357,16 +363,17 @@ process_data_stack <- function(data_stack) {
   dat <- tibble::as_tibble(data_stack) %>% na.omit()
 
   if (nrow(dat) == 0) {
-    glue_stop(
-      "All rows in the data stack have at least one missing value. ",
-      "Please ensure that all candidates supply predictions."
+    cli_abort(
+      "All rows in the data stack have at least one missing value. 
+       Please ensure that all candidates supply predictions.",
+      call = caller_env()
     )
   }
 
   if (nrow(dat) < nrow(data_stack)) {
-    glue_message(
-      "{nrow(data_stack) - nrow(dat)} of the {nrow(data_stack)} rows in the ", 
-      "data stack have missing values, and will be omitted in the blending process."
+    cli_inform(
+      "{nrow(data_stack) - nrow(dat)} of the {nrow(data_stack)} rows in the  
+       data stack have missing values, and will be omitted in the blending process."
     )
   }
 

R/collect_parameters.R

@@ -52,9 +52,10 @@ collect_parameters <- function(stack, candidates, ...) {
 #' @export
 #' @rdname collect_parameters
 collect_parameters.default <- function(stack, candidates, ...) {
-  glue_stop(
-    "There is no `collect_parameters()` method currently implemented ",
-    "for {list(class(stack))} objects."
+  cli_abort(
+    "There is no `collect_parameters()` method currently implemented  
+     for {list(class(stack))} objects.",
+    call = caller_env(0)
   )
 }
 
@@ -154,9 +155,10 @@ collect_params <- function(cols_map, model_metrics, candidates, workflows, blend
 check_for_candidates <- function(model_metrics, candidates) {
   if ((!inherits(candidates, "character")) | 
       (!candidates %in% names(model_metrics))) {
-    glue_stop(
-      "The `candidates` argument to `collect_parameters()` must be the name ",
-      "given to a set of candidates added with `add_candidates()`."
+    cli_abort(
+      "The `candidates` argument to `collect_parameters()` must be the name 
+       given to a set of candidates added with `add_candidates()`.",
+      call = caller_env()
     )
   }
 }