avoid negative values when resolving a ODE - r

I am trying to model the behavior of a made-up networks of 5 genes, but I have the problem that I get negative values, which it has not sense biologically speaking.
Is there a way to limit the values to zero?
I managed to do it when I represent the graph, but I don't know how to use the ifelse in the main equation.
Thank you very much-1
###################################################
###preliminaries
###################################################
library(deSolve)
library(ggplot2)
library(reshape2)
###################################################
### Initial values
###################################################
values <- c(A = 1,
B = 1,
D = 1,
E = 20,
R = 1)
###################################################
### Set of constants
###################################################
constants <- c(a = 1.2,
b = 0.5,
c = 1.2,
d = 1.5,
e = 0.3,
f = 0.5,
g = 1.5,
h = 0.9,
i = 1.3,
j = 1.3,
m = 0.8,
n = 0.6,
q = 1,
t = 0.0075,
u = 0.0009,
Pa = 100,
Pb = 0.05,
Pd = 0.1,
Pe = 10)
###################################################
### differential equations
###################################################
Dynamic_Model<-function(t, values, constants) {
with(as.list(c(values, constants)),{
dA <- Pa + a*D - j*A - R
dB <- Pb + b*A + e*E - m*B
dD <- Pd + d*B + f*E - g*A - n*D
dE <- Pe - h*B + i*E - q*E
dR <- t*A*B - u*D*E
list(c(dA, dB, dD, dE, dR))
})
}
###################################################
### time
###################################################
times <- seq(0, 200, by = 0.01)
###################################################
### print ## Ploting
###################################################
out <- ode(y = values, times = times, func = Dynamic_Model, parms = constants)
out2 <- ifelse(out<0, 0, out)
out.df = as.data.frame(out2)
out.m = melt(out.df, id.vars='time')
p <- ggplot(out.m, aes(time, value, color = variable)) + geom_point(size=0.5) + ggtitle("Dynamic Model")

I agree completely with #Lutz Lehmann, that the negative values are a result of the structure of the model.
The system of equations allows that derivatives still become negative, even if the states are already below zero, i.e. the states can further decrease. We don't have information about what the states are, so the following is only a technical demonstration. Here a dimensionless Monod-type feedback function fb is implemented as a safeguard. It is normally close to one. The km value should be small enough to act only for state values close to zero, and it should not be too small to avoid numerical errors. It can be formulated individually for each state. Other function types are also possible.
library(deSolve)
library(ggplot2)
library(reshape2)
values <- c(A = 1,
B = 1,
D = 1,
E = 20,
R = 1)
constants <- c(a = 1.2,
b = 0.5,
c = 1.2,
d = 1.5,
e = 0.3,
f = 0.5,
g = 1.5,
h = 0.9,
i = 1.3,
j = 1.3,
m = 0.8,
n = 0.6,
q = 1,
t = 0.0075,
u = 0.0009,
Pa = 100,
Pb = 0.05,
Pd = 0.1,
Pe = 10,
km = 0.001)
Dynamic_Model<-function(t, values, constants) {
with(as.list(c(values, constants)),{
fb <- function(x) x / (x+km) # feedback
dA <- (Pa + a*D - j*A - R) * fb(A)
dB <- (Pb + b*A + e*E - m*B) * fb(B)
dD <- (Pd + d*B + f*E - g*A - n*D) * fb(D)
dE <- (Pe - h*B + i*E - q*E) * fb(E)
dR <- (t*A*B - u*D*E) * fb(R)
list(c(dA, dB, dD, dE, dR))
})
}
times <- seq(0, 200, by = 0.1)
out <- ode(y = values, times = times, func = Dynamic_Model, parms = constants)
plot(out)
Additional hints:
Removal of negative values afterwards (out2 <- ifelse(out<0, 0, out)) is just wrong.
Removal of negative values in the model function, i.e.
use the ifelse in the main
would also be wrong as it can lead to a severe violation of mass balance.
the time steps don't need to be very small. They are automatically adapted anyway by the solver. Too small time steps make your model slow and you get more outputs as needed.
some of your parameters are quite large, so that the model becomes very stiff.

Related

Computing Economic Models in R: How to apply shocks to parameter values in the euler equation?

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)

Extracting Results from odeModel?

