diff --git a/NAMESPACE b/NAMESPACE index 66060a5..0767e7d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,8 @@ export(stabilize_arg) export(stabilize_arg_scalar) export(stabilize_int) export(stabilize_int_scalar) +export(stabilize_lgl) +export(stabilize_lgl_scalar) export(to_int) export(to_int_scalar) export(to_lgl) diff --git a/R/check.R b/R/check.R index 2a62125..b05c06e 100644 --- a/R/check.R +++ b/R/check.R @@ -2,7 +2,7 @@ allow_na = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env()) { - allow_na <- to_lgl(allow_na, allow_null = FALSE, call = call) + allow_na <- to_lgl_scalar(allow_na, allow_null = FALSE, call = call) failures <- is.na(x) if (allow_na || !any(failures)) { return(invisible(NULL)) diff --git a/R/is.R b/R/is.R index 3a0efec..afaf1c0 100644 --- a/R/is.R +++ b/R/is.R @@ -6,6 +6,11 @@ allow_null = FALSE, call = call ) + # Can't use to_lgl_scalar because of recursion, do a one-off check. + if (vctrs::vec_size(allow_null) > 1) { + x_arg <- "allow_null" + .stop_must(msg = "must have a single {.cls logical} value.", call = call) + } return(is.null(x) && allow_null) } diff --git a/R/msgs_common.R b/R/msgs_common.R index 4aaa9e3..0e54ef1 100644 --- a/R/msgs_common.R +++ b/R/msgs_common.R @@ -1,4 +1,6 @@ .stop_must <- function(msg, call, additional_msg = NULL) { + # TODO: This x_arg is a hidden argument and I don't have a good answer for how + # to get rid of it yet. main_msg <- paste("{.arg {x_arg}}", msg) cli::cli_abort( c(main_msg, additional_msg), diff --git a/R/stabilize_arg.R b/R/stabilize_arg.R index 2a92633..4aefb9c 100644 --- a/R/stabilize_arg.R +++ b/R/stabilize_arg.R @@ -48,3 +48,50 @@ stabilize_arg <- function(x, ) return(x) } + +.stabilize_cls <- function(x, + to_cls_fn, + ..., + to_cls_args = list(), + check_cls_value_fn = NULL, + check_cls_value_fn_args = list(), + allow_null = TRUE, + allow_na = TRUE, + min_size = NULL, + max_size = NULL, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + x_arg <- force(x_arg) + + x <- rlang::inject( + to_cls_fn( + x, + allow_null = allow_null, + !!!to_cls_args, + x_arg = x_arg, + call = call, + x_class = x_class + ) + ) + if (!is.null(check_cls_value_fn)) { + rlang::inject( + check_cls_value_fn( + x, + !!!check_cls_value_fn_args, + x_arg = x_arg, call = call + ) + ) + } + stabilize_arg( + x = x, + ..., + allow_null = allow_null, + allow_na = allow_na, + min_size = min_size, + max_size = max_size, + x_arg = x_arg, + call = call, + x_class = x_class + ) +} diff --git a/R/stabilize_arg_scalar.R b/R/stabilize_arg_scalar.R index 833029b..69ec1d3 100644 --- a/R/stabilize_arg_scalar.R +++ b/R/stabilize_arg_scalar.R @@ -30,3 +30,46 @@ stabilize_arg_scalar <- function(x, .check_na(x, allow_na = allow_na, x_arg = x_arg, call = call) return(x) } + +.stabilize_cls_scalar <- function(x, + to_cls_fn, + ..., + to_cls_args = list(), + check_cls_value_fn = NULL, + check_cls_value_fn_args = list(), + allow_null = TRUE, + allow_na = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + x_arg <- force(x_arg) + + x <- rlang::inject( + to_cls_fn( + x, + allow_null = allow_null, + !!!to_cls_args, + x_arg = x_arg, + call = call, + x_class = x_class + ) + ) + if (!is.null(check_cls_value_fn)) { + rlang::inject( + check_cls_value_fn( + x, + !!!check_cls_value_fn_args, + x_arg = x_arg, call = call + ) + ) + } + stabilize_arg_scalar( + x = x, + ..., + allow_null = allow_null, + allow_na = allow_na, + x_arg = x_arg, + call = call, + x_class = x_class + ) +} diff --git a/R/stabilize_int.R b/R/stabilize_int.R index 714a18c..e3530ae 100644 --- a/R/stabilize_int.R +++ b/R/stabilize_int.R @@ -41,31 +41,25 @@ stabilize_int <- function(x, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { - x_arg <- force(x_arg) - - x <- to_int( + .stabilize_cls( x, + to_cls_fn = to_int, + to_cls_args = list( + coerce_character = coerce_character, + coerce_factor = coerce_factor + ), + check_cls_value_fn = .check_value_int, + check_cls_value_fn_args = list( + min_value = min_value, max_value = max_value + ), allow_null = allow_null, - coerce_character = coerce_character, - coerce_factor = coerce_factor, - x_arg = x_arg, - call = call, - x_class = x_class - ) - .check_value_int( - x, - min_value = min_value, max_value = max_value, - x_arg = x_arg, call = call - ) - stabilize_arg( - x = x, - ..., allow_na = allow_na, min_size = min_size, max_size = max_size, x_arg = x_arg, call = call, - x_class = x_class + x_class = x_class, + ... ) } diff --git a/R/stabilize_int_scalar.R b/R/stabilize_int_scalar.R index 4b0ba8f..6a06378 100644 --- a/R/stabilize_int_scalar.R +++ b/R/stabilize_int_scalar.R @@ -12,7 +12,8 @@ #' stabilize_int_scalar(1L) #' stabilize_int_scalar("1") #' try(stabilize_int_scalar(1:10)) -#' try(stabilize_int_scalar(NULL)) +#' stabilize_int_scalar(NULL) +#' try(stabilize_int_scalar(NULL, allow_null = FALSE)) stabilize_int_scalar <- function(x, ..., allow_null = TRUE, @@ -24,29 +25,22 @@ stabilize_int_scalar <- function(x, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { - x_arg <- force(x_arg) - - x <- to_int( + .stabilize_cls_scalar( x, - allow_null = FALSE, - coerce_character = coerce_character, - coerce_factor = coerce_factor, - x_arg = x_arg, - call = call, - x_class = x_class - ) - .check_value_int( - x, - min_value = min_value, max_value = max_value, - x_arg = x_arg, call = call - ) - stabilize_arg_scalar( - x = x, - ..., + to_cls_fn = to_int, + to_cls_args = list( + coerce_character = coerce_character, + coerce_factor = coerce_factor + ), + check_cls_value_fn = .check_value_int, + check_cls_value_fn_args = list( + min_value = min_value, max_value = max_value + ), allow_null = allow_null, allow_na = allow_na, x_arg = x_arg, call = call, - x_class = x_class + x_class = x_class, + ... ) } diff --git a/R/stabilize_lgl.R b/R/stabilize_lgl.R new file mode 100644 index 0000000..1ba2a4d --- /dev/null +++ b/R/stabilize_lgl.R @@ -0,0 +1,44 @@ +#' Ensure a logical argument meets expectations +#' +#' Check a logical argument to ensure that it meets expectations, coercing it +#' to logical where possible. If the argument does not meet the requirements, +#' the user will receive an informative error message. Note that [to_lgl()] is a +#' faster version of this function with fewer options. +#' +#' @inheritParams .coerce-params +#' @inheritParams to_lgl +#' +#' @return The argument as a logical vector. +#' @export +#' +#' @examples +#' stabilize_lgl(c(TRUE, FALSE, TRUE)) +#' stabilize_lgl("true") +#' stabilize_lgl(NULL) +#' try(stabilize_lgl(NULL, allow_null = FALSE)) +#' try(stabilize_lgl(c(TRUE, NA), allow_na = FALSE)) +#' try(stabilize_lgl(letters)) +#' try(stabilize_lgl(c(TRUE, FALSE, TRUE), min_size = 5)) +#' try(stabilize_lgl(c(TRUE, FALSE, TRUE), max_size = 2)) +stabilize_lgl <- function(x, + ..., + allow_null = TRUE, + allow_na = TRUE, + min_size = NULL, + max_size = NULL, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + .stabilize_cls( + x, + to_cls_fn = to_lgl, + allow_null = allow_null, + allow_na = allow_na, + min_size = min_size, + max_size = max_size, + x_arg = x_arg, + call = call, + x_class = x_class, + ... + ) +} diff --git a/R/stabilize_lgl_scalar.R b/R/stabilize_lgl_scalar.R new file mode 100644 index 0000000..436d961 --- /dev/null +++ b/R/stabilize_lgl_scalar.R @@ -0,0 +1,34 @@ +#' Ensure a logical argument meets expectations and is length-1 +#' +#' This function is equivalent to [stabilize_lgl()], but it is optimized to +#' check for length-1 logical vectors. +#' +#' @inheritParams stabilize_lgl +#' +#' @return `x`, unless one of the checks fails. +#' @export +#' +#' @examples +#' stabilize_lgl_scalar(TRUE) +#' stabilize_lgl_scalar("TRUE") +#' try(stabilize_lgl_scalar(c(TRUE, FALSE, TRUE))) +#' stabilize_lgl_scalar(NULL) +#' try(stabilize_lgl_scalar(NULL, allow_null = FALSE)) +stabilize_lgl_scalar <- function(x, + ..., + allow_null = TRUE, + allow_na = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + .stabilize_cls_scalar( + x, + to_cls_fn = to_lgl, + allow_null = allow_null, + allow_na = allow_na, + x_arg = x_arg, + call = call, + x_class = x_class, + ... + ) +} diff --git a/R/to_int.R b/R/to_int.R index 21a3f23..787e7d9 100644 --- a/R/to_int.R +++ b/R/to_int.R @@ -71,7 +71,11 @@ to_int.character <- function(x, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { - coerce_character <- to_lgl(coerce_character, allow_null = FALSE, call = call) + coerce_character <- to_lgl_scalar( + coerce_character, + allow_null = FALSE, + call = call + ) if (coerce_character) { cast <- suppressWarnings(as.integer(x)) x_na <- is.na(x) @@ -103,7 +107,7 @@ to_int.factor <- function(x, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { - coerce_factor <- to_lgl(coerce_factor, allow_null = FALSE, call = call) + coerce_factor <- to_lgl_scalar(coerce_factor, allow_null = FALSE, call = call) if (coerce_factor) { return( to_int( diff --git a/R/to_lgl.R b/R/to_lgl.R index 4e4ab88..f6209e3 100644 --- a/R/to_lgl.R +++ b/R/to_lgl.R @@ -1,7 +1,9 @@ #' Coerce an argument to logical #' #' If a value can be coerced to a logical without losing information, do so -#' silently. Otherwise throw an informative error. +#' silently. Otherwise throw an informative error. This function is equivalent +#' to [stabilize_lgl()] with all of the additional arguments set to their +#' default values, but should be faster. #' #' @inheritParams .coerce-params #' diff --git a/R/to_null.R b/R/to_null.R index 0c3d128..0f4f6bb 100644 --- a/R/to_null.R +++ b/R/to_null.R @@ -2,7 +2,7 @@ to_null <- function(x, allow_null = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env()) { - allow_null <- to_lgl(allow_null, allow_null = FALSE, call = call) + allow_null <- to_lgl_scalar(allow_null, allow_null = FALSE, call = call) if (allow_null) { return(NULL) } diff --git a/man/stabilize_int_scalar.Rd b/man/stabilize_int_scalar.Rd index e0e6cd4..147dabf 100644 --- a/man/stabilize_int_scalar.Rd +++ b/man/stabilize_int_scalar.Rd @@ -63,5 +63,6 @@ check for length-1 integers. stabilize_int_scalar(1L) stabilize_int_scalar("1") try(stabilize_int_scalar(1:10)) -try(stabilize_int_scalar(NULL)) +stabilize_int_scalar(NULL) +try(stabilize_int_scalar(NULL, allow_null = FALSE)) } diff --git a/man/stabilize_lgl.Rd b/man/stabilize_lgl.Rd new file mode 100644 index 0000000..cd5b780 --- /dev/null +++ b/man/stabilize_lgl.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stabilize_lgl.R +\name{stabilize_lgl} +\alias{stabilize_lgl} +\title{Ensure a logical argument meets expectations} +\usage{ +stabilize_lgl( + x, + ..., + allow_null = TRUE, + allow_na = TRUE, + min_size = NULL, + max_size = NULL, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x) +) +} +\arguments{ +\item{x}{The argument to stabilize.} + +\item{...}{These dots are for future extensions and should be empty.} + +\item{allow_null}{Logical. Is NULL an acceptable value?} + +\item{allow_na}{Logical. Are NA values ok?} + +\item{min_size}{Integer. The minimum size of the object. Object size will be +tested using \code{\link[vctrs:vec_size]{vctrs::vec_size()}}.} + +\item{max_size}{Integer. The maximum size of the object. Object size will be +tested using \code{\link[vctrs:vec_size]{vctrs::vec_size()}}.} + +\item{x_arg}{Character. An argument name for x. The automatic value will work +in most cases, or pass it through from higher-level functions to make error +messages clearer in unexported functions.} + +\item{call}{The execution environment of the call. See the \code{call} argument of +\code{rlang::abort()} for more information.} + +\item{x_class}{Character. The class name of \code{x} to use in error messages. Use +this if you remove a special class from \code{x} before checking its coercion, +but want the error message to match the original class.} +} +\value{ +The argument as a logical vector. +} +\description{ +Check a logical argument to ensure that it meets expectations, coercing it +to logical where possible. If the argument does not meet the requirements, +the user will receive an informative error message. Note that \code{\link[=to_lgl]{to_lgl()}} is a +faster version of this function with fewer options. +} +\examples{ +stabilize_lgl(c(TRUE, FALSE, TRUE)) +stabilize_lgl("true") +stabilize_lgl(NULL) +try(stabilize_lgl(NULL, allow_null = FALSE)) +try(stabilize_lgl(c(TRUE, NA), allow_na = FALSE)) +try(stabilize_lgl(letters)) +try(stabilize_lgl(c(TRUE, FALSE, TRUE), min_size = 5)) +try(stabilize_lgl(c(TRUE, FALSE, TRUE), max_size = 2)) +} diff --git a/man/stabilize_lgl_scalar.Rd b/man/stabilize_lgl_scalar.Rd new file mode 100644 index 0000000..cfd1d05 --- /dev/null +++ b/man/stabilize_lgl_scalar.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stabilize_lgl_scalar.R +\name{stabilize_lgl_scalar} +\alias{stabilize_lgl_scalar} +\title{Ensure a logical argument meets expectations and is length-1} +\usage{ +stabilize_lgl_scalar( + x, + ..., + allow_null = TRUE, + allow_na = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x) +) +} +\arguments{ +\item{x}{The argument to stabilize.} + +\item{...}{These dots are for future extensions and should be empty.} + +\item{allow_null}{Logical. Is NULL an acceptable value?} + +\item{allow_na}{Logical. Are NA values ok?} + +\item{x_arg}{Character. An argument name for x. The automatic value will work +in most cases, or pass it through from higher-level functions to make error +messages clearer in unexported functions.} + +\item{call}{The execution environment of the call. See the \code{call} argument of +\code{rlang::abort()} for more information.} + +\item{x_class}{Character. The class name of \code{x} to use in error messages. Use +this if you remove a special class from \code{x} before checking its coercion, +but want the error message to match the original class.} +} +\value{ +\code{x}, unless one of the checks fails. +} +\description{ +This function is equivalent to \code{\link[=stabilize_lgl]{stabilize_lgl()}}, but it is optimized to +check for length-1 logical vectors. +} +\examples{ +stabilize_lgl_scalar(TRUE) +stabilize_lgl_scalar("TRUE") +try(stabilize_lgl_scalar(c(TRUE, FALSE, TRUE))) +stabilize_lgl_scalar(NULL) +try(stabilize_lgl_scalar(NULL, allow_null = FALSE)) +} diff --git a/man/to_lgl.Rd b/man/to_lgl.Rd index 277dbb7..74824df 100644 --- a/man/to_lgl.Rd +++ b/man/to_lgl.Rd @@ -33,7 +33,9 @@ A logical vector equivalent to \code{x}. } \description{ If a value can be coerced to a logical without losing information, do so -silently. Otherwise throw an informative error. +silently. Otherwise throw an informative error. This function is equivalent +to \code{\link[=stabilize_lgl]{stabilize_lgl()}} with all of the additional arguments set to their +default values, but should be faster. } \examples{ to_lgl(TRUE) diff --git a/tests/testthat/_snaps/stabilize_arg_scalar.md b/tests/testthat/_snaps/stabilize_arg_scalar.md index 662a314..df219b2 100644 --- a/tests/testthat/_snaps/stabilize_arg_scalar.md +++ b/tests/testthat/_snaps/stabilize_arg_scalar.md @@ -34,3 +34,11 @@ ! `wrapper_val` must be a single . x `wrapper_val` has no values. +# stabilize_arg_scalar() deals with weird values + + Code + stabilize_arg_scalar(given, allow_null = c(TRUE, FALSE)) + Condition + Error: + ! `allow_null` must have a single value. + diff --git a/tests/testthat/_snaps/stabilize_lgl.md b/tests/testthat/_snaps/stabilize_lgl.md new file mode 100644 index 0000000..8e0179a --- /dev/null +++ b/tests/testthat/_snaps/stabilize_lgl.md @@ -0,0 +1,54 @@ +# stabilize_lgl() checks values + + Code + stabilize_lgl(given, allow_na = FALSE) + Condition + Error: + ! `given` must not contain NA values. + * NA locations: 2 + +--- + + Code + wrapper(given, allow_na = FALSE) + Condition + Error in `wrapper()`: + ! `wrapper_val` must not contain NA values. + * NA locations: 2 + +--- + + Code + stabilize_lgl(given, min_size = 5) + Condition + Error: + ! `given` must have size >= 5. + x 4 is too small. + +--- + + Code + wrapper(given, min_size = 5) + Condition + Error in `wrapper()`: + ! `wrapper_val` must have size >= 5. + x 4 is too small. + +--- + + Code + stabilize_lgl(given, max_size = 3) + Condition + Error: + ! `given` must have size <= 3. + x 4 is too big. + +--- + + Code + wrapper(given, max_size = 3) + Condition + Error in `wrapper()`: + ! `wrapper_val` must have size <= 3. + x 4 is too big. + diff --git a/tests/testthat/_snaps/stabilize_lgl_scalar.md b/tests/testthat/_snaps/stabilize_lgl_scalar.md new file mode 100644 index 0000000..14f820b --- /dev/null +++ b/tests/testthat/_snaps/stabilize_lgl_scalar.md @@ -0,0 +1,18 @@ +# stabilize_lgl_scalar() provides informative error messages + + Code + stabilize_lgl_scalar(given) + Condition + Error: + ! `given` must be a single . + x `given` has 3 values. + +--- + + Code + wrapper(given) + Condition + Error in `wrapper()`: + ! `wrapper_val` must be a single . + x `wrapper_val` has 3 values. + diff --git a/tests/testthat/test-stabilize_arg_scalar.R b/tests/testthat/test-stabilize_arg_scalar.R index d427c11..0baaed4 100644 --- a/tests/testthat/test-stabilize_arg_scalar.R +++ b/tests/testthat/test-stabilize_arg_scalar.R @@ -30,3 +30,11 @@ test_that("stabilize_arg_scalar() provides informative error messages", { error = TRUE ) }) + +test_that("stabilize_arg_scalar() deals with weird values", { + given <- NULL + expect_snapshot( + stabilize_arg_scalar(given, allow_null = c(TRUE, FALSE)), + error = TRUE + ) +}) diff --git a/tests/testthat/test-stabilize_lgl.R b/tests/testthat/test-stabilize_lgl.R new file mode 100644 index 0000000..619c442 --- /dev/null +++ b/tests/testthat/test-stabilize_lgl.R @@ -0,0 +1,47 @@ +test_that("stabilize_lgl() checks values", { + given <- TRUE + expect_true(stabilize_lgl(given)) + given <- FALSE + expect_false(stabilize_lgl(given)) + + given <- c("TRUE", "FALSE", "true", "fALSE") + expect_identical( + stabilize_lgl(given), + c(TRUE, FALSE, TRUE, FALSE) + ) + + given[[2]] <- NA + expect_identical( + stabilize_lgl(given), + c(TRUE, NA, TRUE, FALSE) + ) + + expect_snapshot( + stabilize_lgl(given, allow_na = FALSE), + error = TRUE + ) + wrapper <- function(wrapper_val, ...) { + return(stabilize_lgl(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given, allow_na = FALSE), + error = TRUE + ) + + expect_snapshot( + stabilize_lgl(given, min_size = 5), + error = TRUE + ) + expect_snapshot( + wrapper(given, min_size = 5), + error = TRUE + ) + expect_snapshot( + stabilize_lgl(given, max_size = 3), + error = TRUE + ) + expect_snapshot( + wrapper(given, max_size = 3), + error = TRUE + ) +}) diff --git a/tests/testthat/test-stabilize_lgl_scalar.R b/tests/testthat/test-stabilize_lgl_scalar.R new file mode 100644 index 0000000..fd4f8ce --- /dev/null +++ b/tests/testthat/test-stabilize_lgl_scalar.R @@ -0,0 +1,19 @@ +test_that("stabilize_lgl_scalar() allows length-1 lgls through", { + expect_true(stabilize_lgl_scalar(TRUE)) +}) + +test_that("stabilize_lgl_scalar() provides informative error messages", { + given <- c(TRUE, FALSE, TRUE) + expect_snapshot( + stabilize_lgl_scalar(given), + error = TRUE + ) + + wrapper <- function(wrapper_val, ...) { + return(stabilize_lgl_scalar(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given), + error = TRUE + ) +})