├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── case_when.R ├── cumall.R ├── exceeds_tumbling_sum.R ├── if_else.R ├── lest-package.R ├── utils-sfmisc.R └── utils.R ├── README.md ├── benchmark └── bench_cumall.R ├── docs ├── 404.html ├── LICENSE-text.html ├── LICENSE.html ├── authors.html ├── docsearch.css ├── docsearch.js ├── index.html ├── link.svg ├── news │ └── index.html ├── pkgdown.css ├── pkgdown.js ├── pkgdown.yml └── reference │ ├── case_when.html │ ├── cumall.html │ ├── exceeds_tumbling_sum.html │ ├── if_else.html │ ├── index.html │ └── lest-package.html ├── inst └── WORDLIST ├── lest.Rproj ├── man ├── case_when.Rd ├── cumall.Rd ├── exceeds_tumbling_sum.Rd ├── if_else.Rd └── lest-package.Rd ├── src ├── cumall.c ├── exceeds_tumbling_sum.c └── init.c └── tests ├── testthat.R └── testthat ├── integration_tests └── test_case_when.R ├── test_case_when.R ├── test_cumall.R ├── test_exceeds_tumbling_sum.R └── test_if_else.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^LICENSE\.md$ 4 | ^_pkgdown\.yml$ 5 | ^docs$ 6 | ^cran-comments\.md$ 7 | ^benchmark$ 8 | ^\.travis\.yml$ 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | _pkgdown.yml 6 | cran-comments.md 7 | *.o 8 | *.so 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | cache: packages 5 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: lest 3 | Title: Vectorised Nested if-else Statements Similar to CASE WHEN 4 | in 'SQL' 5 | Version: 1.1.0 6 | Authors@R: 7 | c(person(given = "Stefan", 8 | family = "Fleck", 9 | role = c("aut", "cre"), 10 | email = "stefan.b.fleck@gmail.com", 11 | comment = c(ORCID = "0000-0003-3344-9851")), 12 | person(given = "Hadley", 13 | family = "Wickham", 14 | role = "aut", 15 | email = "hadley@rstudio.com", 16 | comment = c(ORCID = "0000-0003-4757-117X")), 17 | person(given = "Romain", 18 | family = "François", 19 | role = "aut", 20 | comment = c(ORCID = "0000-0002-2444-4226")), 21 | person(given = "Lionel", 22 | family = "Henry", 23 | role = "aut"), 24 | person(given = "Kirill", 25 | family = "Müller", 26 | role = "aut", 27 | comment = c(ORCID = "0000-0002-1416-3412"))) 28 | Maintainer: Stefan Fleck 29 | Description: Functions for vectorised conditional recoding of 30 | variables. case_when() enables you to vectorise multiple if and else 31 | statements (like 'CASE WHEN' in 'SQL'). if_else() is a stricter and 32 | more predictable version of ifelse() in 'base' that preserves 33 | attributes. These functions are forked from 'dplyr' with all package 34 | dependencies removed and behave identically to the originals. 35 | License: MIT + file LICENSE 36 | Suggests: 37 | testthat 38 | Encoding: UTF-8 39 | LazyData: true 40 | Roxygen: list(markdown = TRUE) 41 | RoxygenNote: 7.0.1.9000 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2018 2 | COPYRIGHT HOLDER: Stefan Fleck 3 | YEAR: 2013-2015 4 | COPYRIGHT HOLDER: RStudio 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | Copyright © 2018 Stefan Fleck. 5 | Copyright © 2013-2015 RStudio and others. 6 | 7 | Permission is hereby granted, free of charge, to any person 8 | obtaining a copy of this software and associated documentation 9 | files (the “Software”), to deal in the Software without 10 | restriction, including without limitation the rights to use, 11 | copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the 13 | Software is furnished to do so, subject to the following 14 | conditions: 15 | 16 | The above copyright notice and this permission notice shall be 17 | included in all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, 20 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 23 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 24 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 25 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 26 | OTHER DEALINGS IN THE SOFTWARE. 27 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(case_when) 4 | export(cumall) 5 | export(cumany) 6 | export(exceeds_tumbling_sum) 7 | export(if_else) 8 | useDynLib(lest, .registration = TRUE) 9 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # lest 1.1.0 2 | 3 | * Added `exceeds_tumbling_sum()` for checking when a partial cumulative sum 4 | ("tumbling sum"") hits a certain threshold value. This is for example useful 5 | for filtering geographic positions by a minimum distance. Thanks to 6 | [@klmr](https://github.com/klmr) for helping me come up with a name. 7 | 8 | * Added plain C clones of `dplyr::cumall()` and `dplyr::cumany()` 9 | 10 | 11 | 12 | 13 | # lest 1.0.0 14 | 15 | * First public release 16 | -------------------------------------------------------------------------------- /R/case_when.R: -------------------------------------------------------------------------------- 1 | # case_when --------------------------------------------------------------- 2 | 3 | #' A general vectorised if 4 | #' 5 | #' This function allows you to vectorise multiple `if` and `else if` 6 | #' statements. It is an R equivalent of the SQL `CASE WHEN` statement. 7 | #' 8 | #' @param ... A sequence of two-sided formulas. The left hand side (LHS) 9 | #' determines which values match this case. The right hand side (RHS) 10 | #' provides the replacement value. 11 | #' 12 | #' The LHS must evaluate to a logical vector. The RHS does not need to be 13 | #' logical, but all RHSs must evaluate to the same type of vector. 14 | #' 15 | #' Both LHS and RHS may have the same length of either 1 or `n`. The 16 | #' value of `n` must be consistent across all cases. The case of 17 | #' `n == 0` is treated as a variant of `n != 1`. 18 | #' 19 | #' @return A vector of length 1 or `n`, matching the length of the logical 20 | #' input or output vectors, with the type (and attributes) of the first 21 | #' RHS. Inconsistent lengths or types will generate an error. 22 | #' 23 | #' @export 24 | #' @examples 25 | #' x <- 1:50 26 | #' case_when( 27 | #' x %% 35 == 0 ~ "fizz buzz", 28 | #' x %% 5 == 0 ~ "fizz", 29 | #' x %% 7 == 0 ~ "buzz", 30 | #' TRUE ~ as.character(x) 31 | #' ) 32 | #' 33 | #' # Like an if statement, the arguments are evaluated in order, so you must 34 | #' # proceed from the most specific to the most general. This won't work: 35 | #' case_when( 36 | #' TRUE ~ as.character(x), 37 | #' x %% 5 == 0 ~ "fizz", 38 | #' x %% 7 == 0 ~ "buzz", 39 | #' x %% 35 == 0 ~ "fizz buzz" 40 | #' ) 41 | #' 42 | #' # All RHS values need to be of the same type. Inconsistent types will throw an error. 43 | #' # This applies also to NA values used in RHS: NA is logical, use 44 | #' # typed values like NA_real_, NA_complex, NA_character_, NA_integer_ as appropriate. 45 | #' case_when( 46 | #' x %% 35 == 0 ~ NA_character_, 47 | #' x %% 5 == 0 ~ "fizz", 48 | #' x %% 7 == 0 ~ "buzz", 49 | #' TRUE ~ as.character(x) 50 | #' ) 51 | #' case_when( 52 | #' x %% 35 == 0 ~ 35, 53 | #' x %% 5 == 0 ~ 5, 54 | #' x %% 7 == 0 ~ 7, 55 | #' TRUE ~ NA_real_ 56 | #' ) 57 | #' # This throws an error as NA is logical not numeric 58 | #' try({ 59 | #' case_when( 60 | #' x %% 35 == 0 ~ 35, 61 | #' x %% 5 == 0 ~ 5, 62 | #' x %% 7 == 0 ~ 7, 63 | #' TRUE ~ NA 64 | #' ) 65 | #' }) 66 | #' dat <- iris[1:5, ] 67 | #' dat$size <- case_when( 68 | #' dat$Sepal.Length < 5.0 ~ "small", 69 | #' TRUE ~ "big" 70 | #' ) 71 | #' dat 72 | case_when <- function(...) { 73 | formulas <- list(...) 74 | n <- length(formulas) 75 | 76 | if (n == 0) { 77 | stop("No cases provided") 78 | } 79 | 80 | query <- vector("list", n) 81 | value <- vector("list", n) 82 | 83 | for (i in seq_len(n)) { 84 | f <- formulas[[i]] 85 | if (!inherits(f, "formula") || length(f) != 3) { 86 | stop(sprintf( 87 | "Case %s (`%s`) must be a two-sided formula, not a %s", 88 | i, 89 | deparse_trunc(substitute(list(...))[[i + 1]]), 90 | typeof(f) 91 | )) 92 | } 93 | 94 | env <- environment(f) 95 | query[[i]] <- eval(f[[2]], env) 96 | 97 | if (!is.logical(query[[i]])) { 98 | stop(sprintf( 99 | "LHS of case %s (%s) must be a logical, not %s", 100 | i, 101 | backticks(deparse_trunc(f_lhs(f))), 102 | typeof(query[[i]]) 103 | )) 104 | } 105 | 106 | value[[i]] <- eval(f[[3]], env) 107 | } 108 | 109 | lhs_lengths <- vapply(query, length, integer(1)) 110 | rhs_lengths <- vapply(value, length, integer(1)) 111 | all_lengths <- unique(c(lhs_lengths, rhs_lengths)) 112 | 113 | if (length(all_lengths) <= 1) { 114 | m <- all_lengths[[1]] 115 | } else { 116 | non_atomic_lengths <- all_lengths[all_lengths != 1] 117 | m <- non_atomic_lengths[[1]] 118 | if (length(non_atomic_lengths) > 1) { 119 | inconsistent_lengths <- non_atomic_lengths[-1] 120 | lhs_problems <- lhs_lengths %in% inconsistent_lengths 121 | rhs_problems <- rhs_lengths %in% inconsistent_lengths 122 | 123 | bad_calls( 124 | formulas[lhs_problems | rhs_problems], 125 | inconsistent_lengths_message(inconsistent_lengths, m) 126 | ) 127 | } 128 | } 129 | 130 | out <- value[[1]][rep(NA_integer_, m)] 131 | replaced <- rep(FALSE, m) 132 | 133 | for (i in seq_len(n)) { 134 | out <- replace_with(out, query[[i]] & !replaced, value[[i]], NULL) 135 | replaced <- replaced | (query[[i]] & !is.na(query[[i]])) 136 | } 137 | 138 | out 139 | } 140 | -------------------------------------------------------------------------------- /R/cumall.R: -------------------------------------------------------------------------------- 1 | #' Cumulative all and any 2 | #' 3 | #' @param x a `logical` vector. 4 | #' @return a `logical` vector 5 | #' @export 6 | #' 7 | #' @examples 8 | #' cumall(c(TRUE, TRUE, NA, TRUE, FALSE)) 9 | #' cumany(c(FALSE, FALSE, NA, TRUE, FALSE)) 10 | cumall <- function(x) { 11 | .Call("cumall_", x) 12 | } 13 | 14 | 15 | 16 | 17 | #' @rdname cumall 18 | #' @export 19 | cumany <- function(x) { 20 | .Call("cumany_", x) 21 | } 22 | -------------------------------------------------------------------------------- /R/exceeds_tumbling_sum.R: -------------------------------------------------------------------------------- 1 | #' Check When the Tumbling Sum of a Vector Exceeds a Threshold 2 | #' 3 | #' The tumbling sum is calculated as the partial cumulative sum of a vector 4 | #' until a threshold is exceeded. Once this happens, the tumbling sum is 5 | #' calculated from zero again. `exceeds_tumbling_sum()` returns `TRUE` whenever 6 | #' this threshold is hit/exceeded and `FALSE` otherwise. 7 | #' 8 | #' This is for example useful if you have high frequency GPS positions 9 | #' and want to keep only points that are at least `x` seconds apart. 10 | #' 11 | #' @param x a `numeric` vector 12 | #' @param threshold a `numeric` scalar 13 | #' @param inclusive a `logical` scalar. If `TRUE` inclusive bounds are used 14 | #' (i.e. the threshold is checked with `>=`), otherwise exclusive 15 | #' 16 | #' @return a `logical` vector of the same length as `x` that is `TRUE` whenever 17 | #' `threshold` was exceeded and `FALSE` otherwise 18 | #' 19 | #' @seealso [MESS::cumsumbinning()] does something very similar, but returns 20 | #' group indices instead of a logical vector. 21 | #' 22 | #' @export 23 | #' @examples 24 | #' exceeds_tumbling_sum(c(1, 3, 3, 3), 4) 25 | exceeds_tumbling_sum <- function( 26 | x, 27 | threshold, 28 | inclusive = TRUE 29 | ){ 30 | assert(is_scalar(threshold)) 31 | assert(is_scalar_bool(inclusive)) 32 | 33 | if (is.integer(x) && is.integer(threshold)){ 34 | assert(!anyNA(x)) 35 | assert(!is.na(threshold)) 36 | 37 | .Call("exceeds_tumbling_sum_int_", x, threshold, inclusive) 38 | 39 | } else { 40 | x <- as.double(x) 41 | threshold <- as.double(threshold) 42 | assert(!anyNA(x)) 43 | assert(!is.na(threshold)) 44 | 45 | .Call("exceeds_tumbling_sum_double_", x, threshold, inclusive) 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /R/if_else.R: -------------------------------------------------------------------------------- 1 | 2 | #' Vectorised if 3 | #' 4 | #' Compared to the base [ifelse()], this function is more strict. 5 | #' It checks that `true` and `false` are the same type. This 6 | #' strictness makes the output type more predictable, and makes it somewhat 7 | #' faster. 8 | #' 9 | #' @param condition Logical vector 10 | #' @param true,false Values to use for `TRUE` and `FALSE` values of 11 | #' `condition`. They must be either the same length as `condition`, 12 | #' or length 1. They must also be the same type: `if_else()` checks that 13 | #' they have the same type and same class. All other attributes are 14 | #' taken from `true`. 15 | #' @param missing If not `NULL`, will be used to replace missing 16 | #' values. 17 | #' @return Where `condition` is `TRUE`, the matching value from 18 | #' `true`, where it's `FALSE`, the matching value from `false`, 19 | #' otherwise `NA`. 20 | #' 21 | #' @export 22 | #' @examples 23 | #' x <- c(-5:5, NA) 24 | #' if_else(x < 0, NA_integer_, x) 25 | #' if_else(x < 0, "negative", "positive", "missing") 26 | #' 27 | #' # Unlike ifelse, if_else preserves types 28 | #' x <- factor(sample(letters[1:5], 10, replace = TRUE)) 29 | #' ifelse(x %in% c("a", "b", "c"), x, factor(NA)) 30 | #' if_else(x %in% c("a", "b", "c"), x, factor(NA)) 31 | #' # Attributes are taken from the `true` vector, 32 | if_else <- function( 33 | condition, 34 | true, 35 | false, 36 | missing = NULL 37 | ){ 38 | if (!is.logical(condition)) { 39 | stop("`condition` must be a logical, not ", typeof(condition)) 40 | } 41 | 42 | out <- true[rep(NA_integer_, length(condition))] 43 | out <- replace_with( 44 | out, 45 | condition, 46 | true, 47 | "`true`", 48 | sprintf("length of `condition`") 49 | ) 50 | 51 | out <- replace_with( 52 | out, 53 | !condition, 54 | false, 55 | "`false`", 56 | sprintf("length of `condition`") 57 | ) 58 | 59 | out <- replace_with( 60 | out, 61 | is.na(condition), 62 | missing, 63 | "`missing`", 64 | sprintf("length of `condition`") 65 | ) 66 | 67 | out 68 | } 69 | -------------------------------------------------------------------------------- /R/lest-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | #' @useDynLib lest, .registration = TRUE 3 | "_PACKAGE" 4 | 5 | 6 | 7 | 8 | .onUnload <- function (libpath) { 9 | library.dynam.unload("lest", libpath) 10 | } 11 | -------------------------------------------------------------------------------- /R/utils-sfmisc.R: -------------------------------------------------------------------------------- 1 | # sfmisc utils 0.0.1.9031 2 | 3 | 4 | 5 | 6 | # utils ------------------------------------------------------------------- 7 | 8 | # nocov start 9 | # commonly used utility functions included from the package sfmisc 10 | 11 | 12 | #' Paste and Truncate 13 | #' 14 | #' @param x a vector 15 | #' @param width (maximum) width of result 16 | #' @param dots `character` scalar. String to use for ellipses 17 | #' @inheritParams paste 18 | #' 19 | #' @return a `character` scalar 20 | #' @noRd 21 | #' 22 | #' @examples 23 | #' ptrunc(month.abb) 24 | #' ptrunc(month.abb, month.name) 25 | #' 26 | ptrunc <- function( 27 | ..., 28 | width = 40L, 29 | sep = ", ", 30 | collapse = ", ", 31 | dots = " ..." 32 | ){ 33 | assert(width > 7L, "The minimum supported width is 8") 34 | x <- paste(..., sep = sep, collapse = collapse) 35 | 36 | sel <- vapply(x, nchar, integer(1), USE.NAMES = FALSE) > width 37 | 38 | x[sel] <- strtrim(x[sel], width = width - 4L) 39 | x[sel] <- paste0(gsub(",{0,1}\\s*$", "", x[sel]), dots) 40 | x 41 | } 42 | 43 | 44 | 45 | 46 | fmt_class <- function(x){ 47 | paste0("<", paste(x, collapse = "/"), ">") 48 | } 49 | 50 | 51 | 52 | 53 | #' @param x any \R object 54 | #' @param ignore subclasses to ignore 55 | #' @noRd 56 | class_fmt <- function(x, ignore = NULL){ 57 | fmt_class(setdiff(class(x), ignore)) 58 | } 59 | 60 | 61 | 62 | 63 | compact <- function(x){ 64 | x[!vapply(x, is.null, FALSE)] 65 | } 66 | 67 | 68 | 69 | 70 | walk <- function(.x, .f, ...){ 71 | for (i in seq_along(.x)){ 72 | .f(.x[[i]], ...) 73 | } 74 | 75 | invisible(.x) 76 | } 77 | 78 | 79 | 80 | 81 | # assertions -------------------------------------------------------------- 82 | 83 | #' Assert a condition 84 | #' 85 | #' A simpler and more efficient for [base::stopifnot()] that has an easy 86 | #' mechanism for supplying custom error messages. As opposed to `stopifnot()`, 87 | #' `assert()` only works with a single (scalar) assertions. 88 | #' 89 | #' @param cond `TRUE` or `FALSE` (without any attributes). `FALSE` will throw 90 | #' an exception with an automatically constructed error message (if `...` 91 | #' was not supplied). Anything else will throw an exception stating that 92 | #' `cond` was not valid. 93 | #' @param ... passed on to [stop()] 94 | #' @param call. passed on to [stop()] 95 | #' @param domain passed on to [stop()] 96 | #' 97 | #' @noRd 98 | #' 99 | #' @return TRUE on success 100 | #' 101 | #' @examples 102 | #' 103 | #' \dontrun{ 104 | #' assert(1 == 1) 105 | #' assert(1 == 2) 106 | #' } 107 | #' 108 | #' 109 | assert <- function( 110 | cond, 111 | ..., 112 | call. = FALSE, 113 | domain = NULL 114 | ){ 115 | if (identical(cond, TRUE)){ 116 | return(TRUE) 117 | } else if (identical(cond, FALSE)){ 118 | if (identical(length(list(...)), 0L)){ 119 | msg <- paste0("`", deparse(match.call()[[2]]), "`", " is not 'TRUE'") 120 | stop(msg, call. = call., domain = domain) 121 | } else { 122 | suppressWarnings( stop(..., call. = call., domain = domain) ) 123 | } 124 | 125 | } else { 126 | stop("Assertion must be either 'TRUE' or 'FALSE'") 127 | } 128 | } 129 | 130 | 131 | 132 | 133 | assert_namespace <- function(...){ 134 | res <- vapply(c(...), requireNamespace, logical(1), quietly = TRUE) 135 | if (all(res)){ 136 | return(invisible(TRUE)) 137 | 138 | } else { 139 | pkgs <- c(...) 140 | if (identical(length(pkgs), 1L)){ 141 | msg <- sprintf(paste( 142 | "This function requires the package '%s'. You can install it with", 143 | '`install.packages("%s")`.'), pkgs, pkgs 144 | ) 145 | } else { 146 | msg <- sprintf( 147 | paste( 148 | "This function requires the packages %s. You can install them with", 149 | "`install.packages(%s)`." 150 | ), 151 | paste(names(res)[!res], collapse = ", "), 152 | deparse(names(res)) 153 | ) 154 | } 155 | } 156 | 157 | stop(msg) 158 | } 159 | 160 | 161 | 162 | 163 | # conditions -------------------------------------------------------------- 164 | 165 | #' Condition constructor 166 | #' 167 | #' A constructur function for conditions, taken from 168 | #' \url{http://adv-r.had.co.nz/beyond-exception-handling.html} 169 | #' 170 | #' @param subclass Subclass to assign to the condition 171 | #' @param message message to be passed to the condition 172 | #' @param call call passed on to the conditon 173 | #' @param ... further list elements to be passed on to the resulting object 174 | #' 175 | #' @return a condition object 176 | #' @noRd 177 | #' 178 | #' @examples 179 | #' 180 | #' \dontrun{ 181 | #' # Construct a custom condition 182 | #' malformed_log_entry_error <- function(text) { 183 | #' msg <- paste0("Malformed log entry: ", text) 184 | #' condition( 185 | #' c("malformed_log_entry_entry", "error"), 186 | #' message = msg, 187 | #' text = text 188 | #' ) 189 | #' } 190 | #' 191 | #' 192 | #' # Signal the condition 193 | #' parse_log_entry <- function(text) { 194 | #' if (!well_formed_log_entry(text)) { 195 | #' stop(malformed_log_entry_error(text)) 196 | #' } 197 | #' } 198 | #' 199 | #' 200 | #' # Handle the condition 201 | #' tryCatch( 202 | #' malformed_log_entry = function(e) NULL, 203 | #' parse_log_entry(text) 204 | #' ) 205 | #' } 206 | #' 207 | condition <- function(subclass, message, call = sys.call(-1), ...) { 208 | structure( 209 | class = c(subclass, "condition"), 210 | list(message = message, call = call, ...) 211 | ) 212 | } 213 | 214 | 215 | 216 | 217 | error <- function(subclass, message, call = sys.call(-1), ...) { 218 | structure( 219 | class = c(subclass, "error", "condition"), 220 | list(message = message, call = call, ...) 221 | ) 222 | } 223 | 224 | 225 | 226 | 227 | # predicates -------------------------------------------------------------- 228 | 229 | 230 | 231 | is_error <- function(x){ 232 | inherits(x, "error") 233 | } 234 | 235 | 236 | 237 | 238 | is_try_error <- function(x){ 239 | inherits(x, "try-error") 240 | } 241 | 242 | 243 | 244 | 245 | is_scalar <- function(x){ 246 | identical(length(x), 1L) 247 | } 248 | 249 | 250 | 251 | 252 | is_POSIXct <- function(x){ 253 | inherits(x, "POSIXct") 254 | } 255 | 256 | 257 | 258 | 259 | is_scalar_POSIXct <- function(x){ 260 | is_POSIXct(x) && is_scalar(x) 261 | } 262 | 263 | 264 | 265 | 266 | is_POSIXlt <- function(x){ 267 | inherits(x, "POSIXlt") 268 | } 269 | 270 | 271 | 272 | 273 | is_scalar_POSIXlt <- function(x){ 274 | is_POSIXlt(x) && is_scalar(x) 275 | } 276 | 277 | 278 | 279 | 280 | is_POSIXt <- function(x){ 281 | inherits(x, "POSIXt") 282 | } 283 | 284 | 285 | 286 | 287 | is_scalar_POSIXt <- function(x){ 288 | is_POSIXt(x) && is_scalar(x) 289 | } 290 | 291 | 292 | 293 | 294 | is_Date <- function(x){ 295 | inherits(x, "Date") 296 | } 297 | 298 | 299 | 300 | 301 | is_scalar_Date <- function(x){ 302 | is_Date(x) && is_scalar(x) 303 | } 304 | 305 | 306 | 307 | 308 | is_scalar_list <- function(x){ 309 | is_list(x) && is_scalar(x) 310 | } 311 | 312 | 313 | 314 | 315 | is_scalar_atomic <- function(x){ 316 | is.atomic(x) && is_scalar(x) 317 | } 318 | 319 | 320 | 321 | 322 | is_scalar_logical <- function(x){ 323 | is.logical(x) && is_scalar(x) 324 | } 325 | 326 | 327 | 328 | 329 | is_scalar_integer <- function(x){ 330 | is.integer(x) && is_scalar(x) 331 | } 332 | 333 | 334 | 335 | 336 | is_scalar_factor <- function(x){ 337 | is.factor(x) && is_scalar(x) 338 | } 339 | 340 | 341 | 342 | 343 | is_scalar_list <- function(x){ 344 | is.list(x) && is_scalar(x) 345 | } 346 | 347 | 348 | 349 | 350 | is_scalar_numeric <- function(x){ 351 | is.numeric(x) && is_scalar(x) 352 | } 353 | 354 | 355 | 356 | 357 | is_scalar_character <- function(x){ 358 | is.character(x) && is_scalar(x) 359 | } 360 | 361 | 362 | 363 | 364 | is_vector <- function(x){ 365 | is.atomic(x) || is.list(x) 366 | } 367 | 368 | 369 | 370 | 371 | is_bool <- function(x){ 372 | is.logical(x) && !anyNA(x) 373 | } 374 | 375 | 376 | 377 | 378 | #' Check if Object is a Boolean 379 | #' 380 | #' Check wheter an object is either `TRUE` or `FALSE`. 381 | #' 382 | #' @param x Any \R Object. 383 | #' @return either `TRUE` or `FALSE` 384 | #' @noRd 385 | #' 386 | is_scalar_bool <- function(x){ 387 | identical(x, TRUE) || identical(x, FALSE) 388 | } 389 | 390 | 391 | 392 | 393 | #' Check if Object is Integer-like 394 | #' 395 | #' Check wheter an object is either `TRUE` or `FALSE`. 396 | #' 397 | #' @param x Any \R Object. 398 | #' @return either `TRUE` or `FALSE` 399 | #' @noRd 400 | #' 401 | is_integerish <- function(x){ 402 | if (!is.numeric(x)){ 403 | FALSE 404 | } else { 405 | all(as.integer(x) == x) 406 | } 407 | } 408 | 409 | 410 | 411 | 412 | is_scalar_integerish <- function(x){ 413 | is_scalar(x) && is_integerish(x) 414 | } 415 | 416 | 417 | 418 | 419 | is_n <- function(x){ 420 | is_scalar_integerish(x) && identical(x > 0, TRUE) 421 | } 422 | 423 | 424 | 425 | 426 | is_n0 <- function(x){ 427 | is_scalar_integerish(x) && identical(x >= 0, TRUE) 428 | } 429 | 430 | 431 | 432 | 433 | #' Check if Objects have the same length 434 | #' 435 | #' @param ... Any number of \R Objects. 436 | #' 437 | #' @return either `TRUE` or `FALSE` 438 | #' @noRd 439 | is_equal_length <- function(...){ 440 | lengths <- vapply(list(...), length, 1L) 441 | identical(length(unique(lengths)), 1L) 442 | } 443 | 444 | 445 | 446 | 447 | #' Check if Object has length 0 448 | #' 449 | #' Check wheter an object is either `TRUE` or `FALSE`. 450 | #' 451 | #' @param x Any \R Object. 452 | #' @return either `TRUE` or `FALSE` 453 | #' @noRd 454 | #' 455 | is_empty <- function(x){ 456 | identical(length(x), 0L) 457 | } 458 | 459 | 460 | 461 | 462 | #' Check if a String is Blank 463 | #' 464 | #' Check wheter a character vector contains only of spaces 465 | #' 466 | #' @param x Any \R Object. 467 | #' @return either `TRUE` or `FALSE` 468 | #' @noRd 469 | #' 470 | is_blank <- function(x){ 471 | trimws(x) == "" 472 | } 473 | 474 | 475 | 476 | 477 | #' Test if a Vector or Combination of Vectors is a Candidate Key 478 | #' 479 | #' Checks if all elements of the atomic vector `x`, or the combination of 480 | #' all elements of `x` if `x` is a `list`, are unique and neither `NA` or 481 | #' `infinite`. 482 | #' 483 | #' @param x a atomic vector or a list of atomic vectors 484 | #' 485 | #' @return `TRUE/FALSE` 486 | #' @noRd 487 | #' 488 | #' @examples 489 | #' 490 | #' is_candidate_key(c(1, 2, 3)) 491 | #' is_candidate_key(c(1, 2, NA)) 492 | #' is_candidate_key(c(1, 2, Inf)) 493 | #' 494 | #' td <- data.frame( 495 | #' x = 1:10, 496 | #' y = 1:2, 497 | #' z = 1:5 498 | #' ) 499 | #' 500 | #' is_candidate_key(list(td$x, td$z)) 501 | #' # a data.frame is just a special list 502 | #' is_candidate_key(td[, c("y", "z")]) 503 | is_candidate_key <- function(x){ 504 | 505 | if (is.atomic(x)){ 506 | # !is.infinite instead of is.finite because x can be a character vector 507 | length(x) > 1 && 508 | all(!is.infinite(x)) && 509 | !any(is.na(x)) && 510 | identical(length(unique(x)), length(x)) 511 | } else if (is.list(x)){ 512 | length(x) > 0 && 513 | length(x[[1]] > 0) && 514 | do.call(is_equal_length, x) && 515 | all(vapply(x, function(.x) all(!is.infinite(.x)), logical(1))) && 516 | all(vapply(x, function(.x) !any(is.na(.x)), logical(1))) && 517 | !any(duplicated(as.data.frame(x))) 518 | } 519 | } 520 | 521 | 522 | 523 | 524 | # https://modern-sql.com/feature/is-distinct-from 525 | is_not_distinct_from <- function(x, y){ 526 | ((x == y) & !is.na(x) & !is.na(y)) | (is.na(x) & is.na(y)) 527 | } 528 | 529 | 530 | 531 | 532 | is_distinct_from <- function(x, y){ 533 | ((x != y) & !is.na(x) & !is.na(y)) | (is.na(x) != is.na(y)) 534 | } 535 | 536 | 537 | 538 | 539 | is_windows_path <- function(x){ 540 | nchar(x) >= 2 & grepl("^[A-Za-z].*", x) & substr(x, 2, 2) == ":" 541 | } 542 | 543 | 544 | 545 | # equalish ---------------------------------------------------------------- 546 | 547 | #' Check for equality within a tolerance level 548 | #' 549 | #' 550 | #' 551 | #' @param x,y `numeric` vectors 552 | #' @param tolerance `numeric` scalar. tolerance level (absolute value). Defaults 553 | #' to `.Machine$double.eps^0.5` which is a sensible default for comparing 554 | #' floating point numbers. 555 | #' 556 | #' @return `equalish()` returns TRUE if the absolute difference between `x` and 557 | #' `y` is less than `tolerance`. 558 | #' @noRd 559 | #' @seealso [.Machine] 560 | #' 561 | #' 562 | #' @examples 563 | #' a <- 0.7 564 | #' b <- 0.2 565 | #' a - b == 0.5 566 | #' equalish(a - b, 0.5) 567 | #' 568 | equalish <- function(x, y, tolerance = .Machine$double.eps ^ 0.5){ 569 | assert(is_scalar_numeric(tolerance) && tolerance >= 0) 570 | abs(x - y) < tolerance 571 | } 572 | 573 | 574 | 575 | 576 | #' @return `equalish_frac()` returns `TRUE` if the relative difference between 577 | #' `x` and `y` is smaller than `tolerance`. The relative difference is 578 | #' defined as `abs(x - y) / pmax(abs(x), abs(y))`. If both `x` and `y` are 579 | #' `0` the relative difference is not defined, but this function will still 580 | #' return `TRUE`. 581 | #' 582 | #' @noRd 583 | #' @examples 584 | #' 585 | #' equalish_frac(1000, 1010, tolerance = 0.01) 586 | #' equalish_frac(1000, 1010, tolerance = 0.009) 587 | #' equalish_frac(0, 0) 588 | #' 589 | equalish_frac <- function(x, y, tolerance = .Machine$double.eps ^ 0.5){ 590 | assert(is_scalar_numeric(tolerance) && tolerance >= 0) 591 | res <- abs(x - y) / pmax(abs(x), abs(y)) < tolerance 592 | res[x == 0 & y == 0] <- TRUE 593 | res 594 | } 595 | 596 | 597 | 598 | 599 | # all_are ----------------------------------------------------------------- 600 | 601 | #' Convert vector if identical elements to scalar 602 | #' 603 | #' Returns `unique(x)` if all elements of `x` are identical, throws an error if 604 | #' not. 605 | #' 606 | #' @inheritParams all_are_identical 607 | #' 608 | #' @return A scalar of the same type as `x` 609 | #' @noRd 610 | as_scalar <- function(x){ 611 | res <- unique(x) 612 | if (is_scalar(res)){ 613 | return(res) 614 | } else { 615 | stop("Not all elements of x are identical") 616 | } 617 | } 618 | 619 | 620 | 621 | 622 | #' Test if all elements of a vector are identical 623 | #' 624 | #' @param x any object that can be handled by [unique()] (usually a vector or 625 | #' list) 626 | #' @param empty_value Value to return if function is called on a vector of 627 | #' length 0 (e.g. `NULL`, `numeric()`, ...) 628 | #' 629 | #' @noRd 630 | #' @family special equality checks 631 | #' @return `TRUE/FALSE` 632 | #' 633 | #' @examples 634 | #' 635 | #' all_are_identical(c(1,2,3)) 636 | #' all_are_identical(c(1,1,1)) 637 | #' 638 | all_are_identical <- function(x, empty_value = FALSE) { 639 | assert(length(empty_value) <= 1) 640 | 641 | if (length(x) > 0L) { 642 | return(identical(length(unique(x)), 1L)) 643 | 644 | } else { 645 | 646 | if (is.null(x)){ 647 | warning("'x' is NULL") 648 | } else { 649 | warning("'x' is an empty vector") 650 | } 651 | 652 | return(empty_value) 653 | } 654 | } 655 | 656 | 657 | 658 | 659 | #' Test if all elements of a vector are unique 660 | #' 661 | #' @inheritParams all_are_identical 662 | #' 663 | #' @return TRUE/FALSE 664 | #' 665 | #' @noRd 666 | #' @family special equality checks 667 | #' 668 | #' @examples 669 | #' 670 | #' all_are_identical(c(1,2,3)) 671 | #' all_are_identical(c(1,1,1)) 672 | #' 673 | all_are_distinct <- function( 674 | x, 675 | empty_value = FALSE 676 | ){ 677 | assert(length(empty_value) <= 1) 678 | 679 | if (identical(length(x), 1L)) { 680 | return(TRUE) 681 | 682 | } else if (length(x) > 1L) { 683 | return(identical(length(unique(x)), length(x))) 684 | 685 | } else { 686 | 687 | if (is.null(x)){ 688 | warning("'x' is NULL") 689 | } else { 690 | warning("'x' is an empty vector") 691 | } 692 | 693 | return(empty_value) 694 | } 695 | } 696 | 697 | 698 | 699 | 700 | n_distinct <- function(x){ 701 | length(unique(x)) 702 | } 703 | 704 | 705 | 706 | 707 | # misc -------------------------------------------------------------------- 708 | 709 | 710 | pad_left <- function( 711 | x, 712 | width = max(nchar(paste(x))), 713 | pad = " " 714 | ){ 715 | diff <- pmax(width - nchar(paste(x)), 0L) 716 | padding <- 717 | vapply(diff, function(i) paste(rep.int(pad, i), collapse = ""), character(1)) 718 | paste0(padding, x) 719 | } 720 | 721 | 722 | 723 | 724 | pad_right <- function( 725 | x, 726 | width = max(nchar(paste(x))), 727 | pad = " " 728 | ){ 729 | diff <- pmax(width - nchar(paste(x)), 0L) 730 | padding <- 731 | vapply(diff, function(i) paste(rep.int(pad, i), collapse = ""), character(1)) 732 | paste0(x, padding) 733 | } 734 | 735 | 736 | 737 | 738 | `%||%` <- function(x, y){ 739 | if (is.null(x)) 740 | y 741 | else (x) 742 | } 743 | 744 | 745 | 746 | 747 | preview_object <- function( 748 | x, 749 | width = 32, 750 | brackets = c("(", ")"), 751 | quotes = c("`", "`"), 752 | dots = ".." 753 | ){ 754 | if (!is.atomic(x)) 755 | return(class_fmt(x)) 756 | 757 | if (is.numeric(x)) 758 | x <- format(x, justify = "none", drop0trailing = TRUE, trim = TRUE) 759 | 760 | res <- ptrunc(x, collapse = ", ", width = width, dots = dots) 761 | 762 | if (length(x) > 1) 763 | res <- paste0(brackets[[1]], res, brackets[[2]]) 764 | else 765 | res <- paste0(quotes[[1]], res, quotes[[2]]) 766 | 767 | res 768 | } 769 | 770 | 771 | 772 | 773 | #' Clean up paths to make them comparable, inspired by fs::path_tidy 774 | #' 775 | #' @param x `character` vector 776 | #' 777 | #' @return a `character` vector 778 | #' @noRd 779 | path_tidy <- function(x){ 780 | x <- gsub("\\\\", "/", x) 781 | x <- gsub("(?!^)/+", "/", x, perl = TRUE) 782 | 783 | sel <- x != "/" 784 | x[sel] <- gsub("/$", "", x[sel]) 785 | 786 | sel <- is_windows_path(x) 787 | 788 | if (any(sel)){ 789 | clean_win <- function(.x){ 790 | substr(.x, 1, 1) <- toupper(substr(.x, 1 ,1)) 791 | .sel <- nchar(.x) == 2 792 | .x[.sel] <- paste0(.x[.sel], "/") 793 | .x 794 | } 795 | 796 | x[sel] <- clean_win(x[sel]) 797 | } 798 | 799 | x 800 | } 801 | 802 | 803 | 804 | # nocov end 805 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | backticks <- function (x){ 2 | paste0("`", x, "`") 3 | } 4 | 5 | 6 | 7 | 8 | deparse_trunc <- function(x, width = getOption("width")){ 9 | text <- deparse(x, width.cutoff = width) 10 | if (length(text) == 1 && nchar(text) < width) 11 | return(text) 12 | paste0(substr(text[1], 1, width - 3), "...") 13 | } 14 | 15 | 16 | 17 | 18 | f_lhs <- function(x) x[[2]] 19 | 20 | 21 | 22 | 23 | f_rhs <- function(x) x[[3]] 24 | 25 | 26 | 27 | 28 | bad_calls <- function(calls, ...){ 29 | stop(fmt_calls(calls), " ", ...) 30 | } 31 | 32 | 33 | 34 | 35 | fmt_calls <- function(...){ 36 | paste(backticks(vapply(..., deparse, "")), collapse = ", ") 37 | } 38 | 39 | 40 | 41 | 42 | replace_with <- function ( 43 | x, 44 | i, 45 | val, 46 | name, 47 | reason = NULL 48 | ){ 49 | if (is.null(val)) { 50 | return(x) 51 | } 52 | 53 | assert_length_1_or_n(val, length(x), name, reason) 54 | assert_equal_type(val, x, name) 55 | assert_equal_class(val, x, name) 56 | 57 | i[is.na(i)] <- FALSE 58 | if (length(val) == 1L) { 59 | x[i] <- val 60 | } else { 61 | x[i] <- val[i] 62 | } 63 | x 64 | } 65 | 66 | 67 | 68 | 69 | assert_equal_type <- function( 70 | x, 71 | template, 72 | header 73 | ){ 74 | if (identical(typeof(x), typeof(template))) 75 | return(TRUE) 76 | 77 | if (is.null(header)) 78 | header <- "" 79 | else 80 | header <- paste0(header, " ") 81 | 82 | stop(sprintf("%smust be type %s, not %s", header, typeof(template), typeof(x))) 83 | } 84 | 85 | 86 | 87 | 88 | assert_equal_class <- function( 89 | x, 90 | template, 91 | header 92 | ){ 93 | if (!is.object(x)) { 94 | return(TRUE) 95 | 96 | } else if (identical(class(x), class(template))) { 97 | return(TRUE) 98 | 99 | } else { 100 | 101 | if (is.null(header)) 102 | header <- "" 103 | else 104 | header <- paste0(header, " ") 105 | 106 | 107 | stop( 108 | sprintf( 109 | "%smust be %s, not %s", 110 | header, 111 | paste(class(template), collapse = "/"), 112 | paste(class(x), collapse = "/") 113 | ) 114 | ) 115 | } 116 | } 117 | 118 | 119 | 120 | 121 | check_length_1_or_n <- function( 122 | x, 123 | n, 124 | header, 125 | reason 126 | ){ 127 | if (length(x) %in% c(1, n)){ 128 | return(NULL) 129 | } 130 | 131 | 132 | if (is.null(reason)) 133 | reason <- "" 134 | else 135 | reason <- paste0(" (", reason, ")") 136 | 137 | if (is.null(header)) 138 | header <- "" 139 | else 140 | header <- paste0(header, " ") 141 | 142 | 143 | inconsistent_lengths_message(length(x), n, header = header, reason = reason) 144 | } 145 | 146 | 147 | 148 | 149 | assert_length_1_or_n <- function( 150 | x, 151 | n, 152 | header, 153 | reason 154 | ){ 155 | chk <- check_length_1_or_n(x, n, header, reason) 156 | 157 | if (is.null(chk)){ 158 | TRUE 159 | } else { 160 | stop(chk) 161 | } 162 | } 163 | 164 | 165 | 166 | 167 | # messages ---------------------------------------------------------------- 168 | 169 | inconsistent_lengths_message <- function( 170 | length_is, 171 | length_should, 172 | header = "", 173 | reason = "" 174 | ){ 175 | if (length_should == 1) { 176 | sprintf("%smust be length 1%s, not %s", header, reason, paste(length_is, collapse = ", ")) 177 | } else { 178 | sprintf("%smust be length %s%s or one, not %s", header, length_should, reason, paste(length_is, collapse = ", ")) 179 | } 180 | } 181 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **This package is obsolete as dplyr has saner dependencies now, and data.table also implemented a similar function** 2 | 3 | # lest 4 | 5 | 6 | [![CRAN status](https://www.r-pkg.org/badges/version/lest)](https://cran.r-project.org/package=lest) 7 | [![lifecycle](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://www.tidyverse.org/lifecycle/#stable) 8 | [![Travis build status](https://travis-ci.org/s-fleck/lest.svg?branch=master)](https://travis-ci.org/s-fleck/lest) 9 | 10 | 11 | Lest provides two functions for vectorised conditional recoding of variables. 12 | `case_when()` enables you to vectorise multiple `if` and `else` statements (like 13 | `CASE WHEN` in SQL). `if_else()` is a stricter and more predictable version of 14 | `base::ifelse()` that preserves attributes (and therefore works with Dates). The 15 | functions in lest are forks of the 16 | [dplyr](https://CRAN.R-project.org/package=dplyr) functions of 17 | the same name. For more infos please refer to the [documentation](https://s-fleck.github.io/lest/). 18 | 19 | 20 | Why use lest? 21 | ---------------------------------- 22 | 23 | Use this package if you like the semantics of `dplyr::case_when()`, but do not 24 | want to use dplyr because of the dependencies it comes with. 25 | **If you already use dplyr in your project, you gain no advantage from lest**. 26 | `lest::case_when()` and `lest::if_else()` behave exactly identical to 27 | the dplyr equivalents, just that they do not support tidyeval syntax 28 | (like `!!!`). 29 | 30 | 31 | Dependencies 32 | ---------------------------------- 33 | 34 | **lest** depends only on base R, and will never add any external dependencies. 35 | 36 | 37 | Installation 38 | ------------ 39 | 40 | You can install lest from GitHub with: 41 | 42 | ``` r 43 | # install.packages("devtools") 44 | devtools::install_github("s-fleck/lest") 45 | ``` 46 | 47 | 48 | Example 49 | ------- 50 | 51 | ``` r 52 | x <- 1:50 53 | 54 | case_when( 55 | x %% 35 == 0 ~ "fizz buzz", 56 | x %% 5 == 0 ~ "fizz", 57 | x %% 7 == 0 ~ "buzz", 58 | TRUE ~ as.character(x) 59 | ) 60 | 61 | case_when( 62 | x %% 35 == 0 ~ 35, 63 | x %% 5 == 0 ~ 5, 64 | x %% 7 == 0 ~ 7, 65 | TRUE ~ NA 66 | ) 67 | 68 | ``` 69 | -------------------------------------------------------------------------------- /benchmark/bench_cumall.R: -------------------------------------------------------------------------------- 1 | library(bench) 2 | library(ggplot2) 3 | library(ggbeeswarm) 4 | 5 | x <- rep(TRUE, 1e8) 6 | y <- c(rep(TRUE, 1e3), FALSE, rep(TRUE, 1e4)) 7 | z <- c(rep(TRUE, 1e3), NA, rep(TRUE, 1e4)) 8 | 9 | resx <- mark( 10 | dplyr::cumall(x), 11 | lest::cumall(x), 12 | min_iterations = 100 13 | ) 14 | autoplot(resx) 15 | 16 | 17 | resy <- microbenchmark( 18 | dplyr::cumall(y), 19 | lest::cumall(y) 20 | ) 21 | autoplot(resy) 22 | 23 | 24 | resz <- microbenchmark( 25 | dplyr::cumall(z), 26 | lest::cumall(z) 27 | ) 28 | autoplot(resz) 29 | -------------------------------------------------------------------------------- /docs/404.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Page not found (404) • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
58 |
59 | 96 | 97 | 98 | 99 |
100 | 101 |
102 |
103 |
104 |

