R/arrow.R

In mdequeljoe/fu: javascript-style arrow function operator

#' arrow function
#'
#' express a function using javascript-style arrow function syntax
#'
#' @param args the arguments of the function expression. For multiple arguments,
#'   use a vector, `c`.
#' @param body the body of the function. If it contains operations or multiple lines, wrap it in
#'   brackets like an expression.
#' @return a function
#' @examples \dontrun{
#' library(arrow)
#' greet_user <- c() %F% paste("hi", Sys.getenv("USER"))
#' greet_user()
#'
#' scatter <- d %F% {
#'   s <- strsplit(d, "")[[1]]
#'   s[sample(length(s), length(s))]
#' }
#' sapply(month.name, scatter)
#'
#' v <- c(a, b = 10, c = 10) %F% {a + b * c}
#' v(10)
#' }
#' @rdname arrow
#' @export
`%f%` <- function(args, body) {

  args <- set_args(substitute(args))
  body <- set_body(substitute(body))

  eval(call("function", args, body), parent.frame())
}

#' @rdname arrow
#' @export
`%F%` <- `%f%`

#' @rdname arrow
#' @export
`%=>%` <- `%f%`

has_symbol <-
  function(x, s)
    identical(substitute(s), as.list(x)[[1L]])

set_body <- function(x) {
  if (!has_symbol(x, `{`))
    x <- call("{", x)
  x
}

set_args <- function(x) {
  x  <- as.list(x)

  if (has_symbol(x, c))
    x <- x[-1L]

  if (!length(x))
    return(NULL)

  #check for arguments with defaults
  noval <- names(x) == ""
  if (!length(noval))
    noval <- 1:length(x)
  names(x)[noval] <- x[noval]
  x[noval] <- c(substitute())

  as.pairlist(x)
}