Implement to_lgl(). (#34)

* Implement to_lgl().

* Check internal function args.

* Redocument.

NAMESPACE

@@ -8,10 +8,16 @@ 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)
 export(stabilize_int)
 export(stabilize_int_scalar)
 export(to_int)
 export(to_int_scalar)
+export(to_lgl)

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,

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

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

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

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,

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(

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,14 +22,20 @@ 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,
     call = call,
     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)
 }

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

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