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.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 {.cls integer} or {.cls 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.")
   }
 
   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

@@ -25,18 +25,18 @@ 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)}'."
+    cli::cli_abort(
+      "{.arg data} must be a data frame or matrix to add an intercept column,
+      not {.obj_type_friendly {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 {.field {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")
 }
@@ -169,7 +172,7 @@ check_quantile_levels <- function(levels, call = rlang::caller_env()) {
     redund <- unique(redund)
     redund <- signif(redund, digits = 5)
     cli::cli_abort(c(
-      "Quantile levels should be unique.",
+      "Quantile levels must be unique.",
       i = "The following {cli::qty(length(redund))}value{?s} {?was/were} repeated:
          {redund}."),
       call = 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 {.field {column}}: {.val {levels}}.",
+      "i" = "The {cli::qty(n_levels)}level{?s} {?has/have} been removed,
+            and values have been coerced to {.val 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})."
     )
   }
 

R/standardize.R

@@ -39,7 +39,7 @@ standardize <- function(y) {
 
 #' @export
 standardize.default <- function(y) {
-  glubort("`y` is of unknown type '{class1(y)}'.")
+  cli::cli_abort("No {.fn standardize} method provided for {.obj_type_friendly {y}}.")
 }
 
 #' @export
@@ -80,7 +80,7 @@ standardize.array <- function(y) {
   } else if (dims(y) == 2) {
     standardize.matrix(y)
   } else {
-    glubort("3D+ arrays are not supported outcome types.")
+    cli::cli_abort("3D+ arrays are not supported outcome types.")
   }
 }
 
@@ -101,11 +101,12 @@ validate_has_known_outcome_types <- function(y) {
   if (!all(known)) {
     not_known <- which(!known)
     not_known <- colnames(y)[not_known]
-    not_known <- glue_quote_collapse(not_known)
-
-    glubort(
-      "Not all columns of `y` are known outcome types. ",
-      "These columns have unknown types: {not_known}."
+    cli::cli_abort(
+      c(
+        "Not all columns of {.arg y} are known outcome types.",
+        "i" = "{?This/These} column{?s} {?has/have} {?an/} unknown type{?s}:
+              {.val {not_known}}."
+      )
     )
   }
 

R/table.R

@@ -103,17 +103,17 @@ weighted_table <- function(..., weights, na_remove = FALSE) {
   n_args <- length(args)
 
   if (n_args == 0L) {
-    abort("At least one vector must be supplied to `...`.")
+    cli::cli_abort("At least one vector must be supplied to {.arg ...}.")
   }
   if (!all(map_lgl(args, is.factor))) {
-    abort("All elements of `...` must be factors.")
+    cli::cli_abort("All elements of {.arg ...} must be factors.")
   }
 
   sizes <- list_sizes(args)
   size <- sizes[[1L]]
 
   if (!all(sizes == size)) {
-    abort("All elements of `...` must be the same size.")
+    cli::cli_abort("All elements of {.arg ...} must be the same size.")
   }
 
   weights <- vec_cast(weights, to = double())

R/use.R

@@ -62,7 +62,7 @@ create_modeling_package <- function(path,
   check_string(model)
 
   if (has_spaces(model)) {
-    abort("`model` must not contain any spaces.")
+    cli::cli_abort("{.arg model} must not contain any spaces.")
   }
 
   usethis::create_package(path, fields, open = FALSE)
@@ -125,9 +125,9 @@ use_modeling_files_impl <- function(model, prompt_document = TRUE) {
   check_installed("usethis")
 
   check_string(model)
-  
+
   if (has_spaces(model)) {
-    abort("`model` must not contain any spaces.")
+    cli::cli_abort("{.arg model} must not contain any spaces.")
   }
 
   data <- list(model = model)