Add rlang type checkers

NEWS.md

@@ -8,6 +8,8 @@
 
 * `prep.recipe(..., strings_as_factors = TRUE)` now only converts string variables that have role "predictor" or "outcome". (@dajmcdon, #1358, #1376)
 
+* All steps and checks now require arguments `trained`, `skip`, and `id` at all times.
+
 # recipes 1.1.0
 
 ## Improvements

R/import-standalone-obj-type.R

@@ -5,13 +5,16 @@
 # ---
 # repo: r-lib/rlang
 # file: standalone-obj-type.R
-# last-updated: 2023-05-01
+# last-updated: 2024-02-14
 # license: https://unlicense.org
 # imports: rlang (>= 1.1.0)
 # ---
 #
 # ## Changelog
 #
+# 2024-02-14:
+# - `obj_type_friendly()` now works for S7 objects.
+#
 # 2023-05-01:
 # - `obj_type_friendly()` now only displays the first class of S3 objects.
 #
@@ -267,19 +270,19 @@ vec_type_friendly <- function(x, length = FALSE) {
 #' Return OO type
 #' @param x Any R object.
 #' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`,
-#'   `"R6"`, or `"R7"`.
+#'   `"R6"`, or `"S7"`.
 #' @noRd
 obj_type_oo <- function(x) {
   if (!is.object(x)) {
     return("bare")
   }
 
-  class <- inherits(x, c("R6", "R7_object"), which = TRUE)
+  class <- inherits(x, c("R6", "S7_object"), which = TRUE)
 
   if (class[[1]]) {
     "R6"
   } else if (class[[2]]) {
-    "R7"
+    "S7"
   } else if (isS4(x)) {
     "S4"
   } else {

R/import-standalone-types-check.R

@@ -13,6 +13,9 @@
 #
 # ## Changelog
 #
+# 2024-08-15:
+# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724)
+#
 # 2023-03-13:
 # - Improved error messages of number checkers (@teunbrand)
 # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich).
@@ -461,15 +464,28 @@ check_formula <- function(x,
 
 # Vectors -----------------------------------------------------------------
 
+# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE`
+
 check_character <- function(x,
                             ...,
+                            allow_na = TRUE,
                             allow_null = FALSE,
                             arg = caller_arg(x),
                             call = caller_env()) {
+
   if (!missing(x)) {
     if (is_character(x)) {
+      if (!allow_na && any(is.na(x))) {
+        abort(
+          sprintf("`%s` can't contain NA values.", arg),
+          arg = arg,
+          call = call
+        )
+      }
+
       return(invisible(NULL))
     }
+
     if (allow_null && is_null(x)) {
       return(invisible(NULL))
     }
@@ -479,7 +495,6 @@ check_character <- function(x,
     x,
     "a character vector",
     ...,
-    allow_na = FALSE,
     allow_null = allow_null,
     arg = arg,
     call = call

R/misc.R

@@ -65,7 +65,10 @@ get_rhs_vars <- function(formula, data, no_lhs = FALSE) {
 #' @param ordinal A logical; was the original factor ordered?
 #' @param sep A single character value for the separator between the names and
 #'  levels.
-#'
+#' @param call The execution environment of a currently running function, e.g.
+#'   `caller_env()`. The function will be mentioned in error messages as the
+#'   source of the error. See the call argument of [rlang::abort()] for more
+#'   information.
 #' @details When using `dummy_names()`, factor levels that are not valid
 #'  variable names (e.g. "some text  with spaces") will be changed to valid
 #'  names by [base::make.names()]; see example below. This function will also
@@ -98,9 +101,9 @@ get_rhs_vars <- function(formula, data, no_lhs = FALSE) {
 #'
 #' dummy_names("x", substring(after_mm, 2), ordinal = TRUE)
 #' @export
-names0 <- function(num, prefix = "x") {
+names0 <- function(num, prefix = "x", call = rlang::caller_env()) {
   if (num < 1) {
-    cli::cli_abort("{.arg num} should be > 0.")
+    cli::cli_abort("{.arg num} should be > 0.", call = call)
   }
   ind <- format(seq_len(num))
   ind <- gsub(" ", "0", ind)
@@ -635,7 +638,7 @@ rand_id <- function(prefix = "step", len = 5) {
 }
 
 
-check_nominal_type <- function(x, lvl) {
+check_nominal_type <- function(x, lvl, call = rlang::caller_env()) {
   all_act_cols <- names(x)
 
   # What columns do we expect to be factors based on the data
@@ -667,7 +670,8 @@ check_nominal_type <- function(x, lvl) {
                 ",
           "*" = "{.and {.var {was_factor}}}",
           "i" = "This may cause errors when processing new data."
-        )
+        ),
+        call = call
       )
     }
   }
@@ -873,7 +877,7 @@ check_new_data <- function(req, object, new_data) {
   step_cls <- class(object)[1]
   step_id <- object$id
   cli::cli_abort(
-    "The following required {cli::qty(col_diff)} column{?s} {?is/are} missing 
+    "The following required {cli::qty(col_diff)} column{?s} {?is/are} missing
     from {.arg new_data}: {col_diff}.",
     call = rlang::call2(step_cls)
   )

R/steps_and_checks.R

@@ -5,24 +5,41 @@
 #' @param subclass A character string for the resulting class. For example,
 #'   if `subclass = "blah"` the step object that is returned has class
 #'   `step_blah` or `check_blah` depending on the context.
-#' @param ... All arguments to the operator that should be returned.
+#' @param ... All arguments to the operator that should be returned. Required
+#' arguments are `trained`, `skip`, and `id`.
 #' @param .prefix Prefix to the subclass created.
 #'
 #' @seealso [developer_functions]
 #'
 #' @keywords internal
 #' @return An updated step or check with the new class.
 #' @export
-step <- function(subclass, ..., .prefix = "step_") {
-  structure(list(...),
+step <- function(subclass, ..., .prefix = "step_",
+                 call = rlang::caller_env()) {
+  args <- list(...)
+
+  check_string(subclass, call = call)
+  .prefix <- rlang::arg_match0(.prefix, c("step_", "check_", ""),
+                               error_call = call)
+  check_step_check_args(args, call = call)
+
+  structure(args,
     class = c(paste0(.prefix, subclass), "step")
   )
 }
 
 #' @rdname step
 #' @export
-check <- function(subclass, ..., .prefix = "check_") {
-  structure(list(...),
+check <- function(subclass, ..., .prefix = "check_",
+                  call = rlang::caller_env()) {
+  args <- list(...)
+
+  check_string(subclass, call = call)
+  .prefix <- rlang::arg_match0(.prefix, c("step_", "check_", ""),
+                               error_call = call)
+  check_step_check_args(args, call = call)
+
+  structure(args,
     class = c(paste0(.prefix, subclass), "check")
   )
 }
@@ -51,3 +68,22 @@ add_check <- function(rec, object) {
   rec$steps[[length(rec$steps) + 1]] <- object
   rec
 }
+
+# ------------------------------------------------------------------------------
+
+check_step_check_args <- function(x, call = rlang::caller_env()) {
+  req_args <- c("trained", "id", "skip")
+  nms <- names(x)
+  has_req_args <- req_args %in% nms
+  if (!all(has_req_args)) {
+    miss_args <- req_args[!has_req_args]
+    cli::cli_abort("Some required arguments are missing: {.arg {miss_args}}.",
+                   call = call)
+  }
+  check_bool(x$trained, call = call, arg = "trained")
+  check_bool(x$skip, call = call, arg = "skip")
+  check_string(x$id, call = call, arg = "id")
+  invisible(x)
+}
+
+

R/tune_args.R

@@ -65,14 +65,16 @@ tune_tbl <- function(name = character(),
                      source = character(),
                      component = character(),
                      component_id = character(),
-                     full = FALSE) {
+                     full = FALSE,
+                     call = rlang::caller_env()) {
   complete_id <- id[!is.na(id)]
   dups <- duplicated(complete_id)
   if (any(dups)) {
     offenders <- unique(complete_id[dups])
     cli::cli_abort(
       "There are duplicate {.field id} values listed in {.fn tune}: \\
-      {.val {offenders}}."
+      {.val {offenders}}.",
+      call = call
     )
   }
 

tests/testthat/_snaps/basics.md

@@ -238,3 +238,43 @@
       Error in `recipe()`:
       ! `data` must be a data frame, matrix, or sparse matrix, not a function.
 
+# step constructor
+
+    Code
+      step_lightly(trained = "yes")
+    Condition
+      Error in `step_lightly()`:
+      ! `trained` must be `TRUE` or `FALSE`, not the string "yes".
+
+---
+
+    Code
+      step_lightly(id = TRUE)
+    Condition
+      Error in `step_lightly()`:
+      ! `id` must be a single string, not `TRUE`.
+
+---
+
+    Code
+      step_lightly(skip = "you betcha")
+    Condition
+      Error in `step_lightly()`:
+      ! `skip` must be `TRUE` or `FALSE`, not the string "you betcha".
+
+---
+
+    Code
+      step(subclass = "heavy")
+    Condition
+      Error:
+      ! Some required arguments are missing: `trained`, `id`, and `skip`.
+
+---
+
+    Code
+      step()
+    Condition
+      Error:
+      ! `subclass` must be a single string, not absent.
+

tests/testthat/_snaps/nomial_types.md

@@ -28,3 +28,13 @@
       * `city` and `zip`
       i This may cause errors when processing new data.
 
+---
+
+    Code
+      res <- bake(rec, te %>% mutate(city = as.character(city)))
+    Condition
+      Warning in `bake()`:
+      ! There were 2 columns that were factors when the recipe was prepped:
+      * `city` and `zip`
+      i This may cause errors when processing new data.
+

tests/testthat/_snaps/stringsAsFactors.md

@@ -3,7 +3,7 @@
     Code
       rec1_as_str <- bake(rec1, new_data = as_str)
     Condition
-      Warning:
+      Warning in `bake()`:
       ! There were 2 columns that were factors when the recipe was prepped:
       * `fact` and `ord`
       i This may cause errors when processing new data.
@@ -13,7 +13,7 @@
     Code
       rec2_as_str <- bake(rec2, new_data = as_str)
     Condition
-      Warning:
+      Warning in `bake()`:
       ! There were 2 columns that were factors when the recipe was prepped:
       * `fact` and `ord`
       i This may cause errors when processing new data.