Page not found (404)

105 |
106 | 107 | Content not found. Please use links in the navbar. 108 | 109 |
110 | 111 |
112 | 113 | 114 | 115 |
116 |
117 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

118 |
119 | 120 |
121 |

Site built with pkgdown 1.4.1.9000.

122 |
123 | 124 |
125 |
126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | -------------------------------------------------------------------------------- /docs/LICENSE-text.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | License • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
58 |
59 | 96 | 97 | 98 | 99 |
100 | 101 |
102 |
103 |
104 |

License

105 |
106 | 107 | 
YEAR: 2018
108 | COPYRIGHT HOLDER: Stefan Fleck
109 | YEAR: 2013-2015
110 | COPYRIGHT HOLDER: RStudio
111 |
112 | 113 |
114 | 115 |
116 | 117 | 118 | 119 |
120 |
121 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

122 |
123 | 124 |
125 |

Site built with pkgdown 1.4.1.9000.

126 |
127 | 128 |
129 |
130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | -------------------------------------------------------------------------------- /docs/LICENSE.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | The MIT License (MIT) • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
58 |
59 | 96 | 97 | 98 | 99 |
100 | 101 |
102 |
103 |
104 |

The MIT License (MIT)

105 |
106 | 107 |
108 | 109 |

Copyright © 2018 Stefan Fleck. Copyright © 2013-2015 RStudio and others.

