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
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
We can use append function to add element to list. For example like blow.
a_list <- list()
a_list <- append(a_list, "a")
But I want do to like this. The append_new don't return but change the a_list.
a_list <- list()
append_new(a_list, "a")
It can be used by eval function to do this.
a_list <- list()
eval(parse(text="a_list[[1]]<-a"))
a_list
But if I want to write the function add_element_to_list.
a_list <- list()
add_element_to_list(a_list, "a")
a_list ## same as list("a")
How to write the function? This function like assign but more powerful.
The post use eval(parse(text="")) but it can not write in the custom function append_new.
Simpler:
`append<-` <- function(x, value) {
c(x, value)
}
x <- as.list(1:3)
y <- as.list(1:3)
append(x) <- y
append(x) <- "a"
print(x)
[[1]]
[1] 1
[[2]]
[1] 2
[[3]]
[1] 3
[[4]]
[1] 1
[[5]]
[1] 2
[[6]]
[1] 3
[[7]]
[1] "a"
Using evil parse:
append_new <- function(x, y){
eval(parse(text = paste0(x, "[ length(", x, ") + 1 ]<<- '", y, "'")))
}
a_list <- list()
append_new(x = "a_list", y = "a")
a_list
# [[1]]
# [1] "a"
append_new(x = "a_list", y = "b")
a_list
# [[1]]
# [1] "a"
#
# [[2]]
# [1] "b"
Perhaps something like this?
add_element_to_list <- function(this, that)
{
if(typeof(this) != "list") stop("append_new requires a list as first argument")
assign(deparse(substitute(this)),
append(this, that),
envir = parent.frame(),
inherits = TRUE)
}
a_list <- list()
add_element_to_list(a_list, "a")
a_list
#> [[1]]
#> [1] "a"
add_element_to_list(a_list, "b")
a_list
#> [[1]]
#> [1] "a"
#>
#> [[2]]
#> [1] "b"
I would be very cautious in using something like this in a package though, since it is not idiomatic R. In general, R users expect functions not to modify existing objects but to return new objects.
Of course there are some notable exceptions...
I have the following code in R:
a <- 2
evaluate <- function(x){
b <- 2*x
c <- 3*x
d <- 4*x
out <- list("b" = b, "c" = c, "d" = d)
return(out)
}
evaluate(a)
I obtain something like
$b
[1] 4
$c
[1] 6
$d
[1] 8
How can I compute something like b + c + d ?
so many options
# with
with(evaluate(a), b + c + d)
[1] 18
# unlist the unnamed output object
sum(unlist(evaluate(a)))
[1] 18
# subset a named output object
result <- evaluate(a)
result$b + result$c + result$d
[1] 18
# subset an unnamed output object
evaluate(a)$b + evaluate(a)$c + evaluate(a)$d
[1] 18
# custom function with fancy arguments
f <- function(...) {
args <- unlist(...)
sum(args)
}
f(evaluate(a))
[1] 18
Also, +1 from: #Gregor (double-bracket list subsetting)
result[["b"]] + result[["c"]] + result[["d"]]
[1] 18
In R you can access list members using $ operator, followed by member name so, in your code, for example:
result = evaluate(a)
result$b + result$c + result$d
Your function returns a list. You could return a vector and then use the sum() function to compute the sum of the elements in the vector. If you must use a list, the 'Reduce()` function can work.
l <- list(2, 3, 4)
v <- c(2,3,4)
sum(v) # returns 9
Reduce("+", l) # returns 9
Let suppose I have defined a function by f <- function(x,y,z) {...}.
I would like to be able to transform an expression calling that function into a list of the parameters called by that function; it is the opposite of the do.call function.
For example, let us say I have such a function f, and I also have a string "f(2,1,3)".
How can I transform the string "f(2,1,3)" into the list of the parameters list(x=1,y=2,z=3)?
After you've parsed your character string into an R expression, use match.call() to match supplied to formal arguments.
f <- function(x,y,z) {}
x <- "f(1,2,3)"
ee <- parse(text = x)[[1]]
cc <- match.call(match.fun(ee[[1]]), ee)
as.list(cc)[-1]
# $x
# [1] 1
#
# $y
# [1] 2
#
# $z
# [1] 3
Alternatively:
f <- function(x,y,z) {...}
s <- "f(x = 2, y = 1, z = 3)"
c <- as.list(str2lang(s))
c[-1]
# $x
# [1] 2
#
# $y
# [1] 1
#
# $z
# [1] 3
I was looking for a solution to this a while ago in order to reconstruct a function call from a string. Hopefully this will be of use to someone who is looking for a solution to a similar problem.