I have to write a vectorized R function f that takes a vector x= (x_1, . . . , x_m) and a natural number n, and returns the value f_n(x) given by:
Example:
> x = seq(-1, 3, by = 0.4)
> f(x,6) # here n=6
[1] 0.000000e+00 0.000000e+00 0.000000e+00
[4] 2.666667e-06 6.480000e-04 8.333333e-03
[7] 4.430667e-02 1.410800e-01 3.050933e-01
[10] 4.755467e-01 5.500000e-01
This is what I got:
f = function(x, n){
s = 0
for(j in 0:x)
s = s + (-1)^j*choose(n, j)*(x-j)^(n-1)
s/factorial(n-1)
}
x = seq(-1, 3, by = 0.4)
f(x,6)
Warning in 0:x: numerical expression has 11 elements: only the first used
[1] -8.333333e-03 -6.480000e-04 -2.666667e-06 2.666667e-06 6.480000e-04
[6] 8.333333e-03 4.481867e-02 1.574640e-01 4.294693e-01 9.901147e-01
[11] 2.025000e+00
Clearly it is not what it should be in the example. What did I do wrong here? TIA
EDIT: Maybe using outer and apply might help with x?
This is a slightly different way of doing this solely based on base R:
x = seq(-1, 3, by = 0.4)
n <- 6
fn <- function(x, n) {
x[x <= 0] <- 0
sapply(x, function(x) {
Reduce(function(a, b) {
a + (-1) ^ b * (factorial(n)/(factorial(b) * factorial(n-b))) * (x - b) ^ (n-1)
}, seq(0, x), init = 0) * (1/factorial(n-1))
})
}
fn(x, 6)
[1] 0.000000e+00 0.000000e+00 0.000000e+00 2.666667e-06 6.480000e-04 8.333333e-03 4.430667e-02
[8] 1.410800e-01 3.050933e-01 4.755467e-01 5.500000e-01
Try this code. It can be modified to become tidier but maybe it can solve your problem in its current form. I used both base R and purr functions for iteration instead of for loop but maybe for loop alone can do the job.
library(tidyverse)
n <- 6
x <- seq(-1, 3, by = 0.4)
x[x<= 0] <- 0
seq_fun <- function(x) seq(0, x)
d <- sapply(x, seq_fun)
fun <- function(r, t) {
sum((-1) ^ r *choose(n, r)*(r-t)^(n-1)) / factorial(n - 1)
}
as_vector(map2(d, x, fun))
Related
I already tried max(seq_along(x)) but I need it to also return 0 if we, let's say, inputted numeric(0).
So yeah, it works for anything else other than numeric(0). This is what I have so far:
my_length <- function(x){
max(seq_along(x))
}
You can just include a 0 to the max() call in your attempt:
my_length <- function(x) max(0, seq_along(x))
my_length(10:1)
[1] 10
my_length(NULL)
[1] 0
my_length(numeric())
[1] 0
Using forloop:
my_length <- function(x){
l = 0
for(i in x) l <- l + 1
return(l)
}
x <- numeric(0)
my_length(x)
# [1] 0
x <- 1:10
my_length(x)
# [1] 10
Another option:
my_length <- function(x) nrow(matrix(x))
You can use NROW():
len <- \(x) NROW(x)
Examples:
len(numeric(0))
#> [1] 0
len(letters)
#> [1] 26
len(c(3, 0, 9, 1))
#> [1] 4
From the documentation:
nrow and ncol return the number of rows or columns present in x. NCOL and NROW do the same treating a vector as 1-column matrix, even a 0-length vector ...
Here are a few more functional programming approaches:
Using mapping and summation:
length = function (x) {
sum(vapply(x, \(.) 1L, integer(1L)))
}
Using reduction:
length = function (x) {
Reduce(\(x, .) x + 1L, x, 0L)
}
Using recursion:
length = function (x, len = 0L) {
if (is_empty(x)) len else Recall(x[-1L], len + 1L)
}
Alas, the last one needs to define the helper function and that is unfortunately not trivial without using length():
is_empty = function (x) {
is.null(x) || identical(x, vector(typeof(x), 0L))
}
I need to find exact and numerical solutions to a function but my code in R shows Error in optim(start_val[i, ], g) :
function cannot be evaluated at initial parameters
that is my code:
g <- function(x) (3*x[1]+2*x[2]+4*x[3]-4)^2 + (4*x[1]+2*x[2]+4*x[3]-2)^2 + (1*x[1]+1*x[2]+4*x[3]-4)^2
start_val <- expand.grid(c(-10,0,10),c(-10,0,10),c(-10,0,10))
optim_on_a_multiple_grid <- function(start_val, fun, ...) {
opt_result <- sapply(1:nrow(start_val),
function(i) {
res <- optim(start_val[i,], g)
c(res[[1]], res[[2]], res[[4]])
})
rownames(opt_result) <-
c(paste("x_", 1:ncol(start_val),
"_start_val", sep = ""),
paste("x_", 1:ncol(start_val),
"_sol", sep = ""),
paste(c(deparse(substitute(
fun
)), "_min"), collapse = ""),
"convergence")
opt_result
}
round(optim_on_a_multiple_grid(expand.grid(c(-10, 0, 10), c(-10, 0, 10)), g), 3)
Please, point me at my mistakes and explain how to fix them, I am stuck on it for quite a while now
I do not know why you have alot of objects while your aim is to optimize:
Do
# Define g
g <- function(x){
a <- (3 * x[1] + 2 * x[2] + 4 * x[3] - 4)^2
b <- (4 * x[1] + 2 * x[2] + 4*x[3] - 2)^2
d <- (x[1] + x[2] + 4*x[3] - 4)^2
a +b +d
}
optim(par=c(0,0,1), fn=g)
$par
[1] -1.9998762 3.9996836 0.5000453
$value
[1] 8.468819e-09
$counts
function gradient
160 NA
$convergence
[1] 0
$message
NULL
If you need your code:
The problem lies at the very end of it:
You should have:
round(optim_on_a_multiple_grid(start_val, g), 3)
I want to create a function which finds components of a vector which increase continually by k-times.
That is, if the contrived function is f(x,k) and x=c(2,3,4,3,5,6,5,7), then
the value of f(x,1) is 2,3,3,5,5 since only these components of x increase by 1 time.
In addition, if k=2, then the value of f(x,2) is 2,3 since only these components increase continually by 2 times.(2→3→4 and 3→5→6)
I guess that I ought to use repetitive syntax like for for this purpose.
1) Use rollapply from the zoo package:
library(zoo)
f <- function(x, k)
x[rollapply(x, k+1, function(x) all(diff(x) > 0), align = "left", fill = FALSE)]
Now test out f:
x <- c(2,3,4,3,5,6,5,7)
f(x, 1)
## [1] 2 3 3 5 5
f(x, 2)
## [1] 2 3
f(x, 3)
## numeric(0)
1a) This variation is slightly shorter and also works:
f2 <- function(x, k) head(x, -k)[ rollapply(diff(x) > 0, k, all) ]
2) Here is a version of 1a that uses no packages:
f3 <- function(x, k) head(x, -k)[ apply(embed(diff(x) > 0, k), 1, all) ]
A fully vectorized solution:
f <- function(x, k = 1) {
rlecumsum = function(x)
{ #cumsum with resetting
#http://stackoverflow.com/a/32524260/1412059
cs = cumsum(x)
cs - cummax((x == 0) * cs)
}
x[rev(rlecumsum(rev(c(diff(x) > 0, FALSE) ))) >= k]
}
f(x, 1)
#[1] 2 3 3 5 5
f(x, 2)
#[1] 2 3
f(x, 3)
#numeric(0)
I don't quite understand the second part of your question (that with k=2) but for the first part you can use something like this:
test<-c(2,3,4,3,5,6,5,7) #Your vector
diff(test) #Differentiates the vector
diff(test)>0 #Turns the vector in a logical vector with criterion >0
test[diff(test)>0] #Returns only the elements of test that correspond to a TRUE value in the previous line
I would like to compute the triple integral of a function of three variables f(x,y,z) in R. I'm using the package cubature and the function adaptIntegrate(). The integrand is equal to 1 only in a certain domain (x<y<z, 0 otherwise) which I don't know how to specify. I'm trying 2 different implementations of the function, but none of them work:
#First implementation
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
x*y*z*(x < y)&(y < z)
}
#Second implementation
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
if(x<y&y<z)
out<-1
else
out<-0
out
}
#Computation of integral
library(cubature)
lower <- rep(0,3)
upper <- rep(1, 3)
adaptIntegrate(f=fxyz, lowerLimit=lower, upperLimit=upper, fDim = 3)
Any idea on how to specify the domain correctly?
I don't know about the cubature package, but you can do this by repeated application of base R's integrate function for one-dimensional integration.
f.xyz <- function(x, y, z) ifelse(x < y & y < z, 1, 0)
f.yz <- Vectorize(function(y, z) integrate(f.xyz, 0, 1, y=y, z=z)$value,
vectorize.args="y")
f.z <- Vectorize(function(z) integrate(f.yz, 0, 1, z=z)$value,
vectorize.args="z")
integrate(f.z, 0, 1)
# 0.1666632 with absolute error < 9.7e-05
You'll probably want to play with the control arguments to set the numeric tolerances; small errors in the inner integration can turn into big ones on the outside.
In your first function the return value is wrong. It should be as.numeric(x<=y)*as.numeric(y<=z). In your second function you should also use <= instead of <, otherwise `adapIntegrate won't work correctly. You also need to specify a maximum number of evaluations. Try this
library(cubature)
lower <- rep(0,3)
upper <- rep(1,3)
# First implementation (modified)
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
as.numeric(x <= y)*as.numeric(y <= z)
}
adaptIntegrate(f=fxyz,lowerLimit=lower,upperLimit=upper,doChecking=TRUE,
maxEval=2000000,absError=10e-5,tol=1e-5)
#$integral
#[1] 0.1664146
#$error
#[1] 0.0001851699
#$functionEvaluations
#[1] 2000031
#$returnCode
#[1] 0
The domain 0 <= x <= y <= z <= 1 is the "canonical" simplex. To integrate over a simplex, use the SimplicialCubature package.
library(SimplicialCubature)
f <- function(x) 1
S <- CanonicalSimplex(3)
> adaptIntegrateSimplex(function(x) 1, S)
$integral
[1] 0.1666667
$estAbsError
[1] 1.666667e-13
$functionEvaluations
[1] 55
$returnCode
[1] 0
$message
[1] "OK"
Note that integrating the constant function f(x)=1 over the simplex simply gives the volume of the simplex, which is 1/6. The integration is useless for this example.
> SimplexVolume(S)
[1] 0.1666667
Is there a function/package in R which takes a function f and a parameter k, and then returns a Taylor approximation of f of degree k?
You can use Ryacas to work with the yacas computer algebra system (which you will need to install as well)
Using an example from the vignette
library(Ryacas)
# run yacasInstall() if prompted to install yacas
#
yacas("texp := Taylor(x,0,3) Exp(x)")
## expression(x + x^2/2 + x^3/6 + 1)
# or
Now, if you want to turn that into a function that you can give values of x
myTaylor <- function(f, k, var,...){
.call <- sprintf('texp := Taylor( %s, 0, %s) %s', var,k,f)
result <- yacas(.call)
foo <- function(..., print = FALSE){
if(print){print(result)}
Eval(result, list(...))}
return(foo)
}
# create the function
foo <- myTaylor('Exp(x)', 3, 'x')
foo(x=1:5)
## [1] 2.666667 6.333333 13.000000 23.666667 39.333333
foo(x=1:5, print = TRUE)
## expression(x + x^2/2 + x^3/6 + 1)
## [1] 2.666667 6.333333 13.000000 23.666667 39.333333
Compare the above symbolic solution with a numerical Taylor approximation:
library(pracma)
p <- taylor(f = exp, x0 = 0, n = 4) # Numerical coefficients
# 0.1666667 0.5000000 1.0000000 1.0000000 # x^3/6 + x^2/2 + x + 1
polyval(p, 1:5) # Evaluate the polynomial
# 2.66667 6.33333 13.00000 23.66667 39.33334 # exp(x) at x = 1:5
As a followup, consider:
foo <- myTaylor('Exp(x)', 3, 'x')
sprintf('%2.15f',foo(x=1:5))
[1] "2.666666666666667" "6.333333333333333" "13.000000000000000"
[4] "23.666666666666664" "39.333333333333329"
p <- taylor(f = exp, x0 = 0, n = 3)
sprintf('%2.15f',polyval(p,1:5))
[1] "2.666666721845557" "6.333333789579300" "13.000001556539996"
[4] "23.666670376066413" "39.333340601497312"
Which of these is more accurate I'll leave up to the reader :-)
The below function returns the function obtained by using the Taylor series approximation of n-th order of function f at the point a.
taylor <- function(f, n, a) {
ith_derivative <- as.expression(body(f))
f_temp <- function(x) x
series <- as.character(f(a))
for (i in seq_len(n)) {
ith_derivative <- body(f_temp) <- D(ith_derivative, "x")
series <- paste0(series, "+", f_temp(a) / factorial(i), "*(x - ", a, ")^", i)
}
f_output <- function(x) x
body(f_output) <- parse(text = series)
f_output
}
taylor(f = function(x) sin(x), n = 3, a = 0)
If you are asking for Taylor approximation in a background of error propagation, you might try the "propagate" function of my qpcR package, which evaluates symbolic gradient vectors together with the covariance matrix in the form of g * V * t(g) (the famous matrix notation for error propagation), which is equivalent to the first-order Taylor expansion.