I was unsuccessful in trying to get a df object as my output (so that I would be able to subset/ customize each graph). I also read that it is possible to extract the results using the function "out", but I haven't gotten it to work. Could someone please help me with this?
'''
library(simecol)
library(latticeExtra)
Figure_7B <- odeModel(
main = function(time, init, parms) {
with(as.list(c(init, parms)),{
# Computing derivatives
dm <- -k1*eT*m
dmP <- k1*eT*m
dE <- -k2*E*mP
dEP <- k2*mP*E + (k3*EP)*(dE - TE - S) + k3r*TE
dDE <- +k3*EP*DE - k3r*TE
dTE <- (k3*EP)*(DE - TE - S) - k3r*TE - k7*TE*A
dME <- k4*TE - d1*ME
dDA <- +k5*EP*DA - k5r*TA
dTA <- k5*EP*DA - k5r*TA
dMA <- (k6*EP)/(EP + k5) - d2*MA
dA <- k8*MA + k7*TE*A + d3*A
dS <- k7*TE*A
return(list(c(dm, dmP, dE, dEP, dDE, dTE, dME, dDA, dTA, dMA, dA, dS)))
})
},
# Set parameters or constants
parms = c(k1 = 8.3e-3,
eT = 100,
k2 = 1.28e5,
k3 = 1e5,
k3r = 5e-2,
k4 = 6.89e-15,
k5 = 0.5e-6,
k5r = 5e-2,
k6 = 1.03e-15,
k7 = 1e5,
k8 = 0.25,
d1 = 8.89e-4,
d2 = 2.36e-4,
d3 = 2.36e-4),
# Set integrations times
times = c(from=0, to=10, by = 0.25),
# Set initial state
init = c(
m = 130e-7,
mP = 0,
E = 130e-7,
EP = 0,
DE = 3.32e-11,
TE = 0,
ME = 1e-12,
DA = 3.32e-11,
TA = 0,
MA = 0,
A = 0,
S = 0),
solver = "lsoda"
)
'''
'''
library(deSolve)
Figure_7B <- sim(Figure_7B)
plot(Figure_7B)
'''
Try the following:
Figure_7B <- sim(Figure_7B)
plot(Figure_7B)
df <- out(Figure_7B)
head(df)
Explanation: The object returned by sim() contains all the inputs (the complete Figure_7B model) plus the output. Parts of the model can be extracted with slot accessor functions, e.g.:
times(Figure_7B)
main(Figure_7B)
out(Figure_7B)
Hope it helps.

R: FME global sensitivity - error "argument parms is missing"

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.

run deSolve multiple times varying a time-varying parameter

