I'm trying to create a graph in R to show the carrying capacity of a population using an example given to me which is:
install.packages("deSolve", dependencies = TRUE)
clogistic <- function(times, y, parms){
n <- y[1]
r <- parms[1]
alpha <- parms [2]
dN.dt <- r * n * (1 - alpha * n)
return(list(c(dN.dt)))
}
prms <- c(r = 1, alpha = 0.01)
init.N <- c(1)
t.s <- seq(0.1, 10, by = 0.1)
library(deSolve)
out <- ode(y = init.N, times = t.s, clogistic, parms = prms)
plot(out[,1], out[,2], type="l", xlab = "Time", ylab = "N", col = "blue", lwd = 2)
Now I'm using this to try and show a starting population of 178 with an increase of 21 for 15 time steps. But when I try to change the formula it decreases and bottoms out after one time step and stays bottom for the remainder of the time.
I've tried changing init.N <- c(1) to c(178) which it does but then bottoms out. I've tried changing prms <- c(r = 1, alpha = 0.01) to (r = 21, along with the change in initial population change and without but it just doesn't increase. What is it that I am missing? Knowing R it's going to be something small but I just keep missing it.
Any help will be greatly appreciated.
This is the differential equation that is being integrated:
dN.dt <- r * n * (1 - alpha * n)
If you want an asymptote of n= 200 then set alpha to 1/200 so that the rate of change will go to zero when n gets to 200:
prms <- c(r = 1, alpha = .005)
init.N <- 178
t.s <- seq(0.1, 10, by = 0.1)
library(deSolve)
out <- ode(y = init.N, times = t.s, clogistic, parms = prms)
plot(out[,1], out[,2], type="l", xlab = "Time", ylab = "N", col = "blue", lwd = 2)
With a starting value of 178, the rate of change will be negative when alpha is greater than 1/178, will be flatline with alpha == 1/178, and will be logistic when alpha is less than 1/178.
To go from 300 to 200 you would keep alpha = 1/200 and start at 300:
prms <- c(r = 1, alpha = 1/200)
init.N <- c(300)
t.s <- seq(0.1, 10, by = 0.1)
out <- ode(y = init.N, times = t.s, clogistic, parms = prms)
plot(out[,1], out[,2], type="l", xlab = "Time", ylab = "N", col = "blue", lwd = 2)
Related
I want to draw different uniform distributions in R, preferably with ggplot. When attempting to draw the pdf of U(0.35,0.55), it looks like there are values around the edges (i.e. the parameter values, in this case 0.35 and 0.55) that have a probability that is different from what it should be. The output can be seen here:
This is consistent across different parameters as inputs of the uniform distribution, and does not seem to be a scale issue.
A code example that reproduces similar results:
#parameters
alpha_1 <- 0.35
beta_1 <- 0.55
alpha_2 <- 0.5
beta_2 <- 0.7
alpha_3 <- 0.1
beta_3 <- 0.3
base <- ggplot() + xlim(-1, 2)
base +
geom_function(aes(colour = "state 1"), fun = dunif, args = list(alpha_1, beta_1)) +
geom_function(aes(colour = "state 2"), fun = dunif, args = list(alpha_2, beta_2)) +
geom_function(aes(colour = "state 3"), fun = dunif, args = list(alpha_3, beta_3))
Using stat_function instead of geom_function does not change anything.
However, the following works:
curve(dunif(x, min = alpha_1, max = beta_1),
from = 0, to = 1,
n = 100000,
col = "blue",
lwd = 2,
add = F,
yaxt = "n",
ylab = 'probability')
curve(dunif(x, min = alpha_2, max = beta_2),
from = 0, to = 1,
n = 100000,
col = "red",
lwd = 2,
add = T,
yaxt = "n",
ylab = 'probability')
curve(dunif(x, min = alpha_3, max = beta_3),
from = 0, to = 1,
n = 100000,
col = "black",
lwd = 2,
add = T,
yaxt = "n",
ylab = 'probability')
How can I get this to work in ggplot? It seems to me the issue might be this:
n values along the x-axis are evaluated to get coordinates for the graph. Around the parameters (a,b) these are, e.g. at a+0.0001 and a-0.0001. The straight line between these coordinates would not be perfectly vertical. I am not sure whether that is the correct diagnosis, but in any case I would appreciate any help. Thanks!
This is easily solved by increasing the number of evaluation points, as Gregor Thomas has helpfully pointed out in a comment. The following adjusted code works just as intended:
library(ggplot2)
#parameters
alpha_1 <- 0.35
beta_1 <- 0.55
alpha_2 <- 0.5
beta_2 <- 0.7
alpha_3 <- 0.1
beta_3 <- 0.3
base <- ggplot() + xlim(-1, 2)
base +
stat_function(aes(colour = "state 1"), fun = dunif, args = list(alpha_1, beta_1), n = 10001) +
stat_function(aes(colour = "state 2"), fun = dunif, args = list(alpha_2, beta_2), n = 10001) +
stat_function(aes(colour = "state 3"), fun = dunif, args = list(alpha_3, beta_3), n = 10001)
Where the key change is to add n=10001 to every stat_function call.
I have these curves below:
These curves were generated using a library called discreteRV.
library(discreteRV)
placebo.rate <- 0.5
mmm.rate <- 0.3
mmm.power <- power.prop.test(p1 = placebo.rate, p2 = mmm.rate, power = 0.8, alternative = "one.sided")
n <- as.integer(ceiling(mmm.power$n))
patients <- seq(from = 0, to = n, by = 1)
placebo_distribution <- dbinom(patients, size = n, prob = placebo.rate)
mmm_distribution <- dbinom(patients, size = n, prob = mmm.rate)
get_pmf <- function(p1, p2) {
X1 <- RV(patients,p1, fractions = F)
X2 <- RV(patients,p2, fractions = F)
pmf <- joint(X1, X2, fractions = F)
return(pmf)
}
extract <- function(string) {
ints <- unlist(strsplit(string,","))
x1 <- as.integer(ints[1])
x2 <- as.integer(ints[2])
return(x1-x2)
}
diff_prob <- function(pmf) {
diff <- unname(sapply(outcomes(pmf),FUN = extract)/n)
probabilities <- unname(probs(pmf))
df <- data.frame(diff,probabilities)
df <- aggregate(. ~ diff, data = df, FUN = sum)
return(df)
}
most_likely_rate <- function(x) {
x[which(x$probabilities == max(x$probabilities)),]$diff
}
mmm_rate_diffs <- diff_prob(get_pmf(mmm_distribution,placebo_distribution))
placebo_rate_diffs <- diff_prob(get_pmf(placebo_distribution,placebo_distribution))
plot(mmm_rate_diffs$diff,mmm_rate_diffs$probabilities * 100, type = "l", lty = 2, xlab = "Rate difference", ylab = "# of trials per 100", main = paste("Trials with",n,"patients per treatment arm",sep = " "))
lines(placebo_rate_diffs$diff, placebo_rate_diffs$probabilities * 100, lty = 1, xaxs = "i")
abline(v = c(most_likely_rate(placebo_rate_diffs), most_likely_rate(mmm_rate_diffs)), lty = c(1,2))
legend("topleft", legend = c("Alternative hypothesis", "Null hypothesis"), lty = c(2,1))
Basically, I took two binomial discrete random variables, created a joint probability mass function, determined the probability of any given rate difference then plotted them to demonstrate a distribution of those rate differences if the null hypothesis was true or if the alternative hypothesis was true over 100 identical trials.
Now I want to illustrate the 5% percentile on the null hypothesis curve. Unfortunately, I don't know how to do this. If I simply use quantile(x = placebo_rate_diffs$diff, probs = 0.05, I get -0.377027. This can't be correct looking at the graph. I want to calculate the 5th percentile like I would using pbinom() but I don't know how to do that with a graph created from essentially what are just x and y vectors.
Maybe I can approximate these two curves as binomial since they appear to be, but I am still not sure how to do this.
Any help would be appreciated.
I have found few codes on line but non of them could help me solve my problem. I know the expr needs x but I couldn't find way to plot these to functions using the curve function. I am able to plot them when the model has only one independent variable but not more than one. Here is the code
n <- 50
x1 <- runif(n = n, min = 0, max = 1)
x2 <- rnorm(n,mean = -50,1)
x3 <- rnorm(n=n,mean =50,sd=8)
z <- 3 - 4.2*x1 - x2 - x3
pr <- 1/(1+exp(-z))
y <- rbinom(n=n,1,pr)
y
# create dataframe
df = data.frame(y=y,x1=x1,x2=x2,x3=x3)
m <- glm( y~.,data=df,family=binomial(link = "logit"))
summary(m)
beta.hat <- m$coefficients
z.hat <- beta.hat[1] + beta.hat[2]*x1 + beta.hat[3]*x2 + beta.hat[4]*x3
curve(expr = exp(z) / (1 + exp(z)), xlim = c(0,1), ylab = expression(pi), n = 1000, lwd = 3, xlab = expression(z/hat(z)))
curve(expr = exp(z.hat)/(1 + exp(z.hat)), xlim = c(0,1), add = TRUE, col = "red", n = 1000)
I've code gradient descent algorithm in R and now I'm trying to "draw" the path of the vectors.
I've got draw points in my contour plot, but it's not correct because nobody knows what happened first.
In my algorith always I have an previous state P=(Xi,Yi) and a later state L=(Xi+1,Yi+1), so, How can I draw the vector PL in a contour or a persp plot?
I only got this with contour, where the red point is the convergence:
The same for persp:
Thanks all!
EDIT:
Graphics can be obtanined respectively:
f<-function(u,v){
u*u*exp(2*v)+4*v*v*exp(-2*u)-4*u*v*exp(v-u)
}
x = seq(-2, 2, by = 0.5)
y = seq(-2, 2, by = 0.5)
z <- outer(x,y,f)
#Contour plot
contour(x,y,z)
#Persp plot
persp(x, y, z, phi = 25, theta = 55, xlim=c(-2,2), ylim=c(-2,2),
xlab = "U", ylab = "V",
main = "F(u,v)", col="yellow", ticktype = "detailed"
) -> res
Taking Himmelblau's function as a test example:
f <- function(x, y) { (x^2+y-11)^2 + (x+y^2-7)^2 }
Its partial derivatives:
dx <- function(x,y) {4*x**3-4*x*y-42*x+4*x*y-14}
dy <- function(x,y) {4*y**3+2*x**2-26*y+4*x*y-22}
Running the gradient descent:
# gradient descent parameters
num_iter <- 100
learning_rate <- 0.001
x_val <- 6
y_val <- 6
updates_x <- vector("numeric", length = num_iter)
updates_y <- vector("numeric", length = num_iter)
updates_z <- vector("numeric", length = num_iter)
# parameter updates
for (i in 1:num_iter) {
dx_val = dx(x_val,y_val)
dy_val = dy(x_val,y_val)
x_val <- x_val-learning_rate*dx_val
y_val <- y_val-learning_rate*dx_val
z_val <- f(x_val, y_val)
updates_x[i] <- x_val
updates_y[i] <- y_val
updates_z[i] <- z_val
}
Plotting:
x <- seq(-6, 6, length = 100)
y <- x
z <- outer(x, y, f)
plt <- persp(x, y, z,
theta = -50-log(i), phi = 20+log(i),
expand = 0.5,
col = "lightblue", border = 'lightblue',
axes = FALSE, box = FALSE,
ltheta = 60, shade = 0.90
)
points(trans3d(updates_x[1:i], updates_y[1:i], updates_z[1:i],pmat = plt),
col = c(rep('white', num_iter-1), 'blue'),
pch = 16,
cex = c(rep(0.5, num_iter-1), 1))
There's a trick to plotting points using persp, as mentioned in ?persp. By employing the power of trans3d, you can successfully put points and lines on a perspective plot.
f<-function(u,v){
u*u*exp(2*v)+4*v*v*exp(-2*u)-4*u*v*exp(v-u)
}
x = seq(-2, 2, by = 0.5)
y = seq(-2, 2, by = 0.5)
z <- scale(outer(x,y,f))
view <- persp(x, y, z, phi = 30, theta = 30, xlim=c(-2,2), ylim=c(-2,2),
xlab = "X", ylab = "Y", zlab = "Z", scale = FALSE,
main = "F(u,v)", col="yellow", ticktype = "detailed")
set.seed(2)
pts <- data.frame(x = sample(x, 3),
y = sample(y, 3),
z = sample(z, 3))
points(trans3d(x = pts$x, y = pts$y, z = pts$z, pmat = view), pch = 16)
lines(trans3d(x = pts$x, y = pts$y, z = pts$z, pmat = view))
I can plot multiple simultaneous time series that undergo changepoints and regimes using ggplot2, and I can use colour to make the regimes clear (plotting different sections in different colors using geom_rect). I need to produce a plot that makes it clear where the regimes are without the use of color. With three regimes it is possible to distinguish between the regimes using white, black and gray for shading, but it is difficult to tell them apart if more than three regimes are present.
I've put an example of a plot that I can make using color, I'd be very grateful if someone can suggest a plot that conveys the same information without the use of color.
library(ggplot2)
library(scales)
# generate 3 time series and store them in a data frame
generate_cp_ts <- function(tau, params) {
ts(c(arima.sim(model = list(ar = 0.2), n = tau[1], rand.gen = function(n) params[1] * rnorm(n)), arima.sim(model = list(ar = 0.2), n = tau[2] - tau[1], rand.gen = function(n) params[2] * rnorm(n)), arima.sim(model = list(ar = 0.2), n = tau[3] - tau[2], rand.gen = function(n) params[3] * rnorm(n)), arima.sim(model = list(ar = 0.2), n = tau[4] - tau[3], rand.gen = function(n) params[4] * rnorm(n))))
}
tau <- 100 * (1:4)
ts1 <- generate_cp_ts(tau, c(1.7, 0.3, 1.7, 1.7))
ts2 <- generate_cp_ts(tau, c(0.3, 2, 0.3, 0.9))
ts3 <- generate_cp_ts(tau, c(2, 2, 0.1, 0.7))
tsframe <- data.frame(ts = c(ts1, ts2, ts3), ts_level = factor(paste("Time Series", rep(1:3, each = 400))), time = rep(1:400, 3))
# Work out which colors are needed to color the plot and store in a data frame
CPs <- c(0, tau)
colour.frame <- data.frame(regime.from = rep(CPs[-length(CPs)], each = 3), regime.to = rep(CPs[-1], each = 3), ts_level = factor(paste("Time Series", rep(c(1:3), length(CPs) - 1))), regime = factor(c(0,0,0, 1,1,0, 0,0,1, 0,2,2) + 1))
# Plotting
qplot(x = time, y = ts, data = tsframe, facets = ts_level ~ ., alpha = I(1), geom = "line", ylab = "Time Series", xlab = "Time") +
geom_rect(aes(NULL, NULL, xmin = regime.from, xmax = regime.to, fill = regime), ymin = -6, ymax = 6, data = colour.frame) +
scale_fill_manual(values = alpha(c("blue", "red", "green"), 0.2))
Plot generated by the above code
After you created colour.frame you can insert this code:
tdf <- colour.frame
tdf$xval <- (tdf$regime.from + tdf$regime.to)/2
tdf$yval <- max(tsframe$ts) * 0.8 # if 0.8 is higher (0.9) then the text is set higher
ggplot(tsframe, aes(x = time, y = ts)) +
geom_line() +
facet_grid(ts_level~.) +
geom_vline(xintercept = CPs) + # maybe play around with linetype
geom_text(aes(x = xval, y = yval, label = regime), data = tdf)
which gives this plot: