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.
the question I am trying to ask is how to I change one of the values of my variables (noted as LO$M in my list) after I pass a certain time.
The thing I am trying to achieve is that after 20,000 seconds passing I would like to change my value of Lac to the value of Lac at time 20,0000 +10,000
So at t = 20,000, Lac = Lac + 10,000
The issue I am having with my code is that within my if command I have if tt>= 20000, but this leads to the issue that every value of Lac after 20,000 being increased by 10,000 when what i want is that the FIRST value after 20,000 be increased by 10,000.
Basically, after 20,000 of my experiment passing I am trying to inject 10,000 more Lac into the experiment.
My code is given below:
LO = list()
LO$M = c(i = 1, ri = 0, I = 50, Lac = 20, ILac = 0, o = 1, Io = 0, RNAP = 100, RNAPo = 0, r = 0, z = 0)
LO$Pre = matrix(c(1,0,0,0,0,0,0,0,0,0,0,
0,1,0,0,0,0,0,0,0,0,0,
0,0,1,1,0,0,0,0,0,0,0,
0,0,0,0,1,0,0,0,0,0,0,
0,0,1,0,0,1,0,0,0,0,0,
0,0,0,0,0,0,1,0,0,0,0,
0,0,0,0,0,1,0,1,0,0,0,
0,0,0,0,0,0,0,0,1,0,0,
0,0,0,0,0,0,0,0,1,0,0,
0,0,0,0,0,0,0,0,0,1,0,
0,0,0,1,0,0,0,0,0,0,1,
0,1,0,0,0,0,0,0,0,0,0,
0,0,1,0,0,0,0,0,0,0,0,
0,0,0,0,1,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,1,0,
0,0,0,0,0,0,0,0,0,0,1), ncol=11, byrow=TRUE)
LO$Post = matrix(c(1,1,0,0,0,0,0,0,0,0,0,
0,1,1,0,0,0,0,0,0,0,0,
0,0,0,0,1,0,0,0,0,0,0,
0,0,1,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,1,0,0,0,0,
0,0,1,0,0,1,0,0,0,0,0,
0,0,0,0,0,0,0,0,1,0,0,
0,0,0,0,0,1,0,1,0,0,0,
0,0,0,0,0,1,0,1,0,1,0,
0,0,0,0,0,0,0,0,0,1,1,
0,0,0,0,0,0,0,0,0,0,1,
0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,
0,0,0,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0), ncol=11, byrow=TRUE)
LO$h = function(x,t,th=c(0.02,0.1,0.005,0.1,1,0.01,0.1,0.01,0.03,0.1,1e-05,0.01,0.002,0.01,0.001))
{
with(as.list(c(x, th)), {
return(c(th[1]*i, th[2]*ri, th[3]*I*Lac, th[4]*ILac, th[5]*I*o, th[6]*Io, th[7]*o*RNAP,
th[8]*RNAPo, th[9]*RNAPo, th[10]*r, th[11]*Lac*z, th[12]*ri, th[13]*I,
th[13]*ILac, th[14]*r, th[15]*z))
})
}
gillespie1 = function (N, n, ...)
{
tt = 0
x = N$M
S = t(N$Post - N$Pre)
u = nrow(S)
v = ncol(S)
tvec = vector("numeric", n)
xmat = matrix(ncol = u, nrow = n + 1)
xmat[1, ] = x
for (i in 1:n) {
h = N$h(x, tt, ...)
tt = tt + rexp(1, sum(h))
j = sample(v, 1, prob = h)
x = x + S[, j]
tvec[i] = tt
xmat[i + 1, ] = x
if( tt >=20000){
x[4] = x[4] +10000
}
}
return(list(t = tvec, x = xmat))
}
newout = gillespie1(LO,200000)
matplot(newout$x[,4], type="l", lwd=0.25, col="grey")
I don't have a high enough reputation to attach images, but it should look something like this:
https://gyazo.com/0ffd940a22df23b2ccfdf4a17e85dca8
Sorry if this isn't clear. Thanks
In this example, you have the function myTask(). When you call execMyTask(), you will execute myTask()once, and after that, you will execute it at random intervals between 1 to max_wait milliseconds. When you get tired, you can kill the task with tclTaskDelete().
library(tcltk2)
myTask <- function() cat("some task!\n")
id = "execMyTask"
execMyTask <- function(max_wait = 3000) {
id <- toString(match.call()[[1]])
myTask()
wait = sample(1:max_wait, 1)
cat("Waiting", wait, "miliseconds\n") # replace with your function
if (is.null(tclTaskGet(id))) {
tclTaskSchedule(wait=wait, execMyTask(), id=id, redo = TRUE)
} else {
tclTaskChange(wait=wait, execMyTask(), id=id, redo = TRUE)
}
}
execMyTask()
tclTaskDelete(id)
So far, there is a little problem with this approach, because we can not supply arguments to the function fun in tclTaskChange().
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.
I am working on a SIR model with birth pulses, using deSolve package. With the following code, I expected birth pulses at time step 0, 12 and 24, but the output reveals that there are no birth pulses-actually no births at all!
library(deSolve); library(ggplot2)
SIR <- function (times,x,parameters) {
SL = x[1]
IL = x[2]
RL = x[3]
NL = x[4]
if (IL<0) IL=0
with(as.list(c(x,parameters)), {
npopL <- SL + IL + RL
dSL <- -(betaL*SL*IL/npopL) - ((b + (.5*(a-b)*npopL/kl))*SL) + ((((.918*round(cos(2%%((times%%12)+2)))))*(SL+RL)))
dIL <- +(betaL*SL*IL/npopL) - gamma*IL - (b+0.015)*IL
dRL <- +gamma*IL - b*RL
dNL <- +dSL + dIL + dRL
out <- c(dSL,dIL,dRL,dNL)
list(out)
})
}
times <- seq(1,24, by = 1)
parameters <- c(betaL = 0.9, gamma = 0.3, a= 0.0765, b = 0.06,kl = 50)
init <- c(SL=50,IL=0,RL=0,NL=50)
out <- as.data.frame(ode(y = init, times = times, func = SIR, parms = parameters))
mydata1 <- data.frame(Period=rep((1:length(out$SL)),4),Population = c(out$SL,out$IL,out$RL,out$NL),Indicator=rep(c("SusceptibleL","InfectedL","RecoveredL","TotalL"),each=length(out$SL)))
p1 = ggplot(mydata1,aes(x=Period,y=Population, group=Indicator))
f1 = p1+geom_line(aes(colour = Indicator))
f1
What am I doing wrong? Thanks in advance for your help!
library(deSolve); library(ggplot2)
I'm having a go at modifying your model since I think it can be simplified.
There is no need to use npopL since you have variable NLwhich is what you need.
SIR <- function (times,x,parms) {
SL = x[1]
IL = x[2]
RL = x[3]
NL = x[4]
if (IL<0) IL=0
# with(as.list(c(x,parameters)), {
with(as.list(c(x,parms)), {
dSL <- -(betaL*SL*IL/NL) - ((b + (.5*(a-b)*NL/kl))*SL)
dIL <- +(betaL*SL*IL/NL) - gamma*IL - (b+0.015)*IL
dRL <- +gamma*IL - b*RL
dNL <- +dSL + dIL + dRL
out <- c(dSL,dIL,dRL,dNL)
list(out)
})
}
As I said in my comment have a look at events in the documentation of package deSolve.
So create an event function for your birth pulses (where does this come from??) where I have changed the birth pulse to a fraction of total population (NL).
eventfun <- function(t, y, parms){
with (as.list(c(y,parms)),{
SL <- SL + .1*round(cos(2%%((t%%12)+2)))*NL
return(c(SL,IL,RL,NL))
})
}
This changes SL at discrete times and that is the event: birth pulse.
The rest of your code doesn't really need modification but I'm assumning that ode passes parms literally, so I changed parameters in your function to parms.
times <- seq(1,24, by = 1)
parameters <- c(betaL = 0.9, gamma = 0.3, a= 0.0765, b = 0.06,kl = 50)
init <- c(SL=50,IL=0,RL=0,NL=50)
out <- as.data.frame(ode(y = init, times = times, func = SIR, parms = parameters, events=list(func=eventfun,time=times))
)
mydata1 <- data.frame(Period=rep((1:length(out$SL)),4),Population = c(out$SL,out$IL,out$RL,out$NL),
Indicator=rep(c("SusceptibleL","InfectedL","RecoveredL","TotalL"),each=length(out$SL)))
p1 = ggplot(mydata1,aes(x=Period,y=Population, group=Indicator))
f1 = p1+geom_line(aes(colour = Indicator))
f1
I find the results rather weird.
It's up to you to find a sensible set of parameters and to correct any further errors.