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
Related
Is it possible in R to write a function f(x) like
f(x) = a_0 + a_1*sin(x) + ... + a_n*sin(n*x)
for some n, or any other f_i(x) in place of sin(i*x) just varying on i? I tried a recursion like
f <- function(x) a_0
for(n in 1:N)
f <- function(x) f(x) + a_n*x^n
It seemed to work but when I used f(x) to make some computations R said there was too much nesting. I eventually wrote by hand a_0 + a_1*x + ... etc.
Is there a proper way to do it in a compact way without using recursion?
If you have the following values of a and x
a <- 1:5
x <- 3
a[1] + a[2]*sin(x*1) + a[3]*sin(x*2) + a[4]*sin(x*3) + a[5]*sin(x*4)
# [1] -0.5903971
Then you can get the same value using
f <- function(x) {
a[1] + sum( a[-1] * sin((x * seq.int(length(a)-1) )))
}
f(x)
#[1] -0.5903971
Note that arrays in R use 1-based indexing
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)
I can construct a formula that does what I desire starting with the character versions of terms in a formula, but I'm stumbling in starting with a formula object:
form1 <- Y ~ A + B
form1[-c(1,2)][[1]]
#A + B
Now how to build a formula object that looks like:
Y ~ poly(A, 2) + poly(B, 2) + poly(C, 2)
Or:
Y ~ pspline(A, 4) + pspline(B, 4) + pspline(C, 4)
Seems that it might involve a recursive walk along the RHS but I'm not getting progress. It just occurred to me that I might use
> attr( terms(form1), "term.labels")
[1] "A" "B"
And then use the as.formula(character-expr) approach, but I's sorly of like to see an lapply (RHS_form, somefunc) version of a polyize (or perhaps polymer?) function.
If I borrow some functions I originally wrote here, you could do something like this. First, the helper functions...
extract_rhs_symbols <- function(x) {
as.list(attr(delete.response(terms(x)), "variables"))[-1]
}
symbols_to_formula <- function(x) {
as.call(list(quote(`~`), x))
}
sum_symbols <- function(...) {
Reduce(function(a,b) bquote(.(a)+.(b)), do.call(`c`, list(...), quote=T))
}
transform_terms <- function(x, f) {
symbols_to_formula(sum_symbols(sapply(extract_rhs_symbols(x), function(x) do.call("substitute",list(f, list(x=x))))))
}
And then you can use
update(form1, transform_terms(form1, quote(poly(x, 2))))
# Y ~ poly(A, 2) + poly(B, 2)
update(form1, transform_terms(form1, quote(pspline(x, 4))))
# Y ~ pspline(A, 4) + pspline(B, 4)
There's a formula.tools package that provides various utility functions for working with formulas.
f <- y ~ a + b
rhs(f) # a + b
x <- get.vars(rhs(f)) # "a" "b"
r <- paste(sprintf("poly(%s, 4)", x), collapse=" + ") # "poly(a, 4) + poly(b, 4)"
rhs(f) <- parse(text=r)[[1]]
f # y ~ poly(a, 4) + poly(b, 4)
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")))