CODEWITHSUNDEEP
rmetaprogramminglazy-evaluationpurrrmagrittr
Christopher Peralta
Christopher Peralta

Reputation: 421

Making a function that takes a function call as an argument into a pipeable function.

require(magrittr)
require(purrr)

is.out.same <- function(.call, ...) {
  ## Checks if args in .call will produce identical output in other functions
  call <- substitute(.call)               # Captures function call
  f_names <- eval(substitute(alist(...))) # Makes list of f_names


  map2(rep(list(call), length(f_names)),  # Creates list of new function calls
       f_names,
       function(.x, .y, i) {.x[[1]] <- .y; return(.x)} 
  ) %>%
    map(eval) %>%                         # Evaluates function calls
    map_lgl(identical, x = .call) %>%     # Checks output of new calls against output of original call 
    all()                                 # Returns TRUE if calls produce identical outputs
}

is.out.same(map(1:3, cumsum), lapply) # This works
map(1:3, cumsum) %>%                  # Is there any way to make this work?
  is.out.same(lapply)

My function takes a function call as an argument.

Is there any way of making my function pipeable? Right now, the problem is that whatever function I call will be evaluated before the pipe. The only thing I can think of is using a function to 'unevaluate' the value, but this doesn't seem possible.

Upvotes: 3

Views: 82

Answers (1)

MrFlick
MrFlick

Reputation: 206242

I wouldn't recommend one actually does this. The pipe operator is designed to make it easy to pass the output of one function as the input of the next. But that's not really what you're doing here at all. You want to manipulate the entire call stack. But it is technically is possible to do this. You just need to do some extra work to find the chain "meta-data" to see what was originally passed in. Here I put in two helper functions to extract the relevant info.

find_chain_parts <- function() {
  i <- 1
  while(!("chain_parts" %in% ls(envir=parent.frame(i))) && i < sys.nframe()) {
    i <- i+1
  }
  parent.frame(i)
}

find_lhs <- function(x) {
  env <- find_chain_parts()
  if(exists("chain_parts",env)) {
    return(env$chain_parts$lhs)
  } else {
    return(do.call("substitute", list(substitute(x), parent.frame())))
  }
}

These functions walk up the call stack to find the original pipe call. If there is one present, it will extract the expression from the left hand side, if not, it will just substitute on the original parameter. You would just change your function to use

is.out.same <- function(.call, ...) {
  call <- find_lhs(.call)                # Captures function call
  f_names <- eval(substitute(alist(...))) # Makes list of f_names

  map2(rep(list(call), length(f_names)),  # Creates list of new function calls
       f_names,
       function(.x, .y, i) {.x[[1]] <- .y; return(.x)} 
  )  %>% 
    map(eval) %>%                         # Evaluates function calls
    map_lgl(identical, x = .call) %>%     # Checks output of new calls against output of original call 
    all()                                 # Returns TRUE if calls produce identical outputs
}

Then both of these would run

is.out.same(map(1:3, cumsum), lapply)
# [1] TRUE 
map(1:3, cumsum) %>%                  
  is.out.same(lapply)
# [1] TRUE

But if you are really testing for functional equivalence for expressions, it would make much more sense to pass in quosures. Then you wouldn't need the different branches. Such a function would look like this

library(rlang)
is.out.same <- function(call, ...) {
  f_names <- eval(substitute(alist(...))) # Makes list of f_names

  map2(rep(list(call), length(f_names)),  # Creates list of new function calls
       f_names,
       function(.x, .y, i) {.x[[2]][[1]] <- .y; return(.x)} 
  )  %>% 
    map(eval_tidy) %>%                         # Evaluates function calls
    map_lgl(identical, x = eval_tidy(call)) %>%     # Checks output of new calls against output of original call 
    all()                                 # Returns TRUE if calls produce identical outputs
}

and you would call it one of the following ways

is.out.same(quo(map(1:3, cumsum)), lapply) 

quo(map(1:3, cumsum)) %>%
  is.out.same(lapply)

This makes the intent much clearer in my opinion.

Upvotes: 5

Related Questions