I would like to get this code to run repeatedly, creating a single output dataset with a different column variable for each run. Right now, the code works and allows me to insert different events at varying times. However, I would like to be able to change the magnitude of the event,
IPT <- ifelse (t<210, IPT, 0.35*exp(-(t-209)/21))
varying 0.35 to 0.4, 0.5, 0.6, etc. I have tried For loops but couldn't get it to work at all. My code is below:
library(deSolve)
##Simple parameter list
params <- c(b = 0.477, bs = .4, bsv = 0.1, nets = 0.4767, betah = 0.2,
rhos = 179, Bthetas = 0.2, psi = 14,phis = 0.5, gamma =14,
thetas = 0.79,piv = 1/19, betav = 0.09122, nu = 0.2085, sigma = 12,
muv = 1/19, IPT = 0, IPT2 = 0, IPT3 = 0)
dt <- seq(0, 5000, 7)
inits <- c(Ss = 30000, Is = 0, As = 0, Rs = 0,
Sv = 29999, Ev = 0, Iv = 1)
Nh <- 30000
Nv <- 30000
## Create an SIR function
sir1 <- function(t, x, params) {
with(as.list(c(params, x)), {
IPT <- ifelse (t<210, IPT, 0.35*exp(-(t-209)/21))
dSs <- -((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss /Nh + As*(1/rhos)*(1-Bthetas) + Rs*(1/psi)
dIs <- ((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss*(1-phis)/Nh - 1/gamma * Is - Is*(IPT + IPT2 + IPT3)
dAs <- ((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss*( phis)/Nh + 1/gamma * Is*(1-thetas) - As*(1/rhos)*(1-Bthetas) - As*(2/rhos)*Bthetas - As*(IPT + IPT2 + IPT3)
dRs <- 1/gamma * Is*( thetas) + As*(2/rhos)*Bthetas + Is*(IPT2 + IPT3+ IPT) + As*(IPT + IPT2 + IPT3) - Rs*(1/psi)
dSv <- piv*Nv - Sv*betav*b*(nu*(
((bsv*(1-nets))+(bsv*nets*0.78))*As)+
((bsv*(1-nets))+(bsv*nets*0.78))*Is/Nh) - Sv*muv
dEv <- Sv*betav*b*(nu*(
((bsv*(1-nets))+(bsv*nets*0.78))*As)+
((bsv*(1-nets))+(bsv*nets*0.78))*Is/Nh) - Ev*(1/sigma + muv)
dIv <- Ev*(1/sigma)- Iv*muv
der <- c(dSs, dIs, dAs, dRs,
dSv, dEv, dIv)
list(der)
})
}
out <- as.data.frame(lsoda(inits, dt, sir1, parms = params))
out$prev <- with(out, Is+As/Nh)
I would like the final data set to have multiple prev columns, one for each run with different values of the event.
Any help would be appreciated, thanks!
A potential solution would be to have the magnitude be a parameter instead of a constant (here I call it mag).
library(deSolve)
##Simple parameter list
params <- c(b = 0.477, bs = .4, bsv = 0.1, nets = 0.4767, betah = 0.2,
rhos = 179, Bthetas = 0.2, psi = 14,phis = 0.5, gamma =14,
thetas = 0.79,piv = 1/19, betav = 0.09122, nu = 0.2085, sigma = 12,
muv = 1/19, IPT = 0, IPT2 = 0, IPT3 = 0, mag=0.35)
dt <- seq(0, 5000, 7)
inits <- c(Ss = 30000, Is = 0, As = 0, Rs = 0,
Sv = 29999, Ev = 0, Iv = 1)
Nh <- 30000
Nv <- 30000
Then we can adjust the sir1 function to take the mag parameter...
## Create an SIR function
sir1 <- function(t, x, params) {
with(as.list(c(params, x)), {
IPT <- ifelse (t<210, IPT, mag*exp(-(t-209)/21))
dSs <- -((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss /Nh + As*(1/rhos)*(1-Bthetas) + Rs*(1/psi)
dIs <- ((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss*(1-phis)/Nh - 1/gamma * Is - Is*(IPT + IPT2 + IPT3)
dAs <- ((b*bs*(1-nets))+(b*bs*nets*0.78))*betah*Iv*Ss*( phis)/Nh + 1/gamma * Is*(1-thetas) - As*(1/rhos)*(1-Bthetas) - As*(2/rhos)*Bthetas - As*(IPT + IPT2 + IPT3)
dRs <- 1/gamma * Is*( thetas) + As*(2/rhos)*Bthetas + Is*(IPT2 + IPT3+ IPT) + As*(IPT + IPT2 + IPT3) - Rs*(1/psi)
dSv <- piv*Nv - Sv*betav*b*(nu*(
((bsv*(1-nets))+(bsv*nets*0.78))*As)+
((bsv*(1-nets))+(bsv*nets*0.78))*Is/Nh) - Sv*muv
dEv <- Sv*betav*b*(nu*(
((bsv*(1-nets))+(bsv*nets*0.78))*As)+
((bsv*(1-nets))+(bsv*nets*0.78))*Is/Nh) - Ev*(1/sigma + muv)
dIv <- Ev*(1/sigma)- Iv*muv
der <- c(dSs, dIs, dAs, dRs,
dSv, dEv, dIv)
list(der)
})
}
... and we can modify the params vector in a loop that also runs the model, gets the output, calculates prev, and stores it in the out data.frame.
out <- as.data.frame(lsoda(inits, dt, sir1, parms = params))
magz <- seq(0.2, 0.5, length.out=10)
for(i in 1:length(magz)){
params['mag'] <- magz[i]
tmp <- as.data.frame(lsoda(inits, dt, sir1, parms = params))
nm <- paste('prev', round(params['mag'],2), sep='')
out[,nm] <- with(tmp, Is+As/Nh)
}
There are likely better ways to do what you want to do, but this is a potential solution.

R LPPL research reproduction singular gradient matrix

I'm trying to reproduce some research on the fitting LPPL on stock indices for bubble prediction and I'm having trouble with fitting the model to the data. I've been using the following papers for insight on this project: http://arxiv.org/pdf/1002.1010v2.pdf where they've already done some testing on the HSI, http://arxiv.org/pdf/0905.0220v1.pdf where I originally got my idea.
I've also tried to reproduce the findings from this stackoverflow post with no success (ran into multiple similar issues i.e. the max iterator has been reached, singular gradient matrix errors again): NLS And Log-Periodic Power Law (LPPL) in R
Not having much success with using daily prices to fit the model, I used weekly prices on the S&P following the advice in the conclusion of the HSI LPPL paper that the data should be "smoothed" in a way.
Here is the code I'm using. Advice on how to fix my issues would be much appreciated!
library(zoom)
library(minpack.lm)
library(tseries)
library(zoo)
#grab S&P500 historical
ts <- get.hist.quote(instrument="^GSPC",
start="2003-02-15", end="2007-10-31",
quote="Close", provider="yahoo", origin="1970-01-01",
compression="w", retclass="zoo")
df <- data.frame(ts)
df <- data.frame(Date=as.Date(rownames(df)),Y=df$Close)
df <- df[!is.na(df$Y),]
df$days <- as.numeric(df$Date - df[1,]$Date)
ts <- get.hist.quote(instrument="^GSPC",
start="1997-10-04", end="2011-10-12",
quote="Close", provider="yahoo", origin="1970-01-01",
compression="w", retclass="zoo")
df2 <- data.frame(ts)
df2 <- data.frame(Date=as.Date(rownames(df2)),Y=df2$Close)
df2 <- df2[!is.na(df2$Y),]
df2$days <- as.numeric(df2$Date - df2[1,]$Date)
f <- function(pars, xx)
with(pars,(a + ((tc - xx)^m) *b + c *(tc - xx)^m* cos(omega*log(tc - xx))+d *(tc - xx)^m* cos(omega*log(tc - xx))))
# residual function
resids <- function(p, observed, xx) {df$Y - f(p,xx)}
plot(df2$Date,df2$Y,type="l")
lines(df$Date,df$Y,type="l")
points(df$Date,df$Y,type="p")
pp = list(a=1662.239,b=-0.483332,tc=2050, m=0.97, omega=5, c=566, d=-566)
lines(df$Date,f(pars=pp,df$days),type="l")
nls.out <- nls.lm(par=pp, fn = resids, observed = df$Y, xx = df$days, control=nls.lm.control(maxiter=1000),lower = c(a = -Inf, b = -Inf, tc = 2008, m = 0.1, omega = 0.1, c = -Inf, d = -Inf), upper = c(a = Inf, b = -0.01, tc = 2050, m = 0.97, omega = 15, c = 3000, d = 3000))
par <- nls.out$par
par
lines(df$Date,f(par,df$days), col ="blue")
nls.out <- nls.lm(par=nls.out$par, fn = resids, observed = df$Y, xx = df$days, control=nls.lm.control(maxiter=1000),lower = c(a = -Inf, b = -Inf, tc = 2008, m = 0.1, omega = 3, c = -Inf, d = -Inf), upper = c(a = Inf, b = -0.01, tc = 2025, m = 0.999, omega = 10, c = Inf, d = Inf))
lines(df$Date,f(nls.out$par,df$days), col ="purple")
ppp = nls.out$par
lines(df$Date,f(ppp,df$days), col ="purple")
nls.final <- nls(Y~(a + ((tc - df$days)^m) * (b + c * cos(omega*log(tc - df$days))+d * cos(omega*log(tc - df$days)))), data=df, start=ppp, algorithm="port", control=nls.control(maxiter=1000, minFactor=1e-8), lower = c(a = -Inf, b = -Inf, tc = 2007, m = 0.01, omega = 6, c = -Inf, d = -Inf), upper = c(a = Inf, b = 0, tc = 2010, m = 0.999, omega = 10, c = Inf, d = Inf))
summary(nls.final) # display statistics of the fit
lines(df$Date,fitted(nls.final), col = "red")
# append fitted values to df
df$pred <- predict(nls.final, interval = "confidence")
summ = coef(summary(nls.final))

Resources