#' S3 dispatch on class of pipe_left_arg.

#'

#' For formal documentation please see \url{https://github.com/WinVector/wrapr/blob/master/extras/wrapr_pipe.pdf}.

#'

#' @param pipe_left_arg left argument.

#' @param pipe_right_arg substitute(pipe_right_arg) argument.

#' @param pipe_environment environment to evaluate in.

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left.default}}

#'

#' @examples

#'

#' apply_left.character <- function(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' if(is.language(pipe_right_arg)) {

#' wrapr::apply_left_default(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name)

#' } else {

#' paste(pipe_left_arg, pipe_right_arg)

#' }

#' }

#' setMethod(

#' wrapr::apply_right_S4,

#' signature = c(pipe_left_arg = "character", pipe_right_arg = "character"),

#' function(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' paste(pipe_left_arg, pipe_right_arg)

#' })

#'

#' "a" %.>% 5 %.>% 7

#'

#' "a" %.>% toupper(.)

#'

#' q <- "z"

#' "a" %.>% q

#'

#'

#' @export

#'

apply_left <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

UseMethod("apply_left", pipe_left_arg)

}

# things we don't want to piple into

forbidden_pipe_destination_names <- c("else",

"return",

"stop", "warning",

"in", "next", "break",

"TRUE", "FALSE", "NULL", "Inf", "NaN",

"NA", "NA_integer_", "NA_real_", "NA_complex_", "NA_character_",

"->", "->>", "<-", "<<-", "=", # precedence should ensure we do not see these

"?",

"...",

".",

";", ",",

"list", "c", ":",

"for")

#' S3 dispatch on class of pipe_left_arg.

#'

#' Place evaluation of left argument in \code{.} and then evaluate right argument.

#'

#' @param pipe_left_arg left argument

#' @param pipe_right_arg substitute(pipe_right_arg) argument

#' @param pipe_environment environment to evaluate in

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left}}

#'

#' @examples

#'

#' 5 %.>% sin(.)

#'

#' @export

#'

apply_left_default <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

# remove some exceptional cases

if(length(pipe_right_arg)<1) {

stop("wrapr::apply_left.default does not allow direct piping into NULL/empty")

}

# check for piping into constants such as 4 %.>% 5

if(!is.language(pipe_right_arg)) {

stop(paste("wrapr::apply_left.default does not allow piping into obvious concrete right-argument (clearly can't depend on left argument):\n",

ifelse(is.null(left_arg_name), "", left_arg_name), paste(class(pipe_left_arg), collapse = ", "), "\n",

ifelse(is.null(right_arg_name), "", right_arg_name), paste(class(pipe_right_arg), collapse = ", ")),

call. = FALSE)

}

if(is.call(pipe_right_arg) && (is.name(pipe_right_arg[[1]]))) {

call_text <- as.character(pipe_right_arg[[1]])

# mostly grabbing reserved words that are in the middle

# of something, or try to alter control flow (like return).

if(isTRUE(call_text %in% forbidden_pipe_destination_names)) {

stop(paste0("to reduce surprising execution behavior wrapr::apply_left.default does not allow direct piping into some expressions (such as \"",

wrapr_deparse(pipe_right_arg),

"\")."))

}

}

# eval by with pipe_left_arg's value in dot (simulates chaining)

assign(".", pipe_left_arg,

envir = pipe_environment,

inherits = FALSE)

eval(pipe_right_arg,

envir = pipe_environment,

enclos = pipe_environment)

}

#' S3 dispatch on class of pipe_left_arg.

#'

#' Place evaluation of left argument in \code{.} and then evaluate right argument.

#'

#' @param pipe_left_arg left argument

#' @param pipe_right_arg substitute(pipe_right_arg) argument

#' @param pipe_environment environment to evaluate in

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left}}

#'

#' @examples

#'

#' 5 %.>% sin(.)

#'

#' @export

#'

apply_left.default <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

apply_left_default(pipe_left_arg = pipe_left_arg,

pipe_right_arg = pipe_right_arg,

pipe_environment = pipe_environment,

left_arg_name = left_arg_name,

pipe_string = pipe_string,

right_arg_name = right_arg_name)

}

#' S3 dispatch on class of pipe_right_argument.

#'

#' Triggered if right hand side of pipe stage was a name that does not resolve to a function.

#' For formal documentation please see \url{https://github.com/WinVector/wrapr/blob/master/extras/wrapr_pipe.pdf}.

#'

#'

#' @param pipe_left_arg left argument

#' @param pipe_right_arg right argument

#' @param pipe_environment environment to evaluate in

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left}}, \code{\link{apply_right_S4}}

#'

#' @examples

#'

#' # simulate a function pointer

#' apply_right.list <- function(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' pipe_right_arg$f(pipe_left_arg)

