Moving to cli

NAMESPACE

@@ -16,7 +16,6 @@ S3method(mold,formula)
 S3method(mold,matrix)
 S3method(mold,recipe)
 S3method(obj_print_footer,quantile_pred)
-S3method(print,formula_blueprint)
 S3method(print,hardhat_blueprint)
 S3method(print,hardhat_model)
 S3method(refresh_blueprint,default_formula_blueprint)

R/blueprint-formula-default.R

@@ -878,7 +878,10 @@ check_levels <- function(x,
   }
 
   if (!all(map_lgl(x, is.character))) {
-    cli::cli_abort("{.arg {arg}} must only contain character vectors.", call = call)
+    cli::cli_abort(
+      "{.arg {arg}} must only contain character vectors.", 
+      call = call
+    )
   }
 
   invisible(NULL)
@@ -966,11 +969,9 @@ expr_check_no_factorish_in_functions <- function(expr,
       expr <- as_label(original_expr)
 
       message <- c(
-        paste0(
-          "Functions involving factors or characters have been detected on the ",
-          "RHS of `formula`. These are not allowed when `indicators = \"none\"`."
-        ),
-        i = "Functions involving factors were detected for {.str {name}} in {.arg {expr}}."
+        "Functions involving factors or characters have been detected on the
+        RHS of {.arg formula}. These are not allowed when {.code indicators = \"none\"}.",
+        i = "Functions involving factors were detected for {.val {name}} in {.arg {expr}}."
       )
 
       cli::cli_abort(message, call = error_call)
@@ -1031,11 +1032,9 @@ expr_check_no_factorish_in_interaction_term <- function(expr,
     expr <- as_label(expr_original)
 
     message <- c(
-      paste0(
-        "Interaction terms involving factors or characters have been detected on the ",
-        "RHS of `formula`. These are not allowed when `indicators = \"none\"`."
-      ),
-      i = "Interactions terms involving factors were detected for {.str {name}} in {.arg {expr}}."
+      "Interaction terms involving factors or characters have been detected on the
+      RHS of {.arg formula}. These are not allowed when {.code indicators = \"none\"}.",
+      i = "Interactions terms involving factors were detected for {.val {name}} in {.arg {expr}}."
     )
 
     cli::cli_abort(message, call = error_call)
@@ -1072,7 +1071,7 @@ expr_check_no_interactions <- function(expr, error_call) {
     expr <- as_label(expr)
 
     message <- c(
-      "Interaction terms can't be specified on the LHS of `formula`.",
+      "Interaction terms can't be specified on the LHS of {.arg formula}.",
       i = "The following interaction term was found: {.arg {expr}}."
     )
 

R/blueprint.R

@@ -289,11 +289,10 @@ check_has_name <- function(x,
     }
   }
 
-  message <- cli::format_inline(
-    "{.arg {arg}} must have an element named {.str {name}}."
+  cli::cli_abort(
+    "{.arg {arg}} must have an element named {.str {name}}.", 
+    call = call
   )
-
-  abort(message, call = call)
 }
 
 # https://github.com/r-lib/rlang/pull/1605

R/case-weights.R

@@ -31,7 +31,7 @@ importance_weights <- function(x) {
   x <- vec_cast_named(x, to = double(), x_arg = "x")
 
   if (any(x < 0, na.rm = TRUE)) {
-    abort("`x` can't contain negative weights.")
+    cli::cli_abort("{.arg x} can't contain negative weights.")
   }
 
   new_importance_weights(x)
@@ -58,7 +58,7 @@ importance_weights <- function(x) {
 #' new_importance_weights(c(1.5, 2.3, 10))
 new_importance_weights <- function(x = double(), ..., class = character()) {
   if (!is.double(x)) {
-    abort("`x` must be a double vector.")
+    cli::cli_abort("{.arg x} must be a double vector.")
   }
 
   new_case_weights(
@@ -153,7 +153,7 @@ frequency_weights <- function(x) {
   x <- vec_cast_named(x, to = integer(), x_arg = "x")
 
   if (any(x < 0L, na.rm = TRUE)) {
-    abort("`x` can't contain negative weights.")
+    cli::cli_abort("{.arg x} can't contain negative weights.")
   }
 
   new_frequency_weights(x)
@@ -180,7 +180,7 @@ frequency_weights <- function(x) {
 #' new_frequency_weights(1:5)
 new_frequency_weights <- function(x = integer(), ..., class = character()) {
   if (!is.integer(x)) {
-    abort("`x` must be an integer vector.")
+    cli::cli_abort("{.arg x} must be an integer vector.")
   }
 
   new_case_weights(
@@ -265,7 +265,7 @@ vec_ptype_abbr.hardhat_frequency_weights <- function(x, ...) {
 #' new_case_weights(1:5, class = "my_weights")
 new_case_weights <- function(x, ..., class) {
   if (!is.integer(x) && !is.double(x)) {
-    abort("`x` must be an integer or double vector.")
+    cli::cli_abort("{.arg x} must be an integer or double vector.")
   }
 
   new_vctr(

R/constructor.R

@@ -67,15 +67,15 @@ new_scalar <- function(elems, ..., class = character()) {
 
 check_elems <- function(elems) {
   if (!is.list(elems) || length(elems) == 0) {
-    abort("`elems` must be a list of length 1 or greater.")
+    cli::cli_abort("{.arg elems} must be a list of length 1 or greater.")
   }
 
   if (!has_unique_names(elems)) {
-    abort("`elems` must have unique names.")
+    cli::cli_abort("{.arg elems} must have unique names.")
   }
 
   if (!identical(names(attributes(elems)), "names")) {
-    abort("`elems` must have no attributes (apart from names).")
+    cli::cli_abort("{.arg elems} must have no attributes (apart from names).")
   }
 
   invisible(elems)

R/encoding.R

@@ -31,7 +31,7 @@
 #' fct_encode_one_hot(factor(sample(letters[1:4], 10, TRUE)))
 fct_encode_one_hot <- function(x) {
   if (!is.factor(x)) {
-    abort("`x` must be a factor.")
+    cli::cli_abort("{.arg x} must be a factor, not {.obj_type_friendly {x}}.")
   }
 
   row_names <- names(x)
@@ -44,7 +44,7 @@ fct_encode_one_hot <- function(x) {
   x <- unclass(x)
 
   if (vec_any_missing(x)) {
-    abort("`x` can't contain missing values.")
+    cli::cli_abort("{.arg x} can't contain missing values.")
   }
 
   out <- matrix(0L, nrow = n_rows, ncol = n_cols, dimnames = dim_names)

R/forge.R

@@ -70,7 +70,7 @@ forge <- function(new_data, blueprint, ..., outcomes = FALSE) {
 
 #' @export
 forge.default <- function(new_data, blueprint, ..., outcomes = FALSE) {
-  glubort("The class of `new_data`, '{class1(new_data)}', is not recognized.")
+  cli::cli_abort("No {.fn forge} method provided for {.obj_type_friendly {new_data}}.")
 }
 
 #' @export
@@ -140,7 +140,5 @@ run_forge.default <- function(blueprint,
                               new_data,
                               ...,
                               outcomes = FALSE) {
-  class <- class(blueprint)[[1L]]
-  message <- glue("No `run_forge()` method provided for an object of type <{class}>.")
-  abort(message)
+  cli::cli_abort("No {.fn run_forge} method provided for {.obj_type_friendly {blueprint}}.")
 }

R/intercept.R

@@ -22,21 +22,13 @@
 #' add_intercept_column(as.matrix(mtcars))
 #' @export
 add_intercept_column <- function(data, name = "(Intercept)") {
-  ok <- is.data.frame(data) || is.matrix(data)
-
-  if (!ok) {
-    glubort(
-      "`data` must be a data.frame or matrix to add an intercept column, ",
-      "not a '{class1(data)}'."
-    )
-  }
-
+  check_data_frame_or_matrix(data)
   check_name(name)
 
   if (name %in% colnames(data)) {
-    warn(glue::glue(
-      "`data` already has a column named '{name}'. ",
-      "Returning `data` unchanged."
+    cli::cli_warn(c(
+      "{.arg data} already has a column named {.val {name}}.",
+      "i" = "Returning {.arg data} unchanged."
     ))
 
     return(data)

R/model-matrix.R

@@ -178,11 +178,11 @@ model_matrix_one_hot <- function(terms, data) {
 #' @keywords internal
 contr_one_hot <- function(n, contrasts = TRUE, sparse = FALSE) {
   if (sparse) {
-    warn("`sparse = TRUE` not implemented for `contr_one_hot()`.")
+    cli::cli_warn("{.code sparse = TRUE} not implemented for {.fn contr_one_hot}.")
   }
 
   if (!contrasts) {
-    warn("`contrasts = FALSE` not implemented for `contr_one_hot()`.")
+    cli::cli_warn("{.code contrasts = FALSE} not implemented for {.fn contr_one_hot}.")
   }
 
   if (is.character(n)) {
@@ -192,12 +192,12 @@ contr_one_hot <- function(n, contrasts = TRUE, sparse = FALSE) {
     n <- as.integer(n)
 
     if (length(n) != 1L) {
-      abort("`n` must have length 1 when an integer is provided.")
+      cli::cli_abort("{.arg n} must have length 1 when an integer is provided.")
     }
 
     names <- as.character(seq_len(n))
   } else {
-    abort("`n` must be a character vector or an integer of size 1.")
+    cli::cli_abort("{.arg n} must be a character vector or an integer of size 1.")
   }
 
   out <- diag(n)

R/model-offset.R

@@ -63,9 +63,9 @@ model_offset <- function(terms, data) {
     if (!is.numeric(.offset_val)) {
       bad_col <- colnames(data)[.pos]
 
-      glubort(
-        "Column, '{bad_col}', is tagged as an offset, but is not numeric. ",
-        "All offsets must be numeric."
+      cli::cli_abort(
+        "Column {.val {bad_col}} is tagged as an offset and thus must be
+        numeric, not {.obj_type_friendly { .offset_val }}."
       )
     }
 

R/mold.R

@@ -175,7 +175,5 @@ run_mold <- function(blueprint, ...) {
 
 #' @export
 run_mold.default <- function(blueprint, ...) {
-  class <- class(blueprint)[[1L]]
-  message <- glue("No `run_mold()` method provided for an object of type <{class}>.")
-  abort(message)
+  cli::cli_abort("No {.fn run_mold} method provided for {.obj_type_friendly {blueprint}}.")
 }

R/print.R

@@ -9,28 +9,21 @@ format.formula_blueprint <- function(x, ...) "Formula"
 
 #' @export
 print.hardhat_blueprint <- function(x, ...) {
-  cat_line("{format(x)} blueprint:")
-  cat_line("\n")
-  cat_line("# Predictors: {n_blueprint_predictors(x)}")
-  cat_line("  # Outcomes: {n_blueprint_outcomes(x)}")
-  cat_line("   Intercept: {x$intercept}")
-  cat_line("Novel Levels: {x$allow_novel_levels}")
-  cat_line(" Composition: {x$composition}")
-  invisible(x)
-}
+  cli::cli_text("{format(x)} blueprint:")
 
-#' @export
-print.formula_blueprint <- function(x, ...) {
-  NextMethod()
-  cat_line("  Indicators: {x$indicators}")
+  cli::cli_par()
+  cli::cli_text("# Predictors: {n_blueprint_predictors(x)}")
+  cli::cli_text("# Outcomes: {n_blueprint_outcomes(x)}")
+  cli::cli_text("Intercept: {x$intercept}")
+  cli::cli_text("Novel Levels: {x$allow_novel_levels}")
+  cli::cli_text("Composition: {x$composition}")
+  if (inherits(x, "formula_blueprint")) {
+    cli::cli_text("Indicators: {x$indicators}")
+  }
+  cli::cli_end()
   invisible(x)
 }
 
-cat_line <- function(..., .envir = parent.frame()) {
-  lines <- paste(glue(..., .envir = .envir), "\n")
-  cat(lines, sep = "")
-}
-
 n_blueprint_predictors <- function(x) {
   ncol(x$ptypes$predictors) %||% 0L
 }

R/quantile-pred.R

@@ -57,7 +57,10 @@ new_quantile_pred <- function(values = list(), quantile_levels = double()) {
 #' @rdname quantile_pred
 extract_quantile_levels <- function(x) {
   if (!inherits(x, "quantile_pred")) {
-    cli::cli_abort("{.arg x} should have class {.cls quantile_pred}.")
+    cli::cli_abort(
+      "{.arg x} must be a {.cls quantile_pred} object, not
+      {.obj_type_friendly {x}}."
+    )
   }
   attr(x, "quantile_levels")
 }
@@ -131,12 +134,7 @@ obj_print_footer.quantile_pred <- function(x, digits = 3, ...) {
 # Checking functions
 
 check_quantile_pred_inputs <- function(values, levels, call = caller_env()) {
-  if (!is.matrix(values)) {
-    cli::cli_abort(
-      "{.arg values} must be a {.cls matrix}, not {.obj_type_friendly {values}}.",
-      call = call
-    )
-  }
+  check_inherits(values, "matrix", call = call)
 
   num_lvls <- length(levels)
 
@@ -168,10 +166,12 @@ check_quantile_levels <- function(levels, call = rlang::caller_env()) {
     redund <- levels[is_dup]
     redund <- unique(redund)
     redund <- signif(redund, digits = 5)
-    cli::cli_abort(c(
-      "Quantile levels should be unique.",
-      i = "The following {cli::qty(length(redund))}value{?s} {?was/were} repeated:
-         {redund}."),
+    cli::cli_abort(
+      c(
+        "Quantile levels must be unique.",
+        i = "The following {cli::qty(length(redund))}value{?s} {?was/were}
+            repeated: {redund}."
+      ),
       call = call
     )
   }

R/recompose.R

@@ -77,7 +77,8 @@ coerce_to_matrix <- function(data, error_call = caller_env()) {
 
     message <- c(
       "{.arg data} must only contain numeric columns.",
-      i = "These columns aren't numeric: {.str {loc}}."
+      i = "{cli::qty(length(loc))}{?This/These} column{?s} {?isn't/aren't} 
+           numeric: {.val {loc}}."
     )
 
     cli::cli_abort(message, call = error_call)

R/scream.R

@@ -238,13 +238,13 @@ check_novel_levels <- function(x, ptype, column) {
 }
 
 warn_novel_levels <- function(levels, column) {
-  message <- glue(
-    "Novel levels found in column '{column}': {glue_quote_collapse(levels)}. ",
-    "The levels have been removed, and values have been coerced to 'NA'."
-  )
-
-  warn(
-    message,
+  n_levels <- length(levels)
+  cli::cli_warn(
+    c(
+      "{cli::qty(n_levels)}Novel level{?s} found in column {.val {column}}: {.val {levels}}.",
+      "i" = "The {cli::qty(n_levels)}level{?s} {?has/have} been removed,
+            and values have been coerced to {.cls NA}."
+    ),
     class = "hardhat_warn_novel_levels",
     levels = levels,
     column = column

R/spruce.R

@@ -66,9 +66,9 @@ spruce_prob <- function(pred_levels, prob_matrix) {
   n_col <- ncol(prob_matrix)
 
   if (n_levels != n_col) {
-    glubort(
-      "The number of levels ({n_levels}) must be
-      equal to the number of class probability columns ({n_col})."
+    cli::cli_abort(
+      "The number of levels ({n_levels}) must be equal to the number
+      of class probability columns ({n_col})."
     )
   }