I'm trying to find shape1 and shape2 in dbeta() such that the answer from dbeta() for the two input values: .6 and .8 become 3.
I'm using the below optim() but don't get exact result, that is I expect getting values for shape1 and shape2 that when used with .6 and .8 give 3 and 3, but they don't, why?
f <- function(x) {
y <- c(3, 3) - dbeta(c(.6, .8), shape1 = x[1], shape2 = x[2])
}
AA = optim(c(1, 1), function(x) sum(f(x)^2), control = list(reltol = (.Machine$double.eps)))
parms = unname(AA$par)
dbeta(c(.6, .8), parms[1], parms[2]) # Here I expect to get `3` for `.6` and `.8` but I don't.
I had a brief look at this. I don't think there's any problem with the fit: here's a picture of the likelihood surface:
library(emdbook)
cc <- curve3d(g(c(x,y)),xlim=c(1,20),ylim=c(1,20),
sys3d="none")
pp <- which(cc$z==min(cc$z),arr.ind=TRUE)
png("betasurf.png")
with(cc,image(x,y,z))
points(parms[1],parms[2],pch=16)
points(cc$x[pp[1]],cc$y[pp[2]],pch=1)
dev.off()
Filled circle is the fitted value, open circle is the minimum of the grid; I think the difference is just numerical fuzz (I zoomed in a few times to make sure). In any case, there's no evidence of anything weird like multiple optima.
I believe the issue is just that you've set up a set of pair of points that can't be simultaneously matched by any Beta distribution; optim() is giving you the best possible fit ...
png("betatmp.png")
curve(dbeta(x,parms[1],parms[2]),from=0,to=1)
points(c(0.6,0.8),c(3,3),pch=16)
dev.off()
Related
I'm trying to find a root of the following function (based on the Gamma (gamma()) function) using the uniroot() function:
cv = 0.056924/1.024987^2
fx2 = function(theta, eta){
p1 = 1 - 2/(theta*(1-eta))
p2 = 1 - 1/(theta*(1-eta))
return(( gamma(p1)/(gamma(p2))^2 ) - (cv+1) )
}
This function gives me the following plot:
v = seq(0, 1, 0.01)
plot(v, fx2(3.0, v), type='l' )
It seems to me that the root of this function is close to 0.33, but the uniroot() function doesn't find the root, returning the following result:
uniroot(fx2, interval = c(0,0.3), theta=3 )
Error in uniroot(fx2, interval = c(0, 0.3), theta = 3) :
f() values at end points not of opposite sign
How do I find the root of this function? Are there any other packages with a more accurate algorithm?
I first rewrote your function to (optionally) express gamma(p1)/gamma(p2)^2 in terms of a computation that's first done on the log scale (via lgamma()) and then exponentiated. This is more numerically stable, and the consequences will become clear below ... (It's possible that I screwed up the log-scale computation — you should double-check it. Update/warning: reading the documentation more carefully (!!), lgamma() evaluates to the log of the absolute value of the gamma function. So there may be some weird sign stuff going on in the answer below. The fact remains that if you are evaluating ratios of gamma functions for x<0 (i.e. in the regime where the value can go negative), Bad Stuff is very likely going to happen.
cv = 0.056924/1.024987^2
fx3 <- function(theta, eta, lgamma = FALSE) {
p1 <- 1 - 2/(theta*(1-eta))
p2 <- 1 - 1/(theta*(1-eta))
if (lgamma) {
val <- exp(lgamma(p1) - 2*lgamma(p2)) - (cv+1)
} else {
val <- ( gamma(p1)/(gamma(p2))^2 ) - (cv+1)
}
}
Compute the function with and without log-scaling:
x <- seq(0, 1, length.out = 20001)
v <- sapply(x, fx3, theta = 3.0, lgamma = TRUE)
v2 <- sapply(x, fx3, theta = 3.0, lgamma = FALSE)
Find root (more explanation below):
uu <- uniroot(function(eta) fx3(3.0, eta, lgamma = TRUE),
c(0.4, 0.5))
Plot it:
par(las=1, bty="l")
plot(x, abs(v), col = as.numeric(v<0) + 1, type="p", log="y",
pch=".", cex=3)
abline(v = uu$root, lty=2)
cvec <- sapply(c("blue","magenta"), adjustcolor, alpha.f = 0.2)
points(x, abs(v2), col=cvec[as.numeric(v2<0) + 1], pch=".", cex=3)
Here I'm plotting the absolute value on a log scale, with sign indicated by colour (black/blue >0, red>magenta <0). Black/red is the log-scale calculation, blue/magenta is the original calculation. I also plotted the function at very high resolution to try to avoid missing or mischaracterizing features.
There's a lot of weird stuff going on here.
both versions of the function do something interesting near x=1/3; the original version looks like a pole (value diverges to +∞, "returns" from -∞), while the log-scale computation goes up to +∞ and returns without changing sign.
the log-scale computation has a root near x=0.45 (absolute value becomes small while the sign flips), but the original computation doesn't — presumably because of some kind of catastrophic loss of precision? If we give uniroot bounds that don't include the pole, it can find this root.
there are further poles and/or roots at larger values of x that I didn't explore.
All of this basically says that it's pretty dangerous to mess around with this function without knowing what its mathematical properties are. I discovered some stuff by numerical exploration, but it would be best to analyze the function so that you really know what's happening; any numerical exploration can be fooled if the function is sufficiently strangely behaved.
Let me make my question clear because I don't know how to ask it properly (therefore I don't know if it was answered already or not), I will go through my whole problem:
There is a given function (which is the right side of an explicit first order differential equation if it matters):
f = function(t,y){
-2*y+3*t
}
Then there's a given interval from 'a' to 'b', this is the range the function is calculated in with 'n' steps, so the step size in the interval (dt) is:
dt=abs(a-b)/n
In this case 'a' is always 0 and 'b' is always positive, so 'b' is always greater than 'a' but I tried to be generic.
The initial condition:
yt0=y0
The calculation that determines the vector:
yt=vector("numeric",n)
for (i in 1:(n-1))
{
yt[1]=f(0,yt0)*dt+yt0
yt[i+1]=(f(dt*i,yt[i]))*dt+yt[i]
}
The created vector is 'n' long, but this is an approximate solution to the differential equation between the interval ranging from 'a' to 'b'. And here comes my problem:
When I try plotting it alongside the exact solution (using deSolve), it is not accurate. The values of the vector are accurate, but it does not know that these values belong to an approximate function that's between the interval range 'a' to 'b' .
That's why the graphs of the exact and approximate solution are not matching at all. I feel pretty burnt out, so I might not describe my issue properly, but is there a solution to this? To make it realise that its values are between 'a' and 'b' on the 'x' axis and not between '1' and 'n'?
I thank you all for the answers in advance!
The deSolve lines I used (regarding 'b' is greater than 'a'):
df = function(t, y, params) list(-2*y+3*t)
t = seq(a, b, length.out = n)
ddf = as.data.frame(ode(yt0, t, df, parms=NULL))
I tried to reconstruct the comparison between an "approximate" solution using a loop (that is in fact the Euler method), and a solution with package deSolve. It uses the lsoda solver by default that is more precise than Euler'S method, but it is of course also an approximation (default relative and absolute tolerance set to 1e-6).
As the question missed some concrete values and the plot functions, it was not clear where the original problem was, but the following example may help to re-formulate the question. I assume that the problem may be confusion between t (absolute time) and dt between the two approaches. Compare the lines marked as "original code" with the "suggestion":
library(deSolve)
f = function(t, y){
-2 * y + 3 * t
}
## some values
y0 <- 0.1
a <- 3
b <- 5
n <- 100
## Euler method using a loop
dt <- abs(a-b)/n
yt <- vector("numeric", n)
yt[1] <- f(0, y0) * dt + y0 # written before the loop
for (i in 1:(n-1)) {
#yt[i+1] = (f( dt * i, yt[i])) * dt + yt[i] # original code
yt[i+1] <- (f(a + dt * i, yt[i])) * dt + yt[i] # suggestion
}
## Lsoda integration wit package deSolve
df <- function(t, y, params) list(-2*y + 3*t)
t <- seq(a, b, length.out = n)
ddf = as.data.frame(ode(y0, t, df, parms=NULL))
## Plot of both solutions
plot(ddf, type="l", lwd=5, col="orange", ylab="y", las=1)
lines(t, yt, lwd=2, lty="dashed", col="blue")
legend("topleft", c("deSolve", "for loop"),
lty=c("solid", "dashed"), lwd=c(5, 2), col=c("orange", "blue"))
I'm trying to replicate a plot in figure 3.4 in "Coalescent Theory: An introduction" by John Wakely. It consists of the density function of "T total", which I will not define further.
My problem is that I cant seem to correctly write a function for the distribution function.
The distribution function should be a standard convolution of (n-1) random exponentially distributed variables, where the rate of the i'th r.v. is (i/2). The basic distribution can be written as:
I think I have coded this correctly:
DistExpConv <- function(lambdas, t) {
product = function(vector, entrance) {
sapply(entrance, function(x){prod(vector[-x] / (vector[-x] - vector[x]))})
}
sapply(t, function(y){
sum(sapply(lambdas, function(x){
x * exp(-x * y) * product(lambdas, which(lambdas == x))
}))
})
}
I think this should give the correct response, at least I cannot see, where it should be wrong. I have then implemented the distribution of T total:
T_totaldist <- function(n, t) {
lambdas = sapply(2:n, function(x){ (x-1)/2 })
DistExpConv(lambdas , t)
}
As seen, this function just forms n-1 lambdas and then sends them into DistExpConv.
So far so good. My problem arises when trying to plot T_totaldist for n = 100 using the curve function:
n = c(2, 5, 10, 20, 50, 100)
col = rainbow(length(n))
for(i in 1:length(n)){
curve(T_totaldist(n = n[i], x), 0, 14, col = col[i], add = i!=1)
}
legend(8,0.5,paste("n = ",n, sep = ""), col=col, lty=1)
The (in this case pink) curve produced by n = 100 jumps in and out into the extreme negatives and positives. Thus I must conclude my previous functions are doing something wrong. The weird thing is, that the curves of the other n's look perfectly as they should, and from t >= 2 the pink curve is also correct. So I think I might be producing some error for small values of t?
I have no idea how to proceed in making the plot pretty.
I can see in the x- and y-values of the curve, that e.g. T_totaldist(100, 0.14) outputs 4.252961e+13 while T_totaldist(100, 0.28) outputs -4.982278e+10. This is clearly not what I want, since the density should be very close to zero at these small values for t, and since the density should never be negative.
Background:
I'm trying to modify the shape of a histogram resulted from an "Initial" large sample obtained using Initial = rbeta(1e5, 2, 3). Specifically, I want the modified version of the Initial large sample to have 2 additional smaller (in height) "humps" (i.e., another 2 smaller-height peaks in addition to the one that existed in the Initial large sample).
Coding Question:
I'm wondering how to manipulate sample() (maybe using its prob argument) in R base so that this command samples in a manner that the two additional humps be around ".5" and ".6" on the X-Axis?
Here is my current R code:
Initial = rbeta(1e5, 2, 3) ## My initial Large Sample
hist (Initial) ## As seen, here there is only one "hump" say near
# less than ".4" on the X-Axis
Modified.Initial = sample(Initial, 1e4 ) ## This is meant to be the modified version of the
# the Initial with two additional "humps"
hist(Modified.Initial) ## Here, I need to see two additional "humps" near
# ".5" and ".6" on the X-Axis
You can adjust the density distribution by combining it with beta distributions with the desired modes for a smoothed adjustment.
set.seed(47)
Initial = rbeta(1e5, 2, 3)
d <- density(Initial)
# Generate densities of beta distribution. Parameters determine center (0.5) and spread.
b.5 <- dbeta(seq(0, 1, length.out = length(d$y)), 50, 50)
b.5 <- b.5 / (max(b.5) / max(d$y)) # Scale down to max of original density
# Repeat centered at 0.6
b.6 <- dbeta(seq(0, 1, length.out = length(d$y)), 60, 40)
b.6 <- b.6 / (max(b.6) / max(d$y))
# Collect maximum densities at each x to use as sample probability weights
p <- pmax(d$y, b.5, b.6)
plot(p, type = 'l')
# Sample from density breakpoints with new probability weights
Final <- sample(d$x, 1e4, replace = TRUE, prob = p)
Effects on histogram are subtle...
hist(Final)
...but are more obvious in the density plot.
plot(density(Final))
Obviously all adjustments are arbitrary. Please don't do terrible things with your power.
I am very new to machine learning so I am open to suggestions as well. I read something called minimax risk today and I was wondering if this is possible in my case.
I have two datasets and am interested in finding a line (or a boundary to be more precise) such that the area under the left curve to the right of the vertical line is equal to the area under the right curve to the left of the vertical line. Is there a way this can be done in R i.e., find out the exact location to draw the vertical line?
I put up some sample data here that can be used to plot the following graph: https://gist.github.com/Legend/2f299c3b9ba94b9328b2
Suppose you are using the density function to get the estimated kernel density for each response, then follow this link to get the estimated kernel CDF, then your question would become to find a value t, such that: 1 - cdf1(t) = cdf2(t), which can be solved by regular root find function:
x1 <- subset(data, Type == 'Curve 1')$Value
x2 <- subset(data, Type == 'Curve 2')$Value
pdf1 <- density(x1)
f1 <- approxfun(pdf1$x, pdf1$y, yleft = 0, yright = 0)
cdf1 <- function(z){
integrate(f1, -Inf, z)$value
}
pdf2 <- density(x2)
f2 <- approxfun(pdf2$x, pdf2$y, yleft = 0, yright = 0)
cdf2 <- function(z){
integrate(f2, -Inf, z)$value
}
Target <- function(t){
1 - cdf1(t) - cdf2(t)
}
uniroot(Target, range(c(x1, x2)))$root
R > uniroot(Target, range(c(x1, x2)))$root
[1] 0.06501821