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.)
Related
I have a regression model (lm or glm or lmer ...) and I do fitmodel <- lm(inputs) where inputs changes inside a loop (the formula and the data). Then, if the model function does not produce any warning I want to keep fitmodel, but if I get a warning I want to update the model and I want the warning not printed, so I do fitmodel <- lm(inputs) inside tryCatch. So, if it produces a warning, inside warning = function(w){f(fitmodel)}, f(fitmodel) would be something like
fitmodel <- update(fitmodel, something suitable to do on the model)
In fact, this assignation would be inside an if-else structure in such a way that depending on the warning if(w$message satisfies something) I would adapt the suitable to do on the model inside update.
The problem is that I get Error in ... object 'fitmodel' not found. If I use withCallingHandlers with invokeRestarts, it just finishes the computation of the model with the warning without update it. If I add again fitmodel <- lm(inputs) inside something suitable to do on the model, I get the warning printed; now I think I could try suppresswarnings(fitmodel <- lm(inputs)), but yet I think it is not an elegant solution, since I have to add 2 times the line fitmodel <- lm(inputs), making 2 times all the computation (inside expr and inside warning).
Summarising, what I would like but fails is:
tryCatch(expr = {fitmodel <- lm(inputs)},
warning = function(w) {if (w$message satisfies something) {
fitmodel <- update(fitmodel, something suitable to do on the model)
} else if (w$message satisfies something2){
fitmodel <- update(fitmodel, something2 suitable to do on the model)
}
}
)
What can I do?
The loop part of the question is because I thought it like follows (maybe is another question, but for the moment I leave it here): it can happen that after the update I get another warning, so I would do something like while(get a warning on update){update}; in some way, this update inside warning should be understood also as expr. Is something like this possible?
Thank you very much!
Generic version of the question with minimal example:
Let's say I have a tryCatch(expr = {result <- operations}, warning = function(w){f(...)} and if I get a warning in expr (produced in fact in operations) I want to do something with result, so I would do warning = function(w){f(result)}, but then I get Error in ... object 'result' not found.
A minimal example:
y <- "a"
tryCatch(expr = {x <- as.numeric(y)},
warning = function(w) {print(x)})
Error in ... object 'x' not found
I tried using withCallingHandlers instead of tryCatch without success, and also using invokeRestart but it does the expression part, not what I want to do when I get a warning.
Could you help me?
Thank you!
The problem, fundamentally, is that the handler is called before the assignment happens. And even if that weren’t the case, the handler runs in a different scope than the tryCatch expression, so the handler can’t access the names in the other scope.
We need to separate the handling from the value transformation.
For errors (but not warnings), base R provides the function try, which wraps tryCatch to achieve this effect. However, using try is discouraged, because its return type is unsound.1 As mentioned in the answer by ekoam, ‘purrr’ provides soundly typed functional wrappers (e.g. safely) to achieve a similar effect.
However, we can also build our own, which might be a better fit in this situation:
with_warning = function (expr) {
self = environment()
warning = NULL
result = withCallingHandlers(expr, warning = function (w) {
self$warning = w
tryInvokeRestart('muffleWarning')
})
list(result = result, warning = warning)
}
This gives us a wrapper that distinguishes between the result value and a warning. We can now use it to implement your requirement:
fitmodel = with(with_warning(lm(inputs)), {
if (! is.null(warning)) {
if (conditionMessage(warning) satisfies something) {
update(result, something suitable to do on the model)
} else {
update(result, something2 suitable to do on the model)
}
} else {
result
}
})
1 What this means is that try’s return type doesn’t distinguish between an error and a non-error value of type try-error. This is a real situation that can occur, for example, when nesting multiple try calls.
It seems that you are looking for a functional wrapper that captures both the returned value and side effects of a function call. I think purrr::quietly is a perfect candidate for this kind of task. Consider something like this
quietly <- purrr::quietly
foo <- function(x) {
if (x < 3)
warning(x, " is less than 3")
if (x < 4)
warning(x, " is less than 4")
x
}
update_foo <- function(x, y) {
x <- x + y
foo(x)
}
keep_doing <- function(inputs) {
out <- quietly(foo)(inputs)
repeat {
if (length(out$warnings) < 1L)
return(out$result)
cat(paste0(out$warnings, collapse = ", "), "\n")
# This is for you to see the process. You can delete this line.
if (grepl("less than 3", out$warnings[[1L]])) {
out <- quietly(update_foo)(out$result, 1.5)
} else if (grepl("less than 4", out$warnings[[1L]])) {
out <- quietly(update_foo)(out$result, 1)
}
}
}
Output
> keep_doing(1)
1 is less than 3, 1 is less than 4
2.5 is less than 3, 2.5 is less than 4
[1] 4
> keep_doing(3)
3 is less than 4
[1] 4
Are you looking for something like the following? If it is run with y <- "123", the "OK" message will be printed.
y <- "a"
#y <- "123"
x <- tryCatch(as.numeric(y),
warning = function(w) w
)
if(inherits(x, "warning")){
message(x$message)
} else{
message(paste("OK:", x))
}
It's easier to test several argument values with the code above rewritten as a function.
testWarning <- function(x){
out <- tryCatch(as.numeric(x),
warning = function(w) w
)
if(inherits(out, "warning")){
message(out$message)
} else{
message(paste("OK:", out))
}
invisible(out)
}
testWarning("a")
#NAs introduced by coercion
testWarning("123")
#OK: 123
Maybe you could assign x again in the handling condition?
tryCatch(
warning = function(cnd) {
x <- suppressWarnings(as.numeric(y))
print(x)},
expr = {x <- as.numeric(y)}
)
#> [1] NA
Perhaps not the most elegant answer, but solves your toy example.
Don't put the assignment in the tryCatch call, put it outside. For example,
y <- "a"
x <- tryCatch(expr = {as.numeric(y)},
warning = function(w) {y})
This assigns y to x, but you could put anything in the warning body, and the result will be assigned to x.
Your "what I would like" example is more complicated, because you want access to the expr value, but it hasn't been assigned anywhere at the time the warning is generated. I think you'll have to recalculate it:
fitmodel <- tryCatch(expr = {lm(inputs)},
warning = function(w) {if (w$message satisfies something) {
update(lm(inputs), something suitable to do on the model)
} else if (w$message satisfies something2){
update(lm(inputs), something2 suitable to do on the model)
}
}
)
Edited to add:
To allow the evaluation to proceed to completion before processing the warning, you can't use tryCatch. The evaluate package has a function (also called evaluate) that can do this. For example,
y <- "a"
res <- evaluate::evaluate(quote(x <- as.numeric(y)))
for (i in seq_along(res)) {
if (inherits(res[[i]], "warning") &&
conditionMessage(res[[i]]) == gettext("NAs introduced by coercion",
domain = "R"))
x <- y
}
Some notes: the res list will contain lots of different things, including messages, warnings, errors, etc. My code only looks at the warnings. I used conditionMessage to extract the warning message, but
it will be translated to the local language, so you should use gettext to translate the English version of the message for comparison.
I am using a package that has 2 functions which ultimately look like the following:
pkgFun1 <- function(group) {
call <- match.call()
pkgFun2(call)
}
pkgFun2 <- function(call) {
eval(call$group)
}
If I just call pkgFun1(group = 2), it works fine. But I want to call it from a function:
myFun <- function(x) {
pkgFun1(group = x)
}
myFun(x = 2)
## Error in eval(call$group) : object 'x' not found
Is there any way to avoid this error, if I can't modify the package functions, but only myFun?
There are similar questions, such as Issue with match.call or Non-standard evaluation in a user-defined function with lapply or with in R, but my particular issue is that I can't modify the part of code containing the eval call.
It's pkgFun2 that is wrong, so I think you're out of luck without some weird contortions. It needs to pass the appropriate environment to eval(); if you can't modify it, then you can't fix it.
This hack might appear to work, but in real life it doesn't:
pkgFun1 <- function(group) {
call <- match.call()
f <- pkgFun2
environment(f) <- parent.frame()
f(call)
}
With this, you're calling a copy of pkgFun2 modified so its environment is appropriate to evaluate the call. It works in the test case, but will cause you untold grief in the future, because everything that is not local in pkgFun2 will be searched for in the wrong place. For example,
myFun <- function(x) {
eval <- function(...) print("Gotcha!")
pkgFun1(group = x)
}
myFun(x = 2)
# [1] "Gotcha!"
Best is to fix pkgFun2. Here's one fix:
pkgFun1 <- function(group) {
call <- match.call()
pkgFun2(call, parent.frame())
}
pkgFun2 <- function(call, envir) {
eval(call$group, envir = envir)
}
Edited to add: Actually, there is another hack that is not so weird that should work with your original pkgFun1 and pkgFun2. If you force the evaluation of x to happen in myFun so that pkgFun1 never sees the expression x, it should work. For example,
myFun <- function(x) {
do.call("pkgFun1", list(group = x))
}
If you do this, then after myFun(2), the pkgFun1 variable call will be pkgFun1(group = 2) and you won't get the error about 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)
So I'm changing the class of some functions that I'm building in R in order to add a description attribute and because I want to use S3 generics to handle everything for me. Basically, I have a structure like
foo <- function(x) x + 1
addFunction <- function(f, description) {
class(f) <- c("addFunction", "function")
attr(f, "description") <- description
f
}
foo <- addFunction(foo, "Add one")
and then I do stuff like
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
This works fine, but it's not that elegant. I'm wondering if it is possible to define a new class of functions such that instances of this class can be defined in a syntax similar to the function syntax. In other words, is it possible to define addFunction such that foo is generated in the following way:
foo <- addFunction(description = "Add one", x) {
x + 1
}
(or something similar, I have no strong feelings about where the attribute should be added to the function)?
Thanks for reading!
Update: I have experimented a bit more with the idea, but haven't really reached any concrete results yet - so this is just an overview of my current (updated) thoughts on the subject:
I tried the idea of just copying the function()-function, giving it a different name and then manipulating it afterwards. However, this does not work and I would love any inputs on what is happening here:
> function2 <- `function`
> identical(`function`, function2)
[1] TRUE
> function(x) x
function(x) x
> function2(x) x
Error: unexpected symbol in "function2(x) x"
> function2(x)
Error: incorrect number of arguments to "function"
As function() is a primitive function, I tried looking at the C-code defining it for more clues. I was particularly intrigued by the error message from the function2(x) call. The C-code underlying function() is
/* Declared with a variable number of args in names.c */
SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP rval, srcref;
if (TYPEOF(op) == PROMSXP) {
op = forcePromise(op);
SET_NAMED(op, 2);
}
if (length(args) < 2) WrongArgCount("function");
CheckFormals(CAR(args));
rval = mkCLOSXP(CAR(args), CADR(args), rho);
srcref = CADDR(args);
if (!isNull(srcref)) setAttrib(rval, R_SrcrefSymbol, srcref);
return rval;
}
and from this, I conclude that for some reason, at least two of the four arguments call, op, args and rho are now required. From the signature of do_function() I am guessing that the four arguments passed to do_function should be a call, a promise, a list of arguments and then maybe an environment. I tried a lot of different combinations for function2 (including setting up to two of these arguments to NULL), but I keep getting the same (new) error message:
> function2(call("sum", 2, 1), NULL, list(x=NULL), baseenv())
Error: invalid formal argument list for "function"
> function2(call("sum", 2, 1), NULL, list(x=NULL), NULL)
Error: invalid formal argument list for "function"
This error message is returned from the C-function CheckFormals(), which I also looked up:
/* used in coerce.c */
void attribute_hidden CheckFormals(SEXP ls)
{
if (isList(ls)) {
for (; ls != R_NilValue; ls = CDR(ls))
if (TYPEOF(TAG(ls)) != SYMSXP)
goto err;
return;
}
err:
error(_("invalid formal argument list for \"function\""));
}
I'm not fluent in C at all, so from here on I'm not quite sure what to do next.
So these are my updated questions:
Why do function and function2 not behave in the same way? Why
do I need to call function2 using a different syntax when they are
deemed identical in R?
What are the proper arguments of function2
such that function2([arguments]) will actually define a function?
Some keywords in R such as if and function have special syntax in the way that the underlying functions get called. It's quite easy to use if as a function if desired, e.g.
`if`(1 == 1, "True", "False")
is equivalent to
if (1 == 1) {
"True"
} else {
"False"
}
function is trickier. There's some help on this at a previous question.
For your current problem here's one solution:
# Your S3 methods
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
# Creates the pairlist for arguments, handling arguments with no defaults
# properly. Also brings in the description
addFunction <- function(description, ...) {
args <- eval(substitute(alist(...)))
tmp <- names(args)
if (is.null(tmp)) tmp <- rep("", length(args))
names(args)[tmp==""] <- args[tmp==""]
args[tmp==""] <- list(alist(x=)$x)
list(args = as.pairlist(args), description = description)
}
# Actually creates the function using the structure created by addFunction and the body
`%{%` <- function(args, body) {
stopifnot(is.pairlist(args$args), class(substitute(body)) == "{")
f <- eval(call("function", args$args, substitute(body), parent.frame()))
class(f) <- c("addFunction", "function")
attr(f, "description") <- args$description
f
}
# Example. Note that the braces {} are mandatory even for one line functions
foo <- addFunction(description = "Add one", x) %{% {
x + 1
}
foo(1)
#[1] 2
The function testfun1, defined below, does what I want it to do. (For the reasoning of all this, see the background info below the code example.) The question I wanted to ask you is why what I tried in testfun2 doesn't work. To me, both appear to be doing the exact same thing. As shown by the print in testfun2, the evaluation of the helper function inside testfun2 takes place in the correct environment, but the variables from the main function environment get magically passed to the helper function in testfun1, but not in testfun2. Does anyone of you know why?
helpfun <- function(){
x <- x^2 + y^2
}
testfun1 <- function(x,y){
xy <- x*y
environment(helpfun) <- sys.frame(sys.nframe())
x <- eval(as.call(c(as.symbol("helpfun"))))
return(list(x=x,xy=xy))
}
testfun1(x = 2,y = 1:3)
## works as intended
eval.here <- function(fun){
environment(fun) <- parent.frame()
print(environment(fun))
eval(as.call(c(as.symbol(fun))))
}
testfun2 <- function(x,y){
print(sys.frame(sys.nframe()))
xy <- x*y
x <- eval.here("helpfun")
return(list(x=x,xy=xy))
}
testfun2(x = 2,y = 1:3)
## helpfun can't find variable 'x' despite having the same environment as in testfun1...
Background info: I have a large R code in which I want to call helperfunctions inside my main function. They alter variables of the main function environment. The purpose of all this is mainly to unclutter my code. (Main function code is currently over 2000 lines, with many calls to various helperfunctions which themselves are 40-150 lines long...)
Note that the number of arguments to my helper functions is very high, so that the traditional explicit passing of function arguments ( "helpfun(arg1 = arg1, arg2 = arg2, ... , arg50 = arg50)") would be cumbersome and doesnt yield the uncluttering of the code that I am aiming for. Therefore, I need to pass the variables from the parent frame to the helper functions anonymously.
Use this instead:
eval.here <- function(fun){
fun <- get(fun)
environment(fun) <- parent.frame()
print(environment(fun))
fun()
}
Result:
> testfun2(x = 2,y = 1:3)
<environment: 0x0000000013da47a8>
<environment: 0x0000000013da47a8>
$x
[1] 5 8 13
$xy
[1] 2 4 6