refactoring

Author: Stefan Fleck

DESCRIPTION

@@ -10,6 +10,5 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Suggests: 
-    testthat,
-    dplyr
+    testthat
 RoxygenNote: 6.0.1

R/case_when.R

@@ -121,10 +121,11 @@ case_when <- function(...) {
       inconsistent_lengths <- non_atomic_lengths[-1]
       lhs_problems <- lhs_lengths %in% inconsistent_lengths
       rhs_problems <- rhs_lengths %in% inconsistent_lengths
-      problems <- lhs_problems | rhs_problems
+
+
       bad_calls(
-        formulas[problems],
-        check_length_val(inconsistent_lengths, m, header = NULL, .stop = identity)
+        formulas[lhs_problems | rhs_problems],
+        inconsistent_lengths_message(inconsistent_lengths, m)
       )
     }
   }

R/utils.R

@@ -1,5 +1,3 @@
-
-
 backticks <- function (x){
   paste0("`", x, "`")
 }
@@ -41,34 +39,6 @@ fmt_calls <- function(...){
 
 
 
-check_length_val <- function(
-  length_x,
-  n,
-  header,
-  reason = NULL,
-  .stop = stop
-){
-  if (all(length_x %in% c(1L, n)))
-    return()
-
-  if (is.null(reason))
-    reason <- ""
-  else
-    reason <- paste0(" (", reason, ")")
-
-  if (is.null(header))
-    header <- ""
-  else
-    header <- paste0(header, " ")
-
-
-  if (n == 1) {
-    .stop(sprintf("%smust be length 1%s, not %s", header, reason, paste(length_x, collapse = ", ")))
-  } else {
-    .stop(sprintf("%smust be length %s%s or one, not %s", header, n, reason, paste(length_x, collapse = ", ")))
-  }
-}
-
 
 
 
@@ -83,9 +53,9 @@ replace_with <- function (
     return(x)
   }
 
-  check_length(val, x, name, reason)
-  check_type(val, x, name)
-  check_class(val, x, name)
+  assert_length_1_or_n(val, length(x), name, reason)
+  assert_equal_type(val, x, name)
+  assert_equal_class(val, x, name)
 
   i[is.na(i)] <- FALSE
   if (length(val) == 1L) {
@@ -99,26 +69,13 @@ replace_with <- function (
 
 
 
-check_length <- function (
-  x,
-  template,
-  header,
-  reason = NULL
-){
-  check_length_val(length(x), length(template), header, reason)
-}
-
-
-
-
-check_type <- function(
+assert_equal_type <- function(
   x,
   template,
   header
 ){
-  if (identical(typeof(x), typeof(template))) {
-    return()
-  }
+  if (identical(typeof(x), typeof(template)))
+    return(TRUE)
 
   if (is.null(header))
     header <- ""
@@ -131,16 +88,16 @@ check_type <- function(
 
 
 
-check_class <- function(
+assert_equal_class <- function(
   x,
   template,
   header
 ){
   if (!is.object(x)) {
-    return()
+    return(TRUE)
 
   } else if (identical(class(x), class(template))) {
-    return()
+    return(TRUE)
 
   } else {
 
@@ -150,15 +107,77 @@ check_class <- function(
       header <- paste0(header, " ")
 
 
-    stop(sprintf("%smust be type %s, not %s", header, typeof(template), typeof(x)))
+    stop(
+      sprintf(
+        "%smust be %s, not %s",
+        header,
+        paste(class(template), collapse = "/"),
+        paste(class(x), collapse = "/")
+      )
+    )
   }
 }
 
 
 
 
-fmt_classes <- function(
-  x
+check_length_1_or_n <- function(
+  x,
+  n,
+  header,
+  reason
 ){
-  paste(class(x), collapse = "/")
+  if (length(x) %in% c(1, n)){
+    return(NULL)
+  }
+
+
+  if (is.null(reason))
+    reason <- ""
+  else
+    reason <- paste0(" (", reason, ")")
+
+  if (is.null(header))
+    header <- ""
+  else
+    header <- paste0(header, " ")
+
+
+  inconsistent_lengths_message(length(x), n, header = header, reason = reason)
+}
+
+
+
+
+assert_length_1_or_n <- function(
+  x,
+  n,
+  header,
+  reason
+){
+  chk <- check_length_1_or_n(x, n, header, reason)
+
+  if (is.null(chk)){
+    TRUE
+  } else {
+    stop(chk)
+  }
+}
+
+
+
+
+# messages ----------------------------------------------------------------
+
+inconsistent_lengths_message <- function(
+  length_is,
+  length_should,
+  header = "",
+  reason = ""
+){
+  if (length_should == 1) {
+    sprintf("%smust be length 1%s, not %s", header, reason, paste(length_is, collapse = ", "))
+  } else {
+    sprintf("%smust be length %s%s or one, not %s", header, length_should, reason, paste(length_is, collapse = ", "))
+  }
 }

README.md

@@ -1,27 +1,33 @@
 # lest
 
-[![lifecycle](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing)
+[![lifecycle](https://img.shields.io/badge/lifecycle-stable-blue.svg)](https://www.tidyverse.org/lifecycle/#stable)
 
-Vectorised Conditionals Similar to SQL CASE WHEN, forked from dplyr but without
-any dependencies. 
+lest contains forks of the dplyr functions `case_when()` and `if_else()`.
+`case_when()` enables you to vectorise multiple `if` and `else` statements
+(like the `CASE WHEN` statement in SQL). `if_else()` is a stricter and
+more predictable version of `base::ifelse()` that preverves attributes
+(and therefore works with Dates).
 
+**lest** depends only on base, and will never add any external dependencies.
 
-Relationship to dplyr::case_when() 
+
+
+Why use lest?
 ----------------------------------
 
 Use this package if you like the semantics of `dplyr::case_when()`, but do not 
-want to use dplyr. If you already use dplyr, it is not recommended to use 
-**lest**. `lest::case_when()` and `lest::if_else()` behave exactly identical to 
+want to use dplyr. 
+**If you already use dplyr, it is not recommended to use  lest**. 
+`lest::case_when()` and `lest::if_else()` behave exactly identical to 
 the dplyr equivalents, just that they do not support tidyeval syntax 
 (like `!!!`).
 
-The dplyr `suggests` in the package descriptions is just for unit tests. 
 
 
 Installation
 ------------
 
-You can install dint from GitHub with:
+You can install lest from GitHub with:
 
 ``` r
 # install.packages("devtools")

tests/testthat/integration_tests/test_case_when.R

@@ -0,0 +1,6 @@
+test_that("case_when can be used in anonymous functions (#3422)", {
+  res <- tibble::tibble(a = 1:3) %>%
+    dplyr::mutate(b = (function(x) case_when(x < 2 ~ TRUE, TRUE ~ FALSE))(a)) %>%
+    dplyr::pull()
+  expect_equal(res, c(TRUE, FALSE, FALSE))
+})

tests/testthat/test_case_when.R

@@ -1,5 +1,8 @@
 context("case_when")
 
+
+
+
 test_that("zero inputs throws an error", {
   expect_error(
     case_when(),
@@ -8,6 +11,9 @@ test_that("zero inputs throws an error", {
   )
 })
 
+
+
+
 test_that("error messages", {
   expect_error(
     case_when(
@@ -26,6 +32,9 @@ test_that("error messages", {
   )
 })
 
+
+
+
 test_that("cases must yield compatible lengths", {
   expect_error(
     case_when(
@@ -47,6 +56,9 @@ test_that("cases must yield compatible lengths", {
   )
 })
 
+
+
+
 test_that("matches values in order", {
   x <- 1:3
   expect_equal(
@@ -59,6 +71,9 @@ test_that("matches values in order", {
   )
 })
 
+
+
+
 test_that("unmatched gets missing value", {
   x <- 1:3
   expect_equal(
@@ -70,6 +85,9 @@ test_that("unmatched gets missing value", {
   )
 })
 
+
+
+
 test_that("missing values can be replaced (#1999)", {
   x <- c(1:3, NA)
   expect_equal(
@@ -82,6 +100,9 @@ test_that("missing values can be replaced (#1999)", {
   )
 })
 
+
+
+
 test_that("NA conditions (#2927)", {
   expect_equal(
     case_when(
@@ -92,6 +113,9 @@ test_that("NA conditions (#2927)", {
   )
 })
 
+
+
+
 test_that("atomic conditions (#2909)", {
   expect_equal(
     case_when(
@@ -109,6 +133,9 @@ test_that("atomic conditions (#2909)", {
   )
 })
 
+
+
+
 test_that("zero-length conditions and values (#3041)", {
   expect_equal(
     case_when(
@@ -125,10 +152,3 @@ test_that("zero-length conditions and values (#3041)", {
     numeric()
   )
 })
-
-test_that("case_when can be used in anonymous functions (#3422)", {
-  res <- tibble::tibble(a = 1:3) %>%
-    dplyr::mutate(b = (function(x) case_when(x < 2 ~ TRUE, TRUE ~ FALSE))(a)) %>%
-    dplyr::pull()
-  expect_equal(res, c(TRUE, FALSE, FALSE))
-})