Implement stabilize_lgl(). (#36)

Closes #28. Also switched to to_lgl_scalar() wherever possible internally, and abstracted the stabilize_cls functions.
jonthegeek · Aug 10, 2023 · 77c91a2 · 77c91a2
1 parent 485954e
commit 77c91a2
Show file tree

Hide file tree

Showing 23 changed files with 486 additions and 45 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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