# Tutorial: Overlays for interventions in epidemic modelling

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` (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 `column`s 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:

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("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)

1. Technically it’s not a list, it’s a `shiny::reactiveValues()` object, but in many ways it behaves like a normal R list.↩︎