I'm using the FME package to fit a prey-predator model to my data. At the moment I'm just learning and testing the code without fitting anything yet, following this example: http://strimas.com/r/lotka-volterra/
When executing the global sensitivity analyses I get an error and I can't figure out where it comes from.
When I copy paste the example above in my R session, it works. But I can't get my own code to work.
I wrote my function based on another document on FME so the syntax is slightly different.
# model function
RMmodel <- function(t, y, parms) {
#y <- c(N = 30, P = 3)
derivs <- function(t, y, parms) {
with(as.list(c(y, parms)), {
dN <- r * N * (1 - N/K) - a * N * P / (1 + a*h*N)
dP <- e * a * N * P / (1 + a*h*N) - m * P
return(list(c(dN, dP)))
})
}
return(ode(y = y, times = t, parms = parms, func = derivs))
}
# input
parameters <- c(r = 0.4, # growth rate prey
K = 2200, # carrying capacity prey
a = 0.14, # search rate predator
h = 1, # handling time
e = 1.2, # assimilation efficiency predator
m = 0.2) # mortality rate predator
init <- c(N = 30, P = 3)
times <- seq(0, 120, by=1)
# calculate ODE
RM_result <- RMmodel(t = times, y = init, parms = parameters) # this works
# global sensitivity
par_ranges <- data.frame(min = c(0.18, 1500, 0.01, 0.01, 0.01, 0.01),
max = c(0.25, 3500, 2, 2, 2, 2),
row.names = c("r", "K", "a", "h", "e", "m"))
RM_glob_sens <- sensRange(func = RMmodel, parms = parameters,
dist = "grid",
sensvar = c("N", "P"), parRange = par_ranges,
num = 20, t = times)
When I run the above code I get the following error:
Error in ode(y = y, times = t, parms = parms, func = derivs) :
argument "parms" is missing, with no default
I tried the following things: adjusted the argument name in the model to "pars" instead of "parms"; added the initial state within the model function; changed the object name of "parameters" to "pars"; changed the order within sensRange(); put the parameters directly in sensRange through c(a = , ...).
I am clearly missing someting but I can't find it for the life of me.
Anyone a suggestion?
A requirement of sensRange() is that the first argument of func is parms (see documentation). Change the order of the input arguments in RMmodel and derivs so that parms is the first argument and your code will work.
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 am working with an SIR model using R. I need to plot multiple curves of I on the same figure for different values of beta, say for the values of 0.001, 0.002, 0.003, 0.004, and 0.005. Given below is the code that I have been working with so far. I know this might be a very simple problem, but I am new to R and couldn't find anything helpful yet.
library(deSolve)
sir_model <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
parameters <- c(beta = 0.001, gamma = 0.3)
initial_values <- c(S = 999, I = 1, R = 0)
time_series <- seq(0, 100)
sir_model_1 <- ode(
y = initial_values,
times = time_series,
func = sir_model,
parms = parameters
)
sir_model_1 <- as.data.frame(sir_model_1)
with(sir_model_1, {
plot(time, I, type = "l", col = "black",
xlab = "time (days)", ylab = "Number of infections")
})
I tried to use a for loop, but I think I am not doing it right.
Package deSolve contains a plotting function that supports to add multiple scenarios. It works directly with the output of ode that is a matrix of class deSolve. The first argument of the plot function needs to be such a deSolve object and the second can be a list of such objects.
This way, it can be run and plotted as follows:
library(deSolve)
sir_model <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
parameters <- c(beta = 0.001, gamma = 0.3)
initial_values <- c(S = 999, I = 1, R = 0)
time_series <- seq(0, 100)
run_sir <- function(beta) {
parameters["beta"] <- beta
ode(y = initial_values, times = time_series,func = sir_model, parms = parameters)
}
## define scenarios
beta <- 0.001 * 1:5
## run default scenario
run0 <- run_sir(beta = beta[1])
plot(run0)
## run other 4 scenarios
## [-1] means all except the first, that we already have
runs <- lapply(beta[-1], run_sir)
plot(run0, runs, las=1)
legend("bottomright", legend = paste("beta = ", beta), lty=1:5, col=1:5)
The plot.deSolvefunction is highly configurable with respect to layout, colors, line types, selection of variables, etc., see help page ?plot.deSolve.
To plot only selected state variables, one can use the which argument, e.g. which="I" to plot only the infected.
plot(run0, runs, which="I")
Some examples about plotting deSolve outputs can be found in the tutorial slides in section "Plotting".
We could wrap the code in a function and loop over the sequence of beta values, and plot. If we need to do this in a single plot window, modify the par
par(mfrow = c(5, 1))
lapply(seq(0.001, length.out = 5, by = 0.001), f1)
where
f1 <- function(beta) {
parameters <- c(beta = beta, gamma = 0.3)
initial_values <- c(S = 999, I = 1, R = 0)
time_series <- seq(0, 100)
sir_model_1 <- ode(
y = initial_values,
times = time_series,
func = sir_model,
parms = parameters
)
sir_model_1 <- as.data.frame(sir_model_1)
with(sir_model_1, {
plot(time, I, type = "l", col = "black",
xlab = "time (days)", main = beta, ylab = "Number of infections")
})
}
-output
In case we want to loop over the column names, use the formula method
par(mfrow = c(3, 1))
lapply(names(sir_model_1)[-1], function(nm)
plot(reformulate("time", response = nm), data = sir_model_1, main = nm,
type = "l", col = "black",
xlab = "time (days)", ylab = "Number of infections"))
-output
Hi everyone im using R to try and simulate some economic models. We do this primarily through the use of the euler equation. I've figured out that applying shocks to values which are defined within the function (in this case it is k is pretty simple as seen in the code below, however I'm interested in applying a shock to parameters like delta, theta and rho.
For what its worth I'm using the R package deSolve. Any help is appreciated.
library('deSolve')
##############################################
#Computing the neoclassical growth model in R#
##############################################
#parameters and state space
A<-1
theta<- 0.1
alpha<-0.5
delta<-0.3
rho<-0.9
kinital <- c(k = 1)
times <- seq(from = 0, to = 100, by = 0.2)
#define euler equation
euler <- function(t, k, parms)
list((1/theta)*alpha*A*k^(alpha-1)-delta-rho)
#Compute
out <- ode(y = kinital, times = times, func = euler,
parms = NULL)
plot(out, main = "Euler equation", lwd = 2)
#########################
#Temporary Capital Shock#
########################
eventdat <- data.frame(var = c("k"),
time = c(30) ,
value = c(10),
method = c("add"))
eventdat1 <- data.frame(var = c("k"),
time = c(30) ,
value = c(-5),
method = c("add"))
out3<-ode(y=kinital,times=times,func=euler,events=list(data=eventdat))
out4<-ode(y=kinital,times=times,func=euler,events=list(data=eventdat1))
plot(out,out3,out4,main="Temporary Shock",lwd=3)
Not a great fix but the way to deal with this type of problem is by conditioning your values to take place over some interval. I do this for depreciation as follows:
##############################
#Temporary Depreciation Shock#
##############################
#New Vars
A<-1
theta<- 0.1
alpha<-0.5
delta<-0.3
rho<-0.9
kinital <- c(k = 17)
times <- seq(from = 0, to = 400, by = 0.2)
#Redefine Euler
euler2<-function(t,k,prams){
list((1/theta)*alpha*A*k^(alpha-1)-delta-rho)}
euler3<-function(t,k,prams){
list((1/theta)*alpha*A*k^(alpha-1)-(delta+0.05*(t>=30&t<=40))-rho)}
#Output
doutbase<-ode(y=kinital,times=times, func=euler2, parms=NULL)
doutchange<-ode(y=kinital,times=times, func=euler3, parms=NULL)
#plots
plot(doutbase,doutchange,main="Change in depreciation at t=30 until t=40",lwd=2)
A colleague off of stackexchange suggested a cleaner bit of code which is a bit cleaner. This is seen below:
A<-1
theta<- 0.1
alpha <- 0.5
rho<-0.9
init <- c(k = 17, delta = 0.3)
times <- seq(from = 0, to = 400, by = 0.2)
euler.function<-function(t,y, prams){
k <- y[1]
delta <- y[2]
dk <- (1/theta)*alpha*A*k^(alpha-1)-delta-rho
list(c(dk, 0))}
deventdat<- data.frame(var = c("delta", "delta"),
time = c(30, 51) ,
value = c(0.1, -0.1),
method = c("add"))
res<-ode(y=init,times=times, func=euler.function, parms=NULL, events=list(data=deventdat))
plot(res,lwd=2)
We simulated a data set and created a model.
set.seed(459)
# seed mass
n <- 1000
seed.mass <- round(rnorm(n, mean = 250, sd = 75),digits = 1)
## Setting up the deterministic function
detFunc <- function(a,b,x){
return(exp(a+b*x)) / (1+exp(a+b*x))
}
# logit link function for the binomial
inv.link <- function(z){
p <-1/(1+exp(-z))
return(p)
}
#setting a and b values
a <- -2.109
b <- 0.02
# Simulating data
germination <- (rbinom(n = n, size = 10,
p = inv.link(detFunc(x = seed.mass, a = a, b = b))
))/10
## make data frame
mydata <- data.frame("predictor" = seed.mass, "response" = germination)
# plotting the data
tmp.x <- seq(0,1e3,length.out=500)
plot(germination ~ seed.mass,
xlab = "seed mass (mg)",
ylab = "germination proportion")
lines(tmp.x,inv.link(detFunc(x = tmp.x, a = a, b = b)),col="red",lwd=2)
When we check the model we created and infer the parameters, we get an error:
Error in optim(par = c(a = -2.109, b = 0.02), fn = function (p) : initial value in 'vmmin' is not finite
library(bbmle)
mod1<-mle2(response ~ dbinom(size = 10,
p = inv.link(detFunc(x = predictor, a = a, b = b))
),
data = mydata,
start = list("a"= -2.109 ,"b"= 0.02))
We're stumped and can't figure out why we're getting this error.
Your problem is that you're trying to fit a binomial outcome (which must be an integer) to a proportion.
You can use round(response*10) as your predictor (to put the proportion back on the count scale; round() is because (a/b)*b is not always exactly equal to a in floating-point math ...) Specifically, with your setup
mod1 <- mle2(round(response*10) ~ dbinom(size = 10,
p = inv.link(detFunc(x = predictor, a = a, b = b))
),
data = mydata,
start = list(a = -2.109 ,b = 0.02))
works fine. coef(mod1) is {-1.85, 0.018}, plausibly close to the true values you started with (we don't expect to recover the true values exactly, except as the average of many simulations [and even then MLE is only asymptotically unbiased, i.e. for large data sets ...]
The proximal problem is that trying to evaluate dbinom() with a non-integer value gives NA. The full output from your model fit would have been:
Error in optim(par = c(a = -2.109, b = 0.02), fn = function (p) :
initial value in 'vmmin' is not finite
In addition: There were 50 or more warnings (use warnings() to see the first 50)
It's always a good idea to check those additional warnings ... in this case they are all of the form
1: In dbinom(x = c(1, 1, 1, 0.8, 1, 1, 1, 1, 1, 1, 1, 0.8, ... :
non-integer x = 0.800000
which might have given you a clue ...
PS you can use qlogis() and plogis() from base R for your link and inverse-link functions ...
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")