Background
Function is passed as an argument to a function. The problem pertains to:
getting the name of that function as a string for convenient subsequent manipulation
locating that function within the package from which is called
understanding :: and ::: calls
Example
Function fun_tst executes function FUN on x:
fun_tst <- function(x = 1:100, FUN = mean) {
return(FUN(x))
}
mean
fun_tst()
# [1] 50.5
sum
fun_tst(x = 1:1e3, FUN = sum)
# [1] 500500
Problem
fun_tst <- function(x = 1:100, FUN = mean) {
msg <- paste("Executing function", FUN)
print(msg)
return(FUN(x))
}
fun_tst(x = 1:1e3, FUN = sum)
Error in paste("Executing function", FUN) : cannot coerce type
'builtin' to vector of type 'character'
Attempts
1)
Interestingly, print can handle FUN object but results return function body.
fun_tst <- function(x = 1:100, FUN = mean) {
print(FUN)
return(FUN(x))
}
fun_tst(x = 1:1e3, FUN = sum)
function (..., na.rm = FALSE) .Primitive("sum") [1] 500500
2) subsitute
fun_tst <- function(x = 1:100, FUN = mean) {
fun_name <- substitute(FUN)
msg <- paste("Executing function", fun_name, collapse = " ")
print(msg)
return(FUN(x))
}
fun_tst(x = 1:1e3, FUN = sum)
>> fun_tst(x = 1:1e3, FUN = sum)
[1] "Executing function sum"
[1] 500500
Almost there but it looks like a total mess when used with :: as in:
>> fun_tst(x = 1:1e3, FUN = dplyr::glimpse)
[1] "Executing function :: Executing function dplyr Executing function glimpse"
int [1:1000] 1 2 3 4 5 6 7 8 9 10 ..
Desired results
fun_tst(x = 1:1e3, FUN = dplyr::glimpse)
# Executing function glimpse from package dplyr
int [1:1000] 1 2 3 4 5 6 7 8 9 10 ...
fun_tst(x = 1:1e3, FUN = sum)
# Executing function sum from package base
You're almost there with your second try (using substitute). The problem comes from the way R converts language objects to character:
> as.character(substitute(dplyr::glimpse))
[1] "::" "dplyr" "glimpse"
Given this, it's not surprising that paste mangles it that way. I would fix this just by handling the two cases separately:
fun_tst <- function(x = 1:100, FUN = mean) {
fun_name <- substitute(FUN)
if (length(fun_name) == 1) {
msg <- paste("Executing function", fun_name, "from package base")
} else {
msg <- paste("Executing function", fun_name[3], "from package", fun_name[2])
}
print(msg)
return(FUN(x))
}
This works on both of your examples:
> fun_tst(x = 1:1e3, FUN = sum)
[1] "Executing function sum from package base"
[1] 500500
> fun_tst(x = 1:1e3, FUN = dplyr::glimpse)
[1] "Executing function glimpse from package dplyr"
int [1:1000] 1 2 3 4 5 6 7 8 9 10 ...
However, as written, it will think all functions in the global environment are from base, even if they're user-defined or introduced with a library call. If this is your use case, don't explicitly say "from package base".
If you use deparse() and substitute you'll get the desired output, see a similar post on passing variable names to plot(), https://stackoverflow.com/a/9666650/1993932.
fun_tst <- function(x = 1:100, FUN = mean) {
message(paste("Executing function",deparse(substitute(FUN))))
return((FUN(x)))
}
> fun_tst(x = 1:1e3, FUN = sum)
Executing function sum
[1] 500500
> fun_tst(x = 1:1e3, FUN = dplyr::glimpse)
Executing function dplyr::glimpse
int [1:1000] 1 2 3 4 5 6 7 8 9 10 ...
If you rather want the message as a character vector, replace message with print.
Related
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
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
I would like to replace the LHS of "=" in a expression in R. In my personal case, I need it to make sure the following creates a variable that does not already exist in the data frame
df %>% mutate(v = mean(w))
I tried eval(substitute()) but the LHS is not substituted
eval(substitute(df %>% mutate(v = mean(w)), list(v = as.name("id"))))
#similarly in a list
eval(substitute(l <- list(v=1:10),list(v=as.name("id"))))
l
$v
[1] 1 2 3 4 5 6 7 8 9 10
Why can't v substituted throught eval/substitute? What's the best way to work around it?
1) eval/parse Create a cmd string, parse it and evaluate it:
f2 <- function(DF, x, env = parent.frame()){
cmd <- sprintf("mutate(%s, %s = mean(v1))", deparse(substitute(DF)), x)
eval(parse(text = cmd), env)
}
f2(DF, "v1_name")
giving
v1 v1_mean
1 1 2
2 2 2
3 3 2
... etc ...
2) eval/as.call Another way is to construct a list, convert it to a call and evaluate it. (This is also the approach that mutate_each_q in dplyr takes.)
f3 <- function(DF, x, env = parent.frame()) {
L <- list(quote(mutate), .data = substitute(DF), quote(mean(v1)))
names(L)[3] <- x
eval(as.call(L), env)
}
f3(DF, "v1_name")
3) do.call We form a list equal to the last two components of the list in the prior solution and then use do.call :
f3 <- function(DF, x, env = parent.frame()) {
L <- list(.data = substitute(DF), quote(mean(v1)))
names(L)[2] <- x
do.call(mutate, L)
}
f3(DF, "v1_name")
Upodate Added additional solutions.
Take the following data frame and vector,
df <- data.frame(x = 1:3, y = 4:6, z = 7:9)
v <- c(5, 10, 15)
Assume I want to multiply df columnwise by the elements of v, meaning df[1] * v[1], df[2] * v[2], and df[3] * v[3]
I can do this with Map
> Map(`*`, df, v)
$x
[1] 5 10 15
$y
[1] 40 50 60
$z
[1] 105 120 135
Now, since Map is defined as
> Map
function (f, ...)
{
f <- match.fun(f)
mapply(FUN = f, ..., SIMPLIFY = FALSE)
}
<bytecode: 0x3950e00>
<environment: namespace:base>
it seems logical that I should be able to reproduce the above exactly with the following call to mapply, but this is not the case.
> mapply(`*`, df, v, simplify = FALSE)
# Error in .Primitive("*")(dots[[1L]][[1L]], dots[[2L]][[1L]],
# simplify = dots[[3L]][[1L]]) : operator needs one or two arguments
The problem seems to be within the arguments of "*", and those arguments are
> args("*")
function (e1, e2)
NULL
So two more tries yield similar errors.
> mapply(`*`, e1 = df, e2 = v, simplify = FALSE)
# Error in .Primitive("*")(e1 = dots[[1L]][[1L]], e2 = dots[[2L]][[1L]], :
# operator needs one or two arguments
> mapply(`*`, ..1 = df, ..2 = v, simplify = FALSE)
# Error in .Primitive("*")(..1 = dots[[1L]][[1L]], ..2 = dots[[2L]][[1L]], :
# operator needs one or two arguments
What is the issue here? And how can I reproduce (exactly) the result from
Map(`*`, df, v)
with mapply?
Notice that Map calls
mapply(FUN = f, ..., SIMPLIFY = FALSE)
not
mapply(FUN = f, ..., simplify = FALSE)
and of course R is case sensitive. Try
mapply(`*`, df, v, SIMPLIFY = FALSE)
# $x
# [1] 5 10 15
#
# $y
# [1] 40 50 60
#
# $z
# [1] 105 120 135
instead. With simplify = FALSE, it's trying to call
`*`(df[[1]], v[1], simplify = FALSE)
which is what is giving that error.
V1: Suppose functions f(x, ...) and g(x , ...) can be passed different arguments. If I were to define a new function using both of them, can I make the passing of arguments via the ... operator well-defined? As a simple example:
f1 = function(x, n = 1) x + n
g1 = function(x, m = 1) x + m
f = function(x, ...) f1(x, ...)
g = function(x, ...) g1(x, ...)
h = function(x, ...) {
fgList = list()
fgList[["f"]] = f(x, ...)
fgList[["g"]] = g(x, ...)
return(fgList)
}
h(1:4)
# $f
# [1] 2 3 4 5
# $g
# [1] 2 3 4 5
h(1:4, n = 2)
# Error in g1(x, ...) : unused argument (n = 2)
The argument n is being passed down to functions f and g, but it is only well-defined for function f. I want to mitigate against this.
V2: If they are functions that I have defined, then Hong Ooi's solution below works perfectly.
Can this solution be extended for pre-defined functions which don't have a ... argument or equivalently, can a ... argument be 'added' to a predefined function which doesn't have one? For example:
h = function(x, ...) mean(x, ...) * median (x, ...)
h(1:4, test = 1)
## Error in median(x, ...) : unused argument (test = 1)
You can't have multiple versions of ... in the one environment. What you can do, however, is give each of your called sub-functions a ... argument of their own. This means they will ignore any parameters passed down that don't match their own formal arguments.
f1 = function(x, n = 1, ...) x + n
g1 = function(x, m = 1, ...) x + m
> h(1:4, n = 2)
$f
[1] 3 4 5 6
$g
[1] 2 3 4 5
Edit to answer added question: you can make a new version of median, which will override the predefined function when you call it in your own code. (Due to how R namespaces work, other predefined functions will still use the existing version.)
median <- function(x, na.rm=FALSE, ...)
base::median(x, na.rm) # function median exported from base package