#' }

#'

#' f <- list(f=sin)

#' 2 %.>% f

#' f$f <- cos

#' 2 %.>% f

#'

#' @export

#'

apply_right <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

UseMethod("apply_right", pipe_right_arg)

}

#' Default apply_right implementation.

#'

#' Default apply_right implementation: S4 dispatch to apply_right_S4.

#'

#' @param pipe_left_arg left argument

#' @param pipe_right_arg pipe_right_arg argument

#' @param pipe_environment environment to evaluate in

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left}}, \code{\link{apply_right}}, \code{\link{apply_right_S4}}

#'

#' @examples

#'

#' # simulate a function pointer

#' apply_right.list <- function(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' pipe_right_arg$f(pipe_left_arg)

#' }

#'

#' f <- list(f=sin)

#' 2 %.>% f

#' f$f <- cos

#' 2 %.>% f

#'

#' @export

#'

apply_right.default <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

apply_right_S4(pipe_left_arg = pipe_left_arg,

pipe_right_arg = pipe_right_arg,

pipe_environment = pipe_environment,

left_arg_name = left_arg_name,

pipe_string = pipe_string,

right_arg_name = right_arg_name)

}

#' S4 dispatch method for apply_right.

#'

#' Intended to be generic on first two arguments.

#'

#' @param pipe_left_arg left argument

#' @param pipe_right_arg pipe_right_arg argument

#' @param pipe_environment environment to evaluate in

#' @param left_arg_name name, if not NULL name of left argument.

#' @param pipe_string character, name of pipe operator.

#' @param right_arg_name name, if not NULL name of right argument.

#' @return result

#'

#' @seealso \code{\link{apply_left}}, \code{\link{apply_right}}

#'

#' @examples

#'

#' a <- data.frame(x = 1)

#' b <- data.frame(x = 2)

#'

#' # a %.>% b # will (intentionally) throw

#'

#' setMethod(

#' "apply_right_S4",

#' signature("data.frame", "data.frame"),

#' function(pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' rbind(pipe_left_arg, pipe_right_arg)

#' })

#'

#'

#' a %.>% b # should equal data.frame(x = c(1, 2))

#'

#' @export

#'

apply_right_S4 <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name) {

force(pipe_environment)

# # go to default left S3 dispatch on apply_left()

# apply_left(pipe_left_arg = pipe_left_arg,

# pipe_right_arg = pipe_right_arg,

# pipe_environment = pipe_environment,

# left_arg_name = left_arg_name,

# pipe_string = pipe_string,

# right_arg_name = right_arg_name)

stop(paste("wrapr::apply_right_S4 default called with classes:\n",

ifelse(is.null(left_arg_name), "", left_arg_name), paste(class(pipe_left_arg), collapse = ", "), "\n",

ifelse(is.null(right_arg_name), "", right_arg_name), paste(class(pipe_right_arg), collapse = ", "), "\n",

" must have a more specific S4 method defined to dispatch\n"),

call. = FALSE)

}

#' @importFrom methods setGeneric

NULL

# lash in S4 dispatch

methods::setGeneric(

name = "apply_right_S4")

#' Pipe dispatch implementation.

#'

#' This is a helper for implementing additional pipes.

#'

#' @param pipe_left_arg possibily unevaluated left argument.

#' @param pipe_right_arg possibly unevaluated right argument.

#' @param pipe_environment environment to evaluate in.

#' @param pipe_string character, name of pipe operator.

#' @return result

#'

#' @examples

#'

#' # Example: how wrapr pipe is implemented

#'

#' print(`%.>%`)

#'

#'

#'

#'

#' # Example: create a value that causes pipelines to record steps.

#'

#' # inject raw values into wrapped/annotated world

#' unit_recording <- function(x, recording = paste(as.expression(substitute(x)), collapse = '\n')) {

#' res <- list(value = x, recording = recording)

#' class(res) <- "recording_value"

#' res

#' }

#'

#' # similar to bind or >>=

#' # (takes U, f:U -> V to M(f(U)), instead of

#' # U, f:U -> M(V) to M(f(U)))

#' # so similar to a functor taking

#' # f:U -> V to f':M(U) -> M(V)

#' # followed by application.

#' apply_left.recording_value <- function(

#' pipe_left_arg,

#' pipe_right_arg,

#' pipe_environment,

#' left_arg_name,

#' pipe_string,

#' right_arg_name) {

#' force(pipe_environment)

#' tmp <- wrapr::pipe_impl(

#' pipe_left_arg = pipe_left_arg$value,

#' pipe_right_arg = pipe_right_arg,

#' pipe_environment = pipe_environment,

#' pipe_string = pipe_string)

#' unit_recording(

#' tmp,

#' paste0(pipe_left_arg$recording,

#' ' %.>% ',

