I want to calculate the following integral in R.
I tried to use Vectorize and integrate functions but I got error
Error in (log(z)) * (InIntegl2) : non-numeric argument to binary operator
fxyz= function(x,y,z) { (x*y*z)+z+x+2*y}
InIntegl1 = Vectorize(function(x) { integrate(fxyz, 0,5)$value})
InIntegl2 = Vectorize(function(y) { integrate( InIntegl1, 0,3)$value})
InIntegl3 = Vectorize(function(z) { integrate((log(z))*(InIntegl2), 2,6)$value})
Integral = integrate(InIntegl3 , 2, 6)$value
The first integral must be parameterized by y and z and the second by z. Then we can perform the final integration.
int1 <- Vectorize(function(y, z) integrate(fxyz, 0, 5, y = y, z = z)$value)
int2 <- Vectorize(function(z) integrate(int1, 0, 3, z = z)$value)
integrate(function(z) log(z) * int2(z), 2, 6)$value
## [1] 2071.71
In the spirit of Numerical Triple Integration in R
integrate(Vectorize(function(z) {
log(z)*integrate(Vectorize(function(y) {
integrate(function(x) { x*y*z +x + 2*y + z}, 0, 5)$value }), 0,3)$value }), 2,6)
Package cubature can solve triple integrals with one call.
library(cubature)
f <- function(X){
x <- X[1]
y <- X[2]
z <- X[3]
log(z)*(x*y*z + x+ 2*y + z)
}
loLim <- c(0, 0, 2)
hiLim <- c(5, 3, 6)
tol <- .Machine$double.eps^0.5
hcubature(f, loLim, hiLim, tol = tol)
#$integral
#[1] 2071.71
#
#$error
#[1] 2.059926e-05
#
#$functionEvaluations
#[1] 165
#
#$returnCode
#[1] 0
If only the integral's value is needed,
hcubature(f, loLim, hiLim, tol = tol)$integral
#[1] 2071.71
Related
I have a function f of two variables which I want to minimize under the constraint x[1]+x[2]=1.
Here,
f <- function(x){
y <- 4*sin(x[1])+3*cos(x[2])
return(y)
}
I have read here that optim() does the work, but how do I include my constraint?
After adding the constraint x[1] + x[2] = 1, the function becomes an univariate function and you can rewrite it as the following:
f <- function(x){
4*sin(x) + 3*cos(1-x)
}
optimize() can be used on one-dimensional optimization.
opt <- optimize(0, c(0, 10))
opt
# $minimum
# [1] 4.468871
#
# $objective
# [1] -6.722745
curve(f, 0, 10)
with(opt, points(minimum, objective, col = "red", pch = 16))
library(pbivnorm)
rho <- 0.5
f1 <- function(x, y) {
pbivnorm(log(x)-10, log(y)-10, rho)*(exp(-(log(x)-10)^2/2)/(sqrt(2*pi)*x))*(exp(-(log(y)-10)^2/2)/(sqrt(2*pi)*y))
}
integration1 <- round(integrate(function(y) {
sapply(y, function(y) {
integrate(function(x) f1(x,y), 0, Inf, rel.tol = 1e-12)$value
})
}, 0, Inf, rel.tol = 1e-12)$value, 10)
This integration should be around 0.3, but R gives 0. Could anyone point out the problem? What is the best function for integral in R? Many thanks.
Package cubature can solve the problem giving the expected result. The function must be rewritten as a one argument function, and the values for x and y set in the function body.
library(cubature)
f2 <- function(X) {
x <- X[1]
y <- X[2]
pbivnorm(log(x)-10, log(y)-10, rho)*(exp(-(log(x)-10)^2/2)/(sqrt(2*pi)*x))*(exp(-(log(y)-10)^2/2)/(sqrt(2*pi)*y))
}
hcubature(f2, c(0, 0), c(Inf, Inf))
#$integral
#[1] 0.2902153
#
#$error
#[1] 2.863613e-06
#
#$functionEvaluations
#[1] 7599
#
#$returnCode
#[1] 0
Edit.
Following the OP's second comment, here is the integral computed with hcubature
f3 <- function(x) {
pnorm(log(x)-10.2)*(exp(-(log(x)-10)^2/2)/(sqrt(2*pi)*x))
}
hcubature(f3, lowerLimit = 0, upperLimit = Inf, tol = 1e-12)$integral
#[1] 0.4437685
As a sanity check, I want when any arguments in function seda below is a vector of length larger than 1, the function stops.
Question: Instead of individually listing all function arguments (here x, y, z), is there a way to use match.call or formals etc. such that ALL function arguments could be checked at once?
I tried the below with no success:
seda <- function(x, y, z){
is.v <- function(...) lengths(list(...)) > 1
if(is.v(match.call())) stop("Error") # instead of `is.v(x, y, z)`
x + y + z
}
seda(2, 2, 3)
seda(c(2, 3), 2, 3)
match.call() will capture the arguments to the function, which can then be tested for length. We use sapply to return a vector with the length of each function argument, and the any function to test whether any of the arguments have a length greater than 1.
seda <- function(x, y, z){
if(any(sapply(match.call()[-1], length) > 1)) stop("All arguments must be length 1")
x + y + z
}
seda(2, 2, 3)
[1] 7
seda(c(2, 3), 2, 3)
Error in seda(c(2, 3), 2, 3) : All arguments must be length 1
Thanks to #erocoar for pointing out that match.call can be used instead of sys.call and that as.list is unnecessary.
You can tweak what you have a bit to get it to work:
seda <- function(...){
stopifnot(lengths(list(...)) == 1)
sum(...)
}
seda(1, 1, 1)
#> [1] 3
seda(1, 1, 1:2)
#> Error: lengths(list(...)) == 1 are not all TRUE
...or with named parameters,
seda_named <- function(x, y, z){
stopifnot(lengths(list(x, y, z)) == 1)
x + y + z
}
seda_named(1, 1, 1)
#> [1] 3
seda_named(1, 1, 1:2)
#> Error: lengths(list(x, y, z)) == 1 are not all TRUE
To use stop instead of stopifnot so as to control the error message, wrap the condition in all.
If they are tested all at once then the error message won't say which argument was the problem. The following tests them in a loop and does indicate which was the offending argument in the error message.
seda <- function(x, y, z) {
argnames <- names(match.call()[-1])
for(nm in argnames) if (length(get(nm)) != 1) stop(nm, " does not have length 1")
x + y + z
}
# test - note that the error message names z
seda(10, 20, 1:2)
## Error in seda(10, 20, 1:2) : z does not have length 1
Of course if you really had 3 arguments it would be a lot simpler just to write it out. This also gives argument specific error messages:
seda <- function(x, y = 1, z) {
stopifnot(length(x) == 1, length(y) == 1, length(z) == 1)
x + y + z
}
seda(10, 20, 1:2)
## Error: length(z) == 1 is not TRUE
I highly appreciate the input of my expert colleagues. Using your valuable comments, I guess what I want is the following:
seda <- function(x, y, z){
if(lengths(list(get(names(match.call()[-1])))) > 1) stop("Error")
x + y + z
}
seda(c(2, 3), 2, 3)
seda(2, 2, 3)
Also we could perhaps use formals as well:
seda <- function(x, y, z){
if(lengths(list(get(names(formals(seda))))) > 1) stop("Error")
x + y + z
}
seda(c(2, 3), 2, 3)
seda(2, 2, 3)
Or formalArgs like this:
seda <- function(x, y, z){
if(lengths(list(get(formalArgs(seda)))) > 1) stop("Error")
x + y + z
}
seda(c(2, 3), 2, 3)
seda(2, 2, 3)
With the goal of turning the following into a function, I was wondering how I can write the following double integral in terms of R codes?: ($\bar{x} = \mu$):
Assuming pi0 and pi1 implement your functions $\pi_0$ and $\pi_1$ in a vectorized way, a possible solution is:
integral <- function(n, mu, s, pi0, pi1) {
C <- (2 * pi)^(-n/2)
C * integrate(f = function(sigmavec) sapply(sigmavec, function(sigma) {
integrate(f = function(delta) {
exp(-n/2 * ((mu / sigma - delta)^2 + (s / sigma)^2)) * pi1(delta)
}, lower = -Inf, upper = Inf)$value
}) * pi0(sigmavec) / (sigmavec^n), lower = 0, upper = Inf)$value
}
# Tests
integral(n = 1, mu = 0, s = 1, pi0 = dnorm, pi1 = dnorm)
# [1] 0.0473819
integral(n = 1, mu = 0, s = 1, pi0 = function(sigma) 1/sigma, pi1 = dcauchy)
# [1] 0.2615783
Note sure if this question is on topic, but I am open to answer.
May be you should ask a more general question, how to write/computing integral
using computer program (code)? There at least are two ways
Using numerical integration, such as Monte Carlo method
Using symbolic toolbox to solve the problem analytically and plugin the numerical value.
Examples on $\int_0^1 x^2$
f<-function(x){
x^2
}
curve(f,0,1)
# method 1
integrate(f,lower=0,upper = 1)
# method 2
library(Ryacas)
x <- Sym("x")
f <- function(x) {
x^2
}
f2=yacas(yacas(Integrate(f(x), x)))
f2
x <- 1
Eval(f2)
I'm trying to implement the R function ecdf().
I'm considering two cases: one with t 1-dimensional, the other with t as a vector.
#First case
my.ecdf<-function(x,t) {
indicator<-ifelse(x<=t,1,0)
out<-sum(indicator)/length(x)
out
}
#Second case
my.ecdf<-function(x,t) {
out<-length(t)
for(i in 1:length(t)) {
indicator<-ifelse(x<=t[i],1,0)
out[i]<-sum(indicator)/length(t)
}
out
}
How can I check whether I'm doing the right thing with the R function ecdf() or not? This function take as argument just x, therefore I can't specify the value of t.
You could just plot the results and see that it gives something very similar:
# slightly improved version of my.ecdf
my.ecdf<-function(x,t) {
out<-numeric(length(t))
for(i in 1:length(t)) {
indicator <- as.numeric(x<=t[i])
out[i] <- sum(indicator)/length(t)
}
out
}
# test 1
x <- rnorm(1000)
plot(ecdf(x))
lines(seq(-4, 4, length=1000),
my.ecdf(x, seq(-4, 4, length=1000)),
col='red')
# test 2
x <- rexp(1000)
plot(ecdf(x))
lines(seq(0, 8, length=1000),
my.ecdf(x, seq(0, 8, length=1000)),
col='red')
A general tip - you can view the source code of any function by typing its name into the console without parentheses or arguments:
edcf
function (x)
{
x <- sort(x)
n <- length(x)
if (n < 1)
stop("'x' must have 1 or more non-missing values")
vals <- unique(x)
rval <- approxfun(vals, cumsum(tabulate(match(x, vals)))/n,
method = "constant", yleft = 0, yright = 1, f = 0, ties = "ordered")
class(rval) <- c("ecdf", "stepfun", class(rval))
assign("nobs", n, envir = environment(rval))
attr(rval, "call") <- sys.call()
rval
}