Last active
January 29, 2016 21:20
-
-
Save smbache/d4d01e8b055838f4e30c to your computer and use it in GitHub Desktop.
Recursive If-Then-Else in R
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#' Recursive If-Then-Else Evaluation. | |
#' | |
#' This function will recursively evaluate conditions, element-by-element, and | |
#' apply specified actions for the elements that satisfy the conditions. Each | |
#' \code{condition~action} pair is specified by a formula, with the condition as | |
#' left-hand side and action as right-hand side. Each condition is evaluated | |
#' sequentially and only to the relevant elements. This means that if an element | |
#' satisfies an early condition, it will never reach a later condition test. | |
#' The final argument is a one-sided formula with only an action applied to the | |
#' elements that do not satisfy any of the conditions (a default). | |
#' | |
#' @param . An atomic vector or a list, on which the condition tests and actions | |
#' are performed. | |
#' @param fst The first \code{condition ~ action} pair. Both condition and | |
#' action are specified as expressions of the dot (\code{.}). | |
#' @param ... The remaining \code{condition ~ action} pairs. | |
#' | |
#' @return A vector or a list, depending on the input. | |
#' | |
#' @examples | |
#' rifelse(1:10, . < 5 ~ "less", . == 5 ~ "equal", ~"greater") | |
#' | |
#' rifelse(1:10, . < 3 ~ sin(.), . < 6 ~ cos(.), ~ .) | |
#' | |
#' list_test <- list(a = head(iris), b = tail(iris), c = 1:10, d = rnorm(10)) | |
#' rifelse(list_test, is.data.frame(.) ~ TRUE, ~ FALSE) | |
rifelse <- function(., fst, ...) | |
{ | |
if (!inherits(fst, "formula")) | |
stop("Expected a formula specification.") | |
dotarg <- as.pairlist(alist(.=)) | |
value_part <- fst[[length(fst)]] | |
value_fun <- eval.parent(call("function", dotarg, value_part)) | |
if (length(fst) == 2) { | |
`if`(is.list(.), lapply(., value_fun), value_fun(.)) | |
} else { | |
len <- length(.) | |
out <- | |
`if`(is.list(.), vector("list", len), vector(length = len)) | |
condition_part <- fst[[2L]] | |
condition_fun <- eval.parent(call("function", dotarg, condition_part)) | |
passed <- | |
`if`(is.list(.), vapply(., condition_fun, logical(1)), condition_fun(.)) | |
missings <- is.na(passed) | |
if (any(missings)) { | |
out[missings] <- NA | |
passed[missings] <- FALSE | |
} | |
if (any(passed)) | |
out[passed & !missings] <- value_fun(.[passed & !missings]) | |
if (any(!passed & !missings)) | |
out[!passed & !missings] <- Recall(.[!passed & !missings], ...) | |
out | |
} | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment