Last active
August 29, 2015 14:10
-
-
Save smbache/afe0e1e105a8f56eb83f to your computer and use it in GitHub Desktop.
trigger function
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
#' 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 | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment