From bc7626397ea0c52dc43b3efc1ca00a7283441608 Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Thu, 10 Aug 2023 13:31:40 -0500 Subject: [PATCH] Implement to_lgl_scalar(). Closes #32. Also fixed to_lgl bugs. --- NAMESPACE | 3 ++ R/stabilize_int.R | 1 - R/stabilize_int_scalar.R | 1 - R/to_int_scalar.R | 5 +-- R/to_lgl.R | 18 +++++++++ R/to_lgl_scalar.R | 35 +++++++++++++++++ man/to_int_scalar.Rd | 4 +- man/to_lgl_scalar.Rd | 41 +++++++++++++++++++ tests/testthat/_snaps/to_lgl.md | 20 ++++++++++ tests/testthat/_snaps/to_lgl_scalar.md | 54 ++++++++++++++++++++++++++ tests/testthat/test-to_lgl.R | 38 ++++++++++++++++++ tests/testthat/test-to_lgl_scalar.R | 44 +++++++++++++++++++++ 12 files changed, 257 insertions(+), 7 deletions(-) create mode 100644 R/to_lgl_scalar.R create mode 100644 man/to_lgl_scalar.Rd create mode 100644 tests/testthat/_snaps/to_lgl_scalar.md create mode 100644 tests/testthat/test-to_lgl_scalar.R diff --git a/NAMESPACE b/NAMESPACE index a7d97e6..66060a5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,7 +10,9 @@ S3method(to_int,integer) S3method(to_int,logical) S3method(to_lgl,"NULL") S3method(to_lgl,character) +S3method(to_lgl,default) S3method(to_lgl,double) +S3method(to_lgl,factor) S3method(to_lgl,integer) S3method(to_lgl,logical) export(object_type) @@ -21,3 +23,4 @@ export(stabilize_int_scalar) export(to_int) export(to_int_scalar) export(to_lgl) +export(to_lgl_scalar) diff --git a/R/stabilize_int.R b/R/stabilize_int.R index 5bb7450..714a18c 100644 --- a/R/stabilize_int.R +++ b/R/stabilize_int.R @@ -42,7 +42,6 @@ stabilize_int <- function(x, call = rlang::caller_env(), x_class = object_type(x)) { x_arg <- force(x_arg) - x_class <- force(x_class) x <- to_int( x, diff --git a/R/stabilize_int_scalar.R b/R/stabilize_int_scalar.R index e783eb5..4b0ba8f 100644 --- a/R/stabilize_int_scalar.R +++ b/R/stabilize_int_scalar.R @@ -25,7 +25,6 @@ stabilize_int_scalar <- function(x, call = rlang::caller_env(), x_class = object_type(x)) { x_arg <- force(x_arg) - x_class <- force(x_class) x <- to_int( x, diff --git a/R/to_int_scalar.R b/R/to_int_scalar.R index 726fd28..909d38d 100644 --- a/R/to_int_scalar.R +++ b/R/to_int_scalar.R @@ -1,7 +1,7 @@ #' Coerce an argument to a length-1 integer #' -#' This value wraps [to_int()], adding a quick check to confirm that the input -#' contains a single value. +#' This function wraps [to_int()], adding a quick check to confirm that the +#' input contains a single value. #' #' @inheritParams to_int #' @@ -19,7 +19,6 @@ to_int_scalar <- function(x, call = rlang::caller_env(), x_class = object_type(x)) { x_arg <- force(x_arg) - x_class <- force(x_class) x <- to_int( x, allow_null = allow_null, diff --git a/R/to_lgl.R b/R/to_lgl.R index d2045b8..4e4ab88 100644 --- a/R/to_lgl.R +++ b/R/to_lgl.R @@ -73,6 +73,24 @@ to_lgl.character <- function(x, return(cast) } +#' @export +to_lgl.factor <- function(x, + ..., + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + return( + to_lgl.character( + as.character(x), + ..., + x_arg = x_arg, + call = call, + x_class = x_class + ) + ) +} + +#' @export to_lgl.default <- function(x, ..., x_arg = rlang::caller_arg(x), diff --git a/R/to_lgl_scalar.R b/R/to_lgl_scalar.R new file mode 100644 index 0000000..b5f9cc9 --- /dev/null +++ b/R/to_lgl_scalar.R @@ -0,0 +1,35 @@ +#' Coerce an argument to a length-1 logical vector +#' +#' This function wraps [to_lgl()], adding a quick check to confirm that the +#' input contains a single value. +#' +#' @inheritParams to_lgl +#' +#' @return A logical vector equivalent to `x`. +#' @export +#' +#' @examples +#' to_lgl_scalar("TRUE") +#' try(to_lgl_scalar(c(TRUE, FALSE))) +to_lgl_scalar <- function(x, + allow_null = TRUE, + x_arg = rlang::caller_arg(x), + call = rlang::caller_env(), + x_class = object_type(x)) { + force(x_arg) + x <- to_lgl( + x, + allow_null = allow_null, + 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/man/to_int_scalar.Rd b/man/to_int_scalar.Rd index d2dc692..ac38549 100644 --- a/man/to_int_scalar.Rd +++ b/man/to_int_scalar.Rd @@ -42,8 +42,8 @@ but want the error message to match the original class.} An integer equivalent to \code{x}. } \description{ -This value wraps \code{\link[=to_int]{to_int()}}, adding a quick check to confirm that the input -contains a single value. +This function wraps \code{\link[=to_int]{to_int()}}, adding a quick check to confirm that the +input contains a single value. } \examples{ to_int_scalar("1") diff --git a/man/to_lgl_scalar.Rd b/man/to_lgl_scalar.Rd new file mode 100644 index 0000000..f86e99c --- /dev/null +++ b/man/to_lgl_scalar.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/to_lgl_scalar.R +\name{to_lgl_scalar} +\alias{to_lgl_scalar} +\title{Coerce an argument to a length-1 logical vector} +\usage{ +to_lgl_scalar( + 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{ +This function wraps \code{\link[=to_lgl]{to_lgl()}}, adding a quick check to confirm that the +input contains a single value. +} +\examples{ +to_lgl_scalar("TRUE") +try(to_lgl_scalar(c(TRUE, FALSE))) +} diff --git a/tests/testthat/_snaps/to_lgl.md b/tests/testthat/_snaps/to_lgl.md index 2f42a93..b501fa8 100644 --- a/tests/testthat/_snaps/to_lgl.md +++ b/tests/testthat/_snaps/to_lgl.md @@ -34,6 +34,26 @@ 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 works for factors + + Code + to_lgl(given) + Condition + Error: + ! `given` 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(given) + 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 diff --git a/tests/testthat/_snaps/to_lgl_scalar.md b/tests/testthat/_snaps/to_lgl_scalar.md new file mode 100644 index 0000000..c7ed609 --- /dev/null +++ b/tests/testthat/_snaps/to_lgl_scalar.md @@ -0,0 +1,54 @@ +# to_lgl_scalar() provides informative error messages + + Code + to_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. + +--- + + Code + to_lgl_scalar(given) + Condition + Error: + ! `given` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1 + +--- + + Code + wrapper(given) + Condition + Error in `wrapper()`: + ! `wrapper_val` must be coercible to + x Can't convert some values due to incompatible values. + * Locations: 1 + +--- + + Code + to_lgl_scalar(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 . + diff --git a/tests/testthat/test-to_lgl.R b/tests/testthat/test-to_lgl.R index 9e63c91..448fc6b 100644 --- a/tests/testthat/test-to_lgl.R +++ b/tests/testthat/test-to_lgl.R @@ -126,6 +126,44 @@ test_that("to_lgl works for characters", { ) }) +test_that("to_lgl works for factors", { + given <- factor("TRUE") + expect_true(to_lgl(given)) + given <- factor("FALSE") + expect_false(to_lgl(given)) + + given <- factor(c( + "TRUE", "T", "true", + "FALSE", "F", "false" + )) + expect_identical( + to_lgl(given), + as.logical(given) + ) + given <- factor(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) + ) + + given <- factor(letters) + expect_snapshot( + to_lgl(given), + error = TRUE + ) + + wrapper <- function(wrapper_val, ...) { + return(to_lgl(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given), + error = TRUE + ) +}) + test_that("to_lgl() errors for other things", { given <- list(1:10) expect_snapshot( diff --git a/tests/testthat/test-to_lgl_scalar.R b/tests/testthat/test-to_lgl_scalar.R new file mode 100644 index 0000000..39e5a32 --- /dev/null +++ b/tests/testthat/test-to_lgl_scalar.R @@ -0,0 +1,44 @@ +test_that("to_lgl_scalar() allows length-1 lgls through", { + given <- TRUE + expect_true(to_lgl_scalar(given)) + given <- FALSE + expect_false(to_lgl_scalar(given)) + given <- NULL + expect_null(to_lgl_scalar(given)) +}) + +test_that("to_lgl_scalar() provides informative error messages", { + given <- c(TRUE, FALSE, TRUE) + expect_snapshot( + to_lgl_scalar(given), + error = TRUE + ) + + wrapper <- function(wrapper_val, ...) { + return(to_lgl_scalar(wrapper_val, ...)) + } + expect_snapshot( + wrapper(given), + error = TRUE + ) + + given <- "a" + expect_snapshot( + to_lgl_scalar(given), + error = TRUE + ) + expect_snapshot( + wrapper(given), + error = TRUE + ) + + given <- NULL + expect_snapshot( + to_lgl_scalar(given, allow_null = FALSE), + error = TRUE + ) + expect_snapshot( + wrapper(given, allow_null = FALSE), + error = TRUE + ) +})