In R, I can calculate the first-order derivative as the following:
g=expression(x^3+2*x+1)
gPrime = D(g,'x')
x = 2
eval(g)
But I think it's not very readable. I prefer to do something like this:
f = function(x){
x^3+2*x+1
}
fPrime = D(g,'x') #This doesn't work
fPrime(2)
Is that possible? Or is there a more elegant way to do ?
1) D This depends on the particular form of f but for similar ones whose body is one line surrounded by {...} and whose single argument is x and whose operations are in the derivative table this works:
# f is from question
f = function(x){
x^3+2*x+1
}
df <- function(f) {
fun <- function(x) {}
environment(fun) <- environment(f)
body(fun) <- D(body(f)[[2]], "x")
fun
}
df(f)
## function (x)
## 3 * x^2 + 2
2) numDeriv::grad Also consider doing this numerically:
library(numDeriv)
grad(f, 2)
## [1] 14
3) deriv Another approach is to use deriv in the base of R with similar restrictions to (1).
df2 <- function(f) {
fun <- function(x) {
f2 <- deriv(body(f)[[2]], "x", function.arg = TRUE)
attr(f2(x), "gradient")
}
environment(fun) <- environment(f)
fun
}
f2Prime <- df2(f)
f2Prime(2)
## x
## [1,] 14
4) Deriv::Deriv Another apprroach is the Deriv package.
library(Deriv)
Deriv(f, "x")
## function (x)
## 2 + 3 * x^2
Related
I have two functions, as for example:
a <- function(x) return(mean(x))
b <- function(x) return(median(x))
I would like to have another function that passes either a or b as an argument.
The goal is something like this:
oper <- function(f, x) {
ifelse(f == "a", a(x), b(x))
}
If for example I was to execute the function:
oper(a, c(3,4,5))
I get the following error message:
Error in f == "a" :
comparison (1) is possible only for atomic and list types
Disclosure: mean(x) and median(x) are just for example purposes.
Because R has first-class functions, you can simply pass your function and call it directly:
oper2 <- function(f, x) {
f(x)
}
x <- c(2, 3, 8)
oper2(a, x)
# 4.333333
oper2(b, x)
# 3
Hello,
I want to have in output a vector when the entry is vector without using a function of apply's family. How should I write my function?
Thanks.
I used this code where I was forced to use two functions.
f1=function(l){
y= B1 # vector of length N
li= position # a vector of length N
h=10
a=(li-l)/h
Knorm=dnorm(a)
b=Knorm*y
num=sum(b)
den=sum(Knorm)
num/den
}
########## Forme vectorielle
f2 = function(l){
sapply(l,f1)
}
L=seq(10000000,11000000,by=1)
f2(L)
If I compute f1(L) I will get one value. That's why I was forced to write a second function to apply my first function to each element of vector L.
The purpose is to write it in one function.
Use outer and colSums to allow the function to take l as a vector:
f <- function(l){
y <- B1 # vector of length N
li <- position # a vector of length N
h <- 10
a <- outer(li, l, "-")/h
Knorm <- dnorm(a)
b <- Knorm*y
num <- colSums(b)
den <- colSums(Knorm)
num/den
}
And here is a simpler equivalent function:
f <- function(l){
Knorm <- dnorm(outer(position, l, "-")/10)
colSums(Knorm*B1)/colSums(Knorm)
}
Compare to OP's function:
f1=function(l){
y= B1 # vector of length N
li= position # a vector of length N
h=10
a=(li-l)/h
Knorm=dnorm(a)
b=Knorm*y
num=sum(b)
den=sum(Knorm)
num/den
}
position <- 10:1
B1 <- 1:10
sapply(8:12, f1)
#> [1] 5.300480 5.220937 5.141656 5.062713 4.984177
f(8:12)
#> [1] 5.300480 5.220937 5.141656 5.062713 4.984177
UPDATE
Based on the comments, something like this may work best for the large vectors involved:
library(parallel)
f1 <- function(l) {
dkAll <- abs(outer(position, l, "-"))
Knorm <- dnorm(outer(position, l, "-")/pmax(dkAll[order(col(dkAll), dkAll)[seq(70, by = length(position), length.out = length(l))]], 1000))
colSums(Knorm*y)/colSums(Knorm)
}
y <- seq(1, 100, length.out = 23710)
position <- seq(10351673, 12422082, length.out=23710)
l <- seq(11190000, 11460000, by=10)
# ysmoothed <- f1(l) # memory allocation error
cl <- makeCluster(detectCores())
clusterExport(cl, list("y", "position", "l", 'f1'))
system.time(ysmoothed <- parLapply(cl, l, f1))
#> user system elapsed
#> 0.02 0.00 20.13
Created on 2022-02-02 by the reprex package (v2.0.1)
My goal is to create the following function using code:
s <- c(x = 10)
a <- c(i = 3)
model <- function(s, a) {
with(as.list(c(s, a)), {
y <- x * i
y * 10
})
}
model(s, a)
The result should be 300.
I'm parsing another software, and I can extract the equations from that software as strings. So, I need to construct the function's body from those strings.
I've been trying to use rlang library to no avail.
library(rlang)
func_body <- "with(as.list(c(s, a)), {
y <- x * i
y * 10
})";
foo <- new_function(
exprs(s =, a = ),
expr(!!parse(text = func_body))
)
Any idea?
Not sure your motivation for using new_function here but this gives your expected output:
library(rlang)
s <- (x = 10)
a <- (i = 3)
foo <- new_function(
args = pairlist2(s =, a =),
body = expr(
with(as.list(c(s, a)), {
y <- x * i
y * 10
})
)
)
foo(s, a)
#[1] 300
If the body is a string use parse_expr:
foo2 <- new_function(
args = pairlist2(s =, a =),
body = parse_expr(
"with(as.list(c(s, a)), {
y <- x * i
y * 10
})"
)
)
foo2(s, a)
#[1] 300
With base R you can do :
foo <- function(s, a){}
body(foo) <- parse(text=func_body)
foo(s, a)
#> [1] 300
An alternative way, still in base R would be:
foo <- as.function(c(alist(s=,a=), parse(text=func_body)[[1]]))
foo(s, a)
#> [1] 300
As a side note, in your example the values of s and a are not use at all, you're just using the values of x and i from the global workspace. You might want :
# cleanup
rm(s,a,x,i)
s <- c(x = 10)
a <- c(i = 3)
foo(s, a)
#> [1] 300
Hi so I have the following function:
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
I'd like to vectorize this without using any for loops or apply statements, can't seem to get around doing so. Help would be appreciated. Thanks.
EDIT: Given the responses, here are my answers to the questions posed.
Given requests for clarification, I will elaborate on the function inputs and on the user defined function inside the function given. So X here is a dataset in the form of a vector, specifically, a vector of length 7 in the dataset I used as an input to this function. The X I used this function for is c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041). s is a single scalar point set at 0.2 for the use of this function. kde is a user - defined function that I wrote. Here is the implementation:
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
in this function, X is the same vector of data points used in kde.cv. s is also the same scalar value of 0.2 used in kde.cv. x is a vector of evaluation points for the function, I used seq(-2.5, -0.5, by = 0.1).
Here is an option using sapply
kde.cv = function(X,s)
sum(sapply(1:length(X), function(i) log(kde(X[i], X[-i], s))))
For convenience, please provide a more complete example. For example, the kde() function. Is that a customized function?
Alternative to sapply, you can try Vectorize(). There are some examples you can find on stack overflow.
Vectorize() vs apply()
Here is an example
f1 <- function(x,y) return(x+y)
f2 <- Vectorize(f1)
f1(1:3, 2:4)
[1] 3 5 7
f2(1:3, 2:4)
[1] 3 5 7
and the second example
f1 <- function(x)
{
new.vector<-c()
for (i in 1:length(x))
{
new.vector[i]<-sum(x[i] + x[-i])
}
return(sum(new.vector))
}
f2<-function(x)
{
f3<-function(y, i)
{
u<-sum(y[i]+y[-i])
return(u)
}
f3.v<-Vectorize(function(i) f3(y = x, i=i))
new.value<-f3.v(1:length(x))
return(sum(new.value))
}
f1(1:3)
[1] 24
f2(1:3)
[1] 24
Note: Vectorize is a wrapper for mapply
EDIT 1
According to the response, I edited your kde.cv function.
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
##### Vectorize kde.cv ######
kde.cv.v = function(X,s)
{
log.fhat.vector = c()
kde.v<-Vectorize(function(i) kde(X[i], X[-i], s))
CV.score <- sum(log(kde.v(1:length(X))))
return(CV.score)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
x<-seq(-2.5, -0.5, by = 0.1)
kde.cv(X, s)
[1] -10.18278
kde.cv.v(X, s)
[1] -10.18278
EDIT 2
Well, I think the following function may match your requirement. BTW, since the little x is not used in your kde.cv, I just edited both two functions
kde.cv.2 <- function(X,s)
{
log.fhat.vector<-log(kde.2(X, s))
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde.2<-function(X, s)
{
l <- length(X)
b <- matrix(rep(X, l), l, l, byrow = T)
c <- X - b
diag(c) <- NA
phi.matrix <- dnorm(c, 0, s)
d <- rowMeans(phi.matrix, na.rm = T)
return(d)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
kde.cv(X,s)
[1] -10.18278
kde.cv.2(X, s)
[1] -10.18278
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)