I have a list of functions:
func1 <- function(u)
{
list(val=u, ref="XX1")
}
func2 <- function(u)
{
list(val=u*u, ref="XX55")
}
func3 <- function(u)
{
list(val=u-1, ref="XX3")
}
And i want to get a result like this with u=2:
list(XX55=4, XX3=1, XX1=2)
For the moment I proceed like that:
funcs = c(func1, func2, func3)
temp = llply(funcs, function(f) f(2))
res = llply(temp, function(u) u$val)
names(res) = llply(temp, function(u) u$ref)
res
But maybe is there a more elegant/concise way to proceed?
You can use sapply:
sapply(funcs, function(f) {tmp <- f(2); setNames(list(tmp$val), tmp$ref)})
# $XX1
# [1] 1
#
# $XX55
# [1] 341
#
# $XX3
# [1] 11
Related
This is the intergral I'm trying to evaluate
What I'm trying to do is put the g_k(x,s) into a list so I can recursively use them in the loop.
n = 500
k = 3
g_1 <- 1
rho <- sqrt( ((k-1)*(n-k))/(k*(n-k+1)) )
tau2 <- (sqrt( n / (k*(n-k+1))))
g_lst <- c()
#Coded discretely for k=1,2,3,4
g1 <- function(x,s){ return( 1 ) }
g_lst <- c(g_lst,g1)
g2 <- function(x,s){ return( integrate(function(y){g_lst[[1]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
g_lst <- c(g_lst,g2)
g3 <- function(x,s){ return( integrate(function(y){g_lst[[2]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
g_lst <- c(g_lst,g3)
g4 <- function(x,s){ return( integrate(function(y){g_lst[[3]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
g_lst <- c(g_lst,g4)
#Trying to generalise to k=1,2,...,k
g_lst2 <- c()
g1 <- function(x,s){ return( 1 ) }
g_lst2 <- c(g_lst2,g1)
for (i in 1:3){
i <- force(i)
gk <- function(x,s){ return( integrate(function(y){g_lst[[i]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
force(gk)
g_lst2 <- c(g_lst2,gk)
}
Here are the corresponding values im getting from evualting the functions from the list. g_lst is giving me the correct values whereas g_lst2 for all i>=1 g_lst[[i]] is giving me the value of the g_lst2[4].
From the threads I could find on stack exchange I feel i need to use the force() function but for the way I've used it is not helping.
g_lst2[[2]](2,2)
#[1] 1.811419
g_lst2[[3]]](2,2)
#[1] 1.811419
g_lst2[[4]](2,2)
#[1] 1.811419
g_lst[[2]](2,2)
#[1] 0.7380149
g_lst[[3]](2,2)
#[1] 1.156224
g_lst[[4]](2,2)
#[1] 1.811419
Using force() inside a for loop doesn't really help because for doesn't create a new scope. You want to create a generating function instead to build your list. For example
#Trying to generalise to k=1,2,...,k
g_lst2 <- c()
g1 <- function(x,s){ return( 1 ) }
g_lst2 <- c(g_lst2,g1)
for (i in 1:3){
make_gk <- function(i) {
force(i)
function(x,s){ return( integrate(function(y){g_lst2[[i]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
}
gk <- make_gk(i)
g_lst2 <- c(g_lst2,gk)
}
Note that we are calling force() inside the function because that creates a new scope.
This will return the desired values
g_lst2[[2]](2,2)
# [1] 0.7380149
g_lst2[[3]](2,2)
# [1] 1.156224
g_lst2[[4]](2,2)
# [1] 1.811419
Alternatively you could use lapply which would take care of the forcing for you
g_lst2 <- c()
g1 <- function(x,s){ return( 1 ) }
g_lst2 <- c(g_lst2,g1)
g_lst2 <- c(g_lst2, lapply(1:3, function(i)
function(x,s){ return( integrate(function(y){g_lst2[[i]](y,s)*(dnorm(y,rho*x,tau2)+dnorm(y,-rho*x,tau2))},0,s)[[1]] ) }
))
You could easily use recursion to generalize. Below are two ways to do this
n <- 500
k <- 3
rho <- sqrt( ((k-1)*(n-k))/(k*(n-k+1)) )
tau2 <- (sqrt( n / (k*(n-k+1))))
g <- function(x,s,k){
if(k == 1) 1
else
integrate(function(y)g(y,s, k-1)*(
dnorm(y, x*rho, tau2) + dnorm(y, -x*rho, tau2)),0,s)[[1]]
}
g(2,2,1)
#> [1] 1
g(2,2,2)
#> [1] 0.7380149
g(2,2,3)
#> [1] 1.156224
g(2,2,4)
#> [1] 1.811419
The second way is to return a function then evaluate the function at the points needed
g1 <- function(k){
if(k == 1) function(...) 1
else function(x,s)
integrate(function(y)g1(k-1)(y,s)*(
dnorm(y, x*rho, tau2) + dnorm(y, -x*rho, tau2)),0,s)[[1]]
}
g1(1)(2,2)
#> [1] 1
g1(2)(2,2)
#> [1] 0.7380149
g1(3)(2,2)
#> [1] 1.156224
g1(4)(2,2)
#> [1] 1.811419
Created on 2023-02-10 with reprex v2.0.2
Of course this method given is slow as it does not save the intermediate results. ie if you compute g(2,2,10) then if you need g(2,2,8) you should not compute it but rather read it from the table of already computed g(2,2,10). But the method provided above does compute the value again. We can skip this process by using memoization:
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 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.
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