In R: FME/ deSolve - SIR fitting (time varying parameters) - r

Question

What I am trying to do: I have a simple SIR model, with time varying transmission rates beta, I have already implemented this in R (thanks to #tpetzoldt). We have a population of N=10000, gamma is also fixed.
sir_1 <- function(f_beta, S0, I0, R0, times) {
# the differential equations
sir_equations <- function(time, variables, parameters) {
beta <- f_beta(time)
gamma <- f_gamma(time)
with(as.list(variables), {
dS <- -beta * I * S/10000
dI <- beta * I * S/10000 - 1/5 * I
dR <- 1/5 * I
return(list(c(dS, dI, dR), beta=beta))
})
}
# time dependent parameter functions
parameters_values <- list(
f_beta = f_beta
)
# the initial values of variables
initial_values <- c(S = S0, I = I0, R = R0)
out <- ode(initial_values, times, sir_equations, parameters)
}
times <- seq(0, 19)
f_beta <- approxfun(x=times, y=seq(0.901, 0.92, by=0.001), rule=2)
out <- as.data.frame(sir_1(f_beta=f_beta, S0 = 9990, I0 = 10, R0 = 0, times = times))
Now I have some "real" data, with the FME package I want to get the optimal beta parameters at each timestep
datareal <- cbind(time = times, I=c(10,32,120,230,480,567,1040,1743,2300,2619,3542,4039,4231,6378,
5356, 4987, 3421, 2789, 1789,1156))
sir_cost <- function (f_beta) {
outsir <- as.data.frame(sir_1(f_beta=f_beta, S0 = 9990, I0 = 10, R0 = 0, times = times))
costf <- modCost(model = outsir, obs = datareal)
}
p <- rep(0.8, 20)
Fit <- modFit(f = sir_cost, p = p)
Fit
$par
[1] 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8
My issues:
For the initial values I took 0.8 at each timestep, however the Fit function does nothing, it only returns the 0.8 for each timestep (even if I take a very high value like 800, it says that this is already the best fit). My guess is for timevarying values of the same variable (beta) I have to approach this another way as it is in the documentation.
Any help is highly appreciated.

Answer 1

I don't think that estimating beta per time step is a good idea. This is inherent in the problem and not a fault of deSolve or FME. If a dynamic model shall be used to estimate time dependent parameters, I would recommend to use a suitable function with less knots, e.g. time dependent linear, quadratic or spline, for example 3-5 instead of 20 knots. Then replace approxfun with that function and plug it in. Model fitting is an art, so play with start values and solvers. And, read the books.
Note that the following is just a technical demonstration:
library("deSolve")
library("FME")
sir_1 <- function(f_beta, S0, I0, R0, times) {
# the differential equations
sir_equations <- function(time, variables, parameters) {
beta <- parameters$f_beta(time)
with(as.list(variables), {
dS <- -beta * I * S/10000
dI <- beta * I * S/10000 - 1/5 * I
dR <- 1/5 * I
return(list(c(dS, dI, dR), beta=beta))
})
}
initial_values <- c(S = S0, I = I0, R = R0)
parameters <- list(f_beta=f_beta)
out <- ode(initial_values, times, sir_equations, parameters)
}
times <- seq(0, 19)
# use method "constant" to leave beta constant over time step
f_beta <- approxfun(x=times, y=seq(0.901, 0.92, by=0.001), method="constant", rule=2)
out <- sir_1(f_beta=f_beta, S0 = 9990, I0 = 10, R0 = 0, times = times)
plot(out)
datareal <- cbind(time = times, I=c(10,32,120,230,480,567,1040,1743,2300,2619,3542,4039,4231,6378,
5356, 4987, 3421, 2789, 1789,1156))
plot(out, obs=datareal)
sir_cost <- function (p) {
f_beta <- approxfun(x=times, y=p, method="constant", rule=2)
outsir <- sir_1(f_beta=f_beta, S0 = 9990, I0 = 10, R0 = 0, times = times)
modCost(model = outsir, obs = datareal)
}
# Play with start values!!!
p <- rep(0.8, 20)
# e.g.: consider random start values
set.seed(123)
p <- runif(20, min=0.8, max=1.2)
# try other solvers, especially such with true box constraints
Fit <- modFit(f = sir_cost, p = p,
lower=rep(0.2, 20), upper=rep(5, 20), # box constraints
method="Port")
summary(Fit) # system is singular (that is what we expected)
# use another solver. Note: it takes a while
Fit <- modFit(f = sir_cost, p = p,
lower=rep(0.2, 20), upper=rep(5, 20), # box constraints
method="L-BFGS-B")
# goes in a surprisingly good direction
Fit$par
f_beta <- approxfun(x=times, y=Fit$par, method="constant", rule=2)
out2 <- sir_1(f_beta=f_beta, S0 = 9990, I0 = 10, R0 = 0, times = times)
# compare with data
plot(out, out2, obs=datareal)
# but see how unstable beta is
plot(out2)

Answer 2

Fitting a model with time dependent parameters may be a good idea or not, but if there are reasons to do so, I would suggest to restrict the number of parameters and to use a kind of smooth function.
The following example shows how to use a spline for this purpose, but it is of course also possible (and may be preferable) to use a function with some mechanistic meaning.
As a side effect, it was also possible to identify gamma instead of fixing it a-priori. Nevertheless, this is still a technical demonstration, but I leave the scientific question open, whether a time-dependent beta will make any sense.
library("FME")
sir_1 <- function(f_beta, gamma, S0, I0, R0, times) {
# the differential equations
sir_equations <- function(time, variables, parameters) {
beta <- parameters$f_beta(time)
gamma <- parameters$gamma
with(as.list(variables), {
dS <- -beta * I * S / 10000
dI <- beta * I * S / 10000 - gamma * I
dR <- gamma * I
# return vector of derivatives, and beta as auxiliary variable
return(list(c(dS, dI, dR), beta = beta))
})
}
initial_values <- c(S = S0, I = I0, R = R0)
# pass constant parameter and parameter function together as a list
parameters <- list(
f_beta = f_beta,
gamma = gamma
)
ode(initial_values, times, sir_equations, parameters)
}
times <- seq(0, 19)
datareal <- data.frame(
time = times,
I = c(10, 32, 120, 230, 480, 567, 1040, 1743, 2300,
2619, 3542, 4039, 4231, 6378,
5356, 4987, 3421, 2789, 1789, 1156)
)
## define parameter as a vector: gamma and beta
t_beta <- c(0, 12, 16, 19) # consider more or less knots
n_beta <- length(t_beta)
y_beta <- rep(1, n_beta)
p <- c(gamma = 1/5, y_beta) # combine all parameters in one vector
## a small helper function for parameter selection
select <- function(p, which, exclude = FALSE) {
parnames <- names(p)
p[(which == parnames) != exclude]
}
## check the helper function
select(p, "gamma")
select(p, "gamma", excl=TRUE)
## cost function, see ?modCost help page
sir_cost <- function (p) {
gamma <- select(p, "gamma")
y_beta <- select(p, "gamma", exclude = TRUE)
f_beta <- splinefun(x = t_beta, y = y_beta)
outsir <- sir_1(f_beta = f_beta, gamma = gamma,
S0 = 9990, I0 = 10, R0 = 0, times = times)
modCost(model = outsir, obs = datareal)
}
## model calibration, see ?modFit
Fit <- modFit(f = sir_cost, p = p,
# lower bound to avoid negative values of beta
lower = c(gamma = 0, rep(0.0, n_beta)),
# note: high sensitivity wrt. upper bound
upper = c(gamma=1, rep(2.0, n_beta)),
# an algorithm that supports box constraints
method = "Port")
## all parameters were identifiable
summary(Fit)
## smaller time steps to obtain a curves
times <- seq(0, 19, 0.1)
## split components of fitted parameters
gamma <- select(Fit$par, "gamma")
y_beta <- select(Fit$par, "gamma", exclude = TRUE)
out2 <- sir_1(f_beta = splinefun(x = t_beta, y = y_beta), gamma,
S0 = 9990, I0 = 10, R0 = 0, times = times)
## show fitted curves and compare simulation with data
## see ?plot.deSolve help page
plot(out2, obs = datareal, which = c("S", "R", "I", "beta"),
las = 1, obspar = list(pch = 16, col = "red"))