I have taken this example from documentation for demonstration purposes. In the following example when the value of y reaches to 0.1 a random value is added. I want to terminate the solver if the y value is greater than 0.8.
One possible solution is to generate a random value in eventfun such that y is always less than 0.8.
Is there any other possible solution to terminate the solver? This would be helpful in my complicated model.
## =======================================================================
## Example 3:
## using lsodar to trigger an event
## =======================================================================
## a state variable is decaying at a first-order rate.
## when it reaches the value 0.1, a random amount is added.
library("deSolve")
derivfun <- function (t,y,parms)
list (-0.05 * y)
rootfun <- function (t,y,parms)
return(y - 0.1)
eventfun <- function(t,y,parms)
return(y + runif(1))
yini <- 0.5
times <- 0:400
out <- lsodar(func=derivfun, y = yini, times=times,
rootfunc = rootfun, events = list(func=eventfun, root = TRUE))
plot(out, type = "l", lwd = 2, main = "lsodar with event")
# }
Does the following what you want? Thanks for the clear example.
library("deSolve")
derivfun <- function (t,y,parms)
list (-0.05 * y)
rootfun <- function (t,y,parms)
return(c(y - 0.1, y - 0.8))
eventfun <- function(t,y,parms)
return(y + runif(1))
yini <- 0.5
times <- 0:400
out <- lsodar(func=derivfun, y = yini, times=times,
rootfunc = rootfun,
events = list(func=eventfun, root = TRUE, terminalroot = 2))
plot(out, type = "l", lwd = 2, main = "lsodar with event")
And here another refinement of rootfun and eventfun:
library("deSolve")
terminate <- 0.8
eps <- 1e-6
derivfun <- function (t, y, parms)
list (-0.05 * y)
rootfun <- function (t, y, parms)
return(c(y - 0.1, y - terminate))
eventfun <- function(t, y, parms)
return(min(y + runif(1), terminate + eps))
yini <- 0.5
times <- 0:400
out <- lsodar(func=derivfun, y = yini, times=times,
rootfunc = rootfun,
events = list(func = eventfun, root = TRUE, terminalroot = 2))
plot(out, type = "l", lwd = 2, main = "lsodar with event")
Related
TLDR: My main challenge is just how do I write the root function that checks an arbitrary number of state variables, x, and then apply the event function such that all state variables n that have a value less than the threshold (n <= x) are acted upon by the event function?
I'm trying to use deSolve for a set of Lotka-Volterra equations, but with many state variables (i.e. not just a predator and prey but 20 interacting organisms).
I want to use a root function and event function to be constantly checking if any state variable values dip below a threshold value (e.g. 1.0) and if they do, use the event function to make that particular state variable 0. I've been messing around with a simple minimal example, but can't quite understand how to extend this to check all the state variables and just apply to the one(s) that is/are below the threshold.
The LV example from the deSolve package vignette
LVmod <- function(Time, State, Pars) {
with(as.list(c(State, Pars)), {
Ingestion <- rIng * Prey * Predator
GrowthPrey <- rGrow * Prey * (1 - Prey/K)
MortPredator <- rMort * Predator
dPrey <- GrowthPrey - Ingestion
dPredator <- Ingestion * assEff - MortPredator
return(list(c(dPrey, dPredator)))
})
}
pars <- c(rIng = 0.2, # /day, rate of ingestion
rGrow = 1.0, # /day, growth rate of prey
rMort = 0.2 , # /day, mortality rate of predator
assEff = 0.5, # -, assimilation efficiency
K = 10) # mmol/m3, carrying capacity
yini <- c(Prey = 10, Predator = 2)
times <- seq(0, 50, by = 1)
I can apply my root and event functions to check for just the prey's values:
## event triggered if state variable less than 1
rootfun <- function (Time, State, Pars) {
return(State[1] - 1)
}
## sets state variable = 1
eventfun <- function(Time, State, Pars) {
return(c(State[1] <- 0, State[2]))
}
out <- lsode(yini, times, LVmod, pars,
rootfunc = rootfun,
events = list(func = eventfun, root = TRUE))
## User specified plotting
matplot(out[ , 1], out[ , 2:3], type = "l", xlab = "time", ylab = "Conc",
main = "Lotka-Volterra", lwd = 2)
legend("topright", c("prey", "predator"), col = 1:2, lty = 1:2)
And the result is this:
But now I want to extend this so that it checks all the state variables (in this case just the 2), but ideally in a way that is flexible to different numbers of state variables. I have tried messing around with doing this in some sort of loop but can't seem to figure it out. My main challenge is just how do I write the root function that checks an arbitrary number of state variables, x, and then apply the event function such that all state variables n that have a value less than the threshold (n <= x) are acted upon by the event function?
Perhaps useful information is at some point I would like to implement a separate (not root-based) event function to change a parameter at some pre-set times, so ideally the solution to this problem could interface with additional event function implementation.
Help much appreciated as always!!
One can use a vectorized version of the LV model and then write rootfun and eventfun also in vectorized style:
library(deSolve)
model <- function(t, y, parms) {
with(parms, {
dy <- r * y + y * (A %*% y)
list(dy)
})
}
## int6eraction matrix
parms <- list(
r = c(r1 = 0.1, r2 = 0.1, r3 = -0.1, r4 = -0.1),
A = matrix(c(
0.0, 0.0, -0.2, 0.0, # prey 1
0.0, 0.0, 0.0, -0.1, # prey 2
0.2, 0.0, 0.0, 0.0, # predator 1; eats prey 1
0.0, 0.1, 0.0, 0.0), # predator 2; eats prey 2
nrow = 4, ncol = 4, byrow = TRUE)
)
times = seq(0, 150, 1)
y0 = c(n1 = 1, n2 = 1, n3 = 2, n4 = 2)
out <- ode(y0, times, model, parms)
plot(out)
## defined as global variables for simplicity, can also be put into parms
threshold <- 0.2 # can be a vector of length(y0)
y_new <- 1.0 # can be a vector of length(y0)
## uncomment the 'cat' lines to see what's going on
rootfun <- function (t, y, p) {
#cat("root at t=", t, "\n")
#cat("y old =", y, "\n")
return(y - threshold)
}
eventfun <- function(t, y, p) {
#cat("y old =", y, "\n")
y <- ifelse(y <= threshold, y_new, y)
#cat("y new =", y, "\n")
return(y)
}
out <- ode(y0, times, model, parms,
events = list(func = eventfun, root = TRUE), rootfunc=rootfun)
plot(out)
I want to plot function res for different value of epsilon=0.1, 0.2,0.3,0.9 in the same plot in R.
My setting is that
#make this example reproducible
set.seed(1001)
n <- 500
#Sample GOE random matrix
A <- matrix(rnorm(n*n, mean=0, sd=1), n, n)
G <- (A + t(A))/sqrt(2*n)
ev <- eigen(G)
l <- ev$values
v <- ev$vectors
#size of multivariate distribution
mean <- rep(0, n)
var <- diag(n)
#simulate bivariate normal distribution
initial <- MASS::mvrnorm(n=1000, mu=mean, Sigma=var) #ten random vectors
#normalized the first possible initial value, the initial data uniformly distributed on the sphere
xmats <- lapply(1:1000, function(i) initial[i, ]/norm(initial[i, ], type="2"))
#define my function
h1t <- function(t,x_0) {
h10 <- c(x_0 %*% v[, n])
denom <- vapply(t, function(.t) {
sum((x_0 %*% v)^2 * exp(-4*(l - l[n]) * .t))
}, numeric(1L))
abs(h10) / sqrt(denom)
}
For 1000 initial value x_0 from normal distribution (I put them in a matrix xmats), I can plot all value of t so that h1t=epsilon for epsilon=0.9.
#set epsilon=0.9
find_t <- function(x, epsilon = 0.9, range = c(-500, 500)) {
uniroot(function(t) h1t(t, x) - epsilon, range,
tol = .Machine$double.eps)$root
}
res <- lapply(xmats, find_t)
plot(density(unlist(res)), xlim = c(0, 300),col = "red",
main = "Fix epsilon=0.9. Density of tau_epsilon for different initial value for n=500")
I got:
Question: How do I plot the graph of res for different epsilon in the same plot?
You can do this by applying your function to the parameter. I called the result find_t03 and call lines after the plot call with this new result.
I have added ylim to the plot and also added a break in the title.
#set epsilon=0.9
find_t <- function(x, epsilon = 0.9, range = c(-500, 500)) {
uniroot(function(t) h1t(t, x) - epsilon, range,
tol = .Machine$double.eps)$root
}
#set epsilon=0.3
find_t03 <- function(x, epsilon = 0.3, range = c(-500, 500)) {
uniroot(function(t) h1t(t, x) - epsilon, range,
tol = .Machine$double.eps)$root
}
res <- lapply(xmats, find_t)
res03 <- lapply(xmats, find_t03)
plot(density(unlist(res)), xlim = c(0, 200),
ylim=c(0, 0.2),col = "red",
main = paste0("Fix epsilon=0.9 (red) and 0.3 (black).",
"\n", "Density of tau_epsilon for different initial value for n=500"))
lines(density(unlist(res03)), ylim = c(0, 1000))
I want to get a 95% confidence interval for the following question.
I have written function f_n in my R code. I first randomly sample 100 with Normal and then I define function h for lambda. Then I can get f_n. My question is that how to define a function of f_n-chi-square and use uniroot` to find Confidence interval.
# I first get 100 samples
set.seed(201111)
x=rlnorm(100,0,2)
Based on the answer by #RuiBarradas, I try the following code.
set.seed(2011111)
# I define function h, and use uniroot function to find lambda
h <- function(lam, n)
{
sum((x - theta)/(1 + lam*(x - theta)))
}
# sample size
n <- 100
# the parameter of interest must be a value in [1, 12],
#true_theta<-1
#true_sd<- exp(2)
#x <- rnorm(n, mean = true_theta, sd = true_sd)
x=rlnorm(100,0,2)
xmax <- max(x)
xmin <- min(x)
theta_seq = seq(from = 1, to = 12, by = 0.01)
f_n <- rep(NA, length(theta_seq))
for (i in seq_along(theta_seq))
{
theta <- theta_seq[i]
lambdamin <- (1/n-1)/(xmax - theta)
lambdamax <- (1/n-1)/(xmin - theta)
lambda = uniroot(h, interval = c(lambdamin, lambdamax), n = n)$root
f_n[i] = -sum(log(1 + lambda*(x - theta)))
}
j <- which.max(f_n)
max_fn <- f_n[j]
mle_theta <- theta_seq[j]
plot(theta_seq, f_n, type = "l",
main = expression(Estimated ~ theta),
xlab = expression(Theta),
ylab = expression(f[n]))
points(mle_theta, f_n[j], pch = 19, col = "red")
segments(
x0 = c(mle_theta, xmin),
y0 = c(min(f_n)*2, max_fn),
x1 = c(mle_theta, mle_theta),
y1 = c(max_fn, max_fn),
col = "red",
lty = "dashed"
)
I got the following plot of f_n.
For 95% CI, I try
LR <- function(theta, lambda)
{
2*sum(log(1 + lambda*(x - theta))) - qchisq(0.95, df = 1)
}
lambdamin <- (1/n-1)/(xmax - mle_theta)
lambdamax <- (1/n-1)/(xmin - mle_theta)
lambda <- uniroot(h, interval = c(lambdamin, lambdamax), n = n)$root
uniroot(LR, c(xmin, mle_theta), lambda = lambda)$root
The result is 0.07198144. Then the logarithm is log(0.07198144)=-2.631347.
But there is NA in the following code.
uniroot(LR, c(mle_theta, xmax), lambda = lambda)$root
So the 95% CI is theta >= -2.631347.
But the question is that the 95% CI should be a closed interval...
Here is a solution.
First of all, the data generation code is wrong, the parameter theta is in the interval [1, 12], and the data is generated with rnorm(., mean = 0, .). I change this to a true_theta = 5.
set.seed(2011111)
# I define function h, and use uniroot function to find lambda
h <- function(lam, n)
{
sum((x - theta)/(1 + lam*(x - theta)))
}
# sample size
n <- 100
# the parameter of interest must be a value in [1, 12],
true_theta <- 5
true_sd <- 2
x <- rnorm(n, mean = true_theta, sd = true_sd)
xmax <- max(x)
xmin <- min(x)
theta_seq <- seq(from = xmin + .Machine$double.eps^0.5,
to = xmax - .Machine$double.eps^0.5, by = 0.01)
f_n <- rep(NA, length(theta_seq))
for (i in seq_along(theta_seq))
{
theta <- theta_seq[i]
lambdamin <- (1/n-1)/(xmax - theta)
lambdamax <- (1/n-1)/(xmin - theta)
lambda = uniroot(h, interval = c(lambdamin, lambdamax), n = n)$root
f_n[i] = -sum(log(1 + lambda*(x - theta)))
}
j <- which.max(f_n)
max_fn <- f_n[j]
mle_theta <- theta_seq[j]
plot(theta_seq, f_n, type = "l",
main = expression(Estimated ~ theta),
xlab = expression(Theta),
ylab = expression(f[n]))
points(mle_theta, f_n[j], pch = 19, col = "red")
segments(
x0 = c(mle_theta, xmin),
y0 = c(min(f_n)*2, max_fn),
x1 = c(mle_theta, mle_theta),
y1 = c(max_fn, max_fn),
col = "red",
lty = "dashed"
)
LR <- function(theta, lambda)
{
2*sum(log(1 + lambda*(x - theta))) - qchisq(0.95, df = 1)
}
lambdamin <- (1/n-1)/(xmax - mle_theta)
lambdamax <- (1/n-1)/(xmin - mle_theta)
lambda <- uniroot(h, interval = c(lambdamin, lambdamax), n = n)$root
uniroot(LR, c(xmin, mle_theta), lambda = lambda)$root
#> [1] 4.774609
Created on 2022-03-25 by the reprex package (v2.0.1)
The one-sided CI95 is theta >= 4.774609.
I am trying to solve this system of ODEs through deSolve, dX/dt = -X*a + (Y-X)b + c and dY/dt = -Ya + (X-Y)*b for time [0,200], a=0.30, b=0.2 but c is 1 for time [50,70] and 0 otherwise. The code I have been using is,
time <- seq(0, 200, by=1)
parameters <- c(a=0.33, b=0.2, c=1)
state <- c(X = 0, Y = 0)
two_comp <- function(time, state, parameters){
with(as.list(c(state, parameters)), {
dX = -X*a + (Y-X)*b + c
dY = -Y*a + (X-Y)*b
return(list(c(dX, dY)))
})
}
out <- ode(y = state, times = time, func = two_comp, parms = parameters)
out.df = as.data.frame(out)
I have left out the time varying part of the c parameter since I can't figure out a way to include it and run it smoothly. I tried including it in the function definitions, but to no avail.
The standard way is to use approxfun, i.e. create a time dependent signal, that we also call forcing variable:
library("deSolve")
time <- seq(0, 200, by=1)
parameters <- c(a=0.33, b=0.2, c=1)
state <- c(X = 0, Y = 0)
two_comp <- function(time, state, parameters, signal){
cc <- signal(time)
with(as.list(c(state, parameters)), {
dX <- -X * a + (Y - X) * b + cc
dY <- -Y * a + (X - Y) * b
return(list(c(dX, dY), c = cc))
})
}
signal <- approxfun(x = c(0, 50, 70, 200),
y = c(0, 1, 0, 0),
method = "constant", rule = 2)
out <- ode(y = state, times = time, func = two_comp,
parms = parameters, signal = signal)
plot(out)
Note also the deSolve specific plot function and that the time dependent variable cc is used as an additional output variable.
More about this can be found:
in the ?forcings help page and
in a short tutorial on Github.
The interval limits where c is equal to 1 can be passed as parameters. Then, inside the differential function, use them to create a logical value
time >= lower & time <= upper
Since FALSE/TRUE are coded as the integers 0/1, every time this condition is false, c is multiplied by zero and the trick is done.
library(deSolve)
two_comp <- function(time, state, parameters){
with(as.list(c(state, parameters)), {
dX = -X*a + (Y-X)*b + c*(time >= lower & time <= upper)
dY = -Y*a + (X-Y)*b
return(list(c(dX, dY)))
})
}
time <- seq(0, 200, by=1)
parameters <- c(a=0.33, b=0.2, c=1, lower = 50, upper = 70)
state <- c(X = 0, Y = 0)
out <- ode(
y = state,
times = time,
func = two_comp,
parms = parameters
)
out.df <- as.data.frame(out)
head(out.df)
matplot(out.df$time, out.df[-1], type = "l", lty = "solid", ylim = c(0, 3))
legend("topright", legend = names(out.df)[-1], col = 1:2, lty = "solid")
I am trying to obtain a steady state for a spatially-explicit Lotka-Volterra competition model of two competing species (with spatial diffusion). Here is the model (without diffusion term):
http://en.wikipedia.org/wiki/Competitive_Lotka%E2%80%93Volterra_equations
where I let r1 = r2 = rG & alpha12 = alpha 21 = a. The carrying capacity of species 1 is assumed to vary linearly across space x i.e. K1 = x (while K2 = 0.5). And we assume Neumann BC. The spatial domain x is from 0 to 1.
Here is the example of coding in R for this model:
LVcomp1D <- function (time, state, parms, N, Da, x, dx) {
with (as.list(parms), {
S1 <- state[1:N]
S2 <- state[(N+1):(2*N)]
## Dispersive fluxes; zero-gradient boundaries
FluxS1 <- -Da * diff(c(S1[1], S1, S1[N]))/dx
FluxS2 <- -Da * diff(c(S2[1], S2, S2[N]))/dx
## LV Competition
InteractS1 <- rG * S1 * (1- (S1/x)- ((a*S2)/x))
InteractS2 <- rG * S2 * (1- (S2/(K2))- ((a*S1)/(K2)))
## Rate of change = -Flux gradient + Interaction
dS1 <- -diff(FluxS1)/dx + InteractS1
dS2 <- -diff(FluxS2)/dx + InteractS2
return (list(c(dS1, dS2)))
})
}
pars <- c(rG = 1.0, a = 0.8, K2 = 0.5)
dx <- 0.001
x <- seq(0, 1, by = dx)
N <- length(x)
Da <- 0.001
state <- c(rep(0.5, N), rep(0.5, N))
print(system.time(
out <- steady.1D (y = state, func = LVcomp1D, parms = pars,
nspec = 2, N = N, x = x, dx = dx, Da = Da, pos = TRUE)
))
mf <- par(mfrow = c(2, 2))
plot(out, grid = x, xlab = "x", mfrow = NULL,
ylab = "N(x)", main = c("Species 1", "Species 2"), type = "l")
par(mfrow = mf)
The problem is I cannot get the steady state solutions of the model. I keep getting a horizontal line passing through x-axis. Can you please help me since I do not know what is wrong with this code.
Thank you