Skip to content

Commit

Permalink
Implement to_lgl_scalar().
Browse files Browse the repository at this point in the history
Closes #32.

Also fixed to_lgl bugs.
  • Loading branch information
jonthegeek committed Aug 10, 2023
1 parent 450185d commit bc76263
Show file tree
Hide file tree
Showing 12 changed files with 257 additions and 7 deletions.
3 changes: 3 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -21,3 +23,4 @@ export(stabilize_int_scalar)
export(to_int)
export(to_int_scalar)
export(to_lgl)
export(to_lgl_scalar)
1 change: 0 additions & 1 deletion R/stabilize_int.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
1 change: 0 additions & 1 deletion R/stabilize_int_scalar.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
5 changes: 2 additions & 3 deletions R/to_int_scalar.R
Original file line number Diff line number Diff line change
@@ -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
#'
Expand All @@ -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,
Expand Down
18 changes: 18 additions & 0 deletions R/to_lgl.R
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand Down
35 changes: 35 additions & 0 deletions R/to_lgl_scalar.R
Original file line number Diff line number Diff line change
@@ -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)
}
4 changes: 2 additions & 2 deletions man/to_int_scalar.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

41 changes: 41 additions & 0 deletions man/to_lgl_scalar.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

20 changes: 20 additions & 0 deletions tests/testthat/_snaps/to_lgl.md
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
54 changes: 54 additions & 0 deletions tests/testthat/_snaps/to_lgl_scalar.md
Original file line number Diff line number Diff line change
@@ -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>.

38 changes: 38 additions & 0 deletions tests/testthat/test-to_lgl.R
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand Down
44 changes: 44 additions & 0 deletions tests/testthat/test-to_lgl_scalar.R
Original file line number Diff line number Diff line change
@@ -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
)
})

0 comments on commit bc76263

Please sign in to comment.