Nothing
Tutorial: Overlays for interventions in epidemic modelling
In overshiny: Interactive Overlays on 'shiny' Plots
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
This 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 list[^1] called input. So
let's say that the input list contains the following:
[^1]: Technically it's not a list, it's a shiny::reactiveValues()
object, but in many ways it behaves like a normal R list.
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:
fluidRow(
column(4, "part one"),
column(4, "part two"),
column(4, "part three")
)
then on a larger screen, you would see something like
```{=html}
part one part two part three
while on a phone, you might see
```{=html}
<pre>part one
part two
part three</pre>
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:
plotOutput("marmite", width = "100%", height = 400),
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.)
Click for one possible answer...
Here's how you might make these changes to the server function just by
changing the call to ggplot:
ggplot(results) +
geom_line(aes(x = time + input$date_range[1], y = value / 1000)) +
labs(x = NULL, y = "Infection prevalence (thousands)") +
ylim(0, NA)
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:
library(overshiny)
Second, we need to change our plotOutput plot in our UI to an
overlayPlotOutput so that it can respond to overlays:
# Main plot
overlayPlotOutput("display", width = "100%", height = 400),
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 by overlayServer().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):
# Model run function
run_model <- function(input, ...) # <-- FIRST CHANGE HERE
... 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 <- NULL
Here, 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)
Try the overshiny package in your browser
Any scripts or data that you put into this service are public.
overshiny documentation built on Sept. 9, 2025, 5:50 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
knitr::opts_chunk$set( collapse = TRUE, comment = "#>" )
This 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.
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 list[^1] called input. So
let's say that the input list contains the following:
[^1]: Technically it's not a list, it's a shiny::reactiveValues()
object, but in many ways it behaves like a normal R list.
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().
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:
fluidRow( column(4, "part one"), column(4, "part two"), column(4, "part three") )
then on a larger screen, you would see something like
```{=html}
part one part two part three
while on a phone, you might see
```{=html}
<pre>part one
part two
part three</pre>
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:
plotOutput("marmite", width = "100%", height = 400),
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.)
Here's how you might make these changes to the server function just by
changing the call to ggplot:
ggplot(results) + geom_line(aes(x = time + input$date_range[1], y = value / 1000)) + labs(x = NULL, y = "Infection prevalence (thousands)") + ylim(0, NA)
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:
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:
library(overshiny)
Second, we need to change our plotOutput plot in our UI to an
overlayPlotOutput so that it can respond to overlays:
# Main plot overlayPlotOutput("display", width = "100%", height = 400),
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:
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):
# Model run function run_model <- function(input, ...) # <-- FIRST CHANGE HERE
... 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)) })
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 <- NULL
Here, 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!
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)
Try the overshiny package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.