110 |

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

111 |

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

112 |

THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

113 |
114 | 115 |
116 | 117 |
118 | 119 | 120 | 121 |
122 |
123 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

124 |
125 | 126 |
127 |

Site built with pkgdown 1.4.1.9000.

128 |
129 | 130 |
131 |
132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | -------------------------------------------------------------------------------- /docs/authors.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Authors • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
58 |
59 | 96 | 97 | 98 | 99 |
100 | 101 |
102 |
103 |
104 |

Authors

105 |
106 | 107 |
    108 |
  • 109 |

    Stefan Fleck. Author, maintainer. 110 |

    111 |
    • 112 |
  • 113 |

    Hadley Wickham. Author. 114 |

    115 |
    • 116 |
  • 117 |

    Romain François. Author. 118 |

    119 |
    • 120 |
  • 121 |

    Lionel Henry. Author. 122 |

    123 |
    • 124 |
  • 125 |

    Kirill Müller. Author. 126 |

    127 |
    • 128 |
129 | 130 |
131 | 132 |
133 | 134 | 135 | 136 |
137 |
138 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

139 |
140 | 141 |
142 |

Site built with pkgdown 1.4.1.9000.

143 |
144 | 145 |
146 |
147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | -------------------------------------------------------------------------------- /docs/docsearch.css: -------------------------------------------------------------------------------- 1 | /* Docsearch -------------------------------------------------------------- */ 2 | /* 3 | Source: https://github.com/algolia/docsearch/ 4 | License: MIT 5 | */ 6 | 7 | .algolia-autocomplete { 8 | display: block; 9 | -webkit-box-flex: 1; 10 | -ms-flex: 1; 11 | flex: 1 12 | } 13 | 14 | .algolia-autocomplete .ds-dropdown-menu { 15 | width: 100%; 16 | min-width: none; 17 | max-width: none; 18 | padding: .75rem 0; 19 | background-color: #fff; 20 | background-clip: padding-box; 21 | border: 1px solid rgba(0, 0, 0, .1); 22 | box-shadow: 0 .5rem 1rem rgba(0, 0, 0, .175); 23 | } 24 | 25 | @media (min-width:768px) { 26 | .algolia-autocomplete .ds-dropdown-menu { 27 | width: 175% 28 | } 29 | } 30 | 31 | .algolia-autocomplete .ds-dropdown-menu::before { 32 | display: none 33 | } 34 | 35 | .algolia-autocomplete .ds-dropdown-menu [class^=ds-dataset-] { 36 | padding: 0; 37 | background-color: rgb(255,255,255); 38 | border: 0; 39 | max-height: 80vh; 40 | } 41 | 42 | .algolia-autocomplete .ds-dropdown-menu .ds-suggestions { 43 | margin-top: 0 44 | } 45 | 46 | .algolia-autocomplete .algolia-docsearch-suggestion { 47 | padding: 0; 48 | overflow: visible 49 | } 50 | 51 | .algolia-autocomplete .algolia-docsearch-suggestion--category-header { 52 | padding: .125rem 1rem; 53 | margin-top: 0; 54 | font-size: 1.3em; 55 | font-weight: 500; 56 | color: #00008B; 57 | border-bottom: 0 58 | } 59 | 60 | .algolia-autocomplete .algolia-docsearch-suggestion--wrapper { 61 | float: none; 62 | padding-top: 0 63 | } 64 | 65 | .algolia-autocomplete .algolia-docsearch-suggestion--subcategory-column { 66 | float: none; 67 | width: auto; 68 | padding: 0; 69 | text-align: left 70 | } 71 | 72 | .algolia-autocomplete .algolia-docsearch-suggestion--content { 73 | float: none; 74 | width: auto; 75 | padding: 0 76 | } 77 | 78 | .algolia-autocomplete .algolia-docsearch-suggestion--content::before { 79 | display: none 80 | } 81 | 82 | .algolia-autocomplete .ds-suggestion:not(:first-child) .algolia-docsearch-suggestion--category-header { 83 | padding-top: .75rem; 84 | margin-top: .75rem; 85 | border-top: 1px solid rgba(0, 0, 0, .1) 86 | } 87 | 88 | .algolia-autocomplete .ds-suggestion .algolia-docsearch-suggestion--subcategory-column { 89 | display: block; 90 | padding: .1rem 1rem; 91 | margin-bottom: 0.1; 92 | font-size: 1.0em; 93 | font-weight: 400 94 | /* display: none */ 95 | } 96 | 97 | .algolia-autocomplete .algolia-docsearch-suggestion--title { 98 | display: block; 99 | padding: .25rem 1rem; 100 | margin-bottom: 0; 101 | font-size: 0.9em; 102 | font-weight: 400 103 | } 104 | 105 | .algolia-autocomplete .algolia-docsearch-suggestion--text { 106 | padding: 0 1rem .5rem; 107 | margin-top: -.25rem; 108 | font-size: 0.8em; 109 | font-weight: 400; 110 | line-height: 1.25 111 | } 112 | 113 | .algolia-autocomplete .algolia-docsearch-footer { 114 | width: 110px; 115 | height: 20px; 116 | z-index: 3; 117 | margin-top: 10.66667px; 118 | float: right; 119 | font-size: 0; 120 | line-height: 0; 121 | } 122 | 123 | .algolia-autocomplete .algolia-docsearch-footer--logo { 124 | background-image: url("data:image/svg+xml;utf8,"); 125 | background-repeat: no-repeat; 126 | background-position: 50%; 127 | background-size: 100%; 128 | overflow: hidden; 129 | text-indent: -9000px; 130 | width: 100%; 131 | height: 100%; 132 | display: block; 133 | transform: translate(-8px); 134 | } 135 | 136 | .algolia-autocomplete .algolia-docsearch-suggestion--highlight { 137 | color: #FF8C00; 138 | background: rgba(232, 189, 54, 0.1) 139 | } 140 | 141 | 142 | .algolia-autocomplete .algolia-docsearch-suggestion--text .algolia-docsearch-suggestion--highlight { 143 | box-shadow: inset 0 -2px 0 0 rgba(105, 105, 105, .5) 144 | } 145 | 146 | .algolia-autocomplete .ds-suggestion.ds-cursor .algolia-docsearch-suggestion--content { 147 | background-color: rgba(192, 192, 192, .15) 148 | } 149 | -------------------------------------------------------------------------------- /docs/docsearch.js: -------------------------------------------------------------------------------- 1 | $(function() { 2 | 3 | // register a handler to move the focus to the search bar 4 | // upon pressing shift + "/" (i.e. "?") 5 | $(document).on('keydown', function(e) { 6 | if (e.shiftKey && e.keyCode == 191) { 7 | e.preventDefault(); 8 | $("#search-input").focus(); 9 | } 10 | }); 11 | 12 | $(document).ready(function() { 13 | // do keyword highlighting 14 | /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ 15 | var mark = function() { 16 | 17 | var referrer = document.URL ; 18 | var paramKey = "q" ; 19 | 20 | if (referrer.indexOf("?") !== -1) { 21 | var qs = referrer.substr(referrer.indexOf('?') + 1); 22 | var qs_noanchor = qs.split('#')[0]; 23 | var qsa = qs_noanchor.split('&'); 24 | var keyword = ""; 25 | 26 | for (var i = 0; i < qsa.length; i++) { 27 | var currentParam = qsa[i].split('='); 28 | 29 | if (currentParam.length !== 2) { 30 | continue; 31 | } 32 | 33 | if (currentParam[0] == paramKey) { 34 | keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); 35 | } 36 | } 37 | 38 | if (keyword !== "") { 39 | $(".contents").unmark({ 40 | done: function() { 41 | $(".contents").mark(keyword); 42 | } 43 | }); 44 | } 45 | } 46 | }; 47 | 48 | mark(); 49 | }); 50 | }); 51 | 52 | /* Search term highlighting ------------------------------*/ 53 | 54 | function matchedWords(hit) { 55 | var words = []; 56 | 57 | var hierarchy = hit._highlightResult.hierarchy; 58 | // loop to fetch from lvl0, lvl1, etc. 59 | for (var idx in hierarchy) { 60 | words = words.concat(hierarchy[idx].matchedWords); 61 | } 62 | 63 | var content = hit._highlightResult.content; 64 | if (content) { 65 | words = words.concat(content.matchedWords); 66 | } 67 | 68 | // return unique words 69 | var words_uniq = [...new Set(words)]; 70 | return words_uniq; 71 | } 72 | 73 | function updateHitURL(hit) { 74 | 75 | var words = matchedWords(hit); 76 | var url = ""; 77 | 78 | if (hit.anchor) { 79 | url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; 80 | } else { 81 | url = hit.url + '?q=' + escape(words.join(" ")); 82 | } 83 | 84 | return url; 85 | } 86 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | Vectorised Nested if-else Statements Similar to CASE WHEN 9 | in SQL • lest 10 | 11 | 12 | 13 | 14 | 16 | 22 | 23 | 27 | 28 | 29 |
30 |
66 | 67 | 68 | 69 | 70 |
71 |
72 |
73 |

74 | lest

75 | 76 | 77 |

Lest provides two functions for vectorised conditional recoding of variables. case_when() enables you to vectorise multiple if and else statements (like CASE WHEN in SQL). if_else() is a stricter and more predictable version of base::ifelse() that preserves attributes (and therefore works with Dates). The functions in lest are forks of the dplyr functions of the same name.

78 |
79 |

80 | Why use lest?

81 |

Use this package if you like the semantics of dplyr::case_when(), but do not want to use dplyr because of the dependencies it comes with. If you already use dplyr in your project, you gain no advantage from lest. lest::case_when() and lest::if_else() behave exactly identical to the dplyr equivalents, just that they do not support tidyeval syntax (like !!!).

82 |
83 |
84 |

85 | Dependencies

86 |

lest depends only on base R, and will never add any external dependencies.

87 |
88 |
89 |

90 | Installation

91 |

You can install lest from GitHub with:

92 | 94 |
95 |
96 |

97 | Example

98 | 113 |
114 |
115 |
116 | 117 | 145 |
146 | 147 | 148 |
149 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

150 |
151 | 152 |
153 |

Site built with pkgdown 1.4.1.9000.

154 |
155 | 156 |
157 |
158 | 159 | 160 | 161 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /docs/link.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 8 | 12 | 13 | -------------------------------------------------------------------------------- /docs/news/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Changelog • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
58 |
59 | 96 | 97 | 98 | 99 |
100 | 101 |
102 |
103 |
104 |

Changelog

105 | 106 |
107 | 108 |
109 |

110 | lest 1.1.0 Unreleased 111 |

112 |
    113 |

  • Added exceeds_tumbling_sum() for checking when a partial cumulative sum (“tumbling sum”") hits a certain threshold value. This is for example useful for filtering geographic positions by a minimum distance. Thanks to @klmr for helping me come up with a name.

    • 114 |

  • Added plain C clones of dplyr::cumall() and dplyr::cumany()

    • 115 |
116 |
117 |
118 |

119 | lest 1.0.0 2018-08-16 120 |

121 |
    122 |
  • First public release
    • 123 |
124 |
125 |
126 | 127 | 136 | 137 |
138 | 139 | 140 |
141 |
142 |

Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

143 |
144 | 145 |
146 |

Site built with pkgdown 1.4.1.9000.

147 |
148 | 149 |
150 |
151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | -------------------------------------------------------------------------------- /docs/pkgdown.css: -------------------------------------------------------------------------------- 1 | /* Sticky footer */ 2 | 3 | /** 4 | * Basic idea: https://philipwalton.github.io/solved-by-flexbox/demos/sticky-footer/ 5 | * Details: https://github.com/philipwalton/solved-by-flexbox/blob/master/assets/css/components/site.css 6 | * 7 | * .Site -> body > .container 8 | * .Site-content -> body > .container .row 9 | * .footer -> footer 10 | * 11 | * Key idea seems to be to ensure that .container and __all its parents__ 12 | * have height set to 100% 13 | * 14 | */ 15 | 16 | html, body { 17 | height: 100%; 18 | } 19 | 20 | body > .container { 21 | display: flex; 22 | height: 100%; 23 | flex-direction: column; 24 | } 25 | 26 | body > .container .row { 27 | flex: 1 0 auto; 28 | } 29 | 30 | footer { 31 | margin-top: 45px; 32 | padding: 35px 0 36px; 33 | border-top: 1px solid #e5e5e5; 34 | color: #666; 35 | display: flex; 36 | flex-shrink: 0; 37 | } 38 | footer p { 39 | margin-bottom: 0; 40 | } 41 | footer div { 42 | flex: 1; 43 | } 44 | footer .pkgdown { 45 | text-align: right; 46 | } 47 | footer p { 48 | margin-bottom: 0; 49 | } 50 | 51 | img.icon { 52 | float: right; 53 | } 54 | 55 | img { 56 | max-width: 100%; 57 | } 58 | 59 | /* Fix bug in bootstrap (only seen in firefox) */ 60 | summary { 61 | display: list-item; 62 | } 63 | 64 | /* Typographic tweaking ---------------------------------*/ 65 | 66 | .contents .page-header { 67 | margin-top: calc(-60px + 1em); 68 | } 69 | 70 | /* Section anchors ---------------------------------*/ 71 | 72 | a.anchor { 73 | margin-left: -30px; 74 | display:inline-block; 75 | width: 30px; 76 | height: 30px; 77 | visibility: hidden; 78 | 79 | background-image: url(./link.svg); 80 | background-repeat: no-repeat; 81 | background-size: 20px 20px; 82 | background-position: center center; 83 | } 84 | 85 | .hasAnchor:hover a.anchor { 86 | visibility: visible; 87 | } 88 | 89 | @media (max-width: 767px) { 90 | .hasAnchor:hover a.anchor { 91 | visibility: hidden; 92 | } 93 | } 94 | 95 | 96 | /* Fixes for fixed navbar --------------------------*/ 97 | 98 | .contents h1, .contents h2, .contents h3, .contents h4 { 99 | padding-top: 60px; 100 | margin-top: -40px; 101 | } 102 | 103 | /* Sidebar --------------------------*/ 104 | 105 | #pkgdown-sidebar { 106 | margin-top: 30px; 107 | position: -webkit-sticky; 108 | position: sticky; 109 | top: 70px; 110 | } 111 | 112 | #pkgdown-sidebar h2 { 113 | font-size: 1.5em; 114 | margin-top: 1em; 115 | } 116 | 117 | #pkgdown-sidebar h2:first-child { 118 | margin-top: 0; 119 | } 120 | 121 | #pkgdown-sidebar .list-unstyled li { 122 | margin-bottom: 0.5em; 123 | } 124 | 125 | .orcid { 126 | font-size: 16px; 127 | color: #A6CE39; 128 | /* margins are required by official ORCID trademark and display guidelines */ 129 | margin-left:4px; 130 | margin-right:4px; 131 | vertical-align: middle; 132 | } 133 | 134 | /* Reference index & topics ----------------------------------------------- */ 135 | 136 | .ref-index th {font-weight: normal;} 137 | 138 | .ref-index td {vertical-align: top;} 139 | .ref-index .icon {width: 40px;} 140 | .ref-index .alias {width: 40%;} 141 | .ref-index-icons .alias {width: calc(40% - 40px);} 142 | .ref-index .title {width: 60%;} 143 | 144 | .ref-arguments th {text-align: right; padding-right: 10px;} 145 | .ref-arguments th, .ref-arguments td {vertical-align: top;} 146 | .ref-arguments .name {width: 20%;} 147 | .ref-arguments .desc {width: 80%;} 148 | 149 | /* Nice scrolling for wide elements --------------------------------------- */ 150 | 151 | table { 152 | display: block; 153 | overflow: auto; 154 | } 155 | 156 | /* Syntax highlighting ---------------------------------------------------- */ 157 | 158 | pre { 159 | word-wrap: normal; 160 | word-break: normal; 161 | border: 1px solid #eee; 162 | } 163 | 164 | pre, code { 165 | background-color: #f8f8f8; 166 | color: #333; 167 | } 168 | 169 | pre code { 170 | overflow: auto; 171 | word-wrap: normal; 172 | white-space: pre; 173 | } 174 | 175 | pre .img { 176 | margin: 5px 0; 177 | } 178 | 179 | pre .img img { 180 | background-color: #fff; 181 | display: block; 182 | height: auto; 183 | } 184 | 185 | code a, pre a { 186 | color: #375f84; 187 | } 188 | 189 | a.sourceLine:hover { 190 | text-decoration: none; 191 | } 192 | 193 | .fl {color: #1514b5;} 194 | .fu {color: #000000;} /* function */ 195 | .ch,.st {color: #036a07;} /* string */ 196 | .kw {color: #264D66;} /* keyword */ 197 | .co {color: #888888;} /* comment */ 198 | 199 | .message { color: black; font-weight: bolder;} 200 | .error { color: orange; font-weight: bolder;} 201 | .warning { color: #6A0366; font-weight: bolder;} 202 | 203 | /* Clipboard --------------------------*/ 204 | 205 | .hasCopyButton { 206 | position: relative; 207 | } 208 | 209 | .btn-copy-ex { 210 | position: absolute; 211 | right: 0; 212 | top: 0; 213 | visibility: hidden; 214 | } 215 | 216 | .hasCopyButton:hover button.btn-copy-ex { 217 | visibility: visible; 218 | } 219 | 220 | /* headroom.js ------------------------ */ 221 | 222 | .headroom { 223 | will-change: transform; 224 | transition: transform 200ms linear; 225 | } 226 | .headroom--pinned { 227 | transform: translateY(0%); 228 | } 229 | .headroom--unpinned { 230 | transform: translateY(-100%); 231 | } 232 | 233 | /* mark.js ----------------------------*/ 234 | 235 | mark { 236 | background-color: rgba(255, 255, 51, 0.5); 237 | border-bottom: 2px solid rgba(255, 153, 51, 0.3); 238 | padding: 1px; 239 | } 240 | 241 | /* vertical spacing after htmlwidgets */ 242 | .html-widget { 243 | margin-bottom: 10px; 244 | } 245 | 246 | /* fontawesome ------------------------ */ 247 | 248 | .fab { 249 | font-family: "Font Awesome 5 Brands" !important; 250 | } 251 | 252 | /* don't display links in code chunks when printing */ 253 | /* source: https://stackoverflow.com/a/10781533 */ 254 | @media print { 255 | code a:link:after, code a:visited:after { 256 | content: ""; 257 | } 258 | } 259 | -------------------------------------------------------------------------------- /docs/pkgdown.js: -------------------------------------------------------------------------------- 1 | /* http://gregfranko.com/blog/jquery-best-practices/ */ 2 | (function($) { 3 | $(function() { 4 | 5 | $('.navbar-fixed-top').headroom(); 6 | 7 | $('body').css('padding-top', $('.navbar').height() + 10); 8 | $(window).resize(function(){ 9 | $('body').css('padding-top', $('.navbar').height() + 10); 10 | }); 11 | 12 | $('body').scrollspy({ 13 | target: '#sidebar', 14 | offset: 60 15 | }); 16 | 17 | $('[data-toggle="tooltip"]').tooltip(); 18 | 19 | var cur_path = paths(location.pathname); 20 | var links = $("#navbar ul li a"); 21 | var max_length = -1; 22 | var pos = -1; 23 | for (var i = 0; i < links.length; i++) { 24 | if (links[i].getAttribute("href") === "#") 25 | continue; 26 | // Ignore external links 27 | if (links[i].host !== location.host) 28 | continue; 29 | 30 | var nav_path = paths(links[i].pathname); 31 | 32 | var length = prefix_length(nav_path, cur_path); 33 | if (length > max_length) { 34 | max_length = length; 35 | pos = i; 36 | } 37 | } 38 | 39 | // Add class to parent
  • , and enclosing
  • if in dropdown 40 | if (pos >= 0) { 41 | var menu_anchor = $(links[pos]); 42 | menu_anchor.parent().addClass("active"); 43 | menu_anchor.closest("li.dropdown").addClass("active"); 44 | } 45 | }); 46 | 47 | function paths(pathname) { 48 | var pieces = pathname.split("/"); 49 | pieces.shift(); // always starts with / 50 | 51 | var end = pieces[pieces.length - 1]; 52 | if (end === "index.html" || end === "") 53 | pieces.pop(); 54 | return(pieces); 55 | } 56 | 57 | // Returns -1 if not found 58 | function prefix_length(needle, haystack) { 59 | if (needle.length > haystack.length) 60 | return(-1); 61 | 62 | // Special case for length-0 haystack, since for loop won't run 63 | if (haystack.length === 0) { 64 | return(needle.length === 0 ? 0 : -1); 65 | } 66 | 67 | for (var i = 0; i < haystack.length; i++) { 68 | if (needle[i] != haystack[i]) 69 | return(i); 70 | } 71 | 72 | return(haystack.length); 73 | } 74 | 75 | /* Clipboard --------------------------*/ 76 | 77 | function changeTooltipMessage(element, msg) { 78 | var tooltipOriginalTitle=element.getAttribute('data-original-title'); 79 | element.setAttribute('data-original-title', msg); 80 | $(element).tooltip('show'); 81 | element.setAttribute('data-original-title', tooltipOriginalTitle); 82 | } 83 | 84 | if(ClipboardJS.isSupported()) { 85 | $(document).ready(function() { 86 | var copyButton = ""; 87 | 88 | $(".examples, div.sourceCode").addClass("hasCopyButton"); 89 | 90 | // Insert copy buttons: 91 | $(copyButton).prependTo(".hasCopyButton"); 92 | 93 | // Initialize tooltips: 94 | $('.btn-copy-ex').tooltip({container: 'body'}); 95 | 96 | // Initialize clipboard: 97 | var clipboardBtnCopies = new ClipboardJS('[data-clipboard-copy]', { 98 | text: function(trigger) { 99 | return trigger.parentNode.textContent; 100 | } 101 | }); 102 | 103 | clipboardBtnCopies.on('success', function(e) { 104 | changeTooltipMessage(e.trigger, 'Copied!'); 105 | e.clearSelection(); 106 | }); 107 | 108 | clipboardBtnCopies.on('error', function() { 109 | changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); 110 | }); 111 | }); 112 | } 113 | })(window.jQuery || window.$) 114 | -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: 2.3.1 2 | pkgdown: 1.4.1.9000 3 | pkgdown_sha: af379b9bae1d14189ca260a69115ab3e66a6c5c5 4 | articles: [] 5 | 6 | -------------------------------------------------------------------------------- /docs/reference/case_when.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | A general vectorised if — case_when • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 54 | 55 | 56 | 57 | 58 | 59 | 60 |
    61 |
    62 | 99 | 100 | 101 | 102 |
    103 | 104 |
    105 |
    106 |
    107 |

    A general vectorised if

    108 | 109 | 110 |
    111 | 112 |
    113 |

    This function allows you to vectorise multiple if and else if 114 | statements. It is an R equivalent of the SQL CASE WHEN statement.

    115 |
    116 | 117 | 
    case_when(...)
    118 | 119 |

    Arguments

    120 | 121 | 122 | 123 | 124 | 132 | 133 |
    ...

    A sequence of two-sided formulas. The left hand side (LHS) 125 | determines which values match this case. The right hand side (RHS) 126 | provides the replacement value.

    127 |

    The LHS must evaluate to a logical vector. The RHS does not need to be 128 | logical, but all RHSs must evaluate to the same type of vector.

    129 |

    Both LHS and RHS may have the same length of either 1 or n. The 130 | value of n must be consistent across all cases. The case of 131 | n == 0 is treated as a variant of n != 1.

    134 | 135 |

    Value

    136 | 137 |

    A vector of length 1 or n, matching the length of the logical 138 | input or output vectors, with the type (and attributes) of the first 139 | RHS. Inconsistent lengths or types will generate an error.

    140 | 141 |

    Examples

    142 | 
    x <- 1:50
143 | case_when(
144 |   x %% 35 == 0 ~ "fizz buzz",
145 |   x %% 5 == 0 ~ "fizz",
146 |   x %% 7 == 0 ~ "buzz",
147 |   TRUE ~ as.character(x)
148 | )
    #>  [1] "1"         "2"         "3"         "4"         "fizz"      "6"        
149 | #>  [7] "buzz"      "8"         "9"         "fizz"      "11"        "12"       
150 | #> [13] "13"        "buzz"      "fizz"      "16"        "17"        "18"       
151 | #> [19] "19"        "fizz"      "buzz"      "22"        "23"        "24"       
152 | #> [25] "fizz"      "26"        "27"        "buzz"      "29"        "fizz"     
153 | #> [31] "31"        "32"        "33"        "34"        "fizz buzz" "36"       
154 | #> [37] "37"        "38"        "39"        "fizz"      "41"        "buzz"     
155 | #> [43] "43"        "44"        "fizz"      "46"        "47"        "48"       
156 | #> [49] "buzz"      "fizz"     
    
157 | # Like an if statement, the arguments are evaluated in order, so you must
158 | # proceed from the most specific to the most general. This won't work:
159 | case_when(
160 |   TRUE ~ as.character(x),
161 |   x %%  5 == 0 ~ "fizz",
162 |   x %%  7 == 0 ~ "buzz",
163 |   x %% 35 == 0 ~ "fizz buzz"
164 | )
    #>  [1] "1"  "2"  "3"  "4"  "5"  "6"  "7"  "8"  "9"  "10" "11" "12" "13" "14" "15"
165 | #> [16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30"
166 | #> [31] "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43" "44" "45"
167 | #> [46] "46" "47" "48" "49" "50"
    
168 | # All RHS values need to be of the same type. Inconsistent types will throw an error.
169 | # This applies also to NA values used in RHS: NA is logical, use
170 | # typed values like NA_real_, NA_complex, NA_character_, NA_integer_ as appropriate.
171 | case_when(
172 |   x %% 35 == 0 ~ NA_character_,
173 |   x %% 5 == 0 ~ "fizz",
174 |   x %% 7 == 0 ~ "buzz",
175 |   TRUE ~ as.character(x)
176 | )
    #>  [1] "1"    "2"    "3"    "4"    "fizz" "6"    "buzz" "8"    "9"    "fizz"
177 | #> [11] "11"   "12"   "13"   "buzz" "fizz" "16"   "17"   "18"   "19"   "fizz"
178 | #> [21] "buzz" "22"   "23"   "24"   "fizz" "26"   "27"   "buzz" "29"   "fizz"
179 | #> [31] "31"   "32"   "33"   "34"   NA     "36"   "37"   "38"   "39"   "fizz"
180 | #> [41] "41"   "buzz" "43"   "44"   "fizz" "46"   "47"   "48"   "buzz" "fizz"
    case_when(
181 |   x %% 35 == 0 ~ 35,
182 |   x %% 5 == 0 ~ 5,
183 |   x %% 7 == 0 ~ 7,
184 |   TRUE ~ NA_real_
185 | )
    #>  [1] NA NA NA NA  5 NA  7 NA NA  5 NA NA NA  7  5 NA NA NA NA  5  7 NA NA NA  5
186 | #> [26] NA NA  7 NA  5 NA NA NA NA 35 NA NA NA NA  5 NA  7 NA NA  5 NA NA NA  7  5
    # This throws an error as NA is logical not numeric
187 | try({
188 | case_when(
189 |   x %% 35 == 0 ~ 35,
190 |   x %% 5 == 0 ~ 5,
191 |   x %% 7 == 0 ~ 7,
192 |   TRUE ~ NA
193 | )
194 | })
    #> Error in assert_equal_type(val, x, name) : 
195 | #>   must be type double, not logical
    dat <- iris[1:5, ]
196 | dat$size <- case_when(
197 |   dat$Sepal.Length < 5.0 ~ "small",
198 |   TRUE ~ "big"
199 | )
200 | dat
    #>   Sepal.Length Sepal.Width Petal.Length Petal.Width Species  size
201 | #> 1          5.1         3.5          1.4         0.2  setosa   big
202 | #> 2          4.9         3.0          1.4         0.2  setosa small
203 | #> 3          4.7         3.2          1.3         0.2  setosa small
204 | #> 4          4.6         3.1          1.5         0.2  setosa small
205 | #> 5          5.0         3.6          1.4         0.2  setosa   big
    206 |
    207 | 216 |
    217 | 218 | 219 |
    220 |
    221 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    222 |
    223 | 224 |
    225 |

    Site built with pkgdown 1.4.1.9000.

    226 |
    227 | 228 |
    229 |
    230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | -------------------------------------------------------------------------------- /docs/reference/cumall.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Cumulative all and any — cumall • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 53 | 54 | 55 | 56 | 57 | 58 | 59 |
    60 |
    61 | 98 | 99 | 100 | 101 |
    102 | 103 |
    104 |
    105 |
    106 |

    Cumulative all and any

    107 | 108 | 109 |
    110 | 111 |
    112 |

    Cumulative all and any

    113 |
    114 | 115 | 
    cumall(x)
116 | 
117 | cumany(x)
    118 | 119 |

    Arguments

    120 | 121 | 122 | 123 | 124 | 125 | 126 |
    x

    a logical vector.

    127 | 128 |

    Value

    129 | 130 |

    a logical vector

    131 | 132 |

    Examples

    133 | 
    cumall(c(TRUE, TRUE, NA, TRUE, FALSE))
    #> [1]  TRUE  TRUE    NA    NA FALSE
    cumany(c(FALSE, FALSE, NA, TRUE, FALSE))
    #> [1] FALSE FALSE    NA  TRUE  TRUE
    134 |
    135 | 144 |
    145 | 146 | 147 |
    148 |
    149 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    150 |
    151 | 152 |
    153 |

    Site built with pkgdown 1.4.1.9000.

    154 |
    155 | 156 |
    157 |
    158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | -------------------------------------------------------------------------------- /docs/reference/exceeds_tumbling_sum.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Check When the Tumbling Sum of a Vector Exceeds a Threshold — exceeds_tumbling_sum • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 56 | 57 | 58 | 59 | 60 | 61 | 62 |
    63 |
    64 | 101 | 102 | 103 | 104 |
    105 | 106 |
    107 |
    108 |
    109 |

    Check When the Tumbling Sum of a Vector Exceeds a Threshold

    110 | 111 | 112 |
    113 | 114 |
    115 |

    The tumbling sum is calculated as the partial cumulative sum of a vector 116 | until a threshold is exceeded. Once this happens, the tumbling sum is 117 | calculated from zero again. exceeds_tumbling_sum() returns TRUE whenever 118 | this threshold is hit/exceeded and FALSE otherwise.

    119 |
    120 | 121 | 
    exceeds_tumbling_sum(x, threshold, inclusive = TRUE)
    122 | 123 |

    Arguments

    124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 138 | 139 |
    x

    a numeric vector

    threshold

    a numeric scalar

    inclusive

    a logical scalar. If TRUE inclusive bounds are used 137 | (i.e. the threshold is checked with >=), otherwise exclusive

    140 | 141 |

    Value

    142 | 143 |

    a logical vector of the same length as x that is TRUE whenever 144 | threshold was exceeded and FALSE otherwise

    145 |

    Details

    146 | 147 |

    This is for example useful if you have high frequency GPS positions 148 | and want to keep only points that are at least x seconds apart.

    149 |

    See also

    150 | 151 |

    MESS::cumsumbinning() does something very similar, but returns 152 | group indices instead of a logical vector.

    153 | 154 |

    Examples

    155 | 
    exceeds_tumbling_sum(c(1, 3, 3, 3), 4)
    #> [1] FALSE  TRUE FALSE  TRUE
    156 |
    157 | 168 |
    169 | 170 | 171 |
    172 |
    173 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    174 |
    175 | 176 |
    177 |

    Site built with pkgdown 1.4.1.9000.

    178 |
    179 | 180 |
    181 |
    182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | -------------------------------------------------------------------------------- /docs/reference/if_else.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Vectorised if — if_else • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 56 | 57 | 58 | 59 | 60 | 61 | 62 |
    63 |
    64 | 101 | 102 | 103 | 104 |
    105 | 106 |
    107 |
    108 |
    109 |

    Vectorised if

    110 | 111 | 112 |
    113 | 114 |
    115 |

    Compared to the base ifelse(), this function is more strict. 116 | It checks that true and false are the same type. This 117 | strictness makes the output type more predictable, and makes it somewhat 118 | faster.

    119 |
    120 | 121 | 
    if_else(condition, true, false, missing = NULL)
    122 | 123 |

    Arguments

    124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 137 | 138 | 139 | 140 | 142 | 143 |
    condition

    Logical vector

    true, false

    Values to use for TRUE and FALSE values of 133 | condition. They must be either the same length as condition, 134 | or length 1. They must also be the same type: if_else() checks that 135 | they have the same type and same class. All other attributes are 136 | taken from true.

    missing

    If not NULL, will be used to replace missing 141 | values.

    144 | 145 |

    Value

    146 | 147 |

    Where condition is TRUE, the matching value from 148 | true, where it's FALSE, the matching value from false, 149 | otherwise NA.

    150 | 151 |

    Examples

    152 | 
    x <- c(-5:5, NA)
153 | if_else(x < 0, NA_integer_, x)
    #>  [1] NA NA NA NA NA  0  1  2  3  4  5 NA
    if_else(x < 0, "negative", "positive", "missing")
    #>  [1] "negative" "negative" "negative" "negative" "negative" "positive"
154 | #>  [7] "positive" "positive" "positive" "positive" "positive" "missing" 
    
155 | # Unlike ifelse, if_else preserves types
156 | x <- factor(sample(letters[1:5], 10, replace = TRUE))
157 | ifelse(x %in% c("a", "b", "c"), x, factor(NA))
    #>  [1] NA NA NA NA  1 NA NA NA  2  3
    if_else(x %in% c("a", "b", "c"), x, factor(NA))
    #>  [1] <NA> <NA> <NA> <NA> a    <NA> <NA> <NA> b    c   
158 | #> Levels: a b c d e
    # Attributes are taken from the `true` vector,
159 |
    160 |
    161 | 170 |
    171 | 172 | 173 |
    174 |
    175 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    176 |
    177 | 178 |
    179 |

    Site built with pkgdown 1.4.1.9000.

    180 |
    181 | 182 |
    183 |
    184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | -------------------------------------------------------------------------------- /docs/reference/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Function reference • lest 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |
    58 |
    59 | 96 | 97 | 98 | 99 |
    100 | 101 |
    102 |
    103 |
    104 |

    Reference

    105 |
    106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 121 | 122 | 123 | 124 | 127 | 128 | 129 | 130 | 133 | 134 | 135 | 136 | 139 | 140 | 141 | 142 | 145 | 146 | 147 | 148 |
    118 |

    All functions

    119 |

    120 |
    125 |

    case_when()

    126 |

    A general vectorised if

    131 |

    cumall() cumany()

    132 |

    Cumulative all and any

    137 |

    exceeds_tumbling_sum()

    138 |

    Check When the Tumbling Sum of a Vector Exceeds a Threshold

    143 |

    if_else()

    144 |

    Vectorised if

    149 |
    150 | 151 | 157 |
    158 | 159 | 160 |
    161 |
    162 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    163 |
    164 | 165 |
    166 |

    Site built with pkgdown 1.4.1.9000.

    167 |
    168 | 169 |
    170 |
    171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | -------------------------------------------------------------------------------- /docs/reference/lest-package.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | lest: Vectorised Nested if-else Statements Similar to CASE WHEN 10 | in 'SQL' — lest-package • lest 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 41 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 60 | 61 | 62 | 63 | 64 | 65 | 66 |
    67 |
    68 | 105 | 106 | 107 | 108 |
    109 | 110 |
    111 |
    112 |
    113 |

    lest: Vectorised Nested if-else Statements Similar to CASE WHEN 114 | in 'SQL'

    115 | 116 | 117 |
    118 | 119 |
    120 |

    Functions for vectorised conditional recoding of 121 | variables. case_when() enables you to vectorise multiple if and else 122 | statements (like 'CASE WHEN' in 'SQL'). if_else() is a stricter and 123 | more predictable version of ifelse() in 'base' that preserves 124 | attributes. These functions are forked from 'dplyr' with all package 125 | dependencies removed and behave identically to the originals.

    126 |
    127 | 128 | 129 | 130 | 131 |
    132 | 148 |
    149 | 150 | 151 |
    152 |
    153 |

    Developed by Stefan Fleck, Hadley Wickham, Romain François, Lionel Henry, Kirill Müller.

    154 |
    155 | 156 |
    157 |

    Site built with pkgdown 1.4.1.9000.

    158 |
    159 | 160 |
    161 |
    162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | -------------------------------------------------------------------------------- /inst/WORDLIST: -------------------------------------------------------------------------------- 1 | dplyr 2 | ifelse 3 | lifecycle 4 | ORCID 5 | recoding 6 | RHSs 7 | tidyeval 8 | vectorised 9 | vectorise 10 | -------------------------------------------------------------------------------- /lest.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | -------------------------------------------------------------------------------- /man/case_when.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/case_when.R 3 | \name{case_when} 4 | \alias{case_when} 5 | \title{A general vectorised if} 6 | \usage{ 7 | case_when(...) 8 | } 9 | \arguments{ 10 | \item{...}{A sequence of two-sided formulas. The left hand side (LHS) 11 | determines which values match this case. The right hand side (RHS) 12 | provides the replacement value. 13 | 14 | The LHS must evaluate to a logical vector. The RHS does not need to be 15 | logical, but all RHSs must evaluate to the same type of vector. 16 | 17 | Both LHS and RHS may have the same length of either 1 or \code{n}. The 18 | value of \code{n} must be consistent across all cases. The case of 19 | \code{n == 0} is treated as a variant of \code{n != 1}.} 20 | } 21 | \value{ 22 | A vector of length 1 or \code{n}, matching the length of the logical 23 | input or output vectors, with the type (and attributes) of the first 24 | RHS. Inconsistent lengths or types will generate an error. 25 | } 26 | \description{ 27 | This function allows you to vectorise multiple \code{if} and \verb{else if} 28 | statements. It is an R equivalent of the SQL \verb{CASE WHEN} statement. 29 | } 30 | \examples{ 31 | x <- 1:50 32 | case_when( 33 | x \%\% 35 == 0 ~ "fizz buzz", 34 | x \%\% 5 == 0 ~ "fizz", 35 | x \%\% 7 == 0 ~ "buzz", 36 | TRUE ~ as.character(x) 37 | ) 38 | 39 | # Like an if statement, the arguments are evaluated in order, so you must 40 | # proceed from the most specific to the most general. This won't work: 41 | case_when( 42 | TRUE ~ as.character(x), 43 | x \%\% 5 == 0 ~ "fizz", 44 | x \%\% 7 == 0 ~ "buzz", 45 | x \%\% 35 == 0 ~ "fizz buzz" 46 | ) 47 | 48 | # All RHS values need to be of the same type. Inconsistent types will throw an error. 49 | # This applies also to NA values used in RHS: NA is logical, use 50 | # typed values like NA_real_, NA_complex, NA_character_, NA_integer_ as appropriate. 51 | case_when( 52 | x \%\% 35 == 0 ~ NA_character_, 53 | x \%\% 5 == 0 ~ "fizz", 54 | x \%\% 7 == 0 ~ "buzz", 55 | TRUE ~ as.character(x) 56 | ) 57 | case_when( 58 | x \%\% 35 == 0 ~ 35, 59 | x \%\% 5 == 0 ~ 5, 60 | x \%\% 7 == 0 ~ 7, 61 | TRUE ~ NA_real_ 62 | ) 63 | # This throws an error as NA is logical not numeric 64 | try({ 65 | case_when( 66 | x \%\% 35 == 0 ~ 35, 67 | x \%\% 5 == 0 ~ 5, 68 | x \%\% 7 == 0 ~ 7, 69 | TRUE ~ NA 70 | ) 71 | }) 72 | dat <- iris[1:5, ] 73 | dat$size <- case_when( 74 | dat$Sepal.Length < 5.0 ~ "small", 75 | TRUE ~ "big" 76 | ) 77 | dat 78 | } 79 | -------------------------------------------------------------------------------- /man/cumall.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cumall.R 3 | \name{cumall} 4 | \alias{cumall} 5 | \alias{cumany} 6 | \title{Cumulative all and any} 7 | \usage{ 8 | cumall(x) 9 | 10 | cumany(x) 11 | } 12 | \arguments{ 13 | \item{x}{a \code{logical} vector.} 14 | } 15 | \value{ 16 | a \code{logical} vector 17 | } 18 | \description{ 19 | Cumulative all and any 20 | } 21 | \examples{ 22 | cumall(c(TRUE, TRUE, NA, TRUE, FALSE)) 23 | cumany(c(FALSE, FALSE, NA, TRUE, FALSE)) 24 | } 25 | -------------------------------------------------------------------------------- /man/exceeds_tumbling_sum.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/exceeds_tumbling_sum.R 3 | \name{exceeds_tumbling_sum} 4 | \alias{exceeds_tumbling_sum} 5 | \title{Check When the Tumbling Sum of a Vector Exceeds a Threshold} 6 | \usage{ 7 | exceeds_tumbling_sum(x, threshold, inclusive = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{numeric} vector} 11 | 12 | \item{threshold}{a \code{numeric} scalar} 13 | 14 | \item{inclusive}{a \code{logical} scalar. If \code{TRUE} inclusive bounds are used 15 | (i.e. the threshold is checked with \code{>=}), otherwise exclusive} 16 | } 17 | \value{ 18 | a \code{logical} vector of the same length as \code{x} that is \code{TRUE} whenever 19 | \code{threshold} was exceeded and \code{FALSE} otherwise 20 | } 21 | \description{ 22 | The tumbling sum is calculated as the partial cumulative sum of a vector 23 | until a threshold is exceeded. Once this happens, the tumbling sum is 24 | calculated from zero again. \code{exceeds_tumbling_sum()} returns \code{TRUE} whenever 25 | this threshold is hit/exceeded and \code{FALSE} otherwise. 26 | } 27 | \details{ 28 | This is for example useful if you have high frequency GPS positions 29 | and want to keep only points that are at least \code{x} seconds apart. 30 | } 31 | \examples{ 32 | exceeds_tumbling_sum(c(1, 3, 3, 3), 4) 33 | } 34 | \seealso{ 35 | \code{\link[MESS:cumsumbinning]{MESS::cumsumbinning()}} does something very similar, but returns 36 | group indices instead of a logical vector. 37 | } 38 | -------------------------------------------------------------------------------- /man/if_else.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/if_else.R 3 | \name{if_else} 4 | \alias{if_else} 5 | \title{Vectorised if} 6 | \usage{ 7 | if_else(condition, true, false, missing = NULL) 8 | } 9 | \arguments{ 10 | \item{condition}{Logical vector} 11 | 12 | \item{true, false}{Values to use for \code{TRUE} and \code{FALSE} values of 13 | \code{condition}. They must be either the same length as \code{condition}, 14 | or length 1. They must also be the same type: \code{if_else()} checks that 15 | they have the same type and same class. All other attributes are 16 | taken from \code{true}.} 17 | 18 | \item{missing}{If not \code{NULL}, will be used to replace missing 19 | values.} 20 | } 21 | \value{ 22 | Where \code{condition} is \code{TRUE}, the matching value from 23 | \code{true}, where it's \code{FALSE}, the matching value from \code{false}, 24 | otherwise \code{NA}. 25 | } 26 | \description{ 27 | Compared to the base \code{\link[=ifelse]{ifelse()}}, this function is more strict. 28 | It checks that \code{true} and \code{false} are the same type. This 29 | strictness makes the output type more predictable, and makes it somewhat 30 | faster. 31 | } 32 | \examples{ 33 | x <- c(-5:5, NA) 34 | if_else(x < 0, NA_integer_, x) 35 | if_else(x < 0, "negative", "positive", "missing") 36 | 37 | # Unlike ifelse, if_else preserves types 38 | x <- factor(sample(letters[1:5], 10, replace = TRUE)) 39 | ifelse(x \%in\% c("a", "b", "c"), x, factor(NA)) 40 | if_else(x \%in\% c("a", "b", "c"), x, factor(NA)) 41 | # Attributes are taken from the `true` vector, 42 | } 43 | -------------------------------------------------------------------------------- /man/lest-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lest-package.R 3 | \docType{package} 4 | \name{lest-package} 5 | \alias{lest} 6 | \alias{lest-package} 7 | \title{lest: Vectorised Nested if-else Statements Similar to CASE WHEN 8 | in 'SQL'} 9 | \description{ 10 | Functions for vectorised conditional recoding of 11 | variables. case_when() enables you to vectorise multiple if and else 12 | statements (like 'CASE WHEN' in 'SQL'). if_else() is a stricter and 13 | more predictable version of ifelse() in 'base' that preserves 14 | attributes. These functions are forked from 'dplyr' with all package 15 | dependencies removed and behave identically to the originals. 16 | } 17 | \author{ 18 | \strong{Maintainer}: Stefan Fleck \email{stefan.b.fleck@gmail.com} (\href{https://orcid.org/0000-0003-3344-9851}{ORCID}) 19 | 20 | Authors: 21 | \itemize{ 22 | \item Hadley Wickham \email{hadley@rstudio.com} (\href{https://orcid.org/0000-0003-4757-117X}{ORCID}) 23 | \item Romain François (\href{https://orcid.org/0000-0002-2444-4226}{ORCID}) 24 | \item Lionel Henry 25 | \item Kirill Müller (\href{https://orcid.org/0000-0002-1416-3412}{ORCID}) 26 | } 27 | 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /src/cumall.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | SEXP cumall_(SEXP x) { 5 | R_xlen_t n = XLENGTH(x); 6 | SEXP res = PROTECT(allocVector(LGLSXP, n)); 7 | 8 | int *p_x = LOGICAL(x); 9 | int *p_res = LOGICAL(res); 10 | int prev = TRUE; 11 | 12 | for (R_xlen_t i = 0; i < n; i++) { 13 | if (p_x[i] == TRUE) { 14 | p_res[i] = prev; 15 | } else if (p_x[i] == FALSE || prev == FALSE){ 16 | p_res[i] = FALSE; 17 | prev = FALSE; 18 | } else { 19 | p_res[i] = NA_LOGICAL; 20 | prev = NA_LOGICAL; 21 | } 22 | } 23 | 24 | UNPROTECT(1); 25 | return res; 26 | } 27 | 28 | 29 | 30 | 31 | SEXP cumany_(SEXP x) { 32 | R_xlen_t n = XLENGTH(x); 33 | SEXP res = PROTECT(allocVector(LGLSXP, n)); 34 | 35 | int *p_x = LOGICAL(x); 36 | int *p_res = LOGICAL(res); 37 | int prev = FALSE; 38 | 39 | for (R_xlen_t i = 0; i < n; i++) { 40 | if (p_x[i] == FALSE) { 41 | p_res[i] = prev; 42 | } else if (p_x[i] == TRUE || prev == TRUE){ 43 | p_res[i] = TRUE; 44 | prev = TRUE; 45 | } else { 46 | p_res[i] = NA_LOGICAL; 47 | prev = NA_LOGICAL; 48 | } 49 | } 50 | 51 | UNPROTECT(1); 52 | return res; 53 | } 54 | -------------------------------------------------------------------------------- /src/exceeds_tumbling_sum.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | SEXP exceeds_tumbling_sum_double_( 5 | SEXP x, 6 | SEXP threshold, 7 | SEXP inclusive 8 | ){ 9 | R_xlen_t n = XLENGTH(x); 10 | SEXP res = PROTECT(allocVector(LGLSXP, n)); 11 | 12 | const double *p_x = REAL(x); 13 | const double *p_threshold = REAL(threshold); 14 | const int *p_inclusive = LOGICAL(inclusive); 15 | 16 | double cumsum = 0; 17 | int *p_res = LOGICAL(res); 18 | 19 | if (*p_inclusive > 0){ 20 | for (R_xlen_t i = 0; i < n; i++) { 21 | cumsum += p_x[i]; 22 | 23 | if (cumsum >= *p_threshold) { 24 | p_res[i] = TRUE; 25 | cumsum = 0; 26 | } else { 27 | p_res[i] = FALSE; 28 | } 29 | } 30 | } else { 31 | for (R_xlen_t i = 0; i < n; i++) { 32 | cumsum += p_x[i]; 33 | 34 | if (cumsum > *p_threshold) { 35 | p_res[i] = TRUE; 36 | cumsum = 0; 37 | } else { 38 | p_res[i] = FALSE; 39 | } 40 | } 41 | } 42 | 43 | 44 | UNPROTECT(1); 45 | return res; 46 | } 47 | 48 | 49 | 50 | 51 | SEXP exceeds_tumbling_sum_int_( 52 | SEXP x, 53 | SEXP threshold, 54 | SEXP inclusive 55 | ){ 56 | R_xlen_t n = XLENGTH(x); 57 | SEXP res = PROTECT(allocVector(LGLSXP, n)); 58 | 59 | const int *p_x = INTEGER(x); 60 | const int *p_threshold = INTEGER(threshold); 61 | const int *p_inclusive = LOGICAL(inclusive); 62 | 63 | double cumsum = 0; 64 | int *p_res = LOGICAL(res); 65 | 66 | if (*p_inclusive > 0){ 67 | for (R_xlen_t i = 0; i < n; i++) { 68 | cumsum += p_x[i]; 69 | 70 | if (cumsum >= *p_threshold) { 71 | p_res[i] = TRUE; 72 | cumsum = 0; 73 | } else { 74 | p_res[i] = FALSE; 75 | } 76 | } 77 | } else { 78 | for (R_xlen_t i = 0; i < n; i++) { 79 | cumsum += p_x[i]; 80 | 81 | if (cumsum > *p_threshold) { 82 | p_res[i] = TRUE; 83 | cumsum = 0; 84 | } else { 85 | p_res[i] = FALSE; 86 | } 87 | } 88 | } 89 | 90 | 91 | UNPROTECT(1); 92 | return res; 93 | } 94 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | /* .Call calls */ 7 | extern SEXP cumall_(SEXP); 8 | extern SEXP cumany_(SEXP); 9 | extern SEXP exceeds_tumbling_sum_double_(SEXP, SEXP, SEXP); 10 | extern SEXP exceeds_tumbling_sum_int_(SEXP, SEXP, SEXP); 11 | 12 | static const R_CallMethodDef CallEntries[] = { 13 | {"cumall_", (DL_FUNC) &cumall_, 1}, 14 | {"cumany_", (DL_FUNC) &cumany_, 1}, 15 | {"exceeds_tumbling_sum_double_", (DL_FUNC) &exceeds_tumbling_sum_double_, 3}, 16 | {"exceeds_tumbling_sum_int_", (DL_FUNC) &exceeds_tumbling_sum_int_, 3}, 17 | {NULL, NULL, 0} 18 | }; 19 | 20 | void R_init_lest(DllInfo *dll) 21 | { 22 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 23 | R_useDynamicSymbols(dll, FALSE); 24 | } 25 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(lest) 3 | 4 | test_check("lest") 5 | -------------------------------------------------------------------------------- /tests/testthat/integration_tests/test_case_when.R: -------------------------------------------------------------------------------- 1 | test_that("case_when can be used in anonymous functions (#3422)", { 2 | res <- tibble::tibble(a = 1:3) %>% 3 | dplyr::mutate(b = (function(x) case_when(x < 2 ~ TRUE, TRUE ~ FALSE))(a)) %>% 4 | dplyr::pull() 5 | expect_equal(res, c(TRUE, FALSE, FALSE)) 6 | }) 7 | -------------------------------------------------------------------------------- /tests/testthat/test_case_when.R: -------------------------------------------------------------------------------- 1 | context("case_when") 2 | 3 | 4 | 5 | 6 | test_that("zero inputs throws an error", { 7 | expect_error( 8 | case_when(), 9 | "No cases provided", 10 | fixed = TRUE 11 | ) 12 | }) 13 | 14 | 15 | 16 | 17 | test_that("error messages", { 18 | expect_error( 19 | case_when( 20 | paste(50) 21 | ), 22 | "Case 1 (`paste(50)`) must be a two-sided formula, not a character", 23 | fixed = TRUE 24 | ) 25 | 26 | expect_error( 27 | case_when( 28 | 50 ~ 1:3 29 | ), 30 | "LHS of case 1 (`50`) must be a logical, not double", 31 | fixed = TRUE 32 | ) 33 | }) 34 | 35 | 36 | 37 | 38 | test_that("cases must yield compatible lengths", { 39 | expect_error( 40 | case_when( 41 | c(TRUE, FALSE) ~ 1, 42 | c(FALSE, TRUE, FALSE) ~ 2, 43 | c(FALSE, TRUE, FALSE, NA) ~ 3 44 | ), 45 | "`c(FALSE, TRUE, FALSE) ~ 2`, `c(FALSE, TRUE, FALSE, NA) ~ 3` must be length 2 or one, not 3, 4", 46 | fixed = TRUE 47 | ) 48 | 49 | expect_error( 50 | case_when( 51 | c(TRUE, FALSE) ~ 1:3, 52 | c(FALSE, TRUE) ~ 1:2 53 | ), 54 | "`c(TRUE, FALSE) ~ 1:3` must be length 2 or one, not 3", 55 | fixed = TRUE 56 | ) 57 | }) 58 | 59 | 60 | 61 | 62 | test_that("matches values in order", { 63 | x <- 1:3 64 | expect_equal( 65 | case_when( 66 | x <= 1 ~ 1, 67 | x <= 2 ~ 2, 68 | x <= 3 ~ 3 69 | ), 70 | c(1, 2, 3) 71 | ) 72 | }) 73 | 74 | 75 | 76 | 77 | test_that("unmatched gets missing value", { 78 | x <- 1:3 79 | expect_equal( 80 | case_when( 81 | x <= 1 ~ 1, 82 | x <= 2 ~ 2 83 | ), 84 | c(1, 2, NA) 85 | ) 86 | }) 87 | 88 | 89 | 90 | 91 | test_that("missing values can be replaced (#1999)", { 92 | x <- c(1:3, NA) 93 | expect_equal( 94 | case_when( 95 | x <= 1 ~ 1, 96 | x <= 2 ~ 2, 97 | is.na(x) ~ 0 98 | ), 99 | c(1, 2, NA, 0) 100 | ) 101 | }) 102 | 103 | 104 | 105 | 106 | test_that("NA conditions (#2927)", { 107 | expect_equal( 108 | case_when( 109 | c(TRUE, FALSE, NA) ~ 1:3, 110 | TRUE ~ 4L 111 | ), 112 | c(1L, 4L, 4L) 113 | ) 114 | }) 115 | 116 | 117 | 118 | 119 | test_that("atomic conditions (#2909)", { 120 | expect_equal( 121 | case_when( 122 | TRUE ~ 1:3, 123 | FALSE ~ 4:6 124 | ), 125 | 1:3 126 | ) 127 | expect_equal( 128 | case_when( 129 | NA ~ 1:3, 130 | TRUE ~ 4:6 131 | ), 132 | 4:6 133 | ) 134 | }) 135 | 136 | 137 | 138 | 139 | test_that("zero-length conditions and values (#3041)", { 140 | expect_equal( 141 | case_when( 142 | TRUE ~ integer(), 143 | FALSE ~ integer() 144 | ), 145 | integer() 146 | ) 147 | expect_equal( 148 | case_when( 149 | logical() ~ 1, 150 | logical() ~ 2 151 | ), 152 | numeric() 153 | ) 154 | }) 155 | -------------------------------------------------------------------------------- /tests/testthat/test_cumall.R: -------------------------------------------------------------------------------- 1 | context("cumall") 2 | 3 | 4 | test_that("cumall works as expected", { 5 | 6 | # normal usecases 7 | expect_identical( 8 | cumall(c(TRUE, TRUE, TRUE, FALSE)), 9 | c(TRUE, TRUE, TRUE, FALSE) 10 | ) 11 | 12 | expect_identical( 13 | cumall(c(TRUE, TRUE, FALSE, TRUE)), 14 | c(TRUE, TRUE, FALSE, FALSE) 15 | ) 16 | 17 | expect_identical( 18 | cumall(c(TRUE, TRUE, NA, FALSE, NA)), 19 | c(TRUE, TRUE, NA, FALSE, FALSE) 20 | ) 21 | 22 | expect_identical( 23 | cumall(c(TRUE, NA, TRUE, FALSE)), 24 | c(TRUE, NA, NA, FALSE) 25 | ) 26 | 27 | # NAs 28 | expect_true(all(is.na(cumall(rep(NA, 5))))) 29 | expect_true(all(cumall(rep(TRUE, 5)))) 30 | expect_false(any(cumall(rep(FALSE, 5)))) 31 | 32 | 33 | # n = 1 34 | expect_true(is.na(cumall(NA))) 35 | expect_true(cumall(TRUE)) 36 | expect_false(cumall(FALSE)) 37 | 38 | # n = 0 39 | expect_identical( 40 | cumall(logical()), 41 | logical() 42 | ) 43 | }) 44 | 45 | 46 | 47 | 48 | test_that("cumany works as expected", { 49 | 50 | # normal usecases 51 | expect_identical( 52 | cumany(c(TRUE, NA, FALSE)), 53 | c(TRUE, TRUE, TRUE) 54 | ) 55 | 56 | expect_identical( 57 | cumany(c(FALSE, NA, TRUE)), 58 | c(FALSE, NA, TRUE) 59 | ) 60 | 61 | # NAs 62 | expect_true(all(is.na(cumany(rep(NA, 5))))) 63 | expect_true(all(cumany(rep(TRUE, 5)))) 64 | expect_false(any(cumany(rep(FALSE, 5)))) 65 | 66 | # n = 1 67 | expect_true(is.na(cumany(NA))) 68 | expect_true(cumany(TRUE)) 69 | expect_false(cumany(FALSE)) 70 | 71 | # n = 0 72 | expect_identical( 73 | cumany(logical()), 74 | logical() 75 | ) 76 | 77 | }) 78 | -------------------------------------------------------------------------------- /tests/testthat/test_exceeds_tumbling_sum.R: -------------------------------------------------------------------------------- 1 | test_that("cumsum_threshold works as expected", { 2 | 3 | x <- c(1, 5, 5, 3) 4 | expect_identical( 5 | exceeds_tumbling_sum(x, 6), 6 | c(FALSE, TRUE, FALSE, TRUE) 7 | ) 8 | 9 | expect_identical( 10 | exceeds_tumbling_sum(x, 6), 11 | exceeds_tumbling_sum(as.integer(x), 6L) 12 | ) 13 | 14 | 15 | }) 16 | -------------------------------------------------------------------------------- /tests/testthat/test_if_else.R: -------------------------------------------------------------------------------- 1 | context("if_else") 2 | 3 | test_that("first argument must be logical", { 4 | expect_error( 5 | if_else(1:10, 1, 2), 6 | "`condition` must be a logical, not integer", 7 | fixed = TRUE 8 | ) 9 | }) 10 | 11 | test_that("true and false must be same length as condition (or length 1)", { 12 | expect_error( 13 | if_else(1:3 < 2, 1:2, 1:3), 14 | "`true` must be length 3 (length of `condition`) or one, not 2", 15 | fixed = TRUE 16 | ) 17 | expect_error( 18 | if_else(1:3 < 2, 1:3, 1:2), 19 | "`false` must be length 3 (length of `condition`) or one, not 2", 20 | fixed = TRUE 21 | ) 22 | }) 23 | 24 | test_that("true and false must be same type and same class", { 25 | expect_error( 26 | if_else(1:3 < 2, 1, 1L), 27 | "`false` must be type double, not integer", 28 | fixed = TRUE 29 | ) 30 | 31 | x <- factor("x") 32 | y <- ordered("x") 33 | expect_error( 34 | if_else(1:3 < 2, x, y), 35 | "`false` must be factor, not ordered/factor", 36 | fixed = TRUE 37 | ) 38 | }) 39 | 40 | test_that("scalar true and false are vectorised", { 41 | x <- c(TRUE, TRUE, FALSE, FALSE) 42 | expect_equal(if_else(x, 1, 2), c(1, 1, 2, 2)) 43 | }) 44 | 45 | test_that("vector true and false are ok", { 46 | x <- c(-1, 0, 1) 47 | 48 | expect_equal(if_else(x < 0, x, 0), c(-1, 0, 0)) 49 | expect_equal(if_else(x > 0, x, 0), c(0, 0, 1)) 50 | }) 51 | 52 | test_that("missing values are missing", { 53 | expect_equal(if_else(c(TRUE, NA, FALSE), -1, 1), c(-1, NA, 1)) 54 | }) 55 | 56 | test_that("works with lists", { 57 | x <- list(1, 2, 3) 58 | 59 | expect_equal( 60 | if_else(c(TRUE, TRUE, FALSE), x, list(NULL)), 61 | list(1, 2, NULL) 62 | ) 63 | }) 64 | 65 | test_that("better factor support (#2197)", { 66 | skip("Currently failing") 67 | 68 | test_that("gives proper error messages for factor class (#2197)", { 69 | x <- factor(1:3, labels = letters[1:3]) 70 | 71 | expect_error( 72 | if_else(x == "a", "b", x), 73 | "asdf", 74 | fixed = TRUE 75 | ) 76 | expect_error( 77 | if_else(x == "a", 1L, x), 78 | "asdf", 79 | fixed = TRUE 80 | ) 81 | expect_error( 82 | if_else(x == "a", 1., x), 83 | "asdf", 84 | fixed = TRUE 85 | ) 86 | expect_error( 87 | if_else(x == "a", TRUE, x), 88 | "asdf", 89 | fixed = TRUE 90 | ) 91 | expect_error( 92 | if_else(x == "a", Sys.Date(), x), 93 | "asdf", 94 | fixed = TRUE 95 | ) 96 | 97 | expect_error( 98 | if_else(x == "a", x, "b"), 99 | "asdf", 100 | fixed = TRUE 101 | ) 102 | expect_error( 103 | if_else(x == "a", x, 1L), 104 | "asdf", 105 | fixed = TRUE 106 | ) 107 | expect_error( 108 | if_else(x == "a", x, 1.), 109 | "asdf", 110 | fixed = TRUE 111 | ) 112 | expect_error( 113 | if_else(x == "a", x, TRUE), 114 | "asdf", 115 | fixed = TRUE 116 | ) 117 | expect_error( 118 | if_else(x == "a", x, Sys.Date()), 119 | "asdf", 120 | fixed = TRUE 121 | ) 122 | }) 123 | 124 | test_that("works with factors as both `true` and `false` (#2197)", { 125 | x <- factor(1:3, labels = letters[1:3]) 126 | y <- factor(1:3, labels = letters[c(1, 2, 4)]) 127 | 128 | expect_equal(if_else(x == "a", x[[2]], x), x[c(2, 2, 3)]) 129 | 130 | expect_error( 131 | if_else(x == "a", x, y), 132 | "asdf levels in `false` don't match levels in `true`" 133 | ) 134 | }) 135 | }) 136 | --------------------------------------------------------------------------------