Related
Part of a custom function I am trying to create allows the user to provide a function as a parameter. For example
#Custom function
result <- function(.func){
do.call(.func, list(x,y))
}
#Data
x <- 1:2
y <- 0:1
#Call function
result(.func = function(x,y){ sum(x, y) })
However, the code above assumes that the user is providing a function with arguments x and y. Is there a way to use do.call (or something similar) so that the user can provide a function with different arguments? I think that the correct solution might be along the lines of:
#Custom function
result <- function(.func){
do.call(.func, formals(.func))
}
#Data
m <- 1:3
n <- 0:2
x <- 1:2
y <- 0:1
z <- c(4,6)
#Call function
result(.func = function(m,n){ sum(m, n) })
result(.func = function(x,y,z){ sum(x,y,z) })
But this is not it.
1) Use formals/names/mget to get the values in a list. An optional argument, envir, will allow the user to specify the environment that the variables are located in so it knows where to look. The default if not specified is the parent frame, i.e. the caller.
result1 <- function(.func, envir = parent.frame()) {
do.call(.func, mget(names(formals(.func)), envir))
}
m <- 1:3
n <- 0:2
x <- 1:2
y <- 0:1
z <- c(4,6)
result1(.func = function(m,n) sum(m, n) )
## [1] 9
result1(.func = function(x,y,z) sum(x,y,z) )
## [1] 14
result1(function(Time, demand) Time + demand, list2env(BOD))
## [1] 9.3 12.3 22.0 20.0 20.6 26.8
1a) Another possibility is to evaluate the body. This also works if envir is specified as a data frame whose columns are to be looked up.
result1a <- function(.func, envir = parent.frame()) {
eval(body(.func), envir)
}
result1a(.func = function(m,n) sum(m, n) )
## [1] 9
result1a(.func = function(x,y,z) sum(x,y,z) )
## [1] 14
result1a(function(Time, demand) Time + demand, BOD)
## [1] 9.3 12.3 22.0 20.0 20.6 26.8
2) Another design which is even simpler is to provide a one-sided formula interface. Formulas have environments so we can use that to look up the variables.
result2 <- function(fo, envir = environment(fo)) eval(fo[[2]], envir)
result2(~ sum(m, n))
## [1] 9
result2(~ sum(x,y,z))
## [1] 14
result2(~ Time + demand, BOD)
## [1] 9.3 12.3 22.0 20.0 20.6 26.8
3) Even simpler yet is to just pass the result of the computation as an argument.
result3 <- function(x) x
result3(sum(m, n))
## [1] 9
result3(sum(x,y,z))
## [1] 14
result3(with(BOD, Time + demand))
## [1] 9.3 12.3 22.0 20.0 20.6 26.8
This works.
#Custom function
result <- function(.func){
do.call(.func, lapply(formalArgs(.func), as.name))
}
#Data
m <- 1:3
n <- 0:2
x <- 1:2
y <- 0:1
z <- c(4,6)
#Call function
result(.func = function(m,n){ sum(m, n) })
result(.func = function(x,y,z){ sum(x,y,z) })
This seems like a bit of a pointless function, since the examples in your question imply that what you are trying to do is evaluate the body of the passed function using variables in the calling environment. You can certainly do this easily enough:
result <- function(.func){
eval(body(.func), envir = parent.frame())
}
This gives the expected results from your examples:
x <- 1:2
y <- 0:1
result(.func = function(x,y){ sum(x, y) })
#> [1] 4
and
m <- 1:3
n <- 0:2
x <- 1:2
y <- 0:1
z <- c(4,6)
result(.func = function(m,n){ sum(m, n) })
#> [1] 9
result(.func = function(x,y,z){ sum(x,y,z) })
#> [1] 14
But note that, when the user types:
result(.func = function(x,y){ ...user code... })
They get the same result they would already get if they didn't use your function and simply typed
...user code....
You could argue that it would be helpful with a pre-existing function like mean.default:
x <- 1:10
na.rm <- TRUE
trim <- 0
result(mean.default)
#> [1] 5.5
But this means users have to name their variables as the parameters being passed to the function, and this is just a less convenient way of calling the function.
It might be useful if you could demonstrate a use case where what you are proposing doesn't make the user's code longer or more complex.
You could also use ..., but like the other responses, I don't quite see the value, or perhaps I don't fully understand the use-case.
result <- function(.func, ...){
do.call(.func, list(...))
}
Create function
f1 <- function(a,b) sum(a,b)
Pass f1 and values to result()
result(f1, m,n)
Output:
[1] 9
Here is how I would do it based on your clarifying comments.
Basically since you say your function will take a data.frame as input, the function you are asking for essentially just reverses the order of arguments you pass to do.call()... which takes a function, then a list of arguments. A data.frame is just a special form of list where all elements (columns) are vectors of equal length (number of rows)
result <- function(.data, .func) {
# .data is a data.frame, which is a list of argument vectors of equal length
do.call(.func, .data)
}
result(data.frame(a=1, b=1:5), function(a, b) a * b)
result(data.frame(c=1:10, d=1:10), function(c, d) c * d)
In R, running the expression x <- 1 defines a variable x in the global environment with the value 1. Doing the same within a function defines the variable within the function's environment instead.
Using rlang::with_env, we can also do the same thing with an arbitrary environment:
e <- new.env()
rlang::with_env(e, {
x <- 1
y <- 2
f <- function(x) print(x)
g <- function() f(1)
})
e$x
#> [1] 1
e$g()
#> [1] 1
Created on 2021-10-26 by the reprex package (v2.0.1)
However, I can't figure out how to do the same in a function. That is, a function which receives expressions and then runs them in a blank environment, returning the environment:
set_in_env <- function(expr) {
e <- new.env()
# q <- rlang::enquo(expr)
# z <- quote(expr)
# rlang::with_env(e, substitute(expr))
# rlang::with_env(e, parse(text = substitute(expr)))
# rlang::with_env(e, q)
# rlang::with_env(e, rlang::eval_tidy(q))
# rlang::with_env(e, z)
# rlang::with_env(e, eval(z))
rlang::with_env(e, expr)
rlang::with_env(e, {x <- 1})
return(e)
}
e <- set_in_env({y <- 2})
rlang::env_print(e)
#> <environment: 0000000014678340>
#> parent: <environment: 0000000014678730>
#> bindings:
#> * x: <dbl> <-- ONLY `x` WAS SET, NOT `y`!
That is, the function is given the expression y <- 2 which should be run in a new environment. For demonstration purposes, the function also internally sets x <- 1 in the environment.
No matter what I've tried, the environment is only created with e$x, never defining e$y <- 2 (the commented out code were other failed attempts).
I'm confident this can be done and that I'm just missing something. So, can someone give me a hand?
It's odd that the with_env function doesn't seem to allow for injecting expressions into the expression parameter. Here's a work around
set_in_env <- function(expr) {
e <- new.env()
q <- rlang::enexpr(expr)
rlang::inject(rlang::with_env(e, !!q))
rlang::with_env(e, {x <- 1})
return(e)
}
We explicltly use rlang::inject to inject the expression to the call and then inject will also evaluate it.
This could be a base solution:
set_in_env <- function(expr) {
e <- new.env()
# Resolve the given 'expr'ession as a 'call', before evaluating that call in the
# environment 'e'. Otherwise, 'expr' will first be evaluated within 'set_in_env()',
# with such consequences as described below.
eval(expr = substitute(expr), envir = e)
# ^^^^ ^^^^^^^^^^
# 'eval()' with 'substitute()'
# Avoid evaluating anything whatsoever about the 'x <- 1' assignment, until doing so
# in the environment 'e'. Otherwise, 'x <- 1' will first be evaluated within
# 'set_in_env()', and 'x' will be available in 'set_in_env()' yet unavailable in the
# environment 'e'.
evalq(expr = {x <- 1}, envir = e)
# ^^^^^
# 'evalq()' on its own
return(e)
}
When we put set_in_env() through its paces as in your question
e <- set_in_env({y <- 2})
rlang::env_print(e)
we get the desired results:
<environment: 0000013E34E1E0D0>
parent: <environment: 0000013E34E1E488>
bindings:
* x: <dbl>
* y: <dbl>
1) We can use eval/substitute like this:
f <- function(expr) {
eval(substitute({
expr
x <- 1
}), e <- new.env())
e
}
# test
e <- f( {y <- 2} )
ls(e)
## [1] "x" "y"
2) or we can reuse the environment/frame within f like this:
f <- function(expr) {
eval(substitute({
expr
x <- 1
}))
rm(expr)
environment()
}
e <- f( {y <- 2} )
ls(e)
## [1] "x" "y"
I raised this as an issue in the rlang GitHub, where among other comments (including that he intends to deprecate with_env) #lionel gave a very clean way of doing this:
library(rlang)
set_in_env <- function(expr) {
e <- env()
expr <- rlang::enexpr(expr)
rlang::eval_bare(expr, e)
return(e)
}
e <- set_in_env({y <- 2})
e$y
#> [1] 2
Created on 2021-10-27 by the reprex package (v2.0.1)
I'd actually tried eval_tidy with quosures, what I needed was eval_bare with expressions.
I would like something like that:
makeActiveBinding("f", function() {
called_as_a_function <- ... # <- insert answer here
if(called_as_a_function) {
sqrt
} else {
1
}
}, .GlobalEnv)
# Expected output
f + f
#> 2
f(4) + f
#> 3
I use f here, should work with any function
In the example above f returns 1 and f(4) returns sqrt(4). In my real use case the naked f (not f()) will return a function object, so the workaround proposed by Michal cannot be used as is.
I use + here for simplicity, but it might be any function or none, including NSE functions like quote(), so for instance quote(f) and quote(f()) should not have their input changed by the solution.
I tried to play with the sys.calls() but couldn't get anything robust.
Answers using low level code are welcome too, who knows maybe dark magic can help.
These won't be called at the top level so if you cannot make the above work but can get the following to work for instance that's good too, and in practice it won't be the .GlobalEnv so if you can make it work in another environment that's good too.
identity(f + f)
#> 2
identity(f(4) + f)
#> 3
If you have solutions that just get me closer you might post them, for instance if your solution works only if f and f() are not used in the same call it's still useful to me.
Since I was asked about the real context here it is, but solving the above is all I ask.
My package {boomer} provides a way to curry a function f by modifying its environment and populating its new enclosure with shims of every function f calls, we say that we rig f.
These shims print the calls and their outputs, but behave the same apart from side effects, so f and rigged f are expected to return the same
However if the shims are returned, or if their body is manipulated by f, the output will be unexpected
By treating shim and shim() differently I avoid the more obvious corner cases, shim() will show side effects, and shim would return the original function.
The issue is here and package in action is showed here
And also tbh I'm generally curious about if it's possible.
One trick that comes to my mind is to create two nested environments, one being a parent of another and each having a different definition of f. Then you can evaluate f + f() in the "child" and it will work:
e1 <- new.env()
e2 <- new.env(parent = e1)
assign("f", sqrt, envir = e1)
assign("f", 1, envir = e2)
eval(expression(f + f(4)), envir=e2)
#> [1] 3
Here is a method using the walkast package. It essentially replaces function objects named f with f_fun.
f_fun <- sqrt
f <- 1
evaluate <- function(expr) {
expr <- substitute(expr)
eval(
walkast::walk_ast(
expr,
walkast::make_visitor(
hd = function(fun) {
if (all.names(fun) == "f") {
f_fun
} else {
fun
}
}
)
)
)
}
Expressions need to be wrapped in evaluate.
evaluate(f + f(4))
#> 3
evaluate(f + f)
#> 2
evaluate(f(f + f(9)) + f(4))
#> 4
Although this doesn't follow the exact approach you suggested (somehow finding out how the function was called), this trick using attributes and a custom S3 class can be used to produce the intended behaviour:
# Define a function and give it a special class
f <- function(x) sqrt(x)
class(f) <- "fancy"
# Add a 'value' attribute
attr(f, "value") <- 1
# Now define addition for our class to use the 'value' attribute
`+.fancy` <- function(x, y) {
x_val <- if ("fancy" %in% class(x)) attr(x, "value") else x
y_val <- if ("fancy" %in% class(y)) attr(y, "value") else y
x_val + y_val
}
# Seems to work as intended
f + f
#> [1] 2
f(4) + 1
#> [1] 3
TL; DR If this is not too much of an assumption, then I would decide it through humility f = f () And with using a parameter with a default value. It seems to me that this is the simplest solution of the proposed ones.
I know for sure that this is easily achieved in JS, since there is such a method on an object as valueOf.
function f(n){
return Math.sqrt(n)
}
f.valueOf = f.toString = function valueOf(){return 1}
console.log('f(4) =', f(4))
console.log('f + f(4) =', f + f(4))
console.log('f =', f)
console.log('f + f =', f + f)
But unfortunately in R, as far as I know, there is no such method.
default_value <- function(){
1 # I use the function instead value
}
# just for an example of change f = 1 to f = 1 + size
increment <- function(size = 1){
temp <- default_value() + size
default_value <<- function(){
temp # use closure instead infinite recursion
}
0 # without effect in calulations (if it's necessary)
}
f2 <- sqrt
f1 <- function(value = default_value()){
if (value != default_value()){
result <- f2(value) # sqrt
} else {
result <- value # 1
}
}
#--------------------------------------------------------------
assign("f", f1) # just as alias if it's necessary
eval(f() + f(4))
#> 3
eval(f() + f())
#> 2
eval(f(f() + f(9)) + f(4))
#> 4
eval(increment(1) + f(f() + f(9)) + f(4)) # sqrt(5) == 2.236068
#> 4.236068
eval(f())
#> 2
eval(increment(-1) + f(f() + f(9)) + f(4)) # use decrement
#> 4
As you mentioned that solution of type f2(f + f(1)) might work, I decided to contribute this not very elegant but "seems to be working" solution.
TL;DR: convert code to string, parse, get more data with getParseData(), replace target variable depending on if it is a simple symbol or called as function, evaluate new code string in proper environment.
Notes:
This is currently designed to replace only one target variable at a time. If multiple replacements are needed, consecutive calls to replace_in_code() should do the trick.
If you want to only replace target when it is called as function, tweaks in is_target and replacement definition should be fairly straightforward.
I decided to evaluate new code string in a most simple way, but maybe more complicated environment creation might be needed in your case.
replace_and_eval <- function(code_block, target_var, value, fun) {
# Replace variable `target_var` with `value` variable if it is a simple
# symbol and with `fun` if it is called as function
code <- replace_in_code(
code_string = substitute(code_block),
target_var = target_var,
value_var = "value",
fun_var = "fun"
)
# Evaluate in current environment
eval(parse(text = code))
}
replace_in_code <- function(code_string, target_var, value_var, fun_var) {
# Parse code string
parsed <- parse(text = code_string, keep.source = TRUE)
ast <- utils::getParseData(parsed)
# Find any relevant tokens
is_target <- (ast[["text"]] == target_var) &
(ast[["token"]] %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"))
if (!any(is_target)) {
return(code_string)
}
# Prepare data for replacements
target_ast <- ast[is_target, ]
replacement <- ifelse(target_ast[["token"]] == "SYMBOL", value_var, fun_var)
line1 <- target_ast[["line1"]]
col1 <- target_ast[["col1"]]
col2 <- target_ast[["col2"]]
# Get actual lines of code which should be updated ("srcfile" is a source of
# a parsed code)
lines <- getSrcLines(attr(parsed, "srcfile"), 1, max(ast[["line2"]]))
# Make replacements from the end to respect updating `lines` in place
for (i in order(line1, col1, decreasing = TRUE)) {
l_num <- line1[i]
l <- lines[l_num]
lines[l_num] <- paste0(
substr(l, 0, col1[i] - 1),
replacement[i],
substr(l, col2[i] + 1, nchar(l))
)
}
paste0(lines, collapse = "\n")
}
# Tests
replace_and_eval(quote(f + f(4)), "f", value = 10, fun = sqrt)
#> [1] 12
replace_and_eval(quote(list(f, f(4), f)), "f", value = stats::dnorm, fun = sqrt)
#> [[1]]
#> function (x, mean = 0, sd = 1, log = FALSE)
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>
#>
#> [[2]]
#> [1] 2
#>
#> [[3]]
#> function (x, mean = 0, sd = 1, log = FALSE)
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>
## Bizarre target variable
replace_and_eval(quote(data.frame + data.frame(4)), "data.frame", 10, sqrt)
#> [1] 12
## Multiline code block with "tricky" code
replace_and_eval(
code_block = quote({
# Should print 1
print(nchar("f"))
# There is also f in comment, but it won't be quoted
print(f)
print(f(4))
}),
target_var = "f",
value = "Hello",
fun = sqrt
)
#> [1] 1
#> [1] "Hello"
#> [1] 2
## Evaluation is in proper environment
fun <- function(value = 1000, fun = -1000) {
replace_and_eval(
code_block = quote(list(f, f(4))),
target_var = "f",
value = stats::dnorm,
fun = sqrt
)
}
fun()
#> [[1]]
#> function (x, mean = 0, sd = 1, log = FALSE)
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>
#>
#> [[2]]
#> [1] 2
Created on 2021-06-27 by the reprex package (v2.0.0)
I would suggest using R6 package for this problem. An example:
SQRT <- R6::R6Class(
classname = "SQRT",
public = list(
f = function(x = NULL) {
if(is.null(x)){
return(1)
} else {
return(sqrt(x))
}
}
)
);
# create a new instence
env <- SQRT$new();
# call public methods
env$f() + env$f(4);
#> [1] 3
env$f() + env$f(16) + env$f(4)
#> [1] 7
For more details on R6.
In the interest of the idea of f2(f + f(4)), here is an attempt:
f = function() {
print("this is a weird function")
}
main = function(x) {
xsub = substitute(x)
## short circuit if user entered main(f)
if (is.name(xsub) && as.character(xsub) == 'f')
return (f)
else
xsub = parser(xsub)
eval(xsub, list(f = 1))
}
parser = function(e) {
## largely taken from data.table:::replace_dot_alias
if (is.call(e)) {
if (e[[1L]] == 'f') e[[1L]] = quote(sqrt)
## recursively parse deeper into expression for more replacement
for (i in seq_along(e)[-1L]) if (!is.null(e[[i]])) e[[i]] = parser(e[[i]])
}
return(e)
}
main(f)
#> function() {
#> print("this is a weird function")
#> }
main(f(4) + f)
#> [1] 3
main(f + f)
#> [1] 2
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
To extend the usability of a R function, we need to pass an argument of type function (FUN), Could you please demonstrate how to declare a function parameter inside in another function and how to call it. Like
MyOperation <- function(x, y, FUN){
int sum <- x+y
if (!missing(FUN)) sum<-FUN(sum)}
return sum
}
Res <- MyOperation(x=1, y=2, FUN=function(n){...})
You don't declare variables in R. Also you can specify a default value right in the formal argument list. You don't need to use missing in this situation.
This runs FUN(x + y) or returns x+y if FUN is not specified.
myOp2 <- function(x, y, FUN = identity) FUN(x + y)
myOp2(1, 2)
## [1] 3
myOp2(1, 3, sqrt)
## [1] 2
One enhancement might be to allow the function to be specified either as a function or as a character string:
myOp2a <- function(x, y, FUN = identity) {
FUN <- match.fun(FUN)
FUN(x + y)
}
myOp2a(1, 3, "sqrt")
## [1] 2
myOp2a(1, 3, sqrt)
## [1] 2
This sums x and y if FUN is not specified; otherwise, it runs FUN with the arguments x and y.
myOp3 <- function(x, y, FUN = sum) FUN(x, y)
myOp3(1, 2)
## [1] 3
myOp3(1, 2, min)
## [1] 1
You just have some basic R syntax problems there. There's no int in R, your function closing bracket was in the wrong place, return() is a function in R -- not a keyword. Check out
MyOperation<-function(x,y,FUN){
sum <- x+y
if (!missing(FUN)) sum<-FUN(sum)
return(sum)
}
MyOperation(x=1,y=2)
# [1] 3
MyOperation(x=1,y=2,FUN=function(n){n+100})
# [1] 103