Tutorial: Overlays for interventions in epidemic modelling
Source:vignettes/epidemics.Rmd
epidemics.RmdThis tutorial will walk you through how to use overshiny
to add interactive overlays to epidemic curves generated by an
infectious disease transmission model to explore the effect of different
interventions like vaccines and social distancing. This is the use case
that originally spurred the development of overshiny as an
offshoot of an infectious disease modelling Shiny app developed at the
London School of Hygiene and Tropical Medicine during the COVID-19
pandemic.
This tutorial doesn’t assume any previous knowledge of
shiny or overshiny, but is not a comprehensive
introduction to shiny. We will be using the package
epidemics to provide the actual infectious disease model
underlying the simulation.
Epidemic simulation
OK, let’s begin. If you’re developing a shiny app based
around some relatively complex simulation code, it often helps to start
by putting the simulation code together outside the context of a
shiny app, and later building the app to include it. That
helps you catch errors with the simulation code before putting it into
an app, which often makes it harder to catch errors. So let’s start with
our infectious disease model in epidemics and move on to
the shiny app later on.
First, make sure you have the epidemics package
installed, and the most recent version of overshiny (the
version on CRAN is not recent enough for this tutorial!):
devtools::install_github("epiverse-trace/epidemics")
devtools::install_github("nicholasdavies/overshiny")Now, let’s build a simple function that will produce a simulation run
from epidemics and return the results.
library(epidemics)
library(ggplot2)
# Model run function
run_model <- function()
{
# Build parameters
I0 <- 0.001
pop_size <- 1000000
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = 1000000,
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop)
return (results)
}Note that I0 is the initial proportion of infectious
individuals, and pop_size is the total population size.
Test this function out and see if you can plot the prevalence of
infection (compartment "infectious") before continuing.
Click for one possible answer…
Here’s how you might do it using ggplot2:
results <- run_model()
results <- results[results$compartment == "infectious", ]
ggplot(results) +
geom_line(aes(x = time, y = value)) +
labs(x = NULL, y = "Infection prevalence")You should see an exponentially growing epidemic (with a little dip at the start).
Connecting to a mock-up of input
At the moment, our run_model() function produces an
epidemic curve based on some default parameters. We want
run_model() to respond to user input, though, so that users
of our app can provide parameters like the basic reproduction number
R0, the infectious period, the duration of the
epidemic, and so on.
Within shiny, user input is provided in a list1 called
input. So let’s say that the input list
contains the following:
input <- list(
# Start and end dates of the epidemic
date_range = as.Date(c("2025-01-01", "2025-12-31")),
# Population size in millions
pop_size = 59
# Percentage (not proportion) of the population initially infected
init_infec = 0.1,
# Duration of latent period in days
latent_pd = 2,
# Duration of infectious period in days
infec_pd = 7,
# Basic reproduction number
R0 = 1.3,
)Note that in the above, we have specified lots of the parameters in “natural” units – the population size is in millions, the initial proportion of infected people is in percent (not a proportion), and we specify an infectious period in days rather than a recovery rate in days-1. Also, rather than specifying a total duration for the epidemic in days, we have specified a start date and end date for the epidemic. This is because we’re going to develop our Shiny app with end users in mind, and they may not be used to the more mathematically tractable units that infectious disease modellers use.
By looking at the documentation for
epidemics::population() and
epidemics::model_default(), can you rewrite the
run_model() function so that it sets all the relevant
parameters from the input list above? Rewrite it so that
input is passed as an argument to
run_model().
Click for one possible answer…
Here’s how you might do it:
# Model run function
run_model <- function(input)
{
# Transform parameters
I0 <- input$init_infec / 100; # Percent to proportion
duration <- as.numeric(input$date_range[2] - input$date_range[1]) # Dates to duration
infec_rate <- 1 / input$latent_pd # Latent period to infectiousness rate
recov_rate <- 1 / input$infec_pd # Infectious period to recovery rate
trans_rate <- input$R0 * recov_rate # R0 to transmission rate (R_0 = beta / gamma)
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000, # Population size in millions
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration)
return (results)
}Once you’ve done this, check that you’re happy with the results before moving on.
Shiny app skeleton
Now, let’s set our simulation code aside and put together a basic
shiny app.
All shiny apps have two parts. The first part is a
ui (user interface), which determines how the app is laid
out. This is where you define all the components of the app, where they
are, and what they look like. The second part is a server
function, which is where the processing happens. The server is where you
transform all the user inputs into outputs, and do any calculations that
need to respond to user input.
Let’s start with a really basic skeleton for our shiny
app. This can go in a new .R script file, but don’t get rid
of your old code from the last section as we’ll put it back in
later.
library(epidemics)
library(shiny)
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic")
),
column(4,
# Pathogen settings
h3("Pathogen")
),
column(4,
# Intervention settings
h3("Interventions")
)
)
)
# --- App logic ---
server <- function(input, output)
{
}
# --- Run app ---
shinyApp(ui, server)Put all that in a script and run it. You should see a window pop up with a big title that says “SEIRV model with interventions”, and three smaller titles underneath.
Even though this is a very basic app, there’s a lot to unpick here. In particular, the large part of the script that generates the user interface has a lot going on. Let’s take it step by step.
# --- User interface ---
ui <- fluidPage(
...
)In shiny, the user interface is constructed of nested
function calls. This mirrors the nested structure of a web page – so
e.g. here the fluidPage contains several elements, which
themselves may contain several other elements. fluidPage is
just one option for the top-level element; others include
fixedPage or basicPage. fluidPage
is a flexible layout that can dynamically rearrange the elements if
someone is using your app on a smaller screen, like on a mobile phone,
so it’s handy to use.
To make use of this dynamic rearrangement, a fluidPage
is divided into rows, which are defined using the shiny
function fluidRow. In turn, each fluidRow is
divided into columns (with the shiny function
column). Each column within a
fluidRow has a width, and the width of all the columns in a
row together should add up to 12. (In a fluidRow, columns
can only have whole-number widths.) They chose 12 as the total width of
a row because it divides well into 1, 2, 3, 4, or 6 columns. On a
computer screen, normally you will see the fluidRow all in
one actual row, but if you are looking at your Shiny app on a smaller
screen, like on a phone, you might see your fluidRow broken
up across multiple actual rows.
As an example, if your shiny ui contains:
then on a larger screen, you would see something like
part one part two part three
while on a phone, you might see
part one part two part three
Arranging each part vertically on a small screen instead of horizontally helps ensure that your content don’t get too hard to see on a mobile device because it’s all squished into one row, which is especially helpful if the columns contain plots or other more complex elements.
So, looking again at our whole UI definition:
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic")
),
column(4,
# Pathogen settings
h3("Pathogen")
),
column(4,
# Intervention settings
h3("Interventions")
)
)
)This defines a fluidPage. There is a
titlePanel at the top; anything not explicitly in a
fluidRow takes up a whole row, so the title panel appears
on its own row. Then there is a fluidRow, which by
definition has a total “width” of 12 units. It contains three
columns each of size 4 (to add up to 12); the size of the
column is the first parameter to column and then all the
elements that should appear in the column are subsequent arguments.
Here, each column contains a header h3 with some text.
In HTML, h1 through h6 define headers for
sections, where h1 is the biggest and h6 is
the smallest. You don’t need to start at h1 and work your
way down, and often people select header levels (h1 through
h6) based on aesthetics (i.e. which size looks right)
rather than a strict logical ordering. We’ve gone based on aesthetics
here; we could have used h1 instead of h3 but
I think it looks too big (try it and see for yourself!). To be clear,
there’s no relationship between the header level and the column
size.
Adding input widgets
Now we’ll edit our Shiny app skeleton to have some more interesting things going on. Take a look at the code below. We have added new elements to the three columns we had before. After you’ve looked at these, run this entire following script:
library(epidemics)
library(shiny)
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions")
)
)
)
# --- App logic ---
server <- function(input, output)
{
}
# --- Run app ---
shinyApp(ui, server)Now we’re getting somewhere! We’ve added some input widgets to the
first two columns. shiny gives us
dateRangeInput() to put in a range of dates (you can use
dateInput() for just one date); numericInput()
to enter a number using an input box (or textInput() for
free text input); and sliderInput() to enter a number using
a slider–plus many more options. All of the input “widgets” provided by
shiny are called [something]Input() and they
follow some common conventions: the first argument is a special ID which
we’ll use later, the second argument is a label to show next to the
input, and then the other inputs define things like the starting value
or the minimum and maximum. For more information, consult the
shiny manual with e.g. ?sliderInput.
Combining inputs and outputs
Now what we want to do is combine our previous
run_model() function with these shiny inputs
so that the inputs connect to the model. Also, we want to plot the
results of the model. Let’s do that now.
First, in a new file, paste in your run_model() function
from before with the calls to library that we need. Nothing
here is new:
library(shiny)
library(ggplot2)
library(epidemics)
# Model run function
run_model <- function(input)
{
# Transform parameters
I0 <- input$init_infec / 100; # Percent to proportion
duration <- as.numeric(input$date_range[2] - input$date_range[1]) # Dates to duration
infec_rate <- 1 / input$latent_pd # Latent period to infectiousness rate
recov_rate <- 1 / input$infec_pd # Infectious period to recovery rate
trans_rate <- input$R0 * recov_rate # R0 to transmission rate (R_0 = beta / gamma)
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000, # Population size in millions
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration)
return (results)
}Underneath that, let’s put in our user interface from before, with one addition:
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# NEW PART IS HERE:
# Main plot
plotOutput("display", width = "100%", height = 400),
# END OF NEW PART
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions")
)
)
)The bit we added was a plotOutput call, which puts space
in the app for a plot (either ggplot2 or base R plot) with
the ID "display". To connect this plot with the inputs, we
need to add some code to our server function, so put this
code underneath what you have already:
# --- App logic ---
server <- function(input, output)
{
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
ggplot(results) +
geom_line(aes(x = time, y = value)) +
labs(x = NULL, y = "Infection prevalence") +
ylim(0, NA)
})
}
# --- Run app ---
shinyApp(ui, server)If you put all this together, you should have a working model that connects to the user input, where the epidemic curve changes depending on how you manipulate the various input controls.
That handful of lines in server is doing a lot. First,
note that we’re calling the shiny function
renderPlot, and assigning the value to
output$display. The reason output$display
exists is because we put a plotOutput in the
shiny UI with ID "display" – this makes an
entry in output called display which is ready
to receive a plot from the server function. If in our UI, we had given
our plotOutput a different ID, like:
then we would have to assign the results of a call to
renderPlot() to output$marmite.
Within renderPlot(), the first argument is a bit of R
code (in curly braces, {}) that should return a ggplot2
plot, or produce a base R plot. Finally, note that we are now passing
the shiny input object input to
run_model(). run_model() is expecting
input to contain values named date_range,
R0, and so on; because we have made all those input widgets
in out UI above, input automatically contains the values
that have been entered.
OK. Before continuing, let’s tidy up the output a little. First of
all, the y-axis of the plot extends up into the millions, and numbers
like “1e+06” are a little tough to interpret. Try changing the plotting
code in the server function so that the plot y-axis is in
thousands, and this is indicated on the y-axis label.
Second, the x-axis is currently in days from 0 to the duration of the
epidemic, but we are providing our shiny app with specific
dates. Try making the x-axis show calendar dates instead of the number
of days from the beginning of the epidemic. (Hint: you can use the
input list here.)
Adding interventions with overshiny
In the last part of this tutorial, let’s finally connect our
shiny app with overshiny so that we can deploy
interventions such as social distancing and vaccination on our
infectious disease transmission model. We’re not going to get into the
fine details of how specifically to model these interventions; this is
more just to demonstrate how overshiny works in the context
of the model we’ve developed.
Starting from the code we developed in the last section:
Click for starter code…
library(shiny)
library(ggplot2)
library(epidemics)
# Model run function
run_model <- function(input)
{
# Transform parameters
I0 <- input$init_infec / 100; # Percent to proportion
duration <- as.numeric(input$date_range[2] - input$date_range[1]) # Dates to duration
infec_rate <- 1 / input$latent_pd # Latent period to infectiousness rate
recov_rate <- 1 / input$infec_pd # Infectious period to recovery rate
trans_rate <- input$R0 * recov_rate # R0 to transmission rate (R_0 = beta / gamma)
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000, # Population size in millions
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration)
return (results)
}
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# NEW PART IS HERE:
# Main plot
plotOutput("display", width = "100%", height = 400),
# END OF NEW PART
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions")
)
)
)
# --- App logic ---
server <- function(input, output)
{
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
})
}
# --- Run app ---
shinyApp(ui, server)First, we now need to include the overshiny package
with:
Second, we need to change our plotOutput plot in our UI
to an overlayPlotOutput so that it can respond to
overlays:
Third, we need to add some overlayToken()s that can be
dragged onto the plot. Let’s put these into the currently-blank
“Interventions” section of our UI:
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions"),
overlayToken("vx", "Vaccination"),
overlayToken("tx", "Transmission")
)Fourth, we need to initialize the overlay logic in our
server function by putting a call to
overlayServer at the top of the server
function:
# --- App logic ---
server <- function(input, output)
{
# --- OVERLAY SETUP ---
# Initialise 8 draggable/resizable overlays
ov <- overlayServer("display", 8)
# rest of code follows as normal...We need to provide overlayServer with the id of our
overlayPlot (here, "display") and the maximum
number of overlays to support.
And finally, we need to modify our call to renderPlot()
in the server function to tell overshiny more
information about our plot. Where before we had:
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
})Now, we have:
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
plot <- ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})There are two changes above. First, rather than returning the
ggplot() plot, we save the plot in a variable called
plot. Second, we pass this through
overlayBounds(), which takes four key arguments:
-
ov, the object returned byoverlayServer(). -
plot, the plot itself. -
xlim, the x-coordinate limits of the plot. -
ylim, the y-coordinate limits of the plot.
xlim and ylim are not required, but because
ggplot by default includes a bit of extra space on the axes
(i.e. the x-axis doesn’t start precisely at the epidemic start date, but
a little before to provide some visual padding), providing these allows
overshiny to restrict the overlays such that they can only
move over the time span in which the epidemic is actually occurring.
It’s similar for ylim (try removing the xlim
and ylim arguments to overlayBounds to see
what happens.)
overlayBounds() itself returns the plot
object, so it should be the last line in your expression that you pass
to renderPlot().
You should now be able to drag the intervention tokens onto the plot, where they will become overlays that you can move around, resize, and remove by clicking on the “gears” icon on each overlay (then the “remove” button). They won’t do anything yet to the epicurve yet, though; that’s for the next section.
If you’ve gotten stuck and your code isn’t working, here’s some code you could have arrived at:
Click for code…
library(shiny)
library(ggplot2)
library(epidemics)
library(overshiny)
# Model run function
run_model <- function(input)
{
# Transform parameters
I0 <- input$init_infec / 100; # Percent to proportion
duration <- as.numeric(input$date_range[2] - input$date_range[1]) # Dates to duration
infec_rate <- 1 / input$latent_pd # Latent period to infectiousness rate
recov_rate <- 1 / input$infec_pd # Infectious period to recovery rate
trans_rate <- input$R0 * recov_rate # R0 to transmission rate (R_0 = beta / gamma)
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000, # Population size in millions
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration)
return (results)
}
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# NEW PART IS HERE:
# Main plot
overlayPlotOutput("display", width = "100%", height = 400),
# END OF NEW PART
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions"),
overlayToken("vx", "Vaccination"),
overlayToken("tx", "Transmission")
)
)
)
# --- App logic ---
server <- function(input, output)
{
# --- OVERLAY SETUP ---
# Initialise 8 draggable/resizable overlays
ov <- overlayServer("display", 8)
# --- RENDERING OF EPI CURVES ---
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
plot <- ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})
}
# --- Run app ---
shinyApp(ui, server)That’s how overshiny works; the rest of this tutorial is
just about connecting overshiny with epidemics
so that the overlays on the plot actually have an effect on the epidemic
model.
Making the interventions work
The last piece of the puzzle is to make the interventions actually
have an impact on the simulated epidemic. Already, we are using the
function model_default() from epidemics to run
our model, and now we will use the intervention and
vaccination arguments to model_default() to
make our interventions work.
First, let’s change run_model() so that it can pass on
these extra parameters (intervention and
vaccination) to epidemics::model_default(). To
do that, add a ... to the list of parameters so that
run_model() can take other (arbitrarily-named) parameters
and pass them on to model_default(), like so (there are
just two changes to make):
… and then …
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration, ...) # <-- SECOND CHANGE HERE
return (results)Now, let’s modify the call to renderPlot so that it
reads in what overlays have been placed onto the plot, and fills out the
intervention and vaccination parameters
accordingly.
output$display <- renderPlot({
# Create interventions
tx_int <- list()
vax <- NULL
# Apply overlays as interventions
for (i in which(ov$active)) {
begin <- ov$cx0[i] - as.numeric(input$date_range[1])
end <- ov$cx1[i] - as.numeric(input$date_range[1])
if (ov$label[i] == "Vaccination") {
nu <- 0.01 # proportion of population vaccinated per day
if (is.null(vax)) {
vax <- vaccination(name = as.character(i), nu = matrix(nu),
time_begin = matrix(begin), time_end = matrix(end))
} else {
ov$active[i] <- FALSE
}
} else if (ov$label[i] == "Transmission") {
reduc <- 0.5 # reduction in transmission
tx_int[[length(tx_int) + 1]] <- intervention(name = as.character(i),
type = "rate", time_begin = matrix(begin), time_end = matrix(end),
reduction = reduc)
}
}
# Put interventions in the right format
int <- list()
if (length(tx_int)) {
int[["transmission_rate"]] <- do.call(c, tx_int)
}
# Run model
results <- run_model(input,
vaccination = vax,
intervention = if (length(int)) int else NULL)
# Process results (this is the same as before)
results <- results[results$compartment == "infectious", ]
plot <- ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})(Just in case, complete code for the whole script is here…)
library(shiny)
library(ggplot2)
library(epidemics)
library(overshiny)
# Model run function
run_model <- function(input, ...)
{
# Transform parameters
I0 <- input$init_infec / 100; # Percent to proportion
duration <- as.numeric(input$date_range[2] - input$date_range[1]) # Dates to duration
infec_rate <- 1 / input$latent_pd # Latent period to infectiousness rate
recov_rate <- 1 / input$infec_pd # Infectious period to recovery rate
trans_rate <- input$R0 * recov_rate # R0 to transmission rate (R_0 = beta / gamma)
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000, # Population size in millions
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration, ...)
return (results)
}
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# NEW PART IS HERE:
# Main plot
overlayPlotOutput("display", width = "100%", height = 400),
# END OF NEW PART
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions"),
overlayToken("vx", "Vaccination"),
overlayToken("tx", "Transmission")
)
)
)
# --- App logic ---
server <- function(input, output)
{
# --- OVERLAY SETUP ---
# Initialise 8 draggable/resizable overlays
ov <- overlayServer("display", 8)
# --- RENDERING OF EPI CURVES ---
output$display <- renderPlot({
# Create interventions
tx_int <- list()
vax <- NULL
# Apply overlays as interventions
for (i in which(ov$active)) {
begin <- ov$cx0[i] - as.numeric(input$date_range[1])
end <- ov$cx1[i] - as.numeric(input$date_range[1])
if (ov$label[i] == "Vaccination") {
nu <- 0.01 # proportion of population vaccinated per day
if (is.null(vax)) {
vax <- vaccination(name = as.character(i), nu = matrix(nu),
time_begin = matrix(begin), time_end = matrix(end))
} else {
ov$active[i] <- FALSE
}
} else if (ov$label[i] == "Transmission") {
reduc <- 0.5 # reduction in transmission
tx_int[[length(tx_int) + 1]] <- intervention(name = as.character(i),
type = "rate", time_begin = matrix(begin), time_end = matrix(end),
reduction = reduc)
}
}
# Put interventions in the right format
int <- list()
if (length(tx_int)) {
int[["transmission_rate"]] <- do.call(c, tx_int)
}
# Run model
results <- run_model(input,
vaccination = vax,
intervention = if (length(int)) int else NULL)
# Process results (this is the same as before)
results <- results[results$compartment == "infectious", ]
plot <- ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})
}
# --- Run app ---
shinyApp(ui, server)Compare the new call to renderPlot() to what we had
before, which was:
output$display <- renderPlot({
results <- run_model(input)
results <- results[results$compartment == "infectious", ]
plot <- ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})A lot has been added, so let’s take it step by step. First:
# Create interventions
tx_int <- list()
vax <- NULLHere, we create some variables that will hold details of the
interventions to apply; tx_int (for interventions on the
transmission rate) and vax (for a vaccination
campaign).
Then, we process the overlay data from the ov object
that is provided by overlayServer():
# Apply overlays as interventions
for (i in which(ov$active)) {
begin <- ov$cx0[i] - as.numeric(input$date_range[1])
end <- ov$cx1[i] - as.numeric(input$date_range[1])
if (ov$label[i] == "Vaccination") {
nu <- 0.01 # proportion of population vaccinated per day
if (is.null(vax)) {
vax <- vaccination(name = as.character(i), nu = matrix(nu),
time_begin = matrix(begin), time_end = matrix(end))
} else {
ov$active[i] <- FALSE
}
} else if (ov$label[i] == "Transmission") {
reduc <- 0.5 # reduction in transmission
tx_int[[length(tx_int) + 1]] <- intervention(name = as.character(i),
type = "rate", time_begin = matrix(begin), time_end = matrix(end),
reduction = reduc)
}
}ov$active is a logical vector, the same length as the
maximum number of overlays (here, 8), which is TRUE for
overlays that are on the plot and FALSE for overlays that
aren’t. So for (i in which(ov$active)) runs a loop for all
indices i that correspond to an “active” overlay.
Then we read begin and end – the start time
and end time for each intervention – from ov$cx0 (the
starting x-coordinate of each overlay) and from ov$cx1 (the
ending x-coordinate of each overlay). We work out how many days into the
epidemic begin and end are by subtracting the
numeric value of the start date of the epidemic,
as.numeric(input$date_range[1]).
Then, each overlay has a label which corresponds to the
label of the overlayToken() which created it.
So we check whether the overlay with index i is a
"Vaccination" or a "Transmission" overlay.
For vaccination overlays, we set the vaccination rate nu
to 0.01, which (to epidemics) means 1% of the population is
getting vaccinated per day. If there isn’t already a vaccination
intervention (and hence vax is NULL) then we
create one. If there is, then we can’t add a second vaccination
intervention since the epidemics package only allows one
vaccination intervention; so we deactivate the (second, superfluous)
vaccine intervention if one already exists.
For transmission overlays, we set the transmission reduction
reduc to 0.5, which means a reduction in the transmission
rate by 50%. We add our new intervention to the list
tx_int. epidemics does allow multiple
transmission-rate interventions, so we don’t need to limit the number of
these.
Next in the code, we have this:
# Put interventions in the right format
int <- list()
if (length(tx_int)) {
int[["transmission_rate"]] <- do.call(c, tx_int)
}
# Run model
results <- run_model(input,
vaccination = vax,
intervention = if (length(int)) int else NULL)This just turns our list of transmission interventions
tx_int into the right format for epidemics to
understand. It wants the intervention argument to be a list
with elements named "transmission_rate",
"infectiousness_rate", "recovery_rate", or
"contacts" depending on what kind of intervention it is.
Each of these elements should be one or several interventions, and the
way to combine interventions is with c() (hence the
do.call).
Then the code above calls our function run_model with
the appropriately-formatted intervention data for
vaccination and intervention.
Put this all together, and you have a working app with intervention overlays!
Next steps
We have come to the end of the tutorial. We haven’t explored
everything that shiny and overshiny can do,
but we have gone through the basics.
As a next step, it would be nice to modify our app to do two things:
- Compare the mitigated epidemic to the counterfactual–an unmitigated epidemic without any interventions. We could do this by plotting both epi curves, with the unmitigated epi curve in a lighter colour.
- Allow us to customize the vaccination rate or the transmission reduction percentage of each intervention, instead of leaving these at 0.1% and 50% respectively.
The following script shows you how to accomplish both of these
things. Use the shiny and overshiny package
documentation for insight into what all the changes from your existing
code do and how they work. Good luck!
Click for advanced code…
library(epidemics)
library(shiny)
library(overshiny)
library(ggplot2)
# --- User interface ---
ui <- fluidPage(
titlePanel("SEIRV model with interventions"),
# Main plot with support for overlays
overlayPlotOutput("display", width = "100%", height = 400),
# 3 columns of inputs
fluidRow(
column(4,
# Basic epidemic settings
h3("Epidemic"),
dateRangeInput("date_range", "Date range", start = "2025-01-01", end = "2025-12-31"),
numericInput("pop_size", "Population size (millions)", value = 59, min = 1),
sliderInput("init_infec", "Initial proportion infectious (%)", value = 0.1, min = 0, max = 1, step = 0.01)
),
column(4,
# Pathogen settings
h3("Pathogen"),
sliderInput("R0", HTML("Basic reproduction number, <i>R</i><sub>0</sub>"),
value = 1.3, min = 0, max = 5, step = 0.05),
sliderInput("latent_pd", "Latent period (days)", value = 2, min = 1, max = 7, step = 0.1),
sliderInput("infec_pd", "Infectious period (days)", value = 7, min = 1, max = 10, step = 0.1)
),
column(4,
# Overlay controls: tokens that can be dragged onto the plot
h3("Interventions"),
overlayToken("vx", "Vaccination"),
overlayToken("tx", "Transmission")
)
)
)
# --- App logic ---
server <- function(input, output)
{
# --- OVERLAY SETUP ---
# Dropdown menu for overlays
menu <- function(ov, i) {
if (ov$label[i] == "Vaccination") {
numericInput("display_vac_rate", "Vaccines per day (thousands)",
value = ov$data$vac_rate[i], min = 0, max = 10000)
} else if (ov$label[i] == "Transmission") {
sliderInput("display_int_strength", "Transmission reduction (%)",
value = ov$data$int_strength[i], min = 0, max = 100)
}
}
# Initialise 8 draggable/resizable overlays
ov <- overlayServer("display", 8, width = 56, # 56 days = 8 weeks default width
data = list(vac_rate = 10, int_strength = 20),
snap = snapGrid(),
heading = dateHeading("%b %e"),
select = TRUE,
menu = menu)
# --- EPIDEMIC MODEL RUNS BASED ON OVERLAY POSITIONS ---
# Model run function
run_model <- function(...)
{
# Transform parameters
I0 <- input$init_infec / 100;
duration <- as.numeric(input$date_range[2] - input$date_range[1])
infec_rate <- 1 / input$latent_pd
recov_rate <- 1 / input$infec_pd
trans_rate <- input$R0 * recov_rate
# Build population
pop <- population(
name = "Utopia",
contact_matrix = matrix(1),
demography_vector = input$pop_size * 1000000,
initial_conditions = matrix(c(1 - I0, 0, I0, 0, 0), nrow = 1)
)
# Run model (with additional parameters from ...)
results <- model_default(pop, transmission_rate = trans_rate,
infectiousness_rate = infec_rate, recovery_rate = recov_rate,
time_end = duration, ...)
# Transform results -- construct date and only return infection prevalence
results$date <- results$time + input$date_range[1]
results <- results[results$compartment == "infectious", ]
return (results)
}
# Unmitigated epidemic
epi_unmitigated <- reactive({
run_model()
})
# Mitigated epidemic
epi_mitigated <- reactive({
# Create interventions
tx_int <- list()
vax <- NULL
for (i in which(ov$active)) {
begin <- ov$cx0[i] - as.numeric(input$date_range[1])
end <- ov$cx1[i] - as.numeric(input$date_range[1])
if (ov$label[i] == "Vaccination") {
nu <- ov$data$vac_rate[i] * 1000 / (input$pop_size * 1000000)
if (is.null(vax)) {
vax <- vaccination(name = as.character(i), nu = matrix(nu),
time_begin = matrix(begin), time_end = matrix(end))
} else {
ov$active[i] <- FALSE
}
} else if (ov$label[i] == "Transmission") {
reduc <- ov$data$int_strength[i] / 100
tx_int[[length(tx_int) + 1]] <- intervention(name = as.character(i),
type = "rate", time_begin = matrix(begin), time_end = matrix(end),
reduction = reduc)
}
}
# Get mitigated model results
int <- list()
if (length(tx_int)) {
int[["transmission_rate"]] <- do.call(c, tx_int)
}
run_model(vaccination = vax,
intervention = if (length(int)) int else NULL)
})
# --- RENDERING OF EPI CURVES ---
# Render plot and align overlays to current axis limits
output$display <- renderPlot({
plot <- ggplot() +
geom_line(data = epi_unmitigated(),
aes(x = date, y = value/1000), alpha = 0.5) +
geom_line(data = epi_mitigated(),
aes(x = date, y = value/1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
})
}
# --- Run app ---
shinyApp(ui, server)