#' paste(as.expression(pipe_right_arg), collapse = '\n')))

#' }

#'

#' # make available on standard S3 search path

#' assign('apply_left.recording_value',

#' apply_left.recording_value,

#' envir = .GlobalEnv)

#'

#' unpack[value, recording] := 3 %.>%

#' unit_recording(.) %.>%

#' sin(.) %.>%

#' cos(.)

#'

#' print(value)

#' print(recording)

#'

#' # clean up

#' rm(envir = .GlobalEnv, list = 'apply_left.recording_value')

#'

#' @export

#'

pipe_impl <- function(pipe_left_arg,

pipe_right_arg,

pipe_environment,

pipe_string = NULL) {

# make sure environment is available

force(pipe_environment)

# special case: parenthesis

while(is.call(pipe_right_arg) &&

(length(pipe_right_arg)==2) &&

(length(as.character(pipe_right_arg[[1]]))==1) &&

(as.character(pipe_right_arg[[1]])=="(")) {

pipe_right_arg <- pipe_right_arg[[2]]

}

# capture names

left_arg_name <- NULL

if(is.name(pipe_left_arg)) {

left_arg_name <- pipe_left_arg

}

right_arg_name <- NULL

if(is.name(pipe_right_arg)) {

right_arg_name <- pipe_right_arg

}

# special case: name

is_name <- is.name(pipe_right_arg)

# special case: dereference names

qualified_name <- is.call(pipe_right_arg) &&

(length(pipe_right_arg)==3) &&

(length(as.character(pipe_right_arg[[1]]))==1) &&

(as.character(pipe_right_arg[[1]]) %in% c("::", ":::", "$", "[[", "[", "@")) &&

(is.name(pipe_right_arg[[2]])) &&

(as.character(pipe_right_arg[[2]])!=".") &&

(is.name(pipe_right_arg[[3]]) || is.character(pipe_right_arg[[3]])) &&

(as.character(pipe_right_arg[[3]])!=".")

# special case: anonymous funciton decl

is_function_decl <- is.call(pipe_right_arg) &&

(length(as.character(pipe_right_arg[[1]]))==1) &&

(as.character(pipe_right_arg[[1]])=="function")

dot_paren <- FALSE

eager_expression_eval <- FALSE

if(is.call(pipe_right_arg) &&

(length(as.character(pipe_right_arg[[1]]))==1)) {

call_name <- as.character(pipe_right_arg[[1]])[[1]]

if(call_name == ".") {

# special-case .() on RHS

dot_paren <- TRUE

} else {

if(call_name %in% c('[', '[[')) {

# special case [, treat 2nd argument as controller

if(length(pipe_right_arg) >= 2) {

obj_found_name <- as.character(pipe_right_arg[[2]])

if(length(obj_found_name)==1) {

obj_found <- mget(obj_found_name, envir = pipe_environment, mode = "any", inherits=TRUE, ifnotfound = list(NULL))[[1]]

if(!is.null(obj_found)) {

if(isTRUE(attr(obj_found, "dotpipe_eager_eval_bracket"))) {

eager_expression_eval <- TRUE

}

}

}

}

} else {

fn_found <- mget(call_name, envir = pipe_environment, mode = "function", inherits=TRUE, ifnotfound = list(NULL))[[1]]

if(!is.null(fn_found)) {

if(isTRUE(attr(fn_found, "dotpipe_eager_eval_function"))) {

eager_expression_eval <- TRUE

}

}

}

}

}

# check for right-apply situations

if(is.function(pipe_right_arg) ||

is_name || qualified_name ||

is_function_decl || dot_paren || eager_expression_eval) {

if(is_name) {

if(as.character(pipe_right_arg) %in% forbidden_pipe_destination_names) {

stop(paste("to reduce surprising behavior wrapr::pipe does not allow direct piping into some names, such as",

as.character(pipe_right_arg)))

}

pipe_right_arg <- base::get(as.character(pipe_right_arg),

envir = pipe_environment,

mode = "any",

inherits = TRUE)

} else if(qualified_name || is_function_decl) {

pipe_right_arg <- base::eval(pipe_right_arg,

envir = pipe_environment,

enclos = pipe_environment)

} else if(dot_paren) {

pipe_right_arg <- eval(pipe_right_arg[[2]],

envir = pipe_environment,

enclos = pipe_environment)

} else if(eager_expression_eval) {

pipe_right_arg <- eval(pipe_right_arg,

envir = pipe_environment,

enclos = pipe_environment)

}

# pipe_right_arg is now a value (as far as we are concerned)

# special case: functions

if(is.function(pipe_right_arg)) {

if(!is.null(left_arg_name)) {

# try to pass name forward to function

# support NSE in functions, but don't encourage it in expressions

res <- withVisible(do.call(pipe_right_arg,

list(left_arg_name),

envir = pipe_environment))

} else {

# force pipe_left_arg

pipe_left_arg <- eval(pipe_left_arg,

envir = pipe_environment,

enclos = pipe_environment)

res <- withVisible(do.call(pipe_right_arg,

list(pipe_left_arg),

envir = pipe_environment))

}

if(res$visible) {

return(res$value)

} else {

return(invisible(res$value))

}

}

# force pipe_left_arg

pipe_left_arg <- eval(pipe_left_arg,

envir = pipe_environment,

enclos = pipe_environment)

# S3 dispatch on right argument, surrogate function

res <- withVisible(apply_right(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name))

if(res$visible) {

return(res$value)

} else {

return(invisible(res$value))

}

}

# force pipe_left_arg

pipe_left_arg <- eval(pipe_left_arg,

envir = pipe_environment,

enclos = pipe_environment)

# Go for standard (first argument) S3 dispatch

res <- withVisible(apply_left(pipe_left_arg,

pipe_right_arg,

pipe_environment,

left_arg_name,

pipe_string,

right_arg_name))

if(res$visible) {

res$value

} else {

invisible(res$value)

}

}

