diff --git a/NAMESPACE b/NAMESPACE index 5628517..a7d97e6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,11 @@ S3method(to_int,double) S3method(to_int,factor) S3method(to_int,integer) S3method(to_int,logical) +S3method(to_lgl,"NULL") +S3method(to_lgl,character) +S3method(to_lgl,double) +S3method(to_lgl,integer) +S3method(to_lgl,logical) export(object_type) export(stabilize_arg) export(stabilize_arg_scalar) @@ -15,3 +20,4 @@ export(stabilize_int) export(stabilize_int_scalar) export(to_int) export(to_int_scalar) +export(to_lgl) diff --git a/R/check.R b/R/check.R index 7bff220..2a62125 100644 --- a/R/check.R +++ b/R/check.R @@ -1,17 +1,8 @@ -.check_null <- function(x, - allow_null = TRUE, - x_arg = rlang::caller_arg(x), - call = rlang::caller_env()) { - if (allow_null) { - return(x) - } - .stop_null(x_arg, call) -} - .check_na <- function(x, allow_na = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env()) { + allow_na <- to_lgl(allow_na, allow_null = FALSE, call = call) failures <- is.na(x) if (allow_na || !any(failures)) { return(invisible(NULL)) @@ -29,8 +20,8 @@ max_size, x_arg = rlang::caller_arg(x), call = rlang::caller_env()) { - min_size <- to_int(min_size) - max_size <- to_int(max_size) + min_size <- to_int_scalar(min_size, call = call) + max_size <- to_int_scalar(max_size, call = call) .check_x_no_more_than_y(min_size, max_size, call = call) x_size <- vctrs::vec_size(x) @@ -58,15 +49,22 @@ } .check_scalar <- function(x, + allow_null = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { + if (.is_allowed_null(x, allow_null = allow_null, call = call)) { + return(invisible(NULL)) + } if (rlang::is_scalar_vector(x)) { return(invisible(NULL)) } x_size <- vctrs::vec_size(x) + if (x_class == "NULL") { + x_class <- "non-NULL" + } .stop_must( "must be a single {.cls {x_class}}.", call = call, diff --git a/R/is.R b/R/is.R new file mode 100644 index 0000000..3a0efec --- /dev/null +++ b/R/is.R @@ -0,0 +1,11 @@ +.is_allowed_null <- function(x, + allow_null = TRUE, + call = rlang::caller_env()) { + allow_null <- to_lgl( + allow_null, + allow_null = FALSE, + call = call + ) + + return(is.null(x) && allow_null) +} diff --git a/R/stabilize_arg.R b/R/stabilize_arg.R index e56a66d..2a92633 100644 --- a/R/stabilize_arg.R +++ b/R/stabilize_arg.R @@ -34,7 +34,7 @@ stabilize_arg <- function(x, if (is.null(x)) { return( - .check_null(x, allow_null = allow_null, x_arg = x_arg, call = call) + to_null(x, allow_null = allow_null, x_arg = x_arg, call = call) ) } diff --git a/R/stabilize_arg_scalar.R b/R/stabilize_arg_scalar.R index 4019411..833029b 100644 --- a/R/stabilize_arg_scalar.R +++ b/R/stabilize_arg_scalar.R @@ -14,12 +14,19 @@ #' try(stabilize_arg_scalar(1:10)) stabilize_arg_scalar <- function(x, ..., + allow_null = TRUE, allow_na = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), x_class = object_type(x)) { rlang::check_dots_empty0(..., call = call) - .check_scalar(x, x_arg = x_arg, call = call, x_class = x_class) + .check_scalar( + x, + allow_null = allow_null, + x_arg = x_arg, + call = call, + x_class = x_class + ) .check_na(x, allow_na = allow_na, x_arg = x_arg, call = call) return(x) } diff --git a/R/stabilize_int_scalar.R b/R/stabilize_int_scalar.R index b82d3c1..e783eb5 100644 --- a/R/stabilize_int_scalar.R +++ b/R/stabilize_int_scalar.R @@ -15,6 +15,7 @@ #' try(stabilize_int_scalar(NULL)) stabilize_int_scalar <- function(x, ..., + allow_null = TRUE, allow_na = TRUE, coerce_character = TRUE, coerce_factor = TRUE, @@ -43,6 +44,7 @@ stabilize_int_scalar <- function(x, stabilize_arg_scalar( x = x, ..., + allow_null = allow_null, allow_na = allow_na, x_arg = x_arg, call = call, diff --git a/R/to_int.R b/R/to_int.R index 6505566..21a3f23 100644 --- a/R/to_int.R +++ b/R/to_int.R @@ -45,10 +45,7 @@ to_int.NULL <- function(x, allow_null = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env()) { - if (allow_null) { - return(NULL) - } - .stop_null(x_arg, call) + to_null(x, allow_null = allow_null, x_arg = x_arg, call = call) } #' @export @@ -74,6 +71,7 @@ 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) if (coerce_character) { cast <- suppressWarnings(as.integer(x)) x_na <- is.na(x) @@ -105,6 +103,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) if (coerce_factor) { return( to_int( diff --git a/R/to_int_scalar.R b/R/to_int_scalar.R index 781aec2..726fd28 100644 --- a/R/to_int_scalar.R +++ b/R/to_int_scalar.R @@ -12,6 +12,7 @@ #' to_int_scalar("1") #' try(to_int_scalar(1:10)) to_int_scalar <- function(x, + allow_null = TRUE, coerce_character = TRUE, coerce_factor = TRUE, x_arg = rlang::caller_arg(x), @@ -21,7 +22,7 @@ to_int_scalar <- function(x, x_class <- force(x_class) x <- to_int( x, - allow_null = FALSE, + allow_null = allow_null, coerce_character = coerce_character, coerce_factor = coerce_factor, x_arg = x_arg, @@ -29,6 +30,12 @@ to_int_scalar <- function(x, x_class = x_class ) - .check_scalar(x, x_arg = x_arg, call = call, x_class = x_class) + .check_scalar( + x, + allow_null = allow_null, + x_arg = x_arg, + call = call, + x_class = x_class + ) return(x) } diff --git a/R/to_lgl.R b/R/to_lgl.R new file mode 100644 index 0000000..d2045b8 --- /dev/null +++ b/R/to_lgl.R @@ -0,0 +1,82 @@ +#' 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. +#' +#' @inheritParams .coerce-params +#' +#' @return A logical vector equivalent to `x`. +#' @export +#' +#' @examples +#' to_lgl(TRUE) +#' to_lgl("TRUE") +#' to_lgl(1:10) +#' to_lgl(NULL) +#' try(to_lgl(NULL, allow_null = FALSE)) +#' try(to_lgl(letters)) +#' try(to_lgl(list(TRUE))) +to_lgl <- function(x, + allow_null = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + UseMethod("to_lgl") +} + +#' @export +to_lgl.logical <- function(x, ...) { + return(x) +} + +#' @export +to_lgl.NULL <- function(x, + ..., + allow_null = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + to_null(x, allow_null = allow_null, x_arg = x_arg, call = call) +} + +#' @export +to_lgl.integer <- function(x, + ..., + x_arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + return(as.logical(x)) +} + +#' @export +to_lgl.double <- function(x, + ..., + x_arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + return(as.logical(x)) +} + +#' @export +to_lgl.character <- function(x, + ..., + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + cast <- as.logical(toupper(x)) + failures <- xor(is.na(x), is.na(cast)) + + if (any(failures)) { + .stop_incompatible( + x_class, logical(), failures, + due_to = "incompatible values", x_arg, call + ) + } + + return(cast) +} + +to_lgl.default <- function(x, + ..., + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + .stop_cant_coerce(from_class = x_class, to_class = "logical", call = call) +} diff --git a/R/to_null.R b/R/to_null.R new file mode 100644 index 0000000..0c3d128 --- /dev/null +++ b/R/to_null.R @@ -0,0 +1,10 @@ +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) + if (allow_null) { + return(NULL) + } + .stop_null(x_arg, call) +} diff --git a/man/stabilize_arg_scalar.Rd b/man/stabilize_arg_scalar.Rd index 2351db2..159b8f6 100644 --- a/man/stabilize_arg_scalar.Rd +++ b/man/stabilize_arg_scalar.Rd @@ -7,6 +7,7 @@ stabilize_arg_scalar( x, ..., + allow_null = TRUE, allow_na = TRUE, x_arg = rlang::caller_arg(x), call = rlang::caller_env(), @@ -18,6 +19,8 @@ stabilize_arg_scalar( \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 diff --git a/man/stabilize_int_scalar.Rd b/man/stabilize_int_scalar.Rd index 81c9ad5..e0e6cd4 100644 --- a/man/stabilize_int_scalar.Rd +++ b/man/stabilize_int_scalar.Rd @@ -7,6 +7,7 @@ stabilize_int_scalar( x, ..., + allow_null = TRUE, allow_na = TRUE, coerce_character = TRUE, coerce_factor = TRUE, @@ -22,6 +23,8 @@ stabilize_int_scalar( \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{coerce_character}{Logical. Should character vectors such as "1" and diff --git a/man/to_int_scalar.Rd b/man/to_int_scalar.Rd index c2af050..d2dc692 100644 --- a/man/to_int_scalar.Rd +++ b/man/to_int_scalar.Rd @@ -6,6 +6,7 @@ \usage{ to_int_scalar( x, + allow_null = TRUE, coerce_character = TRUE, coerce_factor = TRUE, x_arg = rlang::caller_arg(x), @@ -16,6 +17,8 @@ to_int_scalar( \arguments{ \item{x}{The argument to stabilize.} +\item{allow_null}{Logical. Is NULL an acceptable value?} + \item{coerce_character}{Logical. Should character vectors such as "1" and "2.0" be coerced to integer?} diff --git a/man/to_lgl.Rd b/man/to_lgl.Rd new file mode 100644 index 0000000..277dbb7 --- /dev/null +++ b/man/to_lgl.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/to_lgl.R +\name{to_lgl} +\alias{to_lgl} +\title{Coerce an argument to logical} +\usage{ +to_lgl( + x, + allow_null = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x) +) +} +\arguments{ +\item{x}{The argument to stabilize.} + +\item{allow_null}{Logical. Is NULL an acceptable value?} + +\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{ +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. +} +\examples{ +to_lgl(TRUE) +to_lgl("TRUE") +to_lgl(1:10) +to_lgl(NULL) +try(to_lgl(NULL, allow_null = FALSE)) +try(to_lgl(letters)) +try(to_lgl(list(TRUE))) +} diff --git a/tests/testthat/_snaps/stabilize_arg_scalar.md b/tests/testthat/_snaps/stabilize_arg_scalar.md index b6344dd..662a314 100644 --- a/tests/testthat/_snaps/stabilize_arg_scalar.md +++ b/tests/testthat/_snaps/stabilize_arg_scalar.md @@ -19,18 +19,18 @@ --- Code - stabilize_arg_scalar(given) + stabilize_arg_scalar(given, allow_null = FALSE) Condition Error: - ! `given` must be a single . + ! `given` must be a single . x `given` has no values. --- Code - wrapper(given) + wrapper(given, allow_null = FALSE) Condition Error in `wrapper()`: - ! `wrapper_val` must be a single . + ! `wrapper_val` must be a single . x `wrapper_val` has no values. diff --git a/tests/testthat/_snaps/to_lgl.md b/tests/testthat/_snaps/to_lgl.md new file mode 100644 index 0000000..2f42a93 --- /dev/null +++ b/tests/testthat/_snaps/to_lgl.md @@ -0,0 +1,52 @@ +# to_lgl() works for NULL + + Code + to_lgl(given, allow_null = FALSE) + Condition + Error: + ! `given` must not be . + +--- + + Code + wrapper(given, allow_null = FALSE) + Condition + Error in `wrapper()`: + ! `wrapper_val` must not be . + +# to_lgl works for characters + + Code + to_lgl(letters) + Condition + Error: + ! `letters` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, ..., 25, and 26 + +--- + + Code + wrapper(letters) + Condition + Error in `wrapper()`: + ! `wrapper_val` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, ..., 25, and 26 + +# to_lgl() errors for other things + + Code + to_lgl(given) + Condition + Error: + ! Can't coerce `given` to . + +--- + + Code + wrapper(given) + Condition + Error in `wrapper()`: + ! Can't coerce `wrapper_val` to . + diff --git a/tests/testthat/_snaps/to_null.md b/tests/testthat/_snaps/to_null.md new file mode 100644 index 0000000..edf7f77 --- /dev/null +++ b/tests/testthat/_snaps/to_null.md @@ -0,0 +1,52 @@ +# to_null() errors when NULL isn't allowed + + Code + to_null(given, allow_null = FALSE) + Condition + Error: + ! `given` must not be . + +--- + + Code + wrapper(given, allow_null = FALSE) + Condition + Error in `wrapper()`: + ! `wrapper_val` must not be . + +# to_null() errors informatively for weird allow_null values + + Code + to_null(NULL, allow_null = NULL) + Condition + Error: + ! `allow_null` must not be . + +--- + + Code + to_null(NULL, allow_null = "fish") + Condition + Error: + ! `allow_null` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1 + +--- + + Code + wrapper(given, allow_null = NULL) + Condition + Error in `wrapper()`: + ! `allow_null` must not be . + +--- + + Code + wrapper(given, allow_null = "fish") + Condition + Error in `wrapper()`: + ! `allow_null` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1 + diff --git a/tests/testthat/test-stabilize_arg_scalar.R b/tests/testthat/test-stabilize_arg_scalar.R index 26de4d0..d427c11 100644 --- a/tests/testthat/test-stabilize_arg_scalar.R +++ b/tests/testthat/test-stabilize_arg_scalar.R @@ -22,11 +22,11 @@ test_that("stabilize_arg_scalar() provides informative error messages", { given <- NULL expect_snapshot( - stabilize_arg_scalar(given), + stabilize_arg_scalar(given, allow_null = FALSE), error = TRUE ) expect_snapshot( - wrapper(given), + wrapper(given, allow_null = FALSE), error = TRUE ) }) diff --git a/tests/testthat/test-to_lgl.R b/tests/testthat/test-to_lgl.R new file mode 100644 index 0000000..9e63c91 --- /dev/null +++ b/tests/testthat/test-to_lgl.R @@ -0,0 +1,143 @@ +test_that("to_lgl() works for lgls", { + expect_true(to_lgl(TRUE)) + expect_false(to_lgl(FALSE)) + + given <- sample(c(TRUE, FALSE), size = 10, replace = TRUE) + expect_identical( + to_lgl(given), + given + ) + + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + expect_identical( + wrapper(given), + given + ) + + given[[4]] <- NA + expect_identical( + to_lgl(given), + given + ) + expect_identical( + wrapper(given), + given + ) +}) + +test_that("to_lgl() works for NULL", { + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + + given <- NULL + expect_identical( + to_lgl(given), + given + ) + expect_identical( + wrapper(given), + given + ) + expect_snapshot( + to_lgl(given, allow_null = FALSE), + error = TRUE + ) + expect_snapshot( + wrapper(given, allow_null = FALSE), + error = TRUE + ) +}) + +test_that("to_lgl() works for integers", { + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + + given <- 1L + expect_true(to_lgl(given)) + given <- 0L + expect_false(to_lgl(given)) + + # By default, behave the same as as.logical for ints. I don't have the + # specific use case for anything else yet, so leave this! + given <- 1:10 + expect_identical( + to_lgl(given), + as.logical(given) + ) +}) + +test_that("to_lgl() works for doubles", { + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + + given <- 1 + expect_true(to_lgl(given)) + given <- 0 + expect_false(to_lgl(given)) + + # By default, behave the same as as.logical for dbls. I don't have the + # specific use case for anything else yet, so leave this! + given <- c(1, 2, 3.1, 4.4, 5) + expect_identical( + to_lgl(given), + as.logical(given) + ) +}) + +test_that("to_lgl works for characters", { + given <- "TRUE" + expect_true(to_lgl(given)) + given <- "FALSE" + expect_false(to_lgl(given)) + + given <- c( + "TRUE", "T", "true", + "FALSE", "F", "false" + ) + expect_identical( + to_lgl(given), + as.logical(given) + ) + given <- c( + "TRUE", "T", "true", "t", "TrUe", + "FALSE", "F", "false", "f", "fAlSe" + ) + expect_identical( + to_lgl(given), + c(TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE) + ) + + expect_snapshot( + to_lgl(letters), + error = TRUE + ) + + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + expect_snapshot( + wrapper(letters), + error = TRUE + ) +}) + +test_that("to_lgl() errors for other things", { + given <- list(1:10) + expect_snapshot( + to_lgl(given), + error = TRUE + ) + + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given), + error = TRUE + ) +}) diff --git a/tests/testthat/test-to_null.R b/tests/testthat/test-to_null.R new file mode 100644 index 0000000..4ac15f1 --- /dev/null +++ b/tests/testthat/test-to_null.R @@ -0,0 +1,47 @@ +test_that("to_null() works on the happy path", { + expect_null(to_null(NULL)) +}) + +test_that("to_null() errors when NULL isn't allowed", { + given <- NULL + expect_snapshot( + to_null(given, allow_null = FALSE), + error = TRUE + ) + wrapper <- function(wrapper_val, ...) { + return(to_null(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given, allow_null = FALSE), + error = TRUE + ) +}) + +test_that("to_null() coerces anything to NULL", { + expect_null(to_null(1L)) + expect_null(to_null(mean)) + expect_null(to_null(TRUE)) + expect_null(to_null(letters)) +}) + +test_that("to_null() errors informatively for weird allow_null values", { + expect_snapshot( + to_null(NULL, allow_null = NULL), + error = TRUE + ) + expect_snapshot( + to_null(NULL, allow_null = "fish"), + error = TRUE + ) + wrapper <- function(wrapper_val, ...) { + return(to_null(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given, allow_null = NULL), + error = TRUE + ) + expect_snapshot( + wrapper(given, allow_null = "fish"), + error = TRUE + ) +})