-
Notifications
You must be signed in to change notification settings - Fork 23
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
use_standalone("r-lib/rlang", file = "types-check")
- Loading branch information
1 parent
927df77
commit f4b0d26
Showing
3 changed files
with
919 additions
and
1 deletion.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,364 @@ | ||
# Standalone file: do not edit by hand | ||
# 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: 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. | ||
# - `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 <- class(x)[[1L]] | ||
} | ||
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 `"S7"`. | ||
#' @noRd | ||
obj_type_oo <- function(x) { | ||
if (!is.object(x)) { | ||
return("bare") | ||
} | ||
|
||
class <- inherits(x, c("R6", "S7_object"), which = TRUE) | ||
|
||
if (class[[1]]) { | ||
"R6" | ||
} else if (class[[2]]) { | ||
"S7" | ||
} 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) | ||
} | ||
if (inherits(arg, "AsIs")) { | ||
format_arg <- identity | ||
} else { | ||
format_arg <- cli$format_arg | ||
} | ||
|
||
message <- sprintf( | ||
"%s must be %s, not %s.", | ||
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 |
Oops, something went wrong.