Implement to_lgl_scalar().

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)

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,

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,

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,

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),

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)
+}

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` <factor> must be coercible to <logical>
+      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` <factor> must be coercible to <logical>
+      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

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 <logical>.
+      x `given` has 3 values.
+
+---
+
+    Code
+      wrapper(given)
+    Condition
+      Error in `wrapper()`:
+      ! `wrapper_val` must be a single <logical>.
+      x `wrapper_val` has 3 values.
+
+---
+
+    Code
+      to_lgl_scalar(given)
+    Condition
+      Error:
+      ! `given` <character> must be coercible to <logical>
+      x Can't convert some values due to incompatible values.
+      * Locations: 1
+
+---
+
+    Code
+      wrapper(given)
+    Condition
+      Error in `wrapper()`:
+      ! `wrapper_val` <character> must be coercible to <logical>
+      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 <NULL>.
+
+---
+
+    Code
+      wrapper(given, allow_null = FALSE)
+    Condition
+      Error in `wrapper()`:
+      ! `wrapper_val` must not be <NULL>.
+

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(

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
+  )
+})