Skip to contents

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 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 or 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
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("plot", 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 "plot". 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$plot <- 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")
    })
}

# --- 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$plot. The reason output$plot exists is because we put a plotOutput in the shiny UI with ID "plot" – this makes an entry in output called plot 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)")

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("plot", 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$plot <- 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)")
    })
}

# --- 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:

    # Main plot
    overlayPlotOutput("plot", 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("plot", 8)

    # rest of code follows as normal...

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$plot <- 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)")
    })

Now, we have:

    output$plot <- 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)")
        
        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("plot", 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("plot", 8)
    
    # --- RENDERING OF EPI CURVES ---

    output$plot <- 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)")
        
        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$plot <- 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)")
        
        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("plot", 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("plot", 8)
    
    # --- RENDERING OF EPI CURVES ---

    output$plot <- 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)")
        
        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$plot <- 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)")
        
        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:

  1. 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.
  2. 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("plot", 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 ---

    # Initialise 8 draggable/resizable overlays
    ov <- overlayServer("plot", 8, width = 56, # 56 days = 8 weeks default width
        data = list(vac_rate = 10, int_strength = 20), snap = snap_grid())

    # --- OVERLAY DROPDOWN MENU ---

    # Render dropdown menu when an overlay is being edited
    output$plot_menu <- renderUI({
        i <- req(ov$editing)  # Current overlay being edited
        fmt <- function(t) format(as.Date(t, origin = "1970-01-01"), "%b %d")

        dropdown <- list(
            div(paste(fmt(ov$cx0[i]), "–", fmt(ov$cx1[i]))),
            selectInput("plot_label", NULL, choices = c("Vaccination", "Transmission"), selected = ov$label[i])
        )

        if (ov$label[i] == "Vaccination") {
            dropdown[[3]] <- numericInput("plot_vac_rate", "Vaccines per day (thousands)",
                value = ov$data$vac_rate[i], min = 0, max = 10000)
        } else if (ov$label[i] == "Transmission") {
            dropdown[[3]] <- sliderInput("plot_int_strength", "Transmission reduction (%)",
                value = ov$data$int_strength[i], min = 0, max = 100)
        }

        return (dropdown)
    })

    # --- 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$plot <- 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)")

        overlayBounds(ov, plot, xlim = c(input$date_range), ylim = c(0, NA))
    })
}

# --- Run app ---
shinyApp(ui, server)