Merge pull request #270 from tidymodels/update-type-checkers

Type checkers refresh

Author: hfrick

R/import-standalone-obj-type.R

@@ -1,17 +1,27 @@
 # Standalone file: do not edit by hand
-# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-obj-type.R>
+# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R
+# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type")
 # ----------------------------------------------------------------------
 #
 # ---
 # repo: r-lib/rlang
 # file: standalone-obj-type.R
-# last-updated: 2022-10-04
+# 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.
+#
+# 2023-03-30:
+# - `stop_input_type()` now handles `I()` input literally in `arg`.
+#
 # 2022-10-04:
 # - `obj_type_friendly(value = TRUE)` now shows numeric scalars
 #   literally.
@@ -65,7 +75,7 @@ obj_type_friendly <- function(x, value = TRUE) {
     if (inherits(x, "quosure")) {
       type <- "quosure"
     } else {
-      type <- paste(class(x), collapse = "/")
+      type <- class(x)[[1L]]
     }
     return(sprintf("a <%s> object", type))
   }
@@ -261,19 +271,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 {
@@ -315,10 +325,15 @@ stop_input_type <- function(x,
   if (length(what)) {
     what <- oxford_comma(what)
   }
+  if (inherits(arg, "AsIs")) {
+    format_arg <- identity
+  } else {
+    format_arg <- cli$format_arg
+  }
 
   message <- sprintf(
     "%s must be %s, not %s.",
-    cli$format_arg(arg),
+    format_arg(arg),
     what,
     obj_type_friendly(x, value = show_value)
   )

R/import-standalone-types-check.R

@@ -1,5 +1,6 @@
 # Standalone file: do not edit by hand
-# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-types-check.R>
+# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R
+# Generated by: usethis::use_standalone("r-lib/rlang", "types-check")
 # ----------------------------------------------------------------------
 #
 # ---
@@ -13,6 +14,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 +465,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 +496,6 @@ check_character <- function(x,
     x,
     "a character vector",
     ...,
-    allow_na = FALSE,
     allow_null = allow_null,
     arg = arg,
     call = call

R/table.R

@@ -119,9 +119,7 @@ weighted_table <- function(..., weights, na_remove = FALSE) {
   weights <- vec_cast(weights, to = double())
   vec_assert(weights, size = size)
 
-  if (!is_bool(na_remove)) {
-    abort("`na_remove` must be a single `TRUE` or `FALSE`.")
-  }
+  check_bool(na_remove)
 
   tapply(
     X = weights,

R/tune.R

@@ -25,12 +25,7 @@
 #'   step_normalize(all_numeric_predictors()) %>%
 #'   step_pca(all_numeric_predictors, num_comp = tune())
 tune <- function(id = "") {
-  if (!is.character(id) || length(id) != 1) {
-    abort("The `id` should be a single character string.")
-  }
-  if (is.na(id)) {
-    abort("The `id` can't be missing.")
-  }
+  check_string(id)
 
   if (id == "") {
     call("tune")

R/use.R

@@ -59,9 +59,7 @@ create_modeling_package <- function(path,
   check_installed("withr")
 
   # Avoid creating files if a bad model is supplied
-  if (!is_string(model)) {
-    abort("`model` must be a single string.")
-  }
+  check_string(model)
 
   if (has_spaces(model)) {
     abort("`model` must not contain any spaces.")
@@ -126,10 +124,8 @@ use_modeling_files <- function(model) {
 use_modeling_files_impl <- function(model, prompt_document = TRUE) {
   check_installed("usethis")
 
-  if (!is_string(model)) {
-    abort("`model` must be a string.")
-  }
-
+  check_string(model)
+  
   if (has_spaces(model)) {
     abort("`model` must not contain any spaces.")
   }

tests/testthat/_snaps/table.md

@@ -4,15 +4,15 @@
       weighted_table(x, y, weights = w, na_remove = c(TRUE, FALSE))
     Condition
       Error in `weighted_table()`:
-      ! `na_remove` must be a single `TRUE` or `FALSE`.
+      ! `na_remove` must be `TRUE` or `FALSE`, not a logical vector.
 
 ---
 
     Code
       weighted_table(x, y, weights = w, na_remove = 1)
     Condition
       Error in `weighted_table()`:
-      ! `na_remove` must be a single `TRUE` or `FALSE`.
+      ! `na_remove` must be `TRUE` or `FALSE`, not the number 1.
 
 # requires at least one `...`
 

tests/testthat/_snaps/tune.md

@@ -4,21 +4,21 @@
       tune(1)
     Condition
       Error in `tune()`:
-      ! The `id` should be a single character string.
+      ! `id` must be a single string, not the number 1.
 
 ---
 
     Code
       tune(c("x", "y"))
     Condition
       Error in `tune()`:
-      ! The `id` should be a single character string.
+      ! `id` must be a single string, not a character vector.
 
 ---
 
     Code
       tune(NA_character_)
     Condition
       Error in `tune()`:
-      ! The `id` can't be missing.
+      ! `id` must be a single string, not a character `NA`.
 

tests/testthat/_snaps/use.md

@@ -20,15 +20,15 @@
       create_modeling_package(path = "my/path", model = c("model1", "model2"))
     Condition
       Error in `create_modeling_package()`:
-      ! `model` must be a single string.
+      ! `model` must be a single string, not a character vector.
 
 ---
 
     Code
       create_modeling_package(path = "my/path", model = 1)
     Condition
       Error in `create_modeling_package()`:
-      ! `model` must be a single string.
+      ! `model` must be a single string, not the number 1.
 
 ---