#' Pipe operator ("dot arrow", "dot pipe" or "dot arrow pipe").

#'

#' Defined as roughly : \code{a \%>.\% b} ~ \code{\{ . <- a; b \};}

#' (with visible .-side effects).

#'

#' The pipe operator has a couple of special cases. First: if the right hand side is a name,

#' then we try to de-reference it and apply it as a function or surrogate function.

#'

#' The pipe operator checks for and throws an exception for a number of "piped into

#' nothing cases" such as \code{5 \%.>\% sin()}, many of these checks can be turned

#' off by adding braces.

#'

#' For some discussion, please see \url{https://win-vector.com/2017/07/07/in-praise-of-syntactic-sugar/}.

#' For some more examples, please see the package README \url{https://github.com/WinVector/wrapr}.

#' For formal documentation please see \url{https://github.com/WinVector/wrapr/blob/master/extras/wrapr_pipe.pdf}.

#' For a base-R step-debuggable pipe please try the Bizarro Pipe \url{https://win-vector.com/2017/01/29/using-the-bizarro-pipe-to-debug-magrittr-pipelines-in-r/}.

#' \code{\%>.\%} and \code{\%.>\%} are synonyms.

#'

#' The dot arrow pipe has S3/S4 dispatch (please see \url{https://journal.r-project.org/archive/2018/RJ-2018-042/index.html}).

#' However as the right-hand side of the pipe is normally held unevaluated, we don't know the type except in special

#' cases (such as the rigth-hand side being referred to by a name or variable). To force the evaluation of a pipe term,

#' simply wrap it in .().

#'

#' @param pipe_left_arg left argument expression (substituted into .)

#' @param pipe_right_arg right argument expression (presumably including .)

#' @return eval(\{ . <- pipe_left_arg; pipe_right_arg \};)

#'

#' @examples

#'

#' # both should be equal:

#' cos(exp(sin(4)))

#' 4 %.>% sin(.) %.>% exp(.) %.>% cos(.)

#'

#' f <- function() { sin }

#' # returns f() ignoring dot, not what we want

#' 5 %.>% f()

#' # evaluates f() early then evaluates result with .-substitution rules

#' 5 %.>% .(f())

#'

#' @name dot_arrow

NULL

#' @describeIn dot_arrow dot arrow

#' @export

`%.>%` <- function(pipe_left_arg, pipe_right_arg) {

pipe_left_arg <- substitute(pipe_left_arg)

pipe_right_arg <- substitute(pipe_right_arg)

pipe_environment <- parent.frame()

pipe_string <- as.character(sys.call()[[1]])

pipe_impl(pipe_left_arg, pipe_right_arg,

pipe_environment, pipe_string)

}

#' @describeIn dot_arrow alias for dot arrow

#' @export

`%>.%` <- function(pipe_left_arg, pipe_right_arg) {

pipe_left_arg <- substitute(pipe_left_arg)

pipe_right_arg <- substitute(pipe_right_arg)

pipe_environment <- parent.frame()

pipe_string <- as.character(sys.call()[[1]])

pipe_impl(pipe_left_arg, pipe_right_arg,

pipe_environment, pipe_string)

}

#' @describeIn dot_arrow alias for dot arrow

#' @export

`%.%` <- function(pipe_left_arg, pipe_right_arg) {

pipe_left_arg <- substitute(pipe_left_arg)

pipe_right_arg <- substitute(pipe_right_arg)

pipe_environment <- parent.frame()

pipe_string <- as.character(sys.call()[[1]])

pipe_impl(pipe_left_arg, pipe_right_arg,

pipe_environment, pipe_string)

}