Recursive If-Then-Else in R

rifelse.R

#' 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
  }
}