I'm trying to make a function factory to make functions with custom formal argument names. The idea is to supply a string to the factory, which in turn substitutes it both in the formals and in the body of the function returned. I've managed to do it using eval(parse(text=paste())) , but I read elsewhere that this bad practice. How can I get the same output while avoiding doing evalparse?
MyLinearRateFunctions<-function(varX){
eval(parse(text=paste("function(a,b,",
varX,
") 1/(a + b*",
varX,
")",sep="")
))
}
(LinearRateMPG<-MyLinearRateFunctions('mpg'))
# function(a,b,mpg) 1/(a + b*mpg)
# <environment: 0x11c2f2a00>
(LinearRateCYL<-MyLinearRateFunctions('cyl'))
# function(a,b,cyl) 1/(a + b*cyl)
# <environment: 0x11e4cb908>
(LinearRateDISP<-MyLinearRateFunctions('disp'))
# function(a,b,disp) 1/(a + b*disp)
# <environment: 0x11e47eae8>
There may be a more succinct way to get there, but here's one idea:
fn <- function(x) {
f <- eval(bquote(function(a, b) 1 / (a + b * .(as.name(x)))))
formals(f) <- c(formals(f), setNames(alist(dummy = ), x))
f
}
In the first line of fn(), we use bquote() to substitute x into the math expression. We need to evaluate that (with eval()) to turn it from a call into a function. Then in the second line, we add the third argument to the formal argument list. The final line returns the function.
fn("mpg")
# function (a, b, mpg)
# 1/(a + b * mpg)
# <environment: 0x4f05c78>
fn("cyl")
# function (a, b, cyl)
# 1/(a + b * cyl)
# <environment: 0x4f9ba28>
Quick check:
fn("mpg")(1, 2, 3)
# [1] 0.1428571
1 / (1 + 2 * 3)
# [1] 0.1428571
And THANK YOU for asking for a better alternative to eval(parse(text = ...)), it definitely is bad practice.
Here is an alternative which uses pryr::make_function. This has the added benefit of setting the function "environment" to the calling environment of the "function factory" call
fn2 <- function(x) {
fbody <- bquote(1 / (a + b * .(as.name(x))))
fargs <- setNames(alist(,,),c('a','b',x))
pryr::make_function(fargs,fbody, env=parent.frame(2))
}
While this looks like it avoids a call to eval, it is simply hidden within make_function
This uses only base R and no eval. First set up a function to use as a template and then change the formals, set up the body and set the environment.
factory <- function(x, envir = parent.frame()) {
fun <- function(a, b, x) {}
names(formals(fun))[[3]] <- x
body(fun) <- substitute(1/(a+b*x), list(x = as.name(x)))
environment(fun) <- envir
fun
}
# test
myfun <- factory("m")
giving:
> myfun
function (a, b, m)
1/(a + b * m)
Related
Inside an R function, is it possible to detect if the user has assigned the output to an object?
For example, I would like to print on console some information only if the output is not assigned to an object, I am looking for something like this
fun <- function(a){
b <- a^2
if(!<OUTPUT ASSIGNED>) cat('a squared is ', b)
return(invisible(b))
}
So that the result on console would be different whether the function output is assigned or not, e.g:
> fun(5)
> a squared is 25
>
> out <- fun(5)
>
>
Not sure if I've completely thought this one through, but this seems to work for the example you've given. (Note it's important to use = or assign or .Primitive("<-") inside the fun you'd like to subject to this treatment.)
fun <- function(a){
b = a^2 # can't use <- here
if (!identical(Sys.getenv("R_IS_ASSIGNING"), "true")) cat('a squared is ', b)
return(invisible(b))
}
`<-` <- function(a, b) {
Sys.setenv("R_IS_ASSIGNING" = "true")
eval.parent(substitute(.Primitive("<-")(a, b)))
Sys.unsetenv("R_IS_ASSIGNING")
}
fun(5)
#> a squared is 25
out <- fun(6)
out
#> [1] 36
Created on 2019-02-17 by the reprex package (v0.2.1)
If I correctly understand what do you need it's better to use custom print method:
print.squared_value = function(x, ...){
cat('a squared is', x, "\n")
x
}
fun = function(a){
b = a^2
class(b) = union("squared_value", class(b))
b
}
fun(2)
# a squared is 4
UPDATE:
fun = function(a){
b = a^2
invisible(b)
}
h = taskCallbackManager()
# add a callback
h$add(function(expr, value, ok, visible) {
# if it was a call 'fun' without assinment
if(is.call(expr) && identical(expr[[1]], quote(fun))){
cat('a squared is', value, "\n")
}
return(TRUE)
}, name = "simpleHandler")
fun(2)
# a squared is 4
b = fun(2)
b
# [1] 4
# remove handler
removeTaskCallback("R-taskCallbackManager")
If I understood well, this could do the trick:
fun <- function(a){
b <- a^2
if(sum(unlist(lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)})))==0) cat('a squared is ', b)
return(invisible(b))
}
So:
ls(envir=.GlobalEnv) will return all objects in your global environment
lapply(ls(envir = .GlobalEnv), get): will return a list with the content of all objects in your global environment
lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)}): will return a logical list checking if the content of any of all objects in your global environment is identical to the output of your function
sum(unlist(lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)})))==0 if none of the content of any of all objects is identical to hte ouput of your function, then... cat!
I hope this helps you!
Best!
I am using R and trying to make an function by giving 2 parameters which are function and x, try to look for the answer of the function. But I kept getting error. I do not want to use any packages just solely R base.
Heres the Code so far.
test2 <- function(x) {
func <- expression(x)
der<- D(eval(func), 'x')
return(der(x))
}
test2(function(x) return(x^2))
I kept getting this error: "expression must not be type 'closure'"
Is there any way that I can structure of the function?
Here's a slight adjustment to get the derivation function working:
test2 <- function(x) D(parse(text=x), "x")
test2("sin(cos(x + y^2))")
# -(cos(cos(x + y^2)) * sin(x + y^2))
test2("x^2")
# 2 * x
test2("x^3")
# 3 * x^2
Use substitute to pass the expression to D:
test2 <- function(e, d) D(substitute(e), deparse(substitute(d)))
test2(sin(cos(x + y^2)), x)
#-(cos(cos(x + y^2)) * sin(x + y^2))
You cannot pass a function to D since it's designed for creating derivatives symbolically, which means it needs expressions containing simple functions known to D.
The function f returns a character vector, and string_der gives the derivative. (I used string manipulation inside since it seems you want to pass an argument.)
string_der <- function(x) {
D(parse(text = x), "x")
}
library(stringr)
f <- function(x) {
str <- "sin(cos(z + y^2))"
str <- str_replace(str, "z", x)
return(str)
}
string_der(f(x = "x"))
# -(cos(cos(x + y^2)) * sin(x + y^2))
I guess following is pretty much Adam Queck has done. It uses quote and let's you pass an object wrapped in quote.
quote_der <- function(x) {
D(eval(x), 'x')
}
f <- function(x) {
qt <- substitute(expression(sin(cos(z + y^2))), list(z = x))
return(qt)
}
quote_der(f(x = quote(x)))
#-(cos(cos(x + y^2)) * sin(x + y^2))
Assuming that:
the function passed as the argument has a one-line body and
if x is not specified it defaults to the name of the first argument to the input function
then we can write
test3 <- function(fun, x = names(formals(fun))[1]) D(body(fun), x)
test3(function(x) x^2)
## 2 * x
I am building a simple R package with many auxiliary functions. One of the main function uses a lot of the auxiliary ones as such:
....
#'# description
#'# param
#'# export
...
mainfunction1 <- function(param1,...,auxiliaryfunction){
# Do some stuff
b <- auxiliaryfunction(param2) + c
return(b)
}
...
#'# description
#'# param
auxiliaryfunction1 <- function(param5,param6,...){# do stuff}
The main function should be used by the final user as such:
result1 <- mainfunction1(param1, param2, auxiliaryfunction1)
The problem is that when the package is built, it never finds the auxiliary functions unless they are exported, however I'd like them not be available to the final user or at least avoid the problem of the user overriding them by mistake by referring to the package namespace.
How can I do this?
Should I export the auxiliary functions too?
You are trying to solve a non-problem.
If you want a user to use a function, export it.
If you don't want a user to use a function, do not export it.
That said...
There is a possibility that you are getting caught up on how functions are passed as arguments to other functions. Functions are first class objects in R, so they can be passed around very easily. Consider the following example:
m <- function(x, y) x + y
n <- function(x, y) x - y
k1 <- function(x, y, FUN) FUN(x, y)
k1(10, 5, FUN = m)
# [1] 15
k1(10, 5, FUN = n)
# [1] 5
k2 <- function(x, y, FUN = m) FUN(x, y)
k2(10, 5) # uses `m()` by default
# [1] 15
k2(10, 5, FUN = m)
# [1] 15
k2(10, 5, FUN = n)
# [1] 5
If you really don't want to users to access the functions directly but want to give them choice over which to use, then define the auxiliary functions in the body of the main function and use, for example, a switch() to choose between them:
fun <- function(x, method = c("A", "B")) {
m <- match.arg(method)
a <- function(x) x^2
b <- function(x) sqrt(x)
switch(m, A = a(x), B = b(x))
}
fun(2)
# [1] 4
fun(2, "A")
# [1] 4
fun(2, "B")
# [1] 1.414214
I'm trying to adjust the names of an argument inside a function. I want to create a procedure that takes the body of a function, looks for x, changes every x into x0, and then restores the function to what it was before. To provide an example:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
# Give f new formals
formals(f) = setNames(vector("list", length(form_new)), form_new)
# Copy function body
bod = as.list(body(f))
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod)
}
# return from list to call ?
body(f) = as.call(list(bod))
f(1, 1) # produces an error
So far, this code will change all variable names from x to x0 and from y to y0. However, the final output of bod is a character vector and not a call. How can I now change this back to a call?
Thanks in advance!
Surely there is a better way to do what you are trying to do that doesn't require modifying functions. That being said, you definetly don't want to be replacing variables by regular expressions, that could have all sorts of problems. Generally, trying to manipulate code as strings is going to lead to problems, for example, a function like tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }, where there are strings and variable names overlap, will lead to the wrong results.
Here is a function that takes a recursive approach (Recall) to traverse the expression tree (recursion could be avoided using a 'stack' type structure, but it seems more difficult to me).
## Function to replace variables in function body
## expr is `body(f)`, keyvals is a lookup table for replacements
rep_vars <- function(expr, keyvals) {
if (!length(expr)) return()
for (i in seq_along(expr)) {
if (is.call(expr[[i]])) expr[[i]][-1L] <- Recall(expr[[i]][-1L], keyvals)
if (is.name(expr[[i]]) && deparse(expr[[i]]) %in% names(keyvals))
expr[[i]] <- as.name(keyvals[[deparse(expr[[i]])]])
}
return( expr )
}
## Test it
f <- function(x, y) -x^2 + x + -y^2 + y
newvals <- c('x'='x0', 'y'='y0') # named lookup vector
newbod <- rep_vars(body(f), newvals)
newbod
# -x0^2 + x0 + -y0^2 + y0
## Rename the formals, and update the body
formals(f) <- pairlist(x0=bquote(), y0=bquote())
body(f) <- newbod
## The new 'f'
f
# function (x0, y0)
# -x0^2 + x0 + -y0^2 + y0
f(2, 2)
# [1] -4
With a more difficult function, where you want to avoid modifying strings or the other variables named yy and xx for example,
tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }
formals(tricky) <- pairlist(x0=bquote(), y0=bquote())
body(tricky) <- rep_vars(body(tricky), newvals)
tricky
# function (x0, y0)
# {
# tst <- "x + y"
# -xx * x0 + yy * y0
# }
#
There are a few ways to go here. Following your code, I would go with something like this:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
deparse(body(f)) -> bod
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod, fixed = TRUE)
}
formals(f) = setNames(vector("list", length(form_new)), form_new)
body(f) <- parse(text = bod)
f(1, 1)
Is it possible in R to assign custom functions to mathematical operators (eg. *, +) or interpret the formulae supplied with as.formula() as a directive to evaluate?
Specifically, I would like * to be interpretted as intersect(), and + as c(), so R would evaluate the expression
(a * (b + c)) * d) OR myfun(as.formula('~(a * (b + c)) * d)'), list(a, b, c, d))
AS
intersect(intersect(a, c(b, c)), d)
I'm able to produce the same outcome with gsub()ing an expression supplied as string in a while() loop, but I guess it's far from perfection.
Edit: I've mistakenly posted sum() instead of c(), so some answers may refer to the unedited version of the question.
Example:
############################
## Define functions
var <- '[a-z\\\\{\\},]+'
varM <- paste0('(', var, ')')
varPM <- paste0('\\(', varM, '\\)')
## Strip parentheses
gsubP <- function(x) gsub(varPM, '\\1', x)
## * -> intersect{}
gsubI <- function(x) {
x <- gsubP(x)
x <- gsub(paste0(varM, '\\*', varM), 'intersect\\{\\1,\\2\\}', x)
return(x)
}
## + -> c{}
gsubC <- function(x) {
x <- gsubP(x)
x <- gsub(paste0(varM, '\\+', varM), 'c\\{\\1,\\2\\}', x)
return(x)
}
############################
## Set variables and formula
a <- 1:10
b <- 5:15
c <- seq(1, 20, 2)
d <- 1:5
string <- '(a * (b + c)) * d'
############################
## Substitute formula
string <- gsub(' ', '', string)
while (!identical(gsubI(string), string) || !identical(gsubC(string), string)) {
while (!identical(gsubI(string), string)) {
string <- gsubI(string)
}
string <- gsubC(string)
}
string <- gsub('{', '(', string, fixed=TRUE)
string <- gsub('}', ')', string, fixed=TRUE)
## SHAME! SHAME! SHAME! ding-ding
eval(parse(text=string))
You can do this:
`*` <- intersect
`+` <- c
Be aware that if you do that in the global environment (not a function) it will probably make the rest of your script fail unless you intend for * and + to always do sum and intercept. Other options would be to use S3 methods and classes to restrict that usage.
* and + have special meaning within formulae, so I don't think you can override that. But you can use a formula as a way of passing an unevaluated expression as per #MrFlick's answer.
A formula is really just a way to hold an unevaluated expression. You can create an environment where those functions are re-defined and then evaluate that expression in that environment. Here's a function that will do much of that for you. First, your sample input
a <- 1:10
b <- 5:15
c <- seq(1, 20, 2)
d <- 1:5
Now the function
myfun <- function(x, env=parent.frame()) {
#check the formula
stopifnot("formula" %in% class(x), length(x)==2)
#redefine functions
funcs <- list2env(list(
`+`=base::c,
`*`=base::intersect
), parent=env)
eval(x[[2]], funcs)
}
and we would call it with
myfun( ~(a * (b + c)) * d )
# [1] 1 3 5
Here we grab the variable values from the current enviroment, If you wanted to, we could also pass those as parameters
myfun <- function(x, ..., .dots=list()) {
#check the formula
stopifnot("formula" %in% class(x), length(x)==2)
#check variables
dotraw <- sapply(substitute(...()), deparse)
dots <- list(...)
if(length(dots) && is.null(names(dots))) names(dots)<-dotraw
dots <- c(dots,.dots)
stopifnot(all(names(dots)!=""))
#redefine functions
funcs <- list2env(list(
`+`=base::c,
`*`=base::intersect
), parent=parent.frame())
eval(x[[2]], dots, funcs)
}
Then you could do
myfun( ~(a * (b + c)) * d , a, b, c, d)
myfun( ~(a * (b + c)) * d , a=b, b=a, c=d, d=c)
myfun( ~(a * (b + c)) * d , .dots=list(a=a, b=b, c=c, d=d))
myfun( ~(a * (b + c)) * d , .dots=mget(c("a","b","c","d")))