vignettes/practical-three.Rmd
practical-three.RmdIf you have not installed the course package do this now with the following R code (speak to an instructor if you are having issues with this step).
Now load the course package,
For more help getting started see the course README (https://bristolmathmodellers.github.io/biddmodellingcourse/) or ask an instructor.
As a first exercise we are going to run the simple SEIR model, as seen in practical 2, in R. See practical 2. for the flow diagram.
We first set up the initial populations for the Susceptible (\(S_0\)), Latent (\(E_0\)), Infected (\(I\)), and Recovered (\(R\)) compartments. We have initialised the model as an early stage epidemic with a single case of TB.
We then specify the model parameters (with the units being years-1), varying these parameters will impact the model dynamics.
Finally we specify the model equations for each population compartment. This model incorporates simple demographic processes with a constant natural death rate from all compartments which is equal to the birth rate into the susceptible compartment.
SEIR_demo_ode <- function(t, x, params) {
## Specify model compartments
S <- x[1]
E <- x[2]
I <- x[3]
R <- x[4]
with(as.list(params),{
## Specify total population
N = S + E + I + R
## Derivative Expressions
dS = -beta * S * I / N - mu * S + mu * N
dE = beta * S * I / N - gamma * E - mu * E
dI = gamma * E - tau * I - mu * I
dR = tau * I - mu * R
## output
derivatives <- c(dS, dE, dI, dR)
list(derivatives)
})
}To simulate the model we specify the starting year (begin_time) and final year (end_time) and define a sequence over all intervening years. The model is then solved using deSolve::lsoda which is used within a simple wrapper function (see ?solve_ode for details). The resulting table summarises the simulation results for the first 5 years.
begin_time <- 0
end_time <- 200
times <- seq(begin_time, end_time, 1)
## see ?solve_ode for details
SEIR_sim <- biddmodellingcourse::solve_ode(model = SEIR_demo_ode,
inits = inits,
params = parameters,
times = times,
as.data.frame = TRUE)
SEIR_sim %>%
head %>%
pretty_table(caption = "First 5 years of model simulation",
label = "tab-1")We then summarise the epidemic peak (epi_peak) and epidemic duration (epi_dur), along with population sizes at the end of the time period simulated.
biddmodellingcourse::summarise_model(SEIR_sim) %>%
pretty_table(caption = "SEIR model summary statistics; The final size of each population at the end of the simulation, along with the time the epidemic peak was reached, the number of infected at the epidemic peak and the duration of the epidemic")Finally we plot the population in each model compartment over time.
Now we are going to implement the SHLIR model from practical 2 and try to reproduce some of the behaviour observed using the interactive interface. See practical 2 for details on this model.
As in the previous model the first step is to define the model populations. There are now two new compartments, high risk latents (H), and low risk latents (L). These replace the original latent population (E) used in the SEIR model.
We add two additional parameters for the rate of progression from high to low risk latents (nu) and the rate of progression from low risk latent to active disease (gamma_L).
SHLIR_parameters <- c(
beta = 3, # Rate of transmission
gamma_H = 1/5, # Rate of progression to active symptoms from high risk latent
nu = 1/2, #Rate of progression from high to low risk latent
gamma_L = 1/100, # Rate of progression to active symptoms for low risk latent
tau = 1/2, # Rate of recovery
mu = 1/81 # Rate of natural mortality
)The code below is a starting point, fill in the missing model terms using the model flow diagram (Figure 1) and the code for the previous SEIR model as reference points.
SHLIR_demo_ode <- function(t, x, params) {
## Specify model compartments
S <- x[1]
H <- x[2]
L <- x[3]
I <- x[4]
R <- x[5]
with(as.list(params),{
## Specify total population
N = S + H + L + I + R
## Derivative Expressions
dS = - beta * S * I / N - mu * S + mu * N
## These are the new equations - fill in the remaining terms
dH =
dL =
## Hint terms are missing from this equation as well
dI = gamma_H * H + gamma_L * L - tau * I
dR =
## output
derivatives <- c(dS, dH, dL, dI, dR)
list(derivatives)
})
}Simulation is the same as for the previous model. Does the simulation of your improved model make sense? Evaluate the summary tables and plot of model populations over time.
begin_time <- 0
end_time <- 200
SHILR_times <- seq(begin_time, end_time, 1)
## see ?solve_ode for details
SHLIR_sim <- biddmodellingcourse::solve_ode(model = SHLIR_demo_ode,
inits = SHLIR_inits,
params = SHLIR_parameters,
times = SHILR_times,
as.data.frame = TRUE)
SHLIR_sim %>%
head %>%
pretty_table(caption = "First 5 years of SHLIR model simulation",
label = "tab-1")biddmodellingcourse::summarise_model(SHLIR_sim) %>%
pretty_table(caption = "SHLIR model summary statistics; The final size of each population at the end of the simulation, along with the time the epidemic peak was reached, the number of infected at the epidemic peak and the duration of the epidemic")As a more advanced exercise (feel free to skip this if wanting to design your own model now) we now translate the more complex SHLIR model into code. Look back at practical 2 for a refresher on the structure of this model.
The new populations have been added for you. The population has now been split between low and high risk populations, with the only infectious case being in the high risk population.
The required model parameters have been defined for you (with the units being years-1). The only new parameters are the between group mixing (M), the proportion that are born high risk (p), and the transmission probability in those considered to be high risk (beta_H).
real_SHLIR_parameters <- c(
beta = 3, # Rate of transmission
beta_H = 6, # High risk rate of transmission
gamma_H = 1/5, # Rate of progression to active symptoms from high risk latent
nu = 1/2, #Rate of progression from high to low risk latent
gamma_L = 1/100, # Rate of progression to active symptoms for low risk latent
epsilon = 1/3, # Rate of treatment
tau = 1/2, # Rate of recovery
mu = 1/81, # Rate of natural mortality
p = 0.2, # proportion of new births that are high risk
M = 0.2 # Between group mixing
)Update the model equations using the model flow diagram above. The comments in the code given hints as to where changes need to be made. The equations for the low risk population have been partially provided for you.
real_SHLIR_demo_ode <- function(t, x, params) {
## Specify model compartments
## The compartments for the low risk population have been provided
## Add the high risk population
## Don't forget to update indexing for x. Compare the previous two models for a hint.
S <- x[1]
H <- x[2]
L <- x[3]
I <- x[4]
Tr <- x[5]
R <- x[6]
S_H <- x[7]
H_H <- x[8]
L_H <- x[9]
I_H <- x[10]
Tr_H <- x[11]
R_H <- x[12]
with(as.list(params),{
## Specify total population
N = S + H + L + I + Tr + R + S_H + H_H + L_H + I_H + Tr_H + R_H
## Force of infection
## The force of infetion in the low risk population has been provided for you
foi <- beta * I / N + M * beta_H * I_H / N
## Add the high risk force of infection here
## Derivative Expressions
## General population
## Compare these equations from those used for the previous models
dS = -S * foi - mu * S + (1 - p) * mu * N
dH = (S + L + R) * foi - gamma_H * H - nu * H - mu * H
dL = nu * H - L * foi - gamma_L * L - mu * L
dI =
dTr = epsilon * I - tau * Tr - mu * Tr
dR = tau * Tr - R * foi - mu * R
## High risk population
## Copy the equations used above for the low risk population
## Convert them to be in the high risk population
## output
derivatives <- c(dS, dH, dL, dI, dTr, dR, dS_H, dH_H, dL_H, dI_H, dTr_H, dR_H)
list(derivatives)
})
}Simulate the new model as previously.
begin_time <- 0
end_time <- 200
real_SHLIR_times <- seq(begin_time, end_time, 1)
## see ?solve_ode for details
real_SHLIR_sim <- biddmodellingcourse::solve_ode(model = real_SHLIR_demo_ode,
inits = real_SHLIR_inits,
params = real_SHLIR_parameters,
times = real_SHLIR_times,
as.data.frame = TRUE)
real_SHLIR_sim %>%
head %>%
pretty_table(caption = "First 5 years of model simulation",
label = "tab-real_SHLIR")biddmodellingcourse::summarise_model(real_SHLIR_sim) %>%
pretty_table(caption = "Realistic SHLIR model summary statistics; The final size of each population at the end of the simulation, along with the time the epidemic peak was reached, the number of infected at the epidemic peak and the duration of the epidemic")Using the same structure as used in models above implement your own model into R. Talk to the instructors for tips, tricks, and potential ideas. See the idmodelr package for other example model structures (https://www.samabbott.co.uk/idmodelr/). It may help to first draw out the flow diagram for your model (potentially writing out the equations may also help).