This is not really a problem, but I'm wondering if there is a more elegant solution:
Lets say i have a vector vec <- rlnorm(10) and I want to apply a not vectorized function to it, e.g. exp (ignore for the moment that it is vectorized), I can do
sapply( vec, exp )
But when the function I want to apply is nested, the expression becomes directly less simple:
sapply( vec, function(x) exp( sqrt(x) ) )
This happens to me all the time with the apply and plyr family.
So my question is, is there in general an elegant way to nest (or pipe) functions without defining explicitly an (anonymous) function function(x){...}? Something like
# notrun
sapply( vec, sqrt | exp )
or similar.
See the examples for ?Reduce:
## Iterative function application:
Funcall <- function(f, ...) f(...)
## Compute log(exp(acos(cos(0))
Reduce(Funcall, list(log, exp, acos, cos), 0, right = TRUE)
Here's a more bare-bones implementation with a slightly different interface:
Compose <- function(x, ...)
{
lst <- list(...)
for(i in rev(seq_along(lst)))
x <- lst[[i]](x)
x
}
sapply(0, Compose, log, exp, acos, cos)
The package functional includes a Compose function.
library(functional)
id <- Compose(exp, log)
id(2) # 2
Its implementation is simple enough to include in your source, if, say, you don't need the rest of the stuff in the functional package.
R> Compose
function (...)
{
fs <- list(...)
if (!all(sapply(fs, is.function)))
stop("Argument is not a function")
function(...) Reduce(function(x, f) f(x), fs, ...)
}
<environment: namespace:functional>
Related
I'm trying to use the curve3d function in the emdbook-package to create a contour plot of a function defined locally inside another function as shown in the following minimal example:
library(emdbook)
testcurve3d <- function(a) {
fn <- function(x,y) {
x*y*a
}
curve3d(fn(x,y))
}
Unexpectedly, this generates the error
> testcurve3d(2)
Error in fn(x, y) : could not find function "fn"
whereas the same idea works fine with the more basic curve function of the base-package:
testcurve <- function(a) {
fn <- function(x) {
x*a
}
curve(a*x)
}
testcurve(2)
The question is how curve3d can be rewritten such that it behaves as expected.
You can temporarily attach the function environment to the search path to get it to work:
testcurve3d <- function(a) {
fn <- function(x,y) {
x*y*a
}
e <- environment()
attach(e)
curve3d(fn(x,y))
detach(e)
}
Analysis
The problem comes from this line in curve3d:
eval(expr, envir = env, enclos = parent.frame(2))
At this point, we appear to be 10 frames deep, and fn is defined in parent.frame(8). So you can edit the line in curve3d to use that, but I'm not sure how robust this is. Perhaps parent.frame(sys.nframe()-2) might be more robust, but as ?sys.parent warns there can be some strange things going on:
Strictly, sys.parent and parent.frame refer to the context of the
parent interpreted function. So internal functions (which may or may
not set contexts and so may or may not appear on the call stack) may
not be counted, and S3 methods can also do surprising things.
Beware of the effect of lazy evaluation: these two functions look at
the call stack at the time they are evaluated, not at the time they
are called. Passing calls to them as function arguments is unlikely to
be a good idea.
The eval - parse solution bypasses some worries about variable scope. This passes the value of both the variable and function directly as opposed to passing the variable or function names.
library(emdbook)
testcurve3d <- function(a) {
fn <- eval(parse(text = paste0(
"function(x, y) {",
"x*y*", a,
"}"
)))
eval(parse(text = paste0(
"curve3d(", deparse(fn)[3], ")"
)))
}
testcurve3d(2)
I have found other solution that I do not like very much, but maybe it will help you.
You can create the function fn how a call object and eval this in curve3d:
fn <- quote((function(x, y) {x*y*a})(x, y))
eval(call("curve3d", fn))
Inside of the other function, the continuous problem exists, a must be in the global environment, but it is can fix with substitute.
Example:
testcurve3d <- function(a) {
fn <- substitute((function(x, y) {
c <- cos(a*pi*x)
s <- sin(a*pi*y/3)
return(c + s)
})(x, y), list(a = a))
eval(call("curve3d", fn, zlab = "fn"))
}
par(mfrow = c(1, 2))
testcurve3d(2)
testcurve3d(5)
I have a list of functions
functions <- list(f1, f2, f3, ...)
And I need to pass an object x through all the functions. I could do it by:
for (fun in functions){
fun(x)
}
The functions do not return anything, but their order is important, i.e. f1(x) must be applied before f2(x).
Thus, I'm thinking on using lapply:
lapply(functions, function(fun) fun(x))
But I don't know if lapply applies first the first function of the list functions or if it follows another order. With the loop I assure the ordering but it may go slower.
Any idea?
The wording of the question "pass x through ..." suggests that you think this will accomplish a "composition", i.e. a serial application of functions to results from prior applications. Neither of your proposed solutions will do that although you could rework your for loop to do so. Take a look at the ?funprog help page which I am shamelessly quoting in part:
## Iterative function application:
Funcall <- function(f, ...) f(...)
## Compute log(exp(acos(cos(0))
Reduce(Funcall, list(log, exp, acos, cos), 0, right = TRUE)
Compare the results of a for loop version with the Reduce version:
> flist <- list(log, exp, acos, cos)
> arg <- 0; for (f in flist) {arg <- f(arg)}
> arg
[1] 6.123234e-17
> Funcall <- function(f, ...) f(...)
> ## Compute log(exp(acos(cos(0))
> Reduce(Funcall, list(log, exp, acos, cos), 0, right = TRUE)
[1] 0
This shows that <something> is actually happening:
arg <- 0; for (f in flist) {arg <- f(arg);cat(arg,"\n")}
-Inf
0
1.570796
6.123234e-17
But they are not the same since the right=TRUE actually reverses the order of application and explains the trivial difference in the final result. Compare:
arg <- 0; for (f in rev(flist)) {arg <- f(arg);cat(arg,"\n")}
I am currently dealing with a problem. I am working on a package for some specific distributions where among other things I would like to create a function that will fit an mixture to some data. For this I would like to use for example the fitdistr function. The problem is that I don't know from what distributions and weights and number of components the mixture will be composed of. Hence I need a function that will dynamically create an density function of some specified mixture so the fitdistr function can use it. For example if the user will call:
fitmix(data,dist=c(norm,chisq),params=list(c(mean=0,sd=3),df=2),wights=c(0.5,0.5))
to use ML method the code needs to create an density function
function(x,mean,sd,df) 0.5*dnorm(x,mean,sd)+0.5*dchisq(x,df)
so it can call optim or fitdistr.
An obvious solution is to use a lot of paste+eval+parse but I don't think this is the most elegant solution. A nice solution is probably hiding somewhere in non-standard evaluation and expression manipulation, but I have not enough skills in this problematic.
P.S. the params can be used as starting values for the optimizer.
Building expressions is relatively straight forward in R with functions like as.call and bquote and the fact that functions are first class objects in R. Building functions with dynamic signatures is a bit trickier. Here's a pass at some function that might help
to_params <- function(l) {
z <- as.list(l)
setNames(lapply(names(z), function(x) bquote(args[[.(x)]])), names(z))
}
add_exprs <- function(...) {
x <- list(...)
Reduce(function(a,b) bquote(.(a) + .(b)), x)
}
get_densities <- function(f) {
lapply(paste0("d", f), as.name)
}
weight_expr <- function(w, e) {
bquote(.(w) * .(e))
}
add_params <- function(x, p) {
as.call(c(as.list(x), p))
}
call_with_x <- function(fn) {
as.call(list(fn, quote(x)))
}
fitmix <- function(data, dist, params, weights) {
fb <- Reduce( add_exprs, Map(function(d, p, w) {
weight_expr(w, add_params(call_with_x(d), to_params(p)))
}, get_densities(dist), params, weights))
f <- function(x, args) {}
body(f) <- fb
f
}
Note that I changed the types of some of your parameters. The distributions should be strings. The parameters should be a list of named vectors. It would work with a call like this
ff <- fitmix(data, dist=c("norm","chisq"), params=list(c(mean=0,sd=3),c(df=2)),
weights=c(0.5,0.5))
It returns a function that takes an x and a list of named arguments. You could call it like
ff(0, list(mean=3, sd=2, df=2))
# [1] 0.2823794
which returns the same value as
x <- 0
0.5 * dnorm(x, mean = 3, sd = 2) + 0.5 * dchisq(x, df = 2)
# [1] 0.2823794
I am facing some problem with the apply function passing on arguments to a function when not needed. I understand that apply don't know what to do with the optional arguments and just pass them on the function.
But anyhow, here is what I would like to do:
First I want to specify a list of functions that I would like to use.
functions <- list(length, sum)
Then I would like to create a function which apply these specified functions on a data set.
myFunc <- function(data, functions) {
for (i in 1:length(functions)) print(apply(X=data, MARGIN=2, FUN=functions[[i]]))
}
This works fine.
data <- cbind(rnorm(100), rnorm(100))
myFunc(data, functions)
[1] 100 100
[1] -0.5758939 -5.1311173
But I would also like to use additional arguments for some functions, e.g.
power <- function(x, p) x^p
Which don't work as I want to. If I modify myFunc to:
myFunc <- function(data, functions, ...) {
for (i in 1:length(functions)) print(apply(X=data, MARGIN=2, FUN=functions[[i]], ...))
}
functions as
functions <- list(length, sum, power)
and then try my function I get
myFunc(data, functions, p=2)
Error in FUN(newX[, i], ...) :
2 arguments passed to 'length' which requires 1
How may I solve this issue?
Sorry for the wall of text. Thank you!
You can use Curry from functional to fix the parameter you want, put the function in the list of function you want to apply and finally iterate over this list of functions:
library(functional)
power <- function(x, p) x^p
funcs = list(length, sum, Curry(power, p=2), Curry(power, p=3))
lapply(funcs, function(f) apply(data, 2 , f))
With your code you can use:
functions <- list(length, sum, Curry(power, p=2))
myFunc(data, functions)
I'd advocate using Colonel's Curry approach, but if you want to stick to base R you can always:
funcs <- list(length, sum, function(x) power(x, 2))
which is roughly what Curry ends up doing
One option is to pass the parameters in a list with the arguments needed for each function. You can add those parameters to the others needed for apply using c and then use do.call to call the function. Something like this. I also wrap all the output in a list here rather than using print; your usage may vary.
power <- function(x, p) x^p
myFunc <- function(data, functions, parameters) {
lapply(seq_along(functions), function(i) {
p0 <- list(X=data, MARGIN=2, FUN=functions[[i]])
do.call(apply, c(p0, parameters[[i]]))
})
}
d <- matrix(1:6, nrow=2)
functions <- list(length, sum, power)
parameters <- list(NULL, NULL, p=3)
myFunc(d, functions, parameters)
You can use lazyeval package:
library(lazyeval)
my_evaluate <- function(data, expressions, ...) {
lapply(expressions, function(e) {
apply(data, MARGIN=2, FUN=function(x) {
lazy_eval(e, c(list(x=x), list(...)))
})
})
}
And use it like this:
my_expressions <- lazy_dots(sum = sum(x), sumpow = sum(x^p), length_k = length(x)*k )
data <- cbind(rnorm(100), rnorm(100))
my_evaluate(data, my_expressions, p = 2, k = 2)
I would like to write a wrapper function for two functions that take optional arguments.
Here is an example of a function fun to wrap funA and funB
funA <- function(x = 1, y = 1) return(x+y)
funB <- function(z = c(1, 1) return(sum(z))
fun <- function(x, y, z)
I would like fun to return x+y if x and y are provided, and sum(z) if a vector z is provided.
I have tried to see how the lm function takes such optional arguments, but it is not clear exactly how, e.g., match.call is being used here.
After finding related questions (e.g. How to use R's ellipsis feature when writing your own function? and using substitute to get argument name with )), I have come up with a workable solution.
My solution has just been to use
fun <- function(...){
inputs <- list(...)
if (all(c("x", "y") %in% inputs){
ans <- funA(x, y)
} else if ("z" %in% inputs){
ans <- funB(z)
}
Is there a better way?
Note: Perhaps this question can be closed as a duplicate, but hopefully it can serve a purpose in guiding other users to a good solution: it would have been helpful to have expanded my search to variously include ellipsis, substitute, in addition to match.call.
Use missing. This returns funA(x, y) if both x and y are provided and returns funB if they are not but z is provided and if none of them are provided it returns NULL:
fun <- function(x, y, z) {
if (!missing(x) && !missing(y)) {
funA(x, y)
}
else if (!missing(z)) {
funB(z)
}
This seems to answer your question as stated but note that the default arguments in funA and funB are never used so perhaps you really wanted something different?
Note the fun that is provided in the question only works if the arguments are named whereas the fun here works even if they are provided positionally.
I would something like for example this using match.call. This is similar to your solution but more robust.
fun <- function(...){
arg <- as.list(match.call())[-1]
f <- ifelse(length(arg)>1,"funA","funB")
do.call(f,arg)
}
fun(x=1,y=2) ## or fun(1,2) no need to give named arguments
[1] 3
> fun(z=1:10) ## fun(1:10)
[1] 55