Showing how a 3rd-degree polynomial model would predict future deaths if a plateau continues

cubic-model-animation.R

library(tidyverse)
library(broom)
library(scales)
theme_set(theme_light())

US <- read_csv("https://raw.githubusercontent.com/nytimes/covid-19-data/master/us.csv") %>%
  mutate(new_deaths = deaths - lag(deaths)) %>%
  filter(date >= "2020-02-26")

today <- max(US$date)

# Imagine 5 weeks in the future repeating the last week
simulated_future <- rerun(10, tail(US, 7)) %>%
  bind_rows() %>%
  mutate(date = today + row_number())

US_future <- US %>%
  bind_rows(simulated_future) %>%
  crossing(days_future = seq(0, 20))

# Predict for 21 days in the future
models <- US_future %>%
  filter(date <= today + days_future) %>%
  group_by(days_future) %>%
  nest() %>%
  mutate(model = map(data, ~ lm(log(new_deaths + .5) ~ poly(date, 3), data = .)))

# Predict a few weeks future from each threshold
US_extrapolated <- US_future %>%
  filter(date < today + days_future + 42) %>%
  mutate(new_deaths = ifelse(date <= today + days_future, new_deaths, NA)) %>%
  group_by(days_future) %>%
  nest()

library(gganimate)

models %>%
  select(-data) %>%
  inner_join(US_extrapolated, by = "days_future") %>%
  mutate(augmented = map2(model, data, ~ augment(.x, newdata = .y))) %>%
  unnest(augmented) %>%
  ggplot(aes(date, new_deaths)) +
  geom_line(size = 2) +
  geom_line(aes(color = date > today), size = 2) +
  geom_line(aes(y = exp(.fitted) - 1), size = 1, lty = 2, color = "red") +
  labs(title = "How a cubic model's predictions will change if the plateau continues",
       subtitle = paste0("3rd degree polynomial fit to log(deaths + .5).\n",
                         "Hypothetical future (shown in gray) repeats most recent week.\n"),
       y = "Daily US deaths (NY Times)",
       x = "") +
  scale_y_continuous(labels = comma_format()) +
  scale_color_manual(values = c("black", "gray")) +
  transition_manual(days_future) +
  theme(legend.position = "none")