I have two simple functions: f1 and f2. Suppose we only have access to f2. How can I remove any piece of output in f2 that causes f1 to stop and return the rest of the output?
My desired output is shown below the code.
# FUNCTION #1:
f1 <- function(...){
r <- list(...)
lapply(seq_along(r), function(i) if(r[[i]] == 4) stop("Problem") else r[[i]] + 1)
}
# FUNCTION #2:
f2 <- function(...){
res <- try(f1(...), silent = TRUE)
# if any 'res' causes 'stop' remove it, and return the rest!
}
# EXAMPLE:
f2(1, 2, 4)
My Desired output is:
#[[1]]
#[1] 1
#[[2]]
#[1] 2
The logic in f1 seems to stop everything if any of the ... input gets an error.
So, in f2, you could feed inputs into f1 one by one, normal input will get the correct output.
f1 <- function(...){
r <- list(...)
lapply(seq_along(r), function(i) if(r[[i]] == 4) stop("Problem") else r[[i]] + 1)
}
# FUNCTION #2:
f2 <- function(...){
# res <- try(f1(...), silent = TRUE)
r <- list(...)
res = lapply(r, function(fluffybunny){
tmp =try(f1(fluffybunny))
if(class(tmp) =="try-error") tmp=NULL
return(tmp)
})
# if any 'res' causes 'stop' remove it, and return the rest!
res.remove_error =res[!sapply(res, is.null)]
return(res.remove_error)
}
# EXAMPLE:
result = f2(1, 2, 4)
#> Error in FUN(X[[i]], ...) : Problem
result
#> [[1]]
#> [[1]][[1]]
#> [1] 2
#>
#>
#> [[2]]
#> [[2]][[1]]
#> [1] 3
Created on 2019-10-29 by the reprex package (v0.3.0)
Edit: removed result with try-error from f2's output.
Related
I want to write a decorator function that adds a counter to a function, counting the number of times it was called. E.g.
foo <- function(x) {x}
foo <- counter_decorator(foo)
foo(1)
foo(1)
# => the counter gets incremented with each call and has the value 2 now
The approach below basically works, but:
I want the inner function (which is returned by the decorator) to have the same formal args as the original function and not just ellipsis (i.e. ...). I am not sure how to accomplish that. Any ideas?
Not sure if the whole approach is a good one. Alternatives or improvements are appreciated.
Here is what I did so far:
# Init or reset counter
counter_init <- function() {
.counters <<- list()
}
# Decorate a function with a counter
#
# Each time the function is called the counter is incremented
#
# fun: function to be decorated
# fun_name: name in .counters list to store number of times in
#
counter_decorator <- function(fun, fun_name = NULL)
{
# use function name if no name is passed explicitly
if (is.null(fun_name)) {
fun_name <- deparse(substitute(fun))
}
fun <- force(fun) # deep copy to prevent infinite recursion
function(...) { # ==> ellipsis not optimal!
n <- .counters[[fun_name]]
if (is.null(n)) {
n <- 0
}
.counters[[fun_name]] <<- n + 1
fun(...)
}
}
Now let's create some functions and decorate them.
library(dplyr) # for pipe
# Create functions and decorate them with a counter
# create and decorate in second call
add_one <- function(x) {
x + 1
}
add_one <- counter_decorator(add_one)
# create and decorate the piping way by passing the fun_name arg
add_two <- {function(x) {
x + 2
}} %>% counter_decorator(fun_name = "add_two")
mean <- counter_decorator(mean)
counter_init()
for (i in 1:100) {
add_one(1)
add_two(1)
mean(1)
}
What we get in the .counters list is
> .counters
$add_one
[1] 100
$add_two
[1] 100
$mean
[1] 100
which is basically what I want.
1) The trace command can be used. Use untrace to undo the trace or set .counter to any desired value to start over again from that value.
f <- function(x) x
trace(f, quote(.counter <<- .counter + 1), print = FALSE)
.counter <- 0
f(1)
## [1] 1
f(1)
## [1] 1
.counter
## [1] 2
2) This variation stores the counter in an attribute of f.
f <- function(x) x
trace(f, quote(attr(f, "counter") <<- attr(f, "counter") + 1), print = FALSE)
attr(f, "counter") <- 0
f(1)
## [1] 1
f(1)
## [1] 1
attr(f, "counter")
## [1] 2
3) This variation stores the counter in an option.
f <- function(x) x
trace(f, quote(options(counter = getOption("counter", 0) + 1)), print = FALSE)
f(1)
## [1] 1
f(1)
## [1] 1
getOption("counter")
## [1] 2
This method stores the counter within the wrapper function itself instead of somewhere in the users environment or package environment. (There's nothing wrong with the latter; the former can be problematic or at least annoying/discourteous.)
The biggest side-effect (liability?) of this is when the package is detached or reloaded (i.e., during development), then the counter list is cleared/re-initialized.
counter_decorator <- function(fun) {
.counter <- 0L
fun2 <- function(...) {
.counter <<- .counter + 1L
cl <- match.call()
cl[[1]] <- fun
eval.parent(cl)
}
formals(fun2) <- formals(args(fun))
fun2
}
Demo:
foo <- function(x, y) x + y
foo2 <- counter_decorator(foo)
get(".counter", envir = environment(foo2))
# [1] 0
foo2(5, 9)
# [1] 14
foo2(5, 11)
# [1] 16
foo2(5, 13)
# [1] 18
get(".counter", envir = environment(foo2))
# [1] 3
Same formals:
formals(foo)
# $x
# $y
formals(foo2)
# $x
# $y
Edited (twice) to better track primitives where formals(.) is NULL; in that case, we can use formals(args(fun)).
Adapted for your preferred methodology, albeit with a little poetic liberty:
counters <- local({
.counters <- list()
function(init = FALSE) {
out <- .counters # will return counters *before* initialization
if (init) .counters <<- list()
out
}
})
counter_decorator <- function(fun, fun_name) {
if (missing(fun_name)) {
fun_name <- deparse(substitute(fun))
}
count <- get(".counters", envir = environment(counters))
count[[fun_name]] <- 0L
assign(".counters", count, envir = environment(counters))
fun2 <- function(...) {
.count <- get(".counters", envir = environment(counters))
.count[[fun_name]] <- if (is.null(.count[[fun_name]])) 1L else .count[[fun_name]] + 1L
assign(".counters", .count, envir = environment(counters))
cl <- match.call()
cl[[1]] <- fun
eval.parent(cl)
}
formals(fun2) <- formals(args(fun))
fun2
}
add_one <- function(x) {
x + 1
}
add_one <- counter_decorator(add_one)
add_two <- {function(x) {
x + 2
}} %>% counter_decorator(fun_name = "add_two")
new_mean <- counter_decorator(mean)
for (i in 1:100) {
add_one(1)
add_two(1)
new_mean(1)
}
counters()
# $add_one
# [1] 100
# $add_two
# [1] 100
# $mean
# [1] 100
formals(new_mean)
# $x
# $...
Initialization is not strictly required. Re-initialization returns the counters before reinitializing, so you don't need a double-call to get the values and then reset (and if you don't care about previous values, just ignore its return).
counters(TRUE)
# $add_one
# [1] 100
# $add_two
# [1] 100
# $mean
# [1] 100
counters()
# list()
add_one(10)
# [1] 11
counters()
# $add_one
# [1] 1
Is it possible to retrieve the function components of a function call? That is, is it possible to use as.list(match.call()) on another function call.
The background is, that I want to have a function that takes a function-call and returns the components of said function call.
get_formals <- function(x) {
# something here, which would behave as if x would be a function that returns
# as.list(match.call())
}
get_formals(mean(1:10))
# expected to get:
# [[1]]
# mean
#
# $x
# 1:10
The expected result is to have get_formals return as match.call() was called within the supplied function call.
mean2 <- function(...) {
as.list(match.call())
}
mean2(x = 1:10)
# [[1]]
# mean2
#
# $x
# 1:10
Another Example
The motivation behind this question is to check if a memoised function already contains the cached values. memoise has the function has_cache() but it needs to be called in a specific way has_cache(foo)(vals), e.g.,
library(memoise)
foo <- function(x) mean(x)
foo_cached <- memoise(foo)
foo_cached(1:10) # not yet cached
foo_cached(1:10) # cached
has_cache(foo_cached)(1:10) # TRUE
has_cache(foo_cached)(1:3) # FALSE
My goal is to log something if the function call is cached or not.
cache_wrapper <- function(f_call) {
is_cached <- has_cache()() # INSERT SOLUTION HERE
# I need to deconstruct the function call to pass it to has_cache
# basically
# has_cache(substitute(expr)[[1L]])(substitute(expr)[[2L]])
# but names etc do not get passed correctly
if (is_cached) print("Using Cache") else print("New Evaluation of f_call")
f_call
}
cache_wrapper(foo_cached(1:10))
#> [1] "Using Cache" # From the log-functionality
#> 5.5 # The result from the function-call
You can use match.call() to do argument matching.
get_formals <- function(expr) {
call <- substitute(expr)
call_matched <- match.call(eval(call[[1L]]), call)
as.list(call_matched)
}
get_formals(mean(1:10))
# [[1]]
# mean
#
# $x
# 1:10
library(ggplot2)
get_formals(ggplot(mtcars, aes(x = mpg, y = hp)))
# [[1]]
# ggplot
#
# $data
# mtcars
#
# $mapping
# aes(x = mpg, y = hp)
library(dplyr)
get_formals(iris %>% select(Species))
# [[1]]
# `%>%`
#
# $lhs
# iris
#
# $rhs
# select(Species)
Edit: Thanks for #KonradRudolph's suggestion!
The function above finds the right function. It will search in the scope of the parent of get_formals(), not in that of the caller. The much safer way is:
get_formals <- function(expr) {
call <- substitute(expr)
call_matched <- match.call(eval.parent(bquote(match.fun(.(call[[1L]])))), call)
as.list(call_matched)
}
The match.fun() is important to correctly resolve functions that are shadowed by a non-function object of the same name. For example, if mean is overwrited with a vector
mean <- 1:5
The first example of get_formals() will get an error, while the updated version works well.
Here's a way to do it that also gets the default values from the function if you didn't supply all the arguments:
get_formals <- function(call)
{
f_list <- as.list(match.call()$call)
func_name <- f_list[[1]]
p_list <- formals(eval(func_name))
f_list <- f_list[-1]
ss <- na.omit(match(names(p_list), names(f_list)))
if(length(ss) > 0) {
p_list[na.omit(match(names(f_list), names(p_list)))] <- f_list[ss]
f_list <- f_list[-ss]
}
unnamed <- which(!nzchar(sapply(p_list, as.character)))
if(length(unnamed) > 0)
{
i <- 1
while(length(f_list) > 0)
{
p_list[[unnamed[i]]] <- f_list[[1]]
f_list <- f_list[-1]
i <- i + 1
}
}
c(func_name, p_list)
}
Which gives:
get_formals(rnorm(1))
[[1]]
rnorm
$n
[1] 1
$mean
[1] 0
$sd
[1] 1
get_formals(ggplot2::ggplot())
[[1]]
ggplot2::ggplot
$data
NULL
$mapping
aes()
$...
$environment
parent.frame()
To get this to work one level in you could do something like:
foo <- function(f_call) {
eval(as.call(list(get_formals, call = match.call()$f_call)))
}
foo(mean(1:10))
[[1]]
mean
$x
1:10
$...
This answer is mostly based on Allens answer, but implements Konrads comment regarding the eval and eval.parent functions.
Additionally, some do.call is thrown in to finalise the cache_wrapper from the example above:
library(memoise)
foo <- function(x) mean(x)
foo_cached <- memoise(foo)
foo_cached(1:10) # not yet cached
#> [1] 5.5
foo_cached(1:10) # cached
#> [1] 5.5
has_cache(foo_cached)(1:10)
#> [1] TRUE
has_cache(foo_cached)(1:3)
#> [1] FALSE
# As answered by Allen with Konrads comment
get_formals <- function(call) {
f_list <- as.list(match.call()$call)
func_name <- f_list[[1]]
# changed eval to eval.parent as suggested by Konrad...
p_list <- formals(eval.parent(eval.parent(bquote(match.fun(.(func_name))))))
f_list <- f_list[-1]
ss <- na.omit(match(names(p_list), names(f_list)))
if(length(ss) > 0) {
p_list[na.omit(match(names(f_list), names(p_list)))] <- f_list[ss]
f_list <- f_list[-ss]
}
unnamed <- which(!nzchar(sapply(p_list, as.character)))
if(length(unnamed) > 0) {
i <- 1
while(length(f_list) > 0) {
p_list[[unnamed[i]]] <- f_list[[1]]
f_list <- f_list[-1]
i <- i + 1
}
}
c(func_name, p_list)
}
# check if the function works with has_cache
fmls <- get_formals(foo_cached(x = 1:10))
do.call(has_cache(eval(parse(text = fmls[1]))),
fmls[2])
#> [1] TRUE
# implement a small wrapper around has_cache that reports if its using cache
cache_wrapper <- function(f_call) {
fmls <- eval(as.call(list(get_formals, call = match.call()$f_call)))
is_cached <- do.call(has_cache(eval(parse(text = fmls[1]))),
fmls[2])
if (is_cached) print("Using Cache") else print("New Evaluation of f_call")
f_call
}
cache_wrapper(foo_cached(x = 1:10))
#> [1] "Using Cache"
#> [1] 5.5
cache_wrapper(foo_cached(x = 1:30))
#> [1] "New Evaluation of f_call"
#> [1] 5.5
I fear I get something really wrong. The basics are from here
and a basic (minimal) example is understood (I think) and working:
fun.default <- function(x) { # you could add further fun.class1 (works)...
print("default")
return(x[1] + x[2])
}
my_fun <- function(x) {
print("my_fun")
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun...")
return(res)
}
x <- c(1, 2)
my_fun(x)
However, if I want to add parameters, something goes really wrong. Form the link above:
Once UseMethod has found the correct method, it’s invoked in a special
way. Rather than creating a new evaluation environment, it uses the
environment of the current function call (the call to the generic), so
any assignments or evaluations that were made before the call to
UseMethod will be accessible to the method.
I tried all variants I could think of:
my_fun_wrong1 <- function(x, y) {
print("my_fun_wrong1")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong1...")
return(res)
}
x <- c(1, 2)
# Throws: Error in fun.default(x, y = 2) : unused argument (y = 2)
my_fun_wrong1(x, y = 2)
my_fun_wrong2 <- function(x) {
print("my_fun_wrong2")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong2...")
return(res)
}
x <- c(1, 2)
y = 2
# Does not throw an error, but does not give my expetced result "7":
my_fun_wrong2(x) # wrong result!?
rm(y)
my_fun_wrong3 <- function(x, ...) {
print("my_fun_wrong3")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong3...")
return(res)
}
x <- c(1, 2)
# Throws: Error in my_fun_wrong3(x, y = 2) : object 'y' not found
my_fun_wrong3(x, y = 2)
Edit after answer G. Grothendieck: Using fun.default <- function(x, ...) I get
Runs after change, but I don't understand the result:
my_fun_wrong1(x, y = 2)
[1] "my_fun_wrong1"
[1] 1 2
[1] 3 4 # Ok
[1] "default"
[1] 3 # I excpect 7
As before - I don't understand the result:
my_fun_wrong2(x) # wrong result!?
[1] "my_fun_wrong2"
[1] 1 2
[1] 3 4 # Ok!
[1] "default"
[1] 3 # 3 + 4 = 7?
Still throws an error:
my_fun_wrong3(x, y = 2)
[1] "my_fun_wrong3"
[1] 1 2
Error in my_fun_wrong3(x, y = 2) : object 'y' not found
I think, this question is really useful!
fun.default needs ... so that the extra argument is matched.
fun.default <- function(x, ...) {
print("default")
return(x[1] + x[2])
}
x <- c(1, 2)
my_fun_wrong1(x, y = 2)
## [1] "my_fun_wrong1"
## [1] 1 2
## [1] 5 6
## [1] 3
Also, any statements after the call to UseMethod in the generic will not be evaluated as UseMethoddoes not return so it is pointless to put code after it in the generic.
Furthermore, you can't redefine the arguments to UseMethod. The arguments are passed on as they came in.
Suggest going over the help file ?UseMethod although admittedly it can be difficult to read.
Regarding the quote from ?UseMethod that was added to the question, this just means that the methods can access local variables defined in the function calling UseMethod. It does not mean that you can redefine arguments. Below ff.default refers to the a defined in ff.
a <- 0
ff <- function(x, ...) { a <- 1; UseMethod("ff") }
ff.default <- function(x, ...) a
ff(3)
## [1] 1
Building on this SO question here I want to write a function that manipulates other functions by (1) setting each line visible () and by (2) wrapping withAutoprint({}) around the body of the function. First, I though some call to trace() would yield my desired result, but somehow I can't figure it out.
Here is a simple example:
# Input function foo
foo <- function(x)
{
line1 <- x
line2 <- 0
line3 <- line1 + line2
return(line3)
}
# some function which alters foo (here called make_visible() )
foo2 <- make_visible(foo)
# so that foo2 looks like this after being altered
foo2 <- function(x)
{
withAutoprint({
(line1 <- x)
(line2 <- 0)
(line3 <- line1 + line2)
(return(line3))
})
}
# example of calling foo2 and desired output/result
> foo2(2)
> (line1 <- x)
[1] 2
> (line2 <- 0)
[1] 0
> (line3 <- line1 + line2)
[1] 2
> (return(line3))
[1] 2
background / motivation
Turning functions visible line by line is helpful with longer custom functions when no real error is thrown, but the functions takes a wrong turn and returns and unwanted output. The alternative is using the debugger clicking next and checking each variable step by step. A function like make_visible might save some time here.
Use case
I see an actual use case for this kind of function, when debugging map or lapply functions which do not through an error, but produce an undesired result somewhere in the function that is being looped over.
Here's a solution that creates exactly the body of the solution you proposed in your question, with the addition of the 2 tests you used in your answer :
make_visible <- function(f) {
if (typeof(f) %in% c("special", "builtin")) {
stop("make_visible cannot be applied to primitive functions")
}
if (! typeof(f) %in% "closure") {
stop("make_visible only takes functions of type closures as argument")
}
f2 <- f
bod <- body(f)
if(!is.call(bod) || !identical(bod[[1]], quote(`{`)))
bod <- call("(",body(f))
else
bod[-1] <- lapply(as.list(bod[-1]), function(expr) call("(", expr))
body(f2) <- call("[[",call("withAutoprint", bod),"value")
f2
}
# solve foo issue with standard adverb way
foo <- function(x)
{
line1 <- x
line2 <- 0
line3 <- line1 + line2
return(line3)
}
foo2 <- make_visible(foo)
foo2
#> function (x)
#> withAutoprint({
#> (line1 <- x)
#> (line2 <- 0)
#> (line3 <- line1 + line2)
#> (return(line3))
#> })[["value"]]
foo2(2)
#> > (line1 <- x)
#> [1] 2
#> > (line2 <- 0)
#> [1] 0
#> > (line3 <- line1 + line2)
#> [1] 2
#> > (return(line3))
#> [1] 2
#> [1] 2
Here's another take, printing nicer as your own second proposal :
make_visible2 <- function(f) {
if (typeof(f) %in% c("special", "builtin")) {
stop("make_visible cannot be applied to primitive functions")
}
if (! typeof(f) %in% "closure") {
stop("make_visible only takes functions of type closures as argument")
}
f2 <- f
bod <- body(f)
if(!is.call(bod) || !identical(bod[[1]], quote(`{`))) {
bod <- bquote({
message(deparse(quote(.(bod))))
print(.(bod))
})
} else {
bod[-1] <- lapply(as.list(bod[-1]), function(expr) {
bquote({
message(deparse(quote(.(expr))))
print(.(expr))
})
})
}
body(f2) <- bod
f2
}
foo3 <- make_visible2(foo)
foo3
#> function (x)
#> {
#> {
#> message(deparse(quote(line1 <- x)))
#> print(line1 <- x)
#> }
#> {
#> message(deparse(quote(line2 <- 0)))
#> print(line2 <- 0)
#> }
#> {
#> message(deparse(quote(line3 <- line1 + line2)))
#> print(line3 <- line1 + line2)
#> }
#> {
#> message(deparse(quote(return(line3))))
#> print(return(line3))
#> }
#> }
foo3(2)
#> line1 <- x
#> [1] 2
#> line2 <- 0
#> [1] 0
#> line3 <- line1 + line2
#> [1] 2
#> return(line3)
#> [1] 2
I figured out two different approaches to my own question above. Both of them use something I would call 'deep function hacking' which is probably not a recommended way of doing this - at least it doesn't look like one should be doing this at all. Before playing around I didn't know this was even possible. Probably there are cleaner and more recommended ways of doing this, therefore I leave this questions open for other approaches.
First approach
I call the function of the first approach make_visible. Basically, this function constructs a new function using the body parts of foo and wrapping those with for loops in ( and then in withAutoprint. It is quite hacky, and only works on the first level of a function (it won't show the deeper structure of, for example, functions that use pipes).
make_visible <- function(.fx) {
if (typeof(.fx) %in% c("special", "builtin")) {
stop("`make_visible` cannot be applied to primitive functions")
}
if (! typeof(.fx) %in% "closure") {
stop("`make_visible` only takes functions of type closures as argument")
}
# make environment of .fx parent environment of new function environment
org_e <- environment()
fct_e <- environment(.fx)
parent.env(org_e) <- fct_e
# get formals and body of input function .f
fct_formals <- formals(.fx)
fct_body <- body(.fx)[-1]
# create a minimal example function for `(`
.f1 <- function(x) {
(x)
}
# extract its body
.f1_body <- body(.f1)[-1]
# build a new function .f2 by combining .f and .f1
.f2 <- function() {}
for (i in seq_along(1:length(fct_body))) {
.f1_body[[1]][[2]]<- fct_body[[i]]
body(.f2)[[1+i]] <- .f1_body[[1]]
}
# extract the body of new function .f2
.f2_body <- body(.f2)[-1]
# create a minimal example function .f3 for `withAutoprint`
.f3 <- function() {
withAutoprint({
x
})
}
# insert body part of .f2 into .f3
for (j in seq_along(1:length(.f2_body))) {
body(.f3)[[2]][[2]][[1+j]] <- .f2_body[[j]]
}
# give .f3 the formals of input function
formals(.f3) <- fct_formals
# return .f3 as new function
.f3
}
Which yields the following outcome:
foo2 <- make_visible(foo)
foo2(1)
> (line1 <- x)
> [1] 1
> (line2 <- 0)
> [1] 0
> (line3 <- line1 + line2)
> [1] 1
> (return(line3))
> [1] 1
This approach has a couple of downsides:
1. Wrapping the output of each line into brackets reduced the readability
2. Further, this approach returns a not the value of the original function, but a list with two elements, the original result value and a logical vector visible, which makes it harder to use the output of this function, especially when using it inside a map call.
foo2(1) %>% str
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# List of 2
# $ value : num 1
# $ visible: logi TRUE
purrr::map(1:3, foo2)
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# > (line1 <- x)
# [1] 2
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 2
# > (return(line3))
# [1] 2
# > (line1 <- x)
# [1] 3
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 3
# > (return(line3))
# [1] 3
# [[1]]
# [[1]]$value
# [1] 1
#
# [[1]]$visible
# [1] TRUE
#
#
# [[2]]
# [[2]]$value
# [1] 2
#
# [[2]]$visible
# [1] TRUE
#
#
# [[3]]
# [[3]]$value
# [1] 3
#
# [[3]]$visible
# [1] TRUE
Second approach
While make_visible is a direct approach on my idea of rewriting a function by making each line visible and wrapping it in withAutoprint the second approach rethinks the problem. It is a similar 'deep function hack', looping over body parts of the original function, but this time (1) printing them to console, (2) capturing their evaluated output, (3) printing this output to console, and then (4) actually evaluating each body part. Finally the original function is called and returned invisibly.
reveal <- function(.fx) {
if (typeof(.fx) %in% c("special", "builtin")) {
stop("`reveal` cannot be applied to primitive functions")
}
if (! typeof(.fx) %in% "closure") {
stop("`reveal` only takes functions of type closures as argument")
}
# environment handling
# get environment of .fx and make it parent.env of reveal
org_e <- environment()
fct_e <- environment(.fx)
parent.env(org_e) <- fct_e
# get formals of .fx
fct_formals <- formals(.fx)
# get body of .fx without first part {
fct_body <- body(.fx)[-1]
# define new function to return
.f2 <- function() {
# loop over the body parts of .fx
for (.i in seq_along(1:length(fct_body))) {
# print each body part
cat(paste0(as.list(fct_body)[.i],"\n"))
# check whether eval returns output and if not use eval_tidy
if (length(capture.output(eval(fct_body[[.i]]))) == 0) {
# write output of eval as string
out <- capture.output(rlang::eval_tidy(fct_body[[.i]]))
} else {
# write output of eval as string
out <- capture.output(eval(fct_body[[.i]]))
}
# print output of evaluation
cat(out, sep = "\n")
# evaluate
eval(fct_body[[.i]])
}
# get arguments
.args <- match.call(expand.dots = FALSE)[-1]
# run .fx with .args and return result invisibly
invisible(do.call(.fx, as.list(.args)))
}
# replace formals of .f2 with formals of .fx
formals(.f2) <- fct_formals
# replace environment of .f2 with env of reveal to which env of .fx is a parent environment
environment(.f2) <- org_e
# return new function .f2
.f2
}
The output looks similar but somewhat cleaner:
reveal(foo)(1)
> line1 <- x
> [1] 1
> line2 <- 0
> [1] 0
> line3 <- line1 + line2
> [1] 1
> return(line3)
> [1] 1
This second approach is better because it's more readable and it returns the same value as the original function. However, at the moment I havent't been able to make it work inside a map call. This is probably due to messing with the function environments.
foo2 <- reveal(foo)
purrr::map(1:3, foo2)
#> Error in (function (x) : object '.x' not found
I'm attempting to use a series of lapply calls to build a list of curried functions, which ideally at the last lapply call, returns the final desired value. The currying works, but lapply seems to always applies the last element in the list after the second application.
Example:
curry <- function(fn, ...) {
arglist <- list(...)
function(...) {
do.call(fn, append(arglist, list(...)))
}
}
# rcurry is used only to init the first lapply.
rcurry <- function(v1, fn, ...) {
arglist <- append(list(v1), list(...))
function(...) {
do.call(fn, append(arglist, list(...)))
}
}
myadd <- function(a,b,c) {
a+b+c
}
This works as expected:
# you can achieve the same by closure:
# curry.a <- lapply(c(10, 1000), FUN = function(a) { curry(myadd, a) })
curry.a <- lapply(list(10, 1000), rcurry, myadd)
curry.a[[1]](1,2)
curry.a[[2]](1,2)
# > [1] 13
# > [1] 1003
The next lapply of curry "mangles the scope":
# this does give the desired output:
# curry.a.b <- list(curry(curry.a[[1]], 1), curry(curry.a[[2]], 1))
curry.a.b <- lapply(curry.a, curry, 1)
curry.a.b[[1]](2)
curry.a.b[[2]](2)
# > [1] 1003
# > [1] 1003
It doesn't seem like a result of the curry or rcurry function. Using roxygen's Curry function does the same thing. creating curry.a by closure above or using curry.a <- list(curry(myadd, 10), curry(myadd, 1000)) also results the same.
And of course the final curry:
# it doesn't work if you re-define this:
# curry.a.b <- list(curry(curry.a[[1]], 1), curry(curry.a[[2]], 2))
curry.a.b.c <- lapply(curry.a.b, curry, 2)
lapply(curry.a.b.c, do.call, list())
# > [1] 1003
# > [1] 1003
What's going on here?
fn in curry is not evaluated in the scope of function and hence it is promise.
If you force it then you can get what you expect:
curry <- function(fn, ...) {
force(fn)
arglist <- list(...)
function(...) {
do.call(fn, append(arglist, list(...)))
}
}
then,
> curry.a.b <- lapply(curry.a, curry, 1)
> curry.a.b[[1]](2)
[1] 13
> curry.a.b[[2]](2)
[1] 1003
>
> curry.a.b.c <- lapply(curry.a.b, curry, 2)
> lapply(curry.a.b.c, do.call, list())
[[1]]
[1] 13
[[2]]
[1] 1003
More internally, lapply generates a local variable X that is referred by each call of function. If X is not evaluated in each function when calling the lapply, X is promise. After calling lapply, X in all function call from lapply returns same (i.e., last) value. So lapply is similar with:
f0 <- function(i) function() i
f1 <- function(i) {force(i); function() i}
f <- local({
r0 <- list()
r1 <- list()
for (i in 1:2) {
r0[[i]] <- f0(i)
r1[[i]] <- f1(i)
}
list(r0 = r0, r1 = r1)
})
then,
> f$r0[[1]]()
[1] 2
> f$r1[[1]]()
[1] 1
> f$r0[[2]]()
[1] 2
> f$r1[[2]]()
[1] 2