trigger function

trigger.R

#' Trigger an action associated with first matched/valid condition.
#' 
#' trigger is a flavour of pattern matching (or an if-else abstraction) in which a 
#' value is matched against a sequence of condition-action sets. When a valid 
#' match/condition is found the action is triggered and the result of the action 
#' is returned. The trigger function is designed to particularly useful in pipelines
#' ala magrittr.
#' 
#' @param value the value to match agaist
#' @param ... a set of formulas containing a condition as LHS and an action as RHS.
#'        named arguments will define additional values, and an unnamed argument which
#'        is not a formula will be treated as the sure match, see details and examples.
#'      
#' @return the value resulting from the action of the first valid match/condition is returned.
#'        If no matches are found, and no default is given, NULL will be returned.
#' 
#' @details condition-action sets are written as formulas with conditions as left-hand
#' sides and actions as right-hand sides. If only an action is given (i.e. not as a formula)
#' it is treated as a condition-action pair where the condition is always satisfied.
#' Any named argument will be made available in all conditions and actions, which is useful
#' in avoiding repeated temporary computations or temporary assignments.         
#'                      
#' Validity of the conditions are tested with \code{isTRUE}, or equivalently with
#' `identical(condition, TRUE)`. In other words conditions resulting in more than
#' one logical will never be valid.                      
#'                      
#' @examples
#' 1:10 %>% 
#'   trigger(
#'     sum(.) <=  50 ~ sum(.),
#'     sum(.) <= 100 ~ sum(.)/2,
#'     0
#'   )
#'   
#' 1:10 %>% 
#'   trigger(
#'     sum(.) <=   x ~ sum(.),
#'     sum(.) <= 2*x ~ sum(.)/2,
#'     0,
#'     x = 60
#'   )            
#'   
#' iris %>% 
#'   subset(Sepal.Length > 10) %>%
#'   trigger(
#'     nrow(.) > 0 ~ .
#'     iris %>% head(10)
#'   )
#' @export
trigger <- function(value, ...)
{
  dots   <- eval(substitute(alist(...)))
  names  <- names(dots)
  named  <- if (is.null(names)) rep(FALSE, length(dots)) else names != ""
  
  if (sum(!named) == 0)
    stop("At least one matching condition is needed.", call. = FALSE)
  
  is_formula <- 
    vapply(dots, function(cl) is.call(cl) && identical(cl[[1L]], quote(`~`)),
           logical(1L))
  
  env <- new.env(parent = parent.frame())
  
  env[["."]] <- value
  
  if (sum(named) > 0)
    for (i in which(named))
      assign(names[i], eval(dots[[i]], env, env), env)
  
  result <- NULL
  for (i in which(!named))
  {
    if (is_formula[i]) {
      if (isTRUE(eval(dots[[i]][[2]], env, env))) {
        result <- eval(dots[[i]][[3]], env, env)
        break
      }
    } else {
      result <- eval(dots[[i]], env, env)
    }
  }
  
  result
}