This would seem to be an elementary question, but I can't seem to find an answer on stackoverflow.
How can I obtain the following effect:
f <- function(x = 1){x^2}
miracle(f)
[1] "x^2"
The context is a shiny app (package by RStudio) in which I have a textInput() function to which I supply an initial value x^2. While this works:
textInput(inputId = "inFun", label = h4("Enter a function:"), value = "x^2")
this doesn't:
textInput(inputId = "inFun", label = h4("Enter a function:"), value = f)
It appears that I need something like "x^2" on the rhs of value.
Below is a representative sample of several variations I have tried:
eval(parse(text = f))
Error in as.character(x) :
cannot coerce type 'closure' to vector of type 'character'
f(x = "x")
Error in x^2 : non-numeric argument to binary operator
`f`
function(x){x^2}
f(x = `x`)
Error in f(x = x) : object 'x' not found
Is there a built-in function for this?
I'd like to answer my own question, based on Roman Luštrik's comment, to invite suggestions for improvements rather than raising my meagre tally of "points".
Roman suggested the function body(), which I had never heard of. Here is what body() does to f:
f <- function(x = 1){x^2}
> body(f)
{
x^2
}
The curly brackets were unwanted, so I searched a little further. I managed to get rid of the curly brackets with this:
> gsub(' {2,}','',deparse(body(f))[2])
[1] "x^2"
The above, therefore, answers my own question. But is there a more elegant and shorter way?
Following Roman's suggestion to use body(), I came across this outstanding answer by joran, hadley, and several others, which provided me with a template:
How to create an R function programmatically?
There it explains how to create a function programmatically from an argument list, a body and an environment. I therefore decided to construct my function f with these 3 primitives and to call the body from inside shiny's textInput.
So I put this in my global.R file (the small-cap g is shorthand for global)
# Convenience function
make.function <- function(args = alist(a = 1, b = 2), body = quote(a + b),
env = parent.frame()) {
subs <- list(args = as.pairlist(args), body = body)
eval(substitute(`function`(args, body), subs), env)
}
gArg <- alist(a = 1, b = 2)
gBody <- quote(a + b)
gFun <- make.function(gArg, gBody)
Then in my server.R file, I have:
textInput(inputId = "inFun", label = h4("1. Enter a function:"),
value = deparse(body(gFun)))
And it works!
I was planning to write value = gBody or something to that effect, but my first success came with deparse(body(gFun)), so that's what I'm using now.
The use of make.function to produce a 'static' function in global.R is of course overkill, but I'm using make.function elsewhere inside server.R to process the user-supplied arguments and body to create new functions and plot them, so it's a very useful function to have.
Thanks Roman: if you write your own answer I'll accept yours.
Related
I will use the following example to explain my question. But the question is not only about this specific example, but more general about meta-programming in R.
I have two specific functions to make plots
Specific function 1
draw_hists <- function(dts, indexs, title_prefix = 'sd = ') {
mapply(
function(dt, index)
{
hist(dt, main = paste(title_prefix, as.character(index)))
},
dts, indexs
)
}
plots histograms
sds <- c(0.1, 0.5, 5, 100)
raw_normals <- purrr::map(sds, ~rnorm(500, mean = 1, sd = .x))
draw_hists(raw_normals, sds)
Specific function 2
plots scatter plots of percentage ranks against raw data
draw_percentage <- function(dts, indexs, title_prefix = 'sd = ') {
mapply(
function(dt, index)
{
plot(dt, dplyr::percent_rank(dt), main = paste(title_prefix, as.character(index)))
},
dts, indexs
)
}
sds <- c(0.1, 0.5, 5, 100)
raw_normals <- purrr::map(sds, ~rnorm(500, mean = 1, sd = .x))
draw_percentage(raw_normals, sds)
Now assume I want to abstract out the general patterns of these functions and define a generic higher-order function that takes inputs of any arbitrary plotting function and its argument as an expression to be flexible enough drawing nearly whatever I want to draw. I thought something like this would work.
draw_generic <- function(dts, indexs, plfun, plfun_arguments_as_expr) {
....
}
The formal parameter plfun_arguments_as_expr would bind to an expression such like expr(dplyr::percent_rank(dt)) to make the plotting truly generic and flexible. I come up with the following solution.
draws_generic <- function(dts, indexs, plfun, title_prefix = 'sd =', ...) {
dots <- enquos(...)
mapply(
function(dt, index)
{
eval_tidy(
expr(
plfun(dt, main = paste(title_prefix, as.character(index)), !!!dots)
)
)
}
,
dts, indexs
)
}
draws_generic(raw_normals, sds, hist)
draws_generic(raw_normals, sds, plot, dplyr::percent_rank(dt))
The histogram works. But the percent_rank one gives me error
Error in x[!nas] : object of type 'closure' is not subsettable
In addition: Warning message:
In is.na(x) : is.na() applied to non-(list or vector) of type 'closure'
Called from: rank(x, ties.method = "min", na.last = "keep")
I think this might be related to the fact that the environment scope captured by enquos is global, but the expression contains a name dt for which its binding existed in local scope created by the anonymous function function(dt, index). Is this truly the reason of this error? If so, is there a neat and clean way to fix it that follows principles of "tidy evaluation"?
Update
Inspired by the comments, I modify here my question. In stead of using a pure functional abstraction to generalize procedures, what I really want is to achieve generalization by treating code as object and manipulate it freely in a R function or kind of macro programming. More precisely what I want is a draw_expression function to plot data against a given expression instead of previous draw_generic. Below are some of my attempts so far:
The 1st version plots a plotting expression with x as data argument against given data without additional indexs parameter and title. The code has been tested working.
draw_expression_1 <- function(dts, plexpr) {
plexpr <- enexpr(plexpr)
lapply(dts, eval(expr(function(x) !!plexpr)))
}
draw_expression_1(raw_normals, hist(x))
draw_expression_1(raw_normals, plot(x, dplyr::percent_rank(x))
The 2nd version adds additional indexs parameter and titles by modifying the given expression. The code has been tested working.
draw_expression_2 <- function(dts, indexs, plexpr, title_prefix = 'sd =') {
plexpr <- enexpr(plexpr)
mapply(eval(expr(function(x, index) {
UQ(rlang::call_modify(plexpr, main = quote(paste(title_prefix, as.character(index)))))
})), dts, indexs)
}
draw_expression_2(raw_normals, sds, hist(x))
draw_expression_2(raw_normals, sds, plot(x, dplyr::percent_rank(x))
The 3rd version is aimed at allowing the call expression to have any arbitrary formal parameter name instead of x. Release the assumption to be that the 1st parameter corresponds to the data to be plotted, but it can be named whatever users wished.
draw_expression_3 <- function(dts, indexs, plexpr, title_prefix = 'sd =') {
plexpr <- enexpr(plexpr)
first_arg_name <- rlang::call_args(plexpr)
mapply(eval(expr(function(first_arg_name, index) {
UQ(rlang::call_modify(plexpr, main = quote(paste(title_prefix, as.character(index)))))
})), dts, indexs)
}
draw_expression_3(raw_normals, sds, hist(x))
draw_expression_3(raw_normals, sds, plot(x, dplyr::percent_rank(x))
This prints me error:
Error in plot(x, dplyr::percent_rank(x), main = paste(title_prefix, as.character(index))) :
object 'x' not found
Apparently first_arg_name has to been unquoted in the expression. Thus I did this:
draw_expression_3 <- function(dts, indexs, plexpr, title_prefix = 'sd =') {
plexpr <- enexpr(plexpr)
first_arg_name <- rlang::call_args(plexpr)
mapply(eval(expr(function(UQ(first_arg_name), index) {
UQ(rlang::call_modify(plexpr, main = quote(paste(title_prefix, as.character(index)))))
})), dts, indexs)
}
draw_expression_3(raw_normals, sds, hist(x))
draw_expression_3(raw_normals, sds, plot(x, dplyr::percent_rank(x))
But I got weird syntax error:
Error: unexpected '}' in " }"
Now I don't understand why this happens. Any help?
Also I could not use enquo + eval_tidy here, since enquo will capture the environment of the call expression which is global, but the expression inside the function that I would like to modify and manipulate contains x which belongs to the inner scope. Thus this is not a tidy evaluation. But I am not perusing that anymore. I simply want do macro programming as freely as I can with base R plus some of convenient tools provided by rlang.
NOTE: I am not trying to do any production work. I am just trying to see the limit of this language and understand things better.
I don't know the "tidy evaluation" way to do this, but the simpler base R method is to pass a function rather than an expression. For example,
sds <- c(0.1, 0.5, 5, 100)
raw_normals <- purrr::map(sds, ~rnorm(500, mean = 1, sd = .x))
draws_generic2 <- function(dts, indexs, plfun, title_prefix = 'sd =') {
mapply(
function(dt, index)
{
plfun(dt, main = paste(title_prefix, as.character(index)))
},
dts, indexs
)
invisible(NULL)
}
par(mfrow=c(2,2))
draws_generic2(raw_normals, sds, hist)
draws_generic2(raw_normals, sds, function(dt, ...) plot(dt, dplyr::percent_rank(dt), ...))
Created on 2022-04-15 by the reprex package (v2.0.1)
I used dt in my function definition in the second example, but I could have used any variable name, e.g. this would give the same output except for the axis labels:
draws_generic2(raw_normals, sds,
function(x, ...) plot(x, dplyr::percent_rank(x), ...))
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'm trying to read a function call as a string and evaluate this function within another function. I'm using eval(parse(text = )) to evaluate the string. The function I'm calling in the string doesn't seem to have access to the environment in which it is nested. In the code below, my "isgreater" function finds the object y, defined in the global environment, but can't find the object x, defined within the function. Does anybody know why, and how to get around this? I have already tried adding the argument envir = .GlobalEnv to both of my evals, to no avail.
str <- "isgreater(y)"
isgreater <- function(y) {
return(eval(y > x))
}
y <- 4
test <- function() {
x <- 3
return(eval(parse(text = str)))
}
test()
Error:
Error in eval(y > x) : object 'x' not found
Thanks to #MrFlick and #r2evans for their useful and thought-provoking comments. As far as a solution, I've found that this code works. x must be passed into the function and cannot be a default value. In the code below, my function generates a list of results with the x variable being changed within the function. If anyone knows why this is, I would love to know.
str <- "isgreater(y, x)"
isgreater <- function(y, x) {
return(eval(y > x))
}
y <- 50
test <- function() {
list <- list()
for(i in 1:100) {
x <- i
bool <- eval(parse(text = str))
list <- append(list, bool)
}
return(list)
}
test()
After considering the points made by #r2evans, I have elected to change my approach to the problem so that I do not arrive at this string-parsing step. Thanks a lot, everyone.
I offer the following code, not as a solution, but rather as an insight into how R "works". The code does things that are quite dangerous and should only be examined for its demonstration of how to assert a value for x. Unfortunately, that assertion does destroy the x-value of 3 inside the isgreater-function:
str <- "isgreater(y)"
isgreater <- function(y) {
return(eval( y > x ))
}
y <- 4
test <- function() {
environment(isgreater)$x <- 5
return(eval(parse(text = str) ))
}
test()
#[1] FALSE
The environment<- function is used in the R6 programming paradigm. Take a look at ?R6 if you are interested in working with a more object-oriented set of structures and syntax. (I will note that when I first ran your code, there was an object named x in my workspace and some of my efforts were able to succeed to the extent of not throwing an error, but they were finding that length-10000 vector and filling up my console with logical results until I escaped the console. Yet another argument for passing both x and y to isgreater.)
I am having trouble using the call() function together with the namespace address operators :: and :::. Simply adding it to the function name as supplied for call() produces an error when the call is evaluated, as this silly example shows:
> call("base::print", "Hi there")
`base::print`("Hi there")
> eval(call("base::print", "Hi there"))
Error in `base::print`("Hi there") :
could not find function "base::print"
For some reason, call() adds backticks around the function name (probably because it contains non-standard characters), which seems to mess up everything. Here is what happens when the "address" is omitted:
> call("print", "Hi there")
print("Hi there")
> eval(call("print", "Hi there"))
[1] "Hi there"
I will very much appreciate any suggestions for how to solve this issue. Note however that I need to produce the code with call(), as I am autogenerating code for rmarkdown code chunks, and I need to be able to specify the namespace, because I am using an unexported function from my package which I would really like to stay unexported.
Thanks for reading!
Update: I neglected to mention another property of the solution I am looking for (which I became aware of by reading Stéphane Laurent's otherwise great answer below): I am looking for a solution where the function definition is not copied into the call, which I believe rules out solutions using get(). As an example of what I am trying to avoid, let's say we want to call qplot() from ggplot2. If we use e.g. getFromNamespace() the call will look like this (with the middle part of the output omitted for making it easier to read):
> as.call(list(getFromNamespace("qplot", "ggplot2"), 1:10))
(function (x, y = NULL, ..., data, facets = NULL, margins = FALSE,
geom = "auto", xlim = c(NA, NA), ylim = c(NA, NA), log = "",
main = NULL, xlab = deparse(substitute(x)), ylab = deparse(substitute(y)),
asp = NA, stat = NULL, position = NULL)
{
if (!missing(stat))
warning("`stat` is deprecated", call. = FALSE)
if (!missing(position))
warning("`position` is deprecated", call. = FALSE)
if (!is.character(geom))
stop("`geom` must be a character vector", call. = FALSE)
argnames <- names(as.list(match.call(expand.dots = FALSE)[-1]))
arguments <- as.list(match.call()[-1])
env <- parent.frame()
#### A lot more code defining the function (omitted)#####
if (!missing(xlim))
p <- p + xlim(xlim)
if (!missing(ylim))
p <- p + ylim(ylim)
p
})(1:10)
The same thing happens if we instead use as.call(list(ggplot2::qplot, 1:10)).
What I am looking for is something that produces the call ggplot2::qplot(1:10).
Maybe
> eval(as.call(list(getFromNamespace("print", "base"), "Hi there")))
[1] "Hi there"
This question differs from my original; it adheres more to a minimal reproducible example and incorporates a recommendation by be_green against silently loading entire libraries within the context of a function.
The outer function starts by defining a number of cases, default values, and a list of any case exceptions. The inner function assembles each case by using the default values in a computation unless exceptions are defined. Finally, the outer function assembles these cases into a data frame.
Here is the function:
outerfun <- function(cases, var_default, exceptions=list()){
# Inner Function to create a case
innerfun <- function(var=var_default) { # Case
result = var
return(result)
}
# Combine Cases
datlist <- list()
for(case in 1:cases){
datlist[[paste0("X",case)]] <- do.call(innerfun, as.list(exceptions[[paste0("X",case)]]))
}
casedata <- do.call(dplyr::data_frame, datlist)
return(casedata)
}
This function works fine when I define values for the inner function as exceptions:
data <- outerfun(cases = 3, var_default = 10, exceptions = list("X2" = c(var = 14)))
But not when I mix the two:
data <- outerfun(cases = 3, var_default = 10, exceptions =
list("X2" = c(var = var_default + 4)))
Being able to mix the two are important since it makes the function more intuitive and easier to program for a variety of cases.
I think the problem might result from using do.call and have seen other threads detailing this issue (having to do with environments and frames), but I haven't been able to find an optimal solution for me. I like do.call since I can pass a list of arguments into a function. I could turn the inner function into a list (think: function(...) { }) but then I would have to define every variable instead of relying on the default.
Any help or suggestions you might have would be great.
The problem is that lvl_default is not defined outside the context of the function, and yet you call it as an input to a parameter. Because there is no variable called lvl_default in the global environment, when the function tries to evaluate the parameter exceptions = list(X3 - c(lvl = lvl_default + 10), it fails to find a variable to evaluate. You are not able to specify parameters by setting them equal to the names of other unevaluated parameters.
Instead, what I would recommend doing is setting a variable outside the function associated with the value you were hoping to pass into lvl_default and then pass it into the function like so:
level <- 1000
data <- genCaseData(n_signals = 3, datestart = "2017-07-01T15:00:00",
n_cycles = 4, period_default = 10, phase_default = 0, ampl_default = 15,
lvl_default = level, exceptions = list(X1= c(lvl=980),
X3 = c(lvl = level + 10)))
Also as I noted in a comment, I would recommend against silently loading entire libraries within the context of a function. You can end up masking things you didn't mean to, and running into strange errors because the require call doesn't actually throw one if a library is unavailable. Instead I would reference the functions through pkgname::fncname.
be_green did solve this first, but I wanted to follow-up with what I actually did for my project.
As be_green pointed out, I couldn't call var_default within the exception list since it hadn't yet been defined. I didn't understand this at first since you can actually define the default of an argument to a variable defined within the function itself:
addfun <- function(x, y = z + x + 2) {
z = 20
c(x, y)
}
addfun(x = 20)
[1] 20 42
This is because function arguments in R lazily evaluated. I thought this gave me a pass to call the function like this:
addfun(x = 10, y = x + z)
Error in addfun(x = 10, y = x + z) : object 'x' not found
If you remove x then it calls an error for z. So even though the default to y is dependent on x and z, you can't call the function using x or z.
be_green suggested that I pass arguments in a string and then parse it within the function. But I was afraid that others on my team would find the resulting syntax confusing.
Instead, I used ellipsis (...) and evaluated the ellipsis arguments within my function. I did this using this line of code:
list2env(eval(substitute(alist(...))), envir = as.environment(-1))
Here the eval(substitute(alist(...))) pattern is common but results in a named list of arguments. Due to some other features, it becomes more convenient to evaluate the arguments as objects within the function. list2env(x, envir = as.environment(-1)) accomplishes this with an additional step. Once the argument is called, you need to explicitly evaluate the call. So if I wanted to change my addfun() above:
addfun <- function(x, ...) {
z = 20
list2env(eval(substitute(alist(...))),
envir = as.environment(-1))
c(x, eval(y))
}
addfun(x = 10, y = x + z)
This is a trite example: I now need to define y even though it's not an argument in the function. But now I can even re-define z within the function call:
addfun(x = 10, y = z + 2, z = 10)
This is all possible because of non-standard evaluation. There can be trade-offs but in my application of non-standard evaluation, I was able to increase the usability and flexibility of the function while making it more intuitive to use.
Final code:
outerfun <- function(caseIDs, var_default, ...){
list2env(eval(substitute(alist(...))), envir = as.environment(-1))
# Inner Function to create a case
innerfun <- function(var=var_default) { # Case
result = var
return(result)
}
# Combine Cases
datlist <- lapply(caseIDs, function(case) {
do.call(innerfun, eval(get0(case, ifnotfound = list())))
})
names(datlist) <- caseIDs
casedata <- do.call(dplyr::data_frame, datlist)
return(casedata)
}
Now both examples work with full functionality:
data <- outerfun(caseIDs = c("X1","X2","X3"), var_default = 10,
X2 = list(var = 14))
data <- outerfun(caseIDs = c("X1","X2","X3"), var_default = 10,
X2 = list(var = var_default + 4))
I hope this helps someone else! Enjoy!