I would like to find the root of the following function:
x=0.5
f <- function(y) ((1-pbeta(1-exp(-0.002926543
*( 107.2592+y)^1.082618 *exp(0.04097536*(107.2592+y))),shape1=0.2640229,shape2=0.1595841)) -
(1-pbeta(1-exp(-0.002926543*(x)^1.082618 *exp(0.04097536*(x))),shape1=0.2640229,shape2=0.1595841))^2)
sroot=uniroot(f, lower=0, upper=1000)$root
Error in uniroot(f, lower = 0, upper = 1000) : f() values at end
points not of opposite sign
How can I solve the error?
uniroot() and caution of its use
uniroot is implementing the crude bisection method. Such method is much simpler that (quasi) Newton's method, but need stronger assumption to ensure the existence of a root: f(lower) * f(upper) < 0.
This can be quite a pain,as such assumption is a sufficient condition, but not a necessary one. In practice, if f(lower) * f(upper) > 0, it is still possible that a root exist, but since this is not of 100% percent sure, bisection method can not take the risk.
Consider this example:
# a quadratic polynomial with root: -2 and 2
f <- function (x) x ^ 2 - 4
Obviously, there are roots on [-5, 5]. But
uniroot(f, lower = -5, upper = 5)
#Error in uniroot(f, lower = -5, upper = 5) :
# f() values at end points not of opposite sign
In reality, the use of bisection method requires observation / inspection of f, so that one can propose a reasonable interval where root lies. In R, we can use curve():
curve(f, from = -5, to = 5); abline(h = 0, lty = 3)
From the plot, we observe that a root exist in [-5, 0] or [0, 5]. So these work fine:
uniroot(f, lower = -5, upper = 0)
uniroot(f, lower = 0, upper = 5)
Your problem
Now let's try your function (I have split it into several lines for readability; it is also easy to check correctness this way):
f <- function(y) {
g <- function (u) 1 - exp(-0.002926543 * u^1.082618 * exp(0.04097536 * u))
a <- 1 - pbeta(g(107.2592+y), 0.2640229, 0.1595841)
b <- 1 - pbeta(g(x), 0.2640229, 0.1595841)
a - b^2
}
x <- 0.5
curve(f, from = 0, to = 1000)
How could this function be a horizontal line? It can't have a root!
Check the f above, is it really doing the right thing you want? I doubt something is wrong with g; you might put brackets in the wrong place?
Once you get f correct, use curve to inspect a proper interval where there a root exists. Then use uniroot.
Try using a small interval but allow uniroot() to extend the interval:
uniroot(f, lower=0, upper=1, extendInt = "yes")$root
[1] -102.9519
Related
I apologise if this is a duplicate; I've read answers to similar questions to no avail.
I'm trying to integrate under a curve, given a specific formula (below) for said integration.
As a toy example, here's some data:
Antia_Model <- function(t,y,p1){
r <- p1[1]; k <- p1[2]; p <- p1[3]; o <- p1[4]
P <- y[1]; I <- y[2]
dP = r*P - k*P*I
dI = p*I*(P/(P + o))
list(c(dP,dI))
}
r <- 0.25; k <- 0.01; p <- 1; o <- 1000 # Note that r can range btw 0.1 and 10 in this model
parms <- c(r, k, p, o)
P0 <- 1; I0 <- 1
N0 <- c(P0, I0)
TT <- seq(0.1, 50, 0.1)
results <- lsoda(N0, TT, Antia_Model, parms, verbose = FALSE)
P <- results[,2]; I <- results[,3]
As I understand it, I should be able to use the auc() function from the MESS package (can I just use the integrate() function? Unclear...), which should look something like this:
auc(P, TT, from = x1, to = x2, type = "spline")
Though I don't really understand how to use the "from" and "to" arguments, or how to incorporate "u" from the original integration formula...
Using the integrate() function seems more intuitive, but if I try:
u <- 1
integrand <- function(P) {u*P}
q <- integrate(integrand, lower = 0, upper = Inf)
I get this error:
# Error in integrate(integrand, lower = 0, upper = Inf) :
# the integral is probably divergent
As you can tell, I'm pretty lost, so any help would be greatly appreciated! Thank you so much! :)
integrand is technically acceptable but right now, it's the identity function f(x) = x. The area under it from [0, inf) is infinite, i.e. divergent.
From the documentation of integrate the first argument is:
an R function taking a numeric first argument and returning a numeric vector of the same length. Returning a non-finite element will generate an error.
If instead you use a pulse function:
pulse <- function(x) {ifelse(x < 5 & x >= 0, 1, 0)}
integrate(pulse, lower = 0, upper = Inf)
#> 5 with absolute error < 8.5e-05
I am working on code that uses the uniroot function to approximate the root of an equation. I am trying to plot the behaviour of the function being passed through uniroot as the value of a free variable changes:
library(Deriv)
f1 <- function(s) {
(1 - 2*s)^(-3/2)*exp((8*s)/(1-2*s))
}
f2 <- function(s) {
log(f1(s))
}
f3 <- Deriv(f2, 's')
f4 <- Deriv(f3, 's')
f5 <- Deriv(f4, 's')
upp_s <- 1/2 - 1e-20
f_est <- function(x) {
f3a <- function(s) {f3(s = s) - x}
s_ <- uniroot(f3a,
lower = -9,
upper = upp_s)$root
return(s_)
}
plot(f_est, from = 0, to=100, col="red", main="header")
The output of f_est works as expected. However, when passed through the plot function, uniroot seems to break:
> plot(f_est, from = 0, to=100, col="red", main="header")
Error in uniroot(f3a, lower = -9, upper = upp_s) :
f() values at end points not of opposite sign
In addition: Warning messages:
1: In if (is.na(f.lower)) stop("f.lower = f(lower) is NA") :
the condition has length > 1 and only the first element will be used
2: In if (is.na(f.upper)) stop("f.upper = f(upper) is NA") :
Error in uniroot(f3a, lower = -9, upper = upp_s) :
f() values at end points not of opposite sign
The function is set up such that the endpoints specified in uniroot are always of opposite sign, and that there is always exactly one real root. I have also checked to confirm that the endpoints are non-missing when f_est is run by itself. I've tried vectorising the functions involved to no avail.
Why is this happening?
I was able to get most of the way there with
upp_s <- 0.497
plot(Vectorize(f_est), from = 0.2, to = 100)
Not only is 1/2 - epsilon exactly equal to 1/2 for values of epsilon that are too small (due to floating point error), I found that f3() gives NaN for values >= 0.498. Setting upp_s to 0.497 worked OK.
plot() applied to a function calls curve(), which needs a function that can take a vector of x values.
The curve broke with "f() values at end points not of opposite sign" if I started the curve from 0.1; I didn't dig in further and try to diagnose what was going wrong.
PS. It is generally more numerically stable and efficient to do computations directly on the log scale where possible. In this case, that means using
f2 <- function(s) { (-3/2)*log(1-2*s) + (8*s)/(1-2*s) }
instead of
f1 <- function(s) {
(1 - 2*s)^(-3/2)*exp((8*s)/(1-2*s))
}
f2_orig <- function(s) {
log(f1(s))
}
## check
all.equal(f2(0.25), f2_orig(0.25)) ## TRUE
Doing this and setting the lower bound of uniroot() to -500 lets us get pretty close to the zero boundary (although it looks both analytically and computationally as though the function diverges to -∞ as x goes to 0).
f3 <- Deriv(f2, 's')
upp_s <- 1/2 - 1e-10
lwr_a <- -500
f_est <- function(x) {
f3a <- function(s) { f3(s = s) - x}
s_ <- uniroot(f3a,
lower = lwr_a,
upper = upp_s)$root
return(s_)
}
plot(Vectorize(f_est), from = 0.005, to = 100, log = "x")
You can also solve this analytically, or ask caracas (an R interface to sympy) to do it for you:
library(caracas)
x <- symbol("x"); s <- symbol("s")
## peek at f3() guts to find the expression for the derivative;
## could also do the whole thing in caracas/sympy
solve_sys((11 +16*(s/(1-s*2)))/(1-s*2), x, list(s))
sol <- function(x) { (2*x - sqrt(32*x + 9) -3)/(4*x) }
curve(sol, add = TRUE, col = 2)
func_2 <- function(p,N){
f <- sqrt ((p* (1- p) )/N)
return(f)
}
maxmim <- optimize(func_2, c(0,1), maximum = TRUE)
The error message keeps popping up saying argument "N" missing, what do I do to find my optimization value for p?
In practice one can use optim to find the maximum for a two variable function. However, it requires vector input:
func_3 <- function(vec){
func_2(vec[1],vec[2])
}
You could then do something like this:
optim(par = c(p = 0.1, N = 0.1), fn = func_3,
lower = c(p = 0, N = 0), upper = c(p = 1, N = 1),
method="L-BFGS-B", control = list(fnscale = -1))
However, your function maximizes over the interval of 0 to 1 at p = 0.5 and N = limit as N approaches 0. This evaluates to NaN and thus can't be found by optim using a method that is compatible with lower and upper limits.
Using Base R, I was wondering if I could determine the 95% area under the curve denoted as posterior below?
More specifically, I want to move from the mode (the green dashed line) toward the tails and then stop when I have covered 95% of the curve area. Desired are the x-axis values that are the limits of this 95% area as shown in the picture below?
prior = function(x) dbeta(x, 15.566, 7.051)
likelihood = function(x) dbinom(55, 100, x)
posterior = function(x) prior(x)*likelihood(x)
mode = optimize(posterior, interval = c(0, 1), maximum = TRUE, tol = 1e-12)[[1]]
curve(posterior, n = 1e4)
P.S In other words, it is highly desirable if such an Interval be the shortest 95% interval possible.
Symmetric distribution
Even though OP's example was not exactly symmetric, it is close enough - and useful to start there since the solution is much simpler.
You can use a combination of integrate and optimize. I wrote this as a custom function, but note that if you use this in other situations you may have to rethink the bounds for searching the quantile.
# For a distribution with a single peak, find the symmetric!
# interval that contains probs probability. Search over 'range'.
f_quan <- function(fun, probs, range=c(0,1)){
mode <- optimize(fun, interval = range, maximum = TRUE, tol = 1e-12)[[1]]
total_area <- integrate(fun, range[1], range[2])[[1]]
O <- function(d){
parea <- integrate(fun, mode-d, mode+d)[[1]] / total_area
(probs - parea)^2
}
# Bounds for searching may need some adjustment depending on the problem!
o <- optimize(O, c(0,range[2]/2 - 1E-02))[[1]]
return(c(mode-o, mode+o))
}
Use it like this,
f <- f_quan(posterior, 0.95)
curve(posterior, n = 1e4)
abline(v=f, col="blue", lwd=2, lty=3)
gives
Asymmetric distribution
In the case of an asymmetric distribution, we have to search two points that meet the criterium that P(a < x < b) = Prob, where Prob is some desired probability. Since there are infinitely many intervals (a,b) that meet this, OP suggested finding the shortest one.
Important in the solution is the definition of a domain, the region where we want to search (we cannot use -Inf, Inf, so the user has to set this to reasonable values).
# consider interval (a,b) on the x-axis
# integrate our function, normalize to total area, to
# get the total probability in the interval
prob_ab <- function(fun, a, b, domain){
totarea <- integrate(fun, domain[1], domain[2])[[1]]
integrate(fun, a, b)[[1]] / totarea
}
# now given a and the probability, invert to find b
invert_prob_ab <- function(fun, a, prob, domain){
O <- function(b, fun, a, prob){
(prob_ab(fun, a, b, domain=domain) - prob)^2
}
b <- optimize(O, c(a, domain[2]), a = a, fun=fun, prob=prob)$minimum
return(b)
}
# now find the shortest interval by varying a
# Simplification: don't search past the mode, otherwise getting close
# to the right-hand side of domain will give serious trouble!
prob_int_shortest <- function(fun, prob, domain){
mode <- optimize(fun, interval = domain, maximum = TRUE, tol = 1e-12)[[1]]
# objective function to be minimized: the width of the interval
O <- function(a, fun, prob, domain){
b <- invert_prob_ab(fun, a, prob, domain)
b - a
}
# shortest interval that meets criterium
abest <- optimize(O, c(0,mode), fun=fun, prob=prob, domain=domain)$minimum
# now return the interval
b <- invert_prob_ab(fun, abest, prob, domain)
return(c(abest,b))
}
Now use the above code like this. I use a very asymmetric function (just assume mydist is actually some complicated pdf, not the dgamma).
mydist <- function(x)dgamma(x, shape=2)
curve(mydist(x), from=0, to=10)
abline(v=prob_int_shortest(mydist, 0.9, c(0,10)), lty=3, col="blue", lwd=2)
In this example I set domain to (0,10), since clearly the interval must be in there somewhere. Note that using a very large value like (0, 1E05) does not work, because integrate has trouble with long sequences of near-zeroes. Again, for your situation, you will have to adjust the domain (unless someone has a better idea!).
Here is a solution making use of the Trapezoidal rule. You will note that the solution provided by #Remko is far superior, however this solution hopefully adds some pedagogical value as it illuminates how complicated problems can be reduced to simple geometry, arithmetic, and basic programming constructs such as for loops.
findXVals <- function(lim, p) {
## (1/p) is the precision
## area of a trapezoid
trapez <- function(h1, h2, w) {(h1 + h2) * w / 2}
yVals <- posterior((1:(p - 1))/p)
m <- which.max(yVals)
nZ <- which(yVals > 1/p)
b <- m + 1
e <- m - 1
a <- f <- m
area <- 0
myRng <- 1:(length(nZ)-1)
totArea <- sum(trapez(yVals[nZ[myRng]], yVals[nZ[myRng+1]], 1/p))
targetArea <- totArea * lim
while (area < targetArea) {
area <- area + trapez(yVals[a], yVals[b], 1/p) + trapez(yVals[e], yVals[f], 1/p)
a <- b
b <- b + 1
f <- e
e <- e - 1
}
c((a - 1)/p, (f + 1)/p)
}
findXVals(.95, 10^5)
[1] 0.66375 0.48975
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)