diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R
new file mode 100644
index 0000000..7cd62fc
--- /dev/null
+++ b/R/import-standalone-obj-type.R
@@ -0,0 +1,348 @@
+# Standalone file: do not edit by hand
+# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-obj-type.R>
+# ----------------------------------------------------------------------
+#
+# ---
+# repo: r-lib/rlang
+# file: standalone-obj-type.R
+# last-updated: 2022-10-04
+# license: https://unlicense.org
+# ---
+#
+# ## Changelog
+#
+# 2022-10-04:
+# - `obj_type_friendly(value = TRUE)` now shows numeric scalars
+# literally.
+# - `stop_friendly_type()` now takes `show_value`, passed to
+# `obj_type_friendly()` as the `value` argument.
+#
+# 2022-10-03:
+# - Added `allow_na` and `allow_null` arguments.
+# - `NULL` is now backticked.
+# - Better friendly type for infinities and `NaN`.
+#
+# 2022-09-16:
+# - Unprefixed usage of rlang functions with `rlang::` to
+# avoid onLoad issues when called from rlang (#1482).
+#
+# 2022-08-11:
+# - Prefixed usage of rlang functions with `rlang::`.
+#
+# 2022-06-22:
+# - `friendly_type_of()` is now `obj_type_friendly()`.
+# - Added `obj_type_oo()`.
+#
+# 2021-12-20:
+# - Added support for scalar values and empty vectors.
+# - Added `stop_input_type()`
+#
+# 2021-06-30:
+# - Added support for missing arguments.
+#
+# 2021-04-19:
+# - Added support for matrices and arrays (#141).
+# - Added documentation.
+# - Added changelog.
+#
+# nocov start
+
+#' Return English-friendly type
+#' @param x Any R object.
+#' @param value Whether to describe the value of `x`. Special values
+#' like `NA` or `""` are always described.
+#' @param length Whether to mention the length of vectors and lists.
+#' @return A string describing the type. Starts with an indefinite
+#' article, e.g. "an integer vector".
+#' @noRd
+obj_type_friendly <- function(x, value = TRUE) {
+ if (is_missing(x)) {
+ return("absent")
+ }
+
+ if (is.object(x)) {
+ if (inherits(x, "quosure")) {
+ type <- "quosure"
+ } else {
+ type <- paste(class(x), collapse = "/")
+ }
+ return(sprintf("a <%s> object", type))
+ }
+
+ if (!is_vector(x)) {
+ return(.rlang_as_friendly_type(typeof(x)))
+ }
+
+ n_dim <- length(dim(x))
+
+ if (!n_dim) {
+ if (!is_list(x) && length(x) == 1) {
+ if (is_na(x)) {
+ return(switch(
+ typeof(x),
+ logical = "`NA`",
+ integer = "an integer `NA`",
+ double =
+ if (is.nan(x)) {
+ "`NaN`"
+ } else {
+ "a numeric `NA`"
+ },
+ complex = "a complex `NA`",
+ character = "a character `NA`",
+ .rlang_stop_unexpected_typeof(x)
+ ))
+ }
+
+ show_infinites <- function(x) {
+ if (x > 0) {
+ "`Inf`"
+ } else {
+ "`-Inf`"
+ }
+ }
+ str_encode <- function(x, width = 30, ...) {
+ if (nchar(x) > width) {
+ x <- substr(x, 1, width - 3)
+ x <- paste0(x, "...")
+ }
+ encodeString(x, ...)
+ }
+
+ if (value) {
+ if (is.numeric(x) && is.infinite(x)) {
+ return(show_infinites(x))
+ }
+
+ if (is.numeric(x) || is.complex(x)) {
+ number <- as.character(round(x, 2))
+ what <- if (is.complex(x)) "the complex number" else "the number"
+ return(paste(what, number))
+ }
+
+ return(switch(
+ typeof(x),
+ logical = if (x) "`TRUE`" else "`FALSE`",
+ character = {
+ what <- if (nzchar(x)) "the string" else "the empty string"
+ paste(what, str_encode(x, quote = "\""))
+ },
+ raw = paste("the raw value", as.character(x)),
+ .rlang_stop_unexpected_typeof(x)
+ ))
+ }
+
+ return(switch(
+ typeof(x),
+ logical = "a logical value",
+ integer = "an integer",
+ double = if (is.infinite(x)) show_infinites(x) else "a number",
+ complex = "a complex number",
+ character = if (nzchar(x)) "a string" else "\"\"",
+ raw = "a raw value",
+ .rlang_stop_unexpected_typeof(x)
+ ))
+ }
+
+ if (length(x) == 0) {
+ return(switch(
+ typeof(x),
+ logical = "an empty logical vector",
+ integer = "an empty integer vector",
+ double = "an empty numeric vector",
+ complex = "an empty complex vector",
+ character = "an empty character vector",
+ raw = "an empty raw vector",
+ list = "an empty list",
+ .rlang_stop_unexpected_typeof(x)
+ ))
+ }
+ }
+
+ vec_type_friendly(x)
+}
+
+vec_type_friendly <- function(x, length = FALSE) {
+ if (!is_vector(x)) {
+ abort("`x` must be a vector.")
+ }
+ type <- typeof(x)
+ n_dim <- length(dim(x))
+
+ add_length <- function(type) {
+ if (length && !n_dim) {
+ paste0(type, sprintf(" of length %s", length(x)))
+ } else {
+ type
+ }
+ }
+
+ if (type == "list") {
+ if (n_dim < 2) {
+ return(add_length("a list"))
+ } else if (is.data.frame(x)) {
+ return("a data frame")
+ } else if (n_dim == 2) {
+ return("a list matrix")
+ } else {
+ return("a list array")
+ }
+ }
+
+ type <- switch(
+ type,
+ logical = "a logical %s",
+ integer = "an integer %s",
+ numeric = ,
+ double = "a double %s",
+ complex = "a complex %s",
+ character = "a character %s",
+ raw = "a raw %s",
+ type = paste0("a ", type, " %s")
+ )
+
+ if (n_dim < 2) {
+ kind <- "vector"
+ } else if (n_dim == 2) {
+ kind <- "matrix"
+ } else {
+ kind <- "array"
+ }
+ out <- sprintf(type, kind)
+
+ if (n_dim >= 2) {
+ out
+ } else {
+ add_length(out)
+ }
+}
+
+.rlang_as_friendly_type <- function(type) {
+ switch(
+ type,
+
+ list = "a list",
+
+ NULL = "`NULL`",
+ environment = "an environment",
+ externalptr = "a pointer",
+ weakref = "a weak reference",
+ S4 = "an S4 object",
+
+ name = ,
+ symbol = "a symbol",
+ language = "a call",
+ pairlist = "a pairlist node",
+ expression = "an expression vector",
+
+ char = "an internal string",
+ promise = "an internal promise",
+ ... = "an internal dots object",
+ any = "an internal `any` object",
+ bytecode = "an internal bytecode object",
+
+ primitive = ,
+ builtin = ,
+ special = "a primitive function",
+ closure = "a function",
+
+ type
+ )
+}
+
+.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) {
+ abort(
+ sprintf("Unexpected type <%s>.", typeof(x)),
+ call = call
+ )
+}
+
+#' Return OO type
+#' @param x Any R object.
+#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`,
+#' `"R6"`, or `"R7"`.
+#' @noRd
+obj_type_oo <- function(x) {
+ if (!is.object(x)) {
+ return("bare")
+ }
+
+ class <- inherits(x, c("R6", "R7_object"), which = TRUE)
+
+ if (class[[1]]) {
+ "R6"
+ } else if (class[[2]]) {
+ "R7"
+ } else if (isS4(x)) {
+ "S4"
+ } else {
+ "S3"
+ }
+}
+
+#' @param x The object type which does not conform to `what`. Its
+#' `obj_type_friendly()` is taken and mentioned in the error message.
+#' @param what The friendly expected type as a string. Can be a
+#' character vector of expected types, in which case the error
+#' message mentions all of them in an "or" enumeration.
+#' @param show_value Passed to `value` argument of `obj_type_friendly()`.
+#' @param ... Arguments passed to [abort()].
+#' @inheritParams args_error_context
+#' @noRd
+stop_input_type <- function(x,
+ what,
+ ...,
+ allow_na = FALSE,
+ allow_null = FALSE,
+ show_value = TRUE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ # From standalone-cli.R
+ cli <- env_get_list(
+ nms = c("format_arg", "format_code"),
+ last = topenv(),
+ default = function(x) sprintf("`%s`", x),
+ inherit = TRUE
+ )
+
+ if (allow_na) {
+ what <- c(what, cli$format_code("NA"))
+ }
+ if (allow_null) {
+ what <- c(what, cli$format_code("NULL"))
+ }
+ if (length(what)) {
+ what <- oxford_comma(what)
+ }
+
+ message <- sprintf(
+ "%s must be %s, not %s.",
+ cli$format_arg(arg),
+ what,
+ obj_type_friendly(x, value = show_value)
+ )
+
+ abort(message, ..., call = call, arg = arg)
+}
+
+oxford_comma <- function(chr, sep = ", ", final = "or") {
+ n <- length(chr)
+
+ if (n < 2) {
+ return(chr)
+ }
+
+ head <- chr[seq_len(n - 1)]
+ last <- chr[n]
+
+ head <- paste(head, collapse = sep)
+
+ # Write a or b. But a, b, or c.
+ if (n > 2) {
+ paste0(head, sep, final, " ", last)
+ } else {
+ paste0(head, " ", final, " ", last)
+ }
+}
+
+# nocov end
diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R
new file mode 100644
index 0000000..4c4ca85
--- /dev/null
+++ b/R/import-standalone-types-check.R
@@ -0,0 +1,493 @@
+# Standalone file: do not edit by hand
+# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-types-check.R>
+# ----------------------------------------------------------------------
+#
+# ---
+# repo: r-lib/rlang
+# file: standalone-types-check.R
+# last-updated: 2023-02-15
+# license: https://unlicense.org
+# dependencies: standalone-obj-type.R
+# ---
+#
+# ## Changelog
+#
+# 2023-02-15:
+# - Added `check_logical()`.
+#
+# - `check_bool()`, `check_number_whole()`, and
+# `check_number_decimal()` are now implemented in C.
+#
+# - For efficiency, `check_number_whole()` and
+# `check_number_decimal()` now take a `NULL` default for `min` and
+# `max`. This makes it possible to bypass unnecessary type-checking
+# and comparisons in the default case of no bounds checks.
+#
+# 2022-10-07:
+# - `check_number_whole()` and `_decimal()` no longer treat
+# non-numeric types such as factors or dates as numbers. Numeric
+# types are detected with `is.numeric()`.
+#
+# 2022-10-04:
+# - Added `check_name()` that forbids the empty string.
+# `check_string()` allows the empty string by default.
+#
+# 2022-09-28:
+# - Removed `what` arguments.
+# - Added `allow_na` and `allow_null` arguments.
+# - Added `allow_decimal` and `allow_infinite` arguments.
+# - Improved errors with absent arguments.
+#
+#
+# 2022-09-16:
+# - Unprefixed usage of rlang functions with `rlang::` to
+# avoid onLoad issues when called from rlang (#1482).
+#
+# 2022-08-11:
+# - Added changelog.
+#
+# nocov start
+
+# Scalars -----------------------------------------------------------------
+
+.standalone_types_check_dot_call <- .Call
+
+check_bool <- function(x,
+ ...,
+ allow_na = FALSE,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) {
+ return(invisible(NULL))
+ }
+
+ stop_input_type(
+ x,
+ c("`TRUE`", "`FALSE`"),
+ ...,
+ allow_na = allow_na,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_string <- function(x,
+ ...,
+ allow_empty = TRUE,
+ allow_na = FALSE,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ is_string <- .rlang_check_is_string(
+ x,
+ allow_empty = allow_empty,
+ allow_na = allow_na,
+ allow_null = allow_null
+ )
+ if (is_string) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a single string",
+ ...,
+ allow_na = allow_na,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+.rlang_check_is_string <- function(x,
+ allow_empty,
+ allow_na,
+ allow_null) {
+ if (is_string(x)) {
+ if (allow_empty || !is_string(x, "")) {
+ return(TRUE)
+ }
+ }
+
+ if (allow_null && is_null(x)) {
+ return(TRUE)
+ }
+
+ if (allow_na && (identical(x, NA) || identical(x, na_chr))) {
+ return(TRUE)
+ }
+
+ FALSE
+}
+
+check_name <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ is_string <- .rlang_check_is_string(
+ x,
+ allow_empty = FALSE,
+ allow_na = FALSE,
+ allow_null = allow_null
+ )
+ if (is_string) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a valid name",
+ ...,
+ allow_na = FALSE,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+IS_NUMBER_true <- 0
+IS_NUMBER_false <- 1
+IS_NUMBER_oob <- 2
+
+check_number_decimal <- function(x,
+ ...,
+ min = NULL,
+ max = NULL,
+ allow_infinite = TRUE,
+ allow_na = FALSE,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (missing(x)) {
+ exit_code <- IS_NUMBER_false
+ } else if (0 == (exit_code <- .standalone_types_check_dot_call(
+ ffi_standalone_check_number_1.0.7,
+ x,
+ allow_decimal = TRUE,
+ min,
+ max,
+ allow_infinite,
+ allow_na,
+ allow_null
+ ))) {
+ return(invisible(NULL))
+ }
+
+ .stop_not_number(
+ x,
+ ...,
+ exit_code = exit_code,
+ allow_decimal = TRUE,
+ min = min,
+ max = max,
+ allow_na = allow_na,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_number_whole <- function(x,
+ ...,
+ min = NULL,
+ max = NULL,
+ allow_na = FALSE,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (missing(x)) {
+ exit_code <- IS_NUMBER_false
+ } else if (0 == (exit_code <- .standalone_types_check_dot_call(
+ ffi_standalone_check_number_1.0.7,
+ x,
+ allow_decimal = FALSE,
+ min,
+ max,
+ allow_infinite = FALSE,
+ allow_na,
+ allow_null
+ ))) {
+ return(invisible(NULL))
+ }
+
+ .stop_not_number(
+ x,
+ ...,
+ exit_code = exit_code,
+ allow_decimal = FALSE,
+ min = min,
+ max = max,
+ allow_na = allow_na,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+.stop_not_number <- function(x,
+ ...,
+ exit_code,
+ allow_decimal,
+ min,
+ max,
+ allow_na,
+ allow_null,
+ arg,
+ call) {
+ if (exit_code == IS_NUMBER_oob) {
+ min <- min %||% -Inf
+ max <- max %||% Inf
+
+ if (min > -Inf && max < Inf) {
+ what <- sprintf("a number between %s and %s", min, max)
+ } else if (x < min) {
+ what <- sprintf("a number larger than %s", min)
+ } else if (x > max) {
+ what <- sprintf("a number smaller than %s", max)
+ } else {
+ abort("Unexpected state in OOB check", .internal = TRUE)
+ }
+ } else if (allow_decimal) {
+ what <- "a number"
+ } else {
+ what <- "a whole number"
+ }
+
+ stop_input_type(
+ x,
+ what,
+ ...,
+ allow_na = allow_na,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_symbol <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_symbol(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a symbol",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_arg <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_symbol(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "an argument name",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_call <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_call(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a defused call",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_environment <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_environment(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "an environment",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_function <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_function(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a function",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_closure <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_closure(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "an R function",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_formula <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_formula(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a formula",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+
+# Vectors -----------------------------------------------------------------
+
+check_character <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_character(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a character vector",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+check_logical <- function(x,
+ ...,
+ allow_null = FALSE,
+ arg = caller_arg(x),
+ call = caller_env()) {
+ if (!missing(x)) {
+ if (is_logical(x)) {
+ return(invisible(NULL))
+ }
+ if (allow_null && is_null(x)) {
+ return(invisible(NULL))
+ }
+ }
+
+ stop_input_type(
+ x,
+ "a logical vector",
+ ...,
+ allow_null = allow_null,
+ arg = arg,
+ call = call
+ )
+}
+
+# nocov end
diff --git a/R/utils-check.R b/R/utils-check.R
index a6a5bef..ef68fe8 100644
--- a/R/utils-check.R
+++ b/R/utils-check.R
@@ -21,28 +21,6 @@ check_null <- function(x = NULL,
return(invisible(TRUE))
}
-#' Check if x is a character vector
-#'
-#' @noRd
-check_character <- function(x = NULL,
- arg = caller_arg(x),
- null.ok = FALSE,
- ...) {
- check_null(x, arg, null.ok)
- null.ok <- is.null(x) && null.ok
-
- if (is.character(x) || null.ok) {
- return(invisible(TRUE))
- }
-
- cli_abort(
- c("{.arg {arg}} must be {.cls character}.",
- "i" = "{.arg {arg}}has class {.cls {class(x)}}."
- ),
- ...
- )
-}
-
#' Check if x is between a min and max length
#'
#' @noRd
@@ -106,7 +84,7 @@ check_starts_with <- function(x = NULL,
perl = FALSE,
message = NULL,
...) {
- check_character(x, arg, null.ok)
+ check_character(x, allow_null = null.ok, arg = arg)
null.ok <- is.null(x) && null.ok
starts_with <-
@@ -126,31 +104,6 @@ check_starts_with <- function(x = NULL,
cli_abort(message = message, ...)
}
-#' Check if x is logical
-#'
-#' @noRd
-check_logical <- function(x = NULL,
- null.ok = FALSE,
- n = NULL,
- arg = caller_arg(x),
- call = caller_env(),
- ...) {
- check_null(x, arg, null.ok, FALSE, call)
- null.ok <- is.null(x) && null.ok
-
- if (is_logical(x, n = n) || null.ok) {
- return(invisible(TRUE))
- }
-
- cli_abort(
- c("{.arg {arg}} must be {.cls logical}.",
- "i" = "{.arg {arg}} has class {.cls {class(x)}}."
- ),
- call = call,
- ...
- )
-}
-
#' Check if x is an sf object
#'
#' If x is an `sf` object invisibly return TRUE. If not, return an error with [cli::cli_abort]