Configuration

The key configuration variable is the path to the local copy of the data, but other values below can be configured to experiment with alternative views.

# The following are based on the local copy of the data
jhu_directory <- "COVID-19/csse_covid_19_data/"

# Size of the moving window for averaging
DESIRED_DAYS <- 7
before_count <- DESIRED_DAYS - 1

# Upper Bound of Y-Axis
UPPER_BOUND <- 2

Environment

The tidyverse library is the main dependency. The slider library does the hard work of proper calculations of moving averages. We use lubridate just to get a trivial way to calculate “one month ago”. ggrepel helps make labels in each chart simple as well as easy to execute. Finally, `geofacet’ provides an interesting way to layout the many charts in this visualization.

⊕“If I have seen further it is by standing on the shoulders of Giants” – Issac Newton

library(tidyverse)
library(lubridate)
library(geofacet)
library(ggrepel)
library(slider)

Join Datasets And Calculate Moving Averages

Joining the datasets enables us to calculate the normalized case counts, and as part of the same operation we can then calculate a 7-day moving average (which helps smooth out the sitations where some states tend to report fewer cases during Saturday and Sunday).

jhu_workset <-
    # Join with Lookup data to get Population
    left_join(
        jhu_uscases_data, jhu_lookup_data,
        by = "Admin1"
    ) %>%
    select(
        Name = Admin1, Population, Date, Cases
    ) %>%
    # Convert running totals into daily new cases and generate running average
    group_by(Name) %>%
    arrange(Date) %>%
    mutate(
        NewCases = Cases - lag(Cases),
        AvgCases = slide_dbl(
            NewCases, mean,
            .before = before_count, .complete = TRUE
        ),
        NrmAvgCases = AvgCases / (Population / 1000000),
        RelCases = NrmAvgCases / last(NrmAvgCases)
    ) %>%
    # Reduce to simplify
    ungroup() %>%
    select(
        Date, Name, AvgCases, NrmAvgCases, RelCases
    )

Min and Max Cases

First, the lubridate tools in Tidyverse help keep data calculations clean, but it’s more out of habit than necessity that I use the library just to figure out a date for exactly one month ago.

The “neat” trick is in the second step, using the new slice functions in the updated dplyr library to neatly extract exactly one date each for when min and max values were reached.

# Filter down to just the dates that are of interest
latest_date <- max(jhu_workset$Date)
chart_start_date <- latest_date - months(1, FALSE)
viewset <- jhu_workset %>%
    filter(
        NrmAvgCases > 0,
        Date > chart_start_date
    )

# Find the min and max for each state now that we've removed unwanted dates
min_dates <- viewset %>%
    group_by(Name) %>%
    slice_min(RelCases, with_ties = FALSE) %>%
    ungroup() %>%
    select(Name, MinDate = Date, MinVal = AvgCases)
max_dates <- viewset %>%
    group_by(Name) %>%
    slice_max(RelCases, with_ties = FALSE) %>%
    ungroup() %>%
    select(Name, MaxDate = Date, MaxVal = AvgCases)

# Join the min/max to our data, and generate a label for those min/max dates
viewset <- viewset %>%
    left_join(min_dates, by = "Name") %>%
    left_join(max_dates, by = "Name") %>%
    # Generate a label for the datapoints on the specific min/max dates
    group_by(Name) %>%
    mutate(
        Label = if_else(
            Date == MaxDate,
            as.character(round(MaxVal)),
            if_else(
                Date == MinDate,
                as.character(round(MinVal)),
                ""
            ),
        )
    ) %>%
    # Reduce back down to just what we need
    ungroup() %>%
    select(
        -AvgCases,
        -MinVal, -MaxVal, -MinDate, -MaxDate
    )

Simple Faceting

Each chart is displaying the same sequence of days across the X-axis, and each is displaying the same Y-axis relative to the last day’s value (the Y-axis runs from 0 to 2 with the last day’s value centered at 1.0 and all the other points displayed relative to that last point). In this way the shapes of the curves are easily compared.

The shape of the curve in each chart provides a sense of the recent directions of each state’s trends, but the color of the datapoints can provide an idea of how serious the situation might be, with the “hotter” the color the higher the number of cases per million residents of that state. The legend has been tweaked pretty seriously, using a log10 transform of the Population column with the vivid Viridis color scale – reworking the scale by orders of magnitude makes it is possible to get a reasonable sense of each state’s outbreak even in the tiny subplots within the small-multiple view. The legend itself has been hacked with calls to guides() and theme() to render a long and thin legend along the bottom of the chart which may make it easier to see how to read the colors of the counties while taking only a bit of visual room.

To supply some detailed information from each state, the min and the max values for each chart are noted and the exact values for those are printed in small type for those who may want to squint.

gg <- ggplot(
    viewset,
    aes(
        x = Date,
        y = RelCases,
        label = Label,
        color = NrmAvgCases
        )
) +
    # lay down one reference line
    geom_hline(
        yintercept = 1.0,
        color = "gray90",
        size = 0.5
    ) +
    # add our data
    geom_point(
        size = 1,
        na.rm = TRUE
    ) +
    # Style the chart
    coord_cartesian(
        ylim = c(0, UPPER_BOUND)
    ) +
    scale_x_date(
        date_breaks = "1 month",
        date_labels = "%b"
    ) +
    scale_color_viridis_c(
        trans = "log10",
        n.breaks = 7, breaks = waiver(),
        option = "A", direction = 1
    ) +
    guides(
        color = guide_colorbar(
            barwidth = unit(0.75, "npc"),
            barheight = unit(0.01, "npc"),
            title = "Cases/Million (log scale)"
        )
    ) +
    geom_text_repel(
        min.segment.length = unit(0, 'lines'), 
        size = 2,
        color = "black"
    ) +
    facet_wrap(~ Name) +
    labs(
        title = "COVID By US State: Last Month of New Cases Reported per Day",
        subtitle = paste(
            "Daily Cases Plotted Relative to Latest Counts,",
            "Colored by Daily Cases per Million Population"
        ),
        y = "New Cases Reported (7-day moving average)",
        x = "",
        caption = paste(
            "Visualization by Alexander Carlton;",
            "Data from Johns Hopkins University CSSE,",
            "including data through",
            format(latest_date, "%B %e, %Y")
        )
    ) +
    theme_minimal() +
    theme(
        plot.background = element_rect(
            fill = "gray90", color = "gray90"
        ),
        strip.background = element_rect(
            fill = "white", color = "white"
        ),
        panel.background = element_rect(
            fill = "white", color = "white"
        ),
        panel.grid.minor = element_blank(),
        panel.grid.major.y = element_blank(),
        axis.text.x = element_text(angle = 90, vjust = 0.5),
        axis.text.y = element_blank(),
        legend.position = "bottom"
    )

print(gg)

These charts are all drawn normalized to each other, all with the last date falling on the mid-point of the Y-axis. And unfortunately, almost all of these charts are rising to that last date showing that the peak values over the last month has been reached only recently. Hawaii is the one case where it’s easy to see the trend all month has been downwards.

Adapting the Layout to Provide More Information

Displaying these charts alphabetically is efficient space-wise, but a bit hard to appreciate visually. We can take advantage of peoples’ familiarity with the basic layout of the states in America to re-arrange these charts in such a way that one can get a quick sense of regional differences.

The geofacet library can be fun to work with. Obviously there are severe limits to the accuracy of any attempt to replicate geographic complexity with nothing more than a set of identically sized rectangles, but even with all the distortions a decent layout of these charts can provide a good means of delivering some insights about regional behavior.

# Define an arrangement of states into a grid layout for facet_geo()
unitedstates_grid <- data.frame(
    row = c(
                                   1, 1, 1,
        2, 2, 2, 2, 2, 2, 2,    2, 2, 2, 2,
        3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
        4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
           5, 5, 5, 5, 5, 5, 5,
                 6, 6, 6, 6, 6,          6,
        7, 7,    7,          7,          7
    ),
    col = c(
                                   10, 11, 12,
        1, 2, 3, 4, 5, 6, 7,    9, 10, 11, 12, 
        1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
        1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
           2, 3, 4, 5, 6, 7, 8,
                 4, 5, 6, 7, 8,            12, 
        1, 2,    4,          8,            12
    ),
    code = c(
                                                              "VT", "NH", "ME",
        "WA", "ID", "MT", "ND", "MN", "WI", "MI",       "NY", "CT", "RI", "MA", 
        "OR", "NV", "WY", "SD", "IA", "IL", "IN", "OH", "PA", "NJ",
        "CA", "UT", "CO", "NE", "MO", "KY", "WV", "VA", "MD", "DE",
              "AZ", "NM", "KS", "AR", "TN", "NC", "SC",
                          "OK", "LA", "MS", "AL", "GA",                   "DC",
        "AK", "HI",       "TX",                   "FL",                   "PR"
    ),
    name = c(
        "Vermont", "New Hampshire", "Maine",
        "Washington", "Idaho", "Montana", "North Dakota", "Minnesota",
            "Wisconsin", "Michigan", "New York", "Connecticut", "Rhode Island", 
            "Massachusetts",
        "Oregon", "Nevada", "Wyoming", "South Dakota", "Iowa", "Illinois",
            "Indiana", "Ohio", "Pennsylvania", "New Jersey",
        "California", "Utah", "Colorado", "Nebraska", "Missouri", "Kentucky",
            "West Virginia", "Virginia", "Maryland", "Delaware",
        "Arizona", "New Mexico", "Kansas", "Arkansas", "Tennessee", 
            "North Carolina", "South Carolina",
        "Oklahoma", "Louisiana", "Mississippi", "Alabama", "Georgia",
            "District of Columbia",
        "Alaska", "Hawaii", "Texas", "Florida", "Puerto Rico"
    ),
    stringsAsFactors = FALSE
)

Rebuilding the Chart

Below we repeat this same small-multiples chart, just substituting a call to facet_geo() instead of facet_wrap().

# Generate the plot
geo <- ggplot(
    viewset,
    aes(
        x = Date,
        y = RelCases,
        label = Label,
        color = NrmAvgCases
        )
) +
    # lay down one reference line
    geom_hline(
        yintercept = 1.0,
        color = "gray90",
        size = 0.5
    ) +
    # add our data
    geom_point(
        size = 1,
        na.rm = TRUE
    ) +
    # Style the chart
    coord_cartesian(
        ylim = c(0, UPPER_BOUND)
    ) +
    scale_x_date(
        date_breaks = "1 month",
        date_labels = "%b"
    ) +
    scale_color_viridis_c(
        trans = "log10",
        n.breaks = 7, breaks = waiver(),
        option = "A", direction = 1
    ) +
    guides(
        color = guide_colorbar(
            barwidth = unit(0.75, "npc"),
            barheight = unit(0.01, "npc"),
            title = "Cases/Million (log scale)"
        )
    ) +
    geom_text_repel(
        min.segment.length = unit(0, 'lines'), 
        size = 2,
        color = "black"
    ) +
    facet_geo(
        ~ Name,
        grid = unitedstates_grid,
        move_axes = FALSE
    ) +
    labs(
        title = "COVID By US State: Last Month of New Cases Reported per Day",
        subtitle = paste(
            "Daily Cases Plotted Relative to Latest Counts,",
            "Colored by Daily Cases per Million Population"
        ),
        y = "New Cases Reported (7-day moving average)",
        x = "",
        caption = paste(
            "Visualization by Alexander Carlton;",
            "Data from Johns Hopkins University CSSE,",
            "including data through",
            format(latest_date, "%B %e, %Y")
        )
    ) +
    theme_minimal() +
    theme(
        plot.background = element_rect(
            fill = "gray90", color = "gray90"
        ),
        strip.background = element_rect(
            fill = "white", color = "white"
        ),
        panel.background = element_rect(
            fill = "white", color = "white"
        ),
        panel.grid.minor = element_blank(),
        panel.grid.major.y = element_blank(),
        axis.text.x = element_text(angle = 90, vjust = 0.5),
        axis.text.y = element_blank(),
        legend.position = "bottom"
    )

print(geo)

Clearly this is not an accurate map of the United States, but it is enough to show that the overall upward trends are true almost coast to coast, though northern New England and the West Coast states both look different than their neighboring regions, and that the Dakotas appear to be at the center of an area currently experiencing a rapidly rising caseload.