From 33f621c884a8a39d14b6f024e6d9ef96485a9bd8 Mon Sep 17 00:00:00 2001
From: Max Kuhn <mxkuhn@gmail.com>
Date: Mon, 21 Oct 2024 14:56:27 -0400
Subject: [PATCH] A few missing cli error conversions (#1213)

* remaning rlng errors to cli errors

* remove redundant tests

* updated snapshots

* Update R/misc.R

Co-authored-by: Simon P. Couch <simonpatrickcouch@gmail.com>

* Apply suggestions from code review

Co-authored-by: Simon P. Couch <simonpatrickcouch@gmail.com>

* update snapshots

---------

Co-authored-by: Simon P. Couch <simonpatrickcouch@gmail.com>
---
 R/descriptors.R                               | 22 +++++++--------
 R/misc.R                                      | 27 +++++++++----------
 tests/testthat/_snaps/boost_tree_xgboost.md   |  9 -------
 tests/testthat/_snaps/linear_reg.md           | 14 +++++-----
 tests/testthat/_snaps/logistic_reg.md         | 12 ++++-----
 tests/testthat/_snaps/mars.md                 |  8 ------
 tests/testthat/_snaps/misc.md                 | 18 +------------
 .../testthat/_snaps/nearest_neighbor_kknn.md  |  8 ------
 tests/testthat/_snaps/predict_formats.md      |  6 ++---
 tests/testthat/_snaps/rand_forest_ranger.md   | 10 +------
 tests/testthat/_snaps/sparsevctrs.md          | 16 +++++------
 tests/testthat/test-boost_tree_xgboost.R      |  9 -------
 tests/testthat/test-mars.R                    | 10 -------
 tests/testthat/test-misc.R                    | 10 -------
 tests/testthat/test-nearest_neighbor_kknn.R   | 12 ---------
 tests/testthat/test-rand_forest_ranger.R      | 10 -------
 tests/testthat/test-sparsevctrs.R             | 18 ++++++-------
 17 files changed, 58 insertions(+), 161 deletions(-)

diff --git a/R/descriptors.R b/R/descriptors.R
index 6e4deb05b..0d94d14a9 100644
--- a/R/descriptors.R
+++ b/R/descriptors.R
@@ -245,9 +245,9 @@ get_descr_spark <- function(formula, data) {
   .obs   <- function() obs
   .lvls  <- function() y_vals
   .facts <- function() factor_pred
-  .x       <- function() abort("Descriptor .x() not defined for Spark.")
-  .y       <- function() abort("Descriptor .y() not defined for Spark.")
-  .dat     <- function() abort("Descriptor .dat() not defined for Spark.")
+  .x       <- function() cli::cli_abort("Descriptor {.fn .x} not defined for Spark.")
+  .y       <- function() cli::cli_abort("Descriptor {.fn .y} not defined for Spark.")
+  .dat     <- function() cli::cli_abort("Descriptor {.fn .dat} not defined for Spark.")
 
   # still need .x(), .y(), .dat() ?
 
@@ -409,13 +409,13 @@ scoped_descrs <- function(descrs, frame = caller_env()) {
 # with their actual implementations
 descr_env <- rlang::new_environment(
   data = list(
-    .cols  = function() abort("Descriptor context not set"),
-    .preds = function() abort("Descriptor context not set"),
-    .obs   = function() abort("Descriptor context not set"),
-    .lvls  = function() abort("Descriptor context not set"),
-    .facts = function() abort("Descriptor context not set"),
-    .x     = function() abort("Descriptor context not set"),
-    .y     = function() abort("Descriptor context not set"),
-    .dat   = function() abort("Descriptor context not set")
+    .cols  = function() cli::cli_abort("Descriptor context not set"),
+    .preds = function() cli::cli_abort("Descriptor context not set"),
+    .obs   = function() cli::cli_abort("Descriptor context not set"),
+    .lvls  = function() cli::cli_abort("Descriptor context not set"),
+    .facts = function() cli::cli_abort("Descriptor context not set"),
+    .x     = function() cli::cli_abort("Descriptor context not set"),
+    .y     = function() cli::cli_abort("Descriptor context not set"),
+    .dat   = function() cli::cli_abort("Descriptor context not set")
   )
 )
diff --git a/R/misc.R b/R/misc.R
index 0afbe6602..dfec898a6 100644
--- a/R/misc.R
+++ b/R/misc.R
@@ -369,22 +369,20 @@ check_outcome <- function(y, spec) {
   if (spec$mode == "regression") {
     outcome_is_numeric <- if (is.atomic(y)) {is.numeric(y)} else {all(map_lgl(y, is.numeric))}
     if (!outcome_is_numeric) {
-      cls <- class(y)[[1]]
-      abort(paste0(
-        "For a regression model, the outcome should be `numeric`, ",
-        "not a `", cls, "`."
-      ))
+      cli::cli_abort(
+        "For a regression model, the outcome should be {.cls numeric}, not
+        {.obj_type_friendly {y}}."
+      )
     }
   }
 
   if (spec$mode == "classification") {
     outcome_is_factor <- if (is.atomic(y)) {is.factor(y)} else {all(map_lgl(y, is.factor))}
     if (!outcome_is_factor) {
-      cls <- class(y)[[1]]
-      abort(paste0(
-        "For a classification model, the outcome should be a `factor`, ",
-        "not a `", cls, "`."
-      ))
+      cli::cli_abort(
+        "For a classification model, the outcome should be a {.cls factor}, not
+        {.obj_type_friendly {y}}."
+      )
     }
 
     if (inherits(spec, "logistic_reg") && is.atomic(y) && length(levels(y)) > 2) {
@@ -402,11 +400,10 @@ check_outcome <- function(y, spec) {
   if (spec$mode == "censored regression") {
     outcome_is_surv <- inherits(y, "Surv")
     if (!outcome_is_surv) {
-      cls <- class(y)[[1]]
-      abort(paste0(
-        "For a censored regression model, the outcome should be a `Surv` object, ",
-        "not a `", cls, "`."
-      ))
+      cli::cli_abort(
+        "For a censored regression model, the outcome should be a {.cls Surv} object, not
+        {.obj_type_friendly {y}}."
+      )
     }
   }
 
diff --git a/tests/testthat/_snaps/boost_tree_xgboost.md b/tests/testthat/_snaps/boost_tree_xgboost.md
index 58961127b..688a18979 100644
--- a/tests/testthat/_snaps/boost_tree_xgboost.md
+++ b/tests/testthat/_snaps/boost_tree_xgboost.md
@@ -6,15 +6,6 @@
       Error:
       ! object 'novar' not found
 
-# xgboost execution, regression
-
-    Code
-      res <- parsnip::fit_xy(car_basic, x = mtcars[, num_pred], y = factor(mtcars$vs),
-      control = ctrl)
-    Condition
-      Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
-
 # submodel prediction
 
     Code
diff --git a/tests/testthat/_snaps/linear_reg.md b/tests/testthat/_snaps/linear_reg.md
index c045d5a4d..f497ce3da 100644
--- a/tests/testthat/_snaps/linear_reg.md
+++ b/tests/testthat/_snaps/linear_reg.md
@@ -46,7 +46,7 @@
       res <- fit_xy(hpc_basic, x = hpc[, num_pred], y = hpc$class, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 ---
 
@@ -55,7 +55,7 @@
       control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `character`.
+      ! For a regression model, the outcome should be <numeric>, not a character vector.
 
 ---
 
@@ -63,7 +63,7 @@
       res <- fit(hpc_basic, hpc_bad_form, data = hpc, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 ---
 
@@ -71,7 +71,7 @@
       lm_form_catch <- fit(hpc_basic, hpc_bad_form, data = hpc, control = caught_ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 # glm execution
 
@@ -79,7 +79,7 @@
       res <- fit_xy(hpc_glm, x = hpc[, num_pred], y = hpc$class, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 ---
 
@@ -87,7 +87,7 @@
       res <- fit(hpc_glm, hpc_bad_form, data = hpc, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 ---
 
@@ -95,7 +95,7 @@
       lm_form_catch <- fit(hpc_glm, hpc_bad_form, data = hpc, control = caught_ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
+      ! For a regression model, the outcome should be <numeric>, not a <factor> object.
 
 # newdata error trapping
 
diff --git a/tests/testthat/_snaps/logistic_reg.md b/tests/testthat/_snaps/logistic_reg.md
index 99df268ef..b87d8711f 100644
--- a/tests/testthat/_snaps/logistic_reg.md
+++ b/tests/testthat/_snaps/logistic_reg.md
@@ -51,7 +51,7 @@
       res <- fit(lc_basic, funded_amnt ~ term, data = lending_club, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 ---
 
@@ -60,7 +60,7 @@
       control = caught_ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 ---
 
@@ -69,7 +69,7 @@
         num_pred], y = lending_club$total_bal_il)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 # liblinear execution
 
@@ -77,7 +77,7 @@
       res <- fit(ll_basic, funded_amnt ~ term, data = lending_club, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 ---
 
@@ -86,7 +86,7 @@
       control = caught_ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 ---
 
@@ -95,7 +95,7 @@
         num_pred], y = lending_club$total_bal_il)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 # check_args() works
 
diff --git a/tests/testthat/_snaps/mars.md b/tests/testthat/_snaps/mars.md
index 88f01bac7..75ef9ba90 100644
--- a/tests/testthat/_snaps/mars.md
+++ b/tests/testthat/_snaps/mars.md
@@ -31,14 +31,6 @@
       x Engine "wat?" is not supported for `mars()`
       i See `show_engines("mars")`.
 
-# mars execution
-
-    Code
-      res <- fit(hpc_basic, hpc_bad_form, data = hpc, control = ctrl)
-    Condition
-      Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
-
 # submodel prediction
 
     Code
diff --git a/tests/testthat/_snaps/misc.md b/tests/testthat/_snaps/misc.md
index c82edc8f5..0bbae37cf 100644
--- a/tests/testthat/_snaps/misc.md
+++ b/tests/testthat/_snaps/misc.md
@@ -150,14 +150,6 @@
 
 # check_outcome works as expected
 
-    Code
-      check_outcome(factor(1:2), reg_spec)
-    Condition
-      Error in `check_outcome()`:
-      ! For a regression model, the outcome should be `numeric`, not a `factor`.
-
----
-
     Code
       check_outcome(NULL, reg_spec)
     Condition
@@ -192,14 +184,6 @@
       ! `linear_reg()` was unable to find an outcome.
       i Ensure that you have specified an outcome column and that it hasn't been removed in pre-processing.
 
----
-
-    Code
-      check_outcome(1:2, class_spec)
-    Condition
-      Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
-
 ---
 
     Code
@@ -233,5 +217,5 @@
       check_outcome(1:2, cens_spec)
     Condition
       Error in `check_outcome()`:
-      ! For a censored regression model, the outcome should be a `Surv` object, not a `integer`.
+      ! For a censored regression model, the outcome should be a <Surv> object, not an integer vector.
 
diff --git a/tests/testthat/_snaps/nearest_neighbor_kknn.md b/tests/testthat/_snaps/nearest_neighbor_kknn.md
index 7f9fc992a..aa17225a4 100644
--- a/tests/testthat/_snaps/nearest_neighbor_kknn.md
+++ b/tests/testthat/_snaps/nearest_neighbor_kknn.md
@@ -1,13 +1,5 @@
 # kknn execution
 
-    Code
-      fit_xy(hpc_basic, control = ctrl, x = hpc[, num_pred], y = hpc$input_fields)
-    Condition
-      Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `numeric`.
-
----
-
     Code
       fit(hpc_basic, hpc_bad_form, data = hpc, control = ctrl)
     Condition
diff --git a/tests/testthat/_snaps/predict_formats.md b/tests/testthat/_snaps/predict_formats.md
index e64587641..5a46a58c1 100644
--- a/tests/testthat/_snaps/predict_formats.md
+++ b/tests/testthat/_snaps/predict_formats.md
@@ -14,7 +14,7 @@
         class = class == "VF"))
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `logical`.
+      ! For a classification model, the outcome should be a <factor>, not a logical vector.
 
 ---
 
@@ -23,7 +23,7 @@
         class = ifelse(class == "VF", 1, 0)))
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `numeric`.
+      ! For a classification model, the outcome should be a <factor>, not a double vector.
 
 ---
 
@@ -32,5 +32,5 @@
         dplyr::mutate(class = as.character(class)))
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `character`.
+      ! For a classification model, the outcome should be a <factor>, not a character vector.
 
diff --git a/tests/testthat/_snaps/rand_forest_ranger.md b/tests/testthat/_snaps/rand_forest_ranger.md
index 333a1b277..ae5d7c204 100644
--- a/tests/testthat/_snaps/rand_forest_ranger.md
+++ b/tests/testthat/_snaps/rand_forest_ranger.md
@@ -4,15 +4,7 @@
       res <- fit(lc_ranger, funded_amnt ~ Class + term, data = lending_club, control = ctrl)
     Condition
       Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
-
----
-
-    Code
-      res <- fit(bad_ranger_cls, funded_amnt ~ term, data = lending_club, control = ctrl)
-    Condition
-      Error in `check_outcome()`:
-      ! For a classification model, the outcome should be a `factor`, not a `integer`.
+      ! For a classification model, the outcome should be a <factor>, not an integer vector.
 
 # ranger classification probabilities
 
diff --git a/tests/testthat/_snaps/sparsevctrs.md b/tests/testthat/_snaps/sparsevctrs.md
index 68a3e6f91..006fc82b8 100644
--- a/tests/testthat/_snaps/sparsevctrs.md
+++ b/tests/testthat/_snaps/sparsevctrs.md
@@ -30,14 +30,6 @@
       Warning:
       `data` is a sparse tibble, but `linear_reg()` with engine "lm" doesn't accept that. Converting to non-sparse.
 
----
-
-    Code
-      fit(spec, avg_price_per_room ~ ., data = hotel_data)
-    Condition
-      Error in `fit()`:
-      ! `x` must have column names.
-
 # sparse tibble can be passed to `fit_xy() - unsupported
 
     Code
@@ -135,3 +127,11 @@
       Error in `maybe_sparse_matrix()`:
       ! no sparse vectors detected
 
+# fit() errors if sparse matrix has no colnames
+
+    Code
+      fit(spec, avg_price_per_room ~ ., data = hotel_data)
+    Condition
+      Error in `fit()`:
+      ! `x` must have column names.
+
diff --git a/tests/testthat/test-boost_tree_xgboost.R b/tests/testthat/test-boost_tree_xgboost.R
index d71467ba0..5681a824c 100644
--- a/tests/testthat/test-boost_tree_xgboost.R
+++ b/tests/testthat/test-boost_tree_xgboost.R
@@ -151,15 +151,6 @@ test_that('xgboost execution, regression', {
     )
   )
 
-  expect_snapshot(
-    error = TRUE,
-    res <- parsnip::fit_xy(
-      car_basic,
-      x = mtcars[, num_pred],
-      y = factor(mtcars$vs),
-      control = ctrl
-    )
-  )
 })
 
 
diff --git a/tests/testthat/test-mars.R b/tests/testthat/test-mars.R
index 94fe81147..7ac1db9fe 100644
--- a/tests/testthat/test-mars.R
+++ b/tests/testthat/test-mars.R
@@ -56,16 +56,6 @@ test_that('mars execution', {
   expect_true(has_multi_predict(res))
   expect_equal(multi_predict_args(res), "num_terms")
 
-  expect_snapshot(
-    error = TRUE,
-    res <- fit(
-      hpc_basic,
-      hpc_bad_form,
-      data = hpc,
-      control = ctrl
-    )
-  )
-
   ## multivariate y
 
   expect_no_condition(
diff --git a/tests/testthat/test-misc.R b/tests/testthat/test-misc.R
index dfc91b7d3..af18a4a7d 100644
--- a/tests/testthat/test-misc.R
+++ b/tests/testthat/test-misc.R
@@ -190,11 +190,6 @@ test_that('check_outcome works as expected', {
     check_outcome(mtcars, reg_spec)
   )
 
-  expect_snapshot(
-    error = TRUE,
-    check_outcome(factor(1:2), reg_spec)
-  )
-
   expect_snapshot(
     error = TRUE,
     check_outcome(NULL, reg_spec)
@@ -225,11 +220,6 @@ test_that('check_outcome works as expected', {
     check_outcome(lapply(mtcars, as.factor), class_spec)
   )
 
-  expect_snapshot(
-    error = TRUE,
-    check_outcome(1:2, class_spec)
-  )
-
   expect_snapshot(
     error = TRUE,
     check_outcome(NULL, class_spec)
diff --git a/tests/testthat/test-nearest_neighbor_kknn.R b/tests/testthat/test-nearest_neighbor_kknn.R
index d07024533..e617bf037 100644
--- a/tests/testthat/test-nearest_neighbor_kknn.R
+++ b/tests/testthat/test-nearest_neighbor_kknn.R
@@ -15,18 +15,6 @@ test_that('kknn execution', {
   skip_if_not_installed("kknn")
   library(kknn)
 
-  # continuous
-  # expect no error
-  expect_snapshot(
-    error = TRUE,
-    fit_xy(
-      hpc_basic,
-      control = ctrl,
-      x = hpc[, num_pred],
-      y = hpc$input_fields
-    )
-  )
-
   # nominal
   # expect no error
   expect_no_condition(
diff --git a/tests/testthat/test-rand_forest_ranger.R b/tests/testthat/test-rand_forest_ranger.R
index cc374dffc..b9c0338b4 100644
--- a/tests/testthat/test-rand_forest_ranger.R
+++ b/tests/testthat/test-rand_forest_ranger.R
@@ -46,16 +46,6 @@ test_that('ranger classification execution', {
     )
   )
 
-  expect_snapshot(
-    error = TRUE,
-    res <- fit(
-      bad_ranger_cls,
-      funded_amnt ~ term,
-      data = lending_club,
-      control = ctrl
-    )
-  )
-
   ranger_form_catch <- fit(
     bad_ranger_cls,
     Class ~ term,
diff --git a/tests/testthat/test-sparsevctrs.R b/tests/testthat/test-sparsevctrs.R
index 7dfeeed43..73715b2d0 100644
--- a/tests/testthat/test-sparsevctrs.R
+++ b/tests/testthat/test-sparsevctrs.R
@@ -9,7 +9,7 @@ test_that("sparse tibble can be passed to `fit() - supported", {
   spec <- boost_tree() %>%
     set_mode("regression") %>%
     set_engine("xgboost")
-  
+
   expect_snapshot(
     error = TRUE,
     xgb_fit <- fit(spec, avg_price_per_room ~ ., data = hotel_data)
@@ -33,9 +33,9 @@ test_that("sparse matrix can be passed to `fit() - supported", {
   # Make materialization of sparse vectors throw an error
   # https://r-lib.github.io/sparsevctrs/dev/reference/sparsevctrs_options.html
   withr::local_options("sparsevctrs.verbose_materialize" = 3)
-  
+
   hotel_data <- sparse_hotel_rates()
-  
+
   spec <- boost_tree() %>%
     set_mode("regression") %>%
     set_engine("xgboost")
@@ -64,7 +64,7 @@ test_that("sparse tibble can be passed to `fit_xy() - supported", {
   # Make materialization of sparse vectors throw an error
   # https://r-lib.github.io/sparsevctrs/dev/reference/sparsevctrs_options.html
   withr::local_options("sparsevctrs.verbose_materialize" = 3)
-  
+
   hotel_data <- sparse_hotel_rates(tibble = TRUE)
 
   spec <- boost_tree() %>%
@@ -206,7 +206,7 @@ test_that("sparse data work with xgboost engine", {
   expect_no_error(
     xgb_fit <- fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
    )
-   
+
    expect_no_error(
      predict(xgb_fit, hotel_data)
    )
@@ -221,7 +221,7 @@ test_that("sparse data work with xgboost engine", {
   expect_no_error(
     predict(xgb_fit, hotel_data)
   )
-  
+
   expect_no_error(
     xgb_fit <- fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
   )
@@ -236,7 +236,7 @@ test_that("to_sparse_data_frame() is used correctly", {
   # Make materialization of sparse vectors throw an error
   # https://r-lib.github.io/sparsevctrs/dev/reference/sparsevctrs_options.html
   withr::local_options("sparsevctrs.verbose_materialize" = 3)
-  
+
   local_mocked_bindings(
     to_sparse_data_frame = function(x, object) {
       if (methods::is(x, "sparseMatrix")) {
@@ -263,7 +263,7 @@ test_that("to_sparse_data_frame() is used correctly", {
     error = TRUE,
     fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
   )
-  
+
   spec <- boost_tree() %>%
     set_mode("regression") %>%
     set_engine("xgboost")
@@ -279,7 +279,7 @@ test_that("maybe_sparse_matrix() is used correctly", {
   # Make materialization of sparse vectors throw an error
   # https://r-lib.github.io/sparsevctrs/dev/reference/sparsevctrs_options.html
   withr::local_options("sparsevctrs.verbose_materialize" = 3)
-  
+
   local_mocked_bindings(
     maybe_sparse_matrix = function(x) {
       if (sparsevctrs::has_sparse_elements(x)) {