From ea44928307db3e72376ac8a1ecf3d18cec4166ff Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 22 Oct 2024 10:14:44 +0200 Subject: [PATCH] Import and use {rlang} type checks (#464) Thanks --- DESCRIPTION | 2 +- R/import-standalone-obj-type.R | 364 +++++++++++++++++ R/import-standalone-types-check.R | 554 ++++++++++++++++++++++++++ R/label-bytes.R | 9 +- R/label-date.R | 5 +- R/label-number.R | 7 +- R/pal-.R | 8 +- R/pal-dichromat.R | 6 +- R/scale-continuous.R | 3 +- R/transform.R | 44 +- R/utils.R | 19 + tests/testthat/_snaps/label-bytes.md | 8 + tests/testthat/_snaps/label-number.md | 4 +- tests/testthat/_snaps/trans.md | 2 +- tests/testthat/test-label-bytes.R | 2 +- 15 files changed, 990 insertions(+), 47 deletions(-) create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R create mode 100644 tests/testthat/_snaps/label-bytes.md diff --git a/DESCRIPTION b/DESCRIPTION index 476236c6..3800da3c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,7 @@ Imports: lifecycle, R6, RColorBrewer, - rlang (>= 1.0.0), + rlang (>= 1.1.0), viridisLite Suggests: bit64, diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 00000000..47268d62 --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -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 diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 00000000..ef8c5a1d --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,554 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R +# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-types-check.R +# last-updated: 2023-03-13 +# license: https://unlicense.org +# dependencies: standalone-obj-type.R +# imports: rlang (>= 1.1.0) +# --- +# +# ## 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). +# - Added `check_data_frame()` (@mgirlich). +# +# 2023-03-07: +# - Added dependency on rlang (>= 1.1.0). +# +# 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_infinite = FALSE, + 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, + 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 (allow_decimal) { + what <- "a number" + } else { + what <- "a whole number" + } + + if (exit_code == IS_NUMBER_oob) { + min <- min %||% -Inf + max <- max %||% Inf + + if (min > -Inf && max < Inf) { + what <- sprintf("%s between %s and %s", what, min, max) + } else if (x < min) { + what <- sprintf("%s larger than or equal to %s", what, min) + } else if (x > max) { + what <- sprintf("%s smaller than or equal to %s", what, max) + } else { + abort("Unexpected state in OOB check", .internal = TRUE) + } + } + + 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_na = FALSE, + 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_na = FALSE, + 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_na = FALSE, + 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_na = FALSE, + 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_na = FALSE, + 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_na = FALSE, + 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_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + + +# 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)) + } + } + + 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_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_data_frame <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is.data.frame(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a data frame", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +# nocov end diff --git a/R/label-bytes.R b/R/label-bytes.R index 8fa805e6..1eb90ef4 100644 --- a/R/label-bytes.R +++ b/R/label-bytes.R @@ -37,9 +37,7 @@ #' labels = label_bytes("auto_binary") #' ) label_bytes <- function(units = "auto_si", accuracy = 1, scale = 1, ...) { - if (!(is.character(units) && length(units) == 1)) { - cli::cli_abort("{.arg units} must be a scalar string") - } + check_string(units) force_all(accuracy, ...) function(x) { @@ -51,14 +49,13 @@ label_bytes <- function(units = "auto_si", accuracy = 1, scale = 1, ...) { si_units <- paste0(names(powers), "B") bin_units <- paste0(names(powers), "iB") + arg_match0(units, c(si_units, bin_units)) if (units %in% si_units) { base <- 1000 power <- powers[[match(units, si_units)]] - } else if (units %in% bin_units) { + } else { base <- 1024 power <- powers[[match(units, bin_units)]] - } else { - cli::cli_abort("{.val {units}} is not a valid unit") } suffix <- paste0(" ", units) diff --git a/R/label-date.R b/R/label-date.R index bcf3fb57..0cf47a41 100644 --- a/R/label-date.R +++ b/R/label-date.R @@ -123,7 +123,10 @@ label_time <- function(format = "%H:%M:%S", tz = "UTC", locale = NULL) { } else if (inherits(x, "difftime")) { format(as.POSIXct(x), format = format, tz = tz) } else { - cli::cli_abort("{.fun label_time} can't be used with an object of class {.cls {class(x)}}") + stop_input_type( + x, as_cli("used with a {.cls POSIXt} or {.cls difftime} object"), + arg = I(as_cli("{.fn label_time}")) + ) } } } diff --git a/R/label-number.R b/R/label-number.R index fd094f7a..b8a06eca 100644 --- a/R/label-number.R +++ b/R/label-number.R @@ -394,11 +394,12 @@ precision <- function(x) { # each value of x is assigned a suffix and associated scaling factor scale_cut <- function(x, breaks, scale = 1, accuracy = NULL, suffix = "") { - if (!is.numeric(breaks) || is.null(names(breaks))) { - cli::cli_abort("{.arg scale_cut} must be a named numeric vector") + check_object(breaks, is.numeric, "a numeric vector", arg = caller_arg(breaks)) + if (is.null(names(breaks))) { + cli::cli_abort("{.arg scale_cut} must have names") } breaks <- sort(breaks, na.last = TRUE) - if (any(is.na(breaks))) { + if (anyNA(breaks)) { cli::cli_abort("{.arg scale_cut} values must not be missing") } diff --git a/R/pal-.R b/R/pal-.R index 8665dfc6..4c20d174 100644 --- a/R/pal-.R +++ b/R/pal-.R @@ -62,9 +62,7 @@ #' pal <- as_discrete_pal(pal_div_gradient()) #' show_col(pal(9)) new_continuous_palette <- function(fun, type, na_safe = NA) { - if (!is.function(fun)) { - cli::cli_abort("{.arg fun} must be a function.") - } + check_function(fun) class(fun) <- union("pal_continuous", class(fun)) attr(fun, "type") <- type attr(fun, "na_safe") <- na_safe @@ -74,9 +72,7 @@ new_continuous_palette <- function(fun, type, na_safe = NA) { #' @rdname new_continuous_palette #' @export new_discrete_palette <- function(fun, type, nlevels = NA) { - if (!is.function(fun)) { - cli::cli_abort("{.arg fun} must be a function.") - } + check_function(fun) class(fun) <- union("pal_discrete", class(fun)) attr(fun, "type") <- type attr(fun, "nlevels") <- nlevels diff --git a/R/pal-dichromat.R b/R/pal-dichromat.R index 38aee521..4a94fb28 100644 --- a/R/pal-dichromat.R +++ b/R/pal-dichromat.R @@ -14,11 +14,7 @@ #' } pal_dichromat <- function(name) { check_installed("dichromat") - - if (!any(name == names(dichromat::colorschemes))) { - cli::cli_abort("Palette name must be one of {.or {.val {names(dichromat::colorschemes)}}}") - } - + arg_match0(name, names(dichromat::colorschemes)) pal <- dichromat::colorschemes[[name]] pal_manual(pal, type = "colour") diff --git a/R/scale-continuous.R b/R/scale-continuous.R index b5095fbe..d2ccd0a0 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -24,8 +24,7 @@ #' col = cscale(hp, pal_seq_gradient("grey80", "black")) #' )) cscale <- function(x, palette, na.value = NA_real_, trans = transform_identity()) { - if (!is.trans(trans)) cli::cli_abort("{.arg trans} must be a {.cls trans} object") - + check_object(trans, is.transform, "a {.cls transform} object") x <- trans$transform(x) limits <- train_continuous(x) map_continuous(palette, x, limits, na.value) diff --git a/R/transform.R b/R/transform.R index 3ea739b2..24e0ca3f 100644 --- a/R/transform.R +++ b/R/transform.R @@ -103,26 +103,32 @@ lines.transform <- function(x, ..., xlim) { #' @export as.transform <- function(x, arg = deparse(substitute(x))) { if (is.transform(x)) { - x - } else if (is.character(x) && length(x) >= 1) { - if (length(x) == 1) { - f <- paste0("transform_", x) - # For backward compatibility - fun <- get0(f, mode = "function") - if (is.null(fun)) { - f2 <- paste0(x, "_trans") - fun <- get0(f2, mode = "function") - } - if (is.null(fun)) { - cli::cli_abort("Could not find any function named {.fun {f}} or {.fun {f2}}") - } - fun() - } else { - transform_compose(!!!x) - } - } else { - cli::cli_abort(sprintf("{.arg %s} must be a character vector or a transformer object", arg)) + return(x) } + if (!(is.character(x) && length(x) >= 1)) { + stop_input_type(x, "a character vector or transform object") + } + + # A character vector is translated to a transform composition + if (length(x) != 1) { + return(transform_compose(!!!x)) + } + + # Single characters are interpreted as function names with the + # `transform_`-prefix + f <- paste0("transform_", x) + fun <- get0(f, mode = "function") + + # For backward compatibility we preserve `trans_`-prefixes + if (is.null(fun)) { + f2 <- paste0(x, "_trans") + fun <- get0(f2, mode = "function") + } + + if (is.null(fun)) { + cli::cli_abort("Could not find any function named {.fun {f}} or {.fun {f2}}") + } + fun() } #' @export diff --git a/R/utils.R b/R/utils.R index 25cfa505..55fdf6fd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -97,6 +97,25 @@ recycle_common <- function(..., size = NULL, call = caller_env()) { x } +as_cli <- function(..., env = caller_env()) { + cli::cli_fmt(cli::cli_text(..., .envir = env)) +} + +check_object <- function(x, check_fun, what, ..., allow_null = FALSE, + arg = caller_arg(x), call = caller_env()) { + if (!missing(x)) { + if (check_fun(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type(x, as_cli(what), ..., allow_null = allow_null, + arg = arg, call = call) +} + .onLoad <- function(lib, pkg) { run_on_load() } diff --git a/tests/testthat/_snaps/label-bytes.md b/tests/testthat/_snaps/label-bytes.md new file mode 100644 index 00000000..e995d89c --- /dev/null +++ b/tests/testthat/_snaps/label-bytes.md @@ -0,0 +1,8 @@ +# errors if unknown unit + + Code + label_bytes("unit")(0) + Condition + Error: + ! `units` must be one of "kB", "MB", "GB", "TB", "PB", "EB", "ZB", "YB", "kiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", or "YiB", not "unit". + diff --git a/tests/testthat/_snaps/label-number.md b/tests/testthat/_snaps/label-number.md index c70d7aa6..bf6e4422 100644 --- a/tests/testthat/_snaps/label-number.md +++ b/tests/testthat/_snaps/label-number.md @@ -4,12 +4,12 @@ number(1, scale_cut = 0) Condition Error in `scale_cut()`: - ! `scale_cut` must be a named numeric vector + ! `scale_cut` must have names Code number(1, scale_cut = "x") Condition Error in `scale_cut()`: - ! `scale_cut` must be a named numeric vector + ! `scale_cut` must be a numeric vector, not the string "x". Code number(1, scale_cut = c(x = 0, NA)) Condition diff --git a/tests/testthat/_snaps/trans.md b/tests/testthat/_snaps/trans.md index 0c4b0adc..4ec016e1 100644 --- a/tests/testthat/_snaps/trans.md +++ b/tests/testthat/_snaps/trans.md @@ -4,7 +4,7 @@ as.transform(1) Condition Error in `as.transform()`: - ! `1` must be a character vector or a transformer object + ! `x` must be a character vector or transform object, not the number 1. Code as.transform("x") Condition diff --git a/tests/testthat/test-label-bytes.R b/tests/testthat/test-label-bytes.R index 635edb41..d18fab94 100644 --- a/tests/testthat/test-label-bytes.R +++ b/tests/testthat/test-label-bytes.R @@ -20,7 +20,7 @@ test_that("compatible with scale argument", { }) test_that("errors if unknown unit", { - expect_error(label_bytes("unit")(0), "valid unit") + expect_snapshot(label_bytes("unit")(0), error = TRUE) }) # deprecated interface ----------------------------------------------------