├── analysis ├── 13-timeline.R ├── 99-optimize.R ├── 00-run-all.R ├── 09-rw.R ├── get_thresh_covidseir.R ├── data-model-prep.R ├── 14-sensitivity2.R ├── 07-threshold.R ├── 17-washington.R ├── 09-delay.R ├── 17-california.R ├── plot_projection_w_inset.R ├── 18-fl.R ├── 08-f-projections.R ├── make_projection_plot.R ├── 15-epi-curves.R ├── 06-cycle-f2.R ├── 05-main-fig.R ├── 01-simulation-test.R ├── 17-ny.R ├── 19-nz.R ├── 10-sensitivity.R ├── seeiqr.stan ├── functions_sir.R ├── 20-plot-other-regions.R ├── make_quick_plots.R ├── 11-onset-date.R └── fit_seeiqr.R ├── README-figs └── proj-plot-1.png ├── .gitignore ├── data-raw ├── timeline_states.csv ├── timeline.csv ├── hospitalization-data.csv └── BC-Case-Counts_09.04.2020.csv ├── data-generated └── daily-cases.csv ├── figs-ms └── values.tex ├── README.Rmd ├── 21-combined-proj-plot.R ├── README.md └── LICENSE.md /analysis/13-timeline.R: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README-figs/proj-plot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/carolinecolijn/distancing-impact-covid19/HEAD/README-figs/proj-plot-1.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.Rproj 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | .Ruserdata 6 | *.png 7 | *.log 8 | *.asv 9 | *.aux 10 | *.gz 11 | *.pdf 12 | data-raw/2019-nCoV_daily_linelist.csv 13 | *.rda 14 | *.rds 15 | *.html 16 | data-generated/us-data.csv 17 | -------------------------------------------------------------------------------- /analysis/99-optimize.R: -------------------------------------------------------------------------------- 1 | if (Sys.info()[["user"]] == "seananderson") { 2 | files_per_core <- 2 3 | setwd("figs-ms") 4 | system(paste0( 5 | "find -X . -name '*.png' -print0 | xargs -0 -n ", 6 | files_per_core, " -P ", parallel::detectCores() / 2, " optipng -strip all" 7 | )) 8 | setwd("..") 9 | } 10 | -------------------------------------------------------------------------------- /data-raw/timeline_states.csv: -------------------------------------------------------------------------------- 1 | event,CA,WA,FL,NY 2 | First case ,#2020-01-26,#2020-01-21,#2020-03-01,#2020-03-01 3 | Ban on large gatherings,2020-03-12,2020-03-11,2020-03-12,2020-03-12 4 | Schools closed,2020-03-13,2020-03-12,2020-03-17,2020-03-16 5 | Bars and restuarants closed,2020-03-15,2020-03-15,#2020-03-17,2020-03-17 6 | Stay-at-home orders,2020-03-17,2020-03-23,2020-04-01,2020-03-22 7 | -------------------------------------------------------------------------------- /data-raw/timeline.csv: -------------------------------------------------------------------------------- 1 | date, event 2 | # 2020-01-26, "First case detected in B.C." 3 | 2020-03-08, "Sustained increase in cases" 4 | 2020-03-12, "Gatherings > 250 people banned" 5 | 2020-03-13, "Non-essential travel outside Canada recommended against" 6 | 2020-03-14, "Schools closed" 7 | 2020-03-16, "University classes moved online" 8 | 2020-03-17, "Bars, pubs, and nightclubs closed" 9 | 2020-03-20, "Restaurant/cafe dine-in service closed" 10 | 2020-03-21, "Personal-care services closed" 11 | -------------------------------------------------------------------------------- /data-raw/hospitalization-data.csv: -------------------------------------------------------------------------------- 1 | Date,Hosp Census,Hosp Ever 2 | 16-Mar-2020,6,9 3 | 17-Mar-2020,7,10 4 | 18-Mar-2020,13,21 5 | 19-Mar-2020,17,30 6 | 20-Mar-2020,22,34 7 | 21-Mar-2020,27,41 8 | 22-Mar-2020,33,60 9 | 23-Mar-2020,40,83 10 | 24-Mar-2020,59,96 11 | 25-Mar-2020,64,107 12 | 26-Mar-2020,66,110 13 | 27-Mar-2020,73,123 14 | 28-Mar-2020,81,144 15 | 29-Mar-2020,93,158 16 | 30-Mar-2020,106,175 17 | 31-Mar-2020,128,204 18 | 01-Apr-2020,142,225 19 | 02-Apr-2020,149,244 20 | 03-Apr-2020,146,263 21 | 04-Apr-2020,149,273 22 | 05-Apr-2020,137,279 23 | 06-Apr-2020,140,290 24 | 07-Apr-2020,138,298 25 | 08-Apr-2020,135,309 26 | 09-Apr-2020,132,317 27 | 10-Apr-2020,128,324 28 | 11-Apr-2020,134,330 29 | 12-Apr-2020,135,336 30 | 13-Apr-2020,137,343 31 | 14-Apr-2020,134,349 32 | -------------------------------------------------------------------------------- /data-generated/daily-cases.csv: -------------------------------------------------------------------------------- 1 | date,cases 2 | 2020-03-01,0 3 | 2020-03-02,0 4 | 2020-03-03,1 5 | 2020-03-04,3 6 | 2020-03-05,1 7 | 2020-03-06,8 8 | 2020-03-07,0 9 | 2020-03-08,6 10 | 2020-03-09,5 11 | 2020-03-10,0 12 | 2020-03-11,7 13 | 2020-03-12,7 14 | 2020-03-13,18 15 | 2020-03-14,9 16 | 2020-03-15,22 17 | 2020-03-16,38 18 | 2020-03-17,53 19 | 2020-03-18,45 20 | 2020-03-19,40 21 | 2020-03-20,77 22 | 2020-03-21,76 23 | 2020-03-22,48 24 | 2020-03-23,67 25 | 2020-03-24,78 26 | 2020-03-25,42 27 | 2020-03-26,66 28 | 2020-03-27,67 29 | 2020-03-28,92 30 | 2020-03-29,16 31 | 2020-03-30,70 32 | 2020-03-31,43 33 | 2020-04-01,53 34 | 2020-04-02,55 35 | 2020-04-03,53 36 | 2020-04-04,29 37 | 2020-04-05,26 38 | 2020-04-06,37 39 | 2020-04-07,25 40 | 2020-04-08,45 41 | 2020-04-09,34 42 | 2020-04-10,40 43 | 2020-04-11,35 44 | -------------------------------------------------------------------------------- /analysis/00-run-all.R: -------------------------------------------------------------------------------- 1 | # Make all the figures for the paper: 2 | 3 | library("here") 4 | 5 | source(here("analysis/01-simulation-test.R")) 6 | 7 | rm(list = ls()) # to avoid 'future' package exporting large objects 8 | source(here("analysis/05-main-fig.R")) 9 | 10 | rm(list = ls()) 11 | source(here("analysis/06-cycle-f2.R")) 12 | 13 | rm(list = ls()) 14 | source(here("analysis/07-threshold.R")) 15 | 16 | rm(list = ls()) 17 | source(here("analysis/08-f-projections.R")) 18 | 19 | rm(list = ls()) 20 | source(here("analysis/09-delay.R")) 21 | 22 | rm(list = ls()) 23 | source(here("analysis/09-rw.R")) 24 | 25 | rm(list = ls()) 26 | source(here("analysis/10-sensitivity.R")) 27 | 28 | if (Sys.info()[["user"]] == "seananderson") { 29 | # Data cannot be publicly released: 30 | source(here("analysis/11-onset-date.R")) 31 | } 32 | source(here("analysis/13-timeline.R")) 33 | 34 | rm(list = ls()) 35 | source(here("analysis/14-sensitivity2.R")) 36 | 37 | source(here("analysis/99-optimize.R")) 38 | -------------------------------------------------------------------------------- /analysis/09-rw.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # sampFrac random walk -------------------------------------------------------- 4 | 5 | m_rw <- fit_seeiqr( 6 | daily_diffs, 7 | sampFrac2_type = "rw", 8 | rw_sigma = 0.1, 9 | sampFrac2_prior = c(0.2, 0.2), 10 | sampled_fraction_day_change = 5, 11 | forecast_days = 60, 12 | seeiqr_model = seeiqr_model, chains = 4, iter = 1000 13 | ) 14 | saveRDS(m_rw, file = "data-generated/rw-fit.rds") 15 | m_rw <- readRDS("data-generated/rw-fit.rds") 16 | 17 | .days <- seq(lubridate::ymd("2020-03-01"), 18 | lubridate::ymd("2020-03-01") + 42, by = "1 day") 19 | g1 <- m_rw$post$sampFrac2 %>% 20 | reshape2::melt() %>% 21 | as_tibble() %>% 22 | rename(day = Var2) %>% 23 | group_by(day) %>% 24 | summarise( 25 | lwr = quantile(value, probs = 0.05), 26 | lwr2 = quantile(value, probs = 0.25), 27 | upr = quantile(value, probs = 0.95), 28 | upr2 = quantile(value, probs = 0.75), 29 | med = median(value) 30 | ) %>% 31 | ggplot(aes(.days[day + 4], med)) + 32 | geom_line(lwd = 0.8) + 33 | geom_ribbon(aes(ymin = lwr, ymax = upr), alpha = 0.2) + 34 | geom_ribbon(aes(ymin = lwr2, ymax = upr2), alpha = 0.5) + 35 | xlim(.days[1], max(.days) + 60) + 36 | coord_cartesian(expand = FALSE, ylim = c(0, 1)) + 37 | ylab("Estimated sampled fraction") + 38 | xlab("") 39 | 40 | g2 <- make_projection_plot(list(m_rw)) 41 | 42 | cowplot::plot_grid(g1, g2, ncol = 1, align = "hv", labels = "AUTO") 43 | ggsave(paste0("figs-ms/sampFrac2-rw.png"), width = 5, height = 6) 44 | -------------------------------------------------------------------------------- /analysis/get_thresh_covidseir.R: -------------------------------------------------------------------------------- 1 | get_thresh_covidseir <- function(obj, iter = 1:25, forecast_days = 60, 2 | fs = seq(0.4, 0.95, length.out = 6), 3 | show_plot = TRUE, 4 | window_check = 25) { 5 | m_fs <- purrr::map(fs, function(.f) { 6 | cat("Projecting", round(.f, 2), "\n") 7 | project_seir(obj, forecast_days = forecast_days, iter = iter, 8 | f_fixed_start = nrow(obj$daily_cases) + 1, 9 | f_fixed = rep(.f, forecast_days), 10 | return_states = TRUE) 11 | }) 12 | slopes <- purrr::map2_df(m_fs, fs, function(x, y) { 13 | temp <- x %>% 14 | dplyr::filter(time > max(x$time) - window_check, 15 | variable %in% c("I", "Id")) %>% 16 | group_by(.iteration, time) %>% 17 | summarize( 18 | I = value[variable == "I"], Id = value[variable == "Id"], 19 | prevalence = I + Id 20 | ) 21 | iters <- temp %>% 22 | group_by(.iteration) %>% 23 | summarise(iter = .iteration[[1]]) 24 | temp %>% 25 | group_by(.iteration) %>% 26 | group_split() %>% 27 | purrr::map(~ lm(log(prevalence) ~ time, data = .x)) %>% 28 | purrr::map_df(~ tibble(slope = coef(.x)[[2]])) %>% 29 | mutate(f = y) %>% 30 | ungroup() %>% 31 | mutate(.iteration = iters$iter) 32 | }) 33 | if (show_plot) { 34 | plot(slopes$f, slopes$slope) 35 | } 36 | mlm <- lm(slope ~ f, data = slopes) 37 | nd <- data.frame(f = seq(0.2, 0.9, length.out = 5000)) 38 | nd$predicted_slope <- stats::predict(mlm, newdata = nd) 39 | dplyr::filter(nd, predicted_slope > 0) %>% `[`(1, "f") 40 | } 41 | -------------------------------------------------------------------------------- /data-raw/BC-Case-Counts_09.04.2020.csv: -------------------------------------------------------------------------------- 1 | Date,BC,ICU Census,new_icu_confirmed 2 | 22/01/2020,0,, 3 | 23/01/2020,0,, 4 | 24/01/2020,0,, 5 | 25/01/2020,0,, 6 | 26/01/2020,0,, 7 | 27/01/2020,0,, 8 | 28/01/2020,1,, 9 | 29/01/2020,1,, 10 | 30/01/2020,1,, 11 | 31/01/2020,1,, 12 | 1/2/2020,1,, 13 | 2/2/2020,1,, 14 | 3/2/2020,1,, 15 | 4/2/2020,1,, 16 | 5/2/2020,2,, 17 | 6/2/2020,2,, 18 | 7/2/2020,4,, 19 | 8/2/2020,4,, 20 | 9/2/2020,4,, 21 | 10/2/2020,4,, 22 | 11/2/2020,4,, 23 | 12/2/2020,4,, 24 | 13/02/2020,4,, 25 | 14/02/2020,4,, 26 | 15/02/2020,4,, 27 | 16/02/2020,4,, 28 | 17/02/2020,5,, 29 | 18/02/2020,5,, 30 | 19/02/2020,5,, 31 | 20/02/2020,5,, 32 | 21/02/2020,6,, 33 | 22/02/2020,6,, 34 | 23/02/2020,6,, 35 | 24/02/2020,6,, 36 | 25/02/2020,7,, 37 | 26/02/2020,7,, 38 | 27/02/2020,7,, 39 | 28/02/2020,7,, 40 | 29/02/2020,8,, 41 | 1/3/2020,8,, 42 | 2/3/2020,8,, 43 | 3/3/2020,9,, 44 | 4/3/2020,12,, 45 | 5/3/2020,13,, 46 | 6/3/2020,21,, 47 | 7/3/2020,21,, 48 | 8/3/2020,27,, 49 | 9/3/2020,32,, 50 | 10/3/2020,32,, 51 | 11/3/2020,39,, 52 | 12/3/2020,46,, 53 | 13/03/2020,64,, 54 | 14/03/2020,73,, 55 | 15/03/2020,95,, 56 | 16/03/2020,133,, 57 | 17/03/2020,186,4, 58 | 18/03/2020,231,7, 59 | 19/03/2020,271,9, 60 | 20/03/2020,348,10, 61 | 21/03/2020,424,12, 62 | 22/03/2020,472,14, 63 | 23/03/2020,539,29, 64 | 24/03/2020,617,31, 65 | 25/03/2020,659,49,15 66 | 26/03/2020,725,48,6 67 | 27/03/2020,792,56,12 68 | 28/03/2020,884,57,1 69 | 29/03/2020,900,56,2 70 | 30/03/2020,970,62,4 71 | 31/03/2020,1013,62,2 72 | 1/4/2020,1066,67,8 73 | 2/4/2020,1121,68,7 74 | 3/4/2020,1174,64,2 75 | 4/4/2020,1203,68,4 76 | 5/4/2020,1229,70,4 77 | 6/4/2020,1266,72,2 78 | 7/4/2020,1291,67, 79 | 8/4/2020,1336,62, -------------------------------------------------------------------------------- /analysis/data-model-prep.R: -------------------------------------------------------------------------------- 1 | library("rstan") 2 | library("dplyr") 3 | library("ggplot2") 4 | library("future") 5 | library("here") 6 | rstan_options(auto_write = TRUE) 7 | dir.create("data-generated", showWarnings = FALSE) 8 | dir.create("figs-ms", showWarnings = FALSE) 9 | dir.create("figs", showWarnings = FALSE) 10 | options(mc.cores = parallel::detectCores() / 2) 11 | # remotes::install_github("seananderson/ggsidekick") 12 | theme_set(ggsidekick::theme_sleek()) 13 | dat <- here("data-raw/BC-Case-Counts_09.04.2020.csv") %>% 14 | readr::read_csv(col_types = readr::cols( 15 | Date = readr::col_character(), 16 | BC = readr::col_double(), 17 | `ICU Census` = readr::col_double(), 18 | new_icu_confirmed = readr::col_double() 19 | )) 20 | names(dat)[names(dat) == "BC"] <- "Cases" 21 | dat$Date <- lubridate::dmy(dat$Date) 22 | dat$day <- seq_len(nrow(dat)) 23 | dat$daily_diffs <- c( 24 | dat$Cases[2] - dat$Cases[1], 25 | diff(dat$Cases) 26 | ) 27 | .today <- max(dat$Date) 28 | dat <- dplyr::filter(dat, Date >= "2020-03-01") 29 | daily_diffs <- dat$daily_diffs 30 | if (.today == "2020-04-08") { 31 | daily_diffs <- c(daily_diffs, 34, 40, 35) # April 9, 10, 11 32 | .today <- "2020-04-11" 33 | } 34 | tibble( 35 | date = seq(dat$Date[1], lubridate::ymd(.today), by = "1 day"), 36 | cases = daily_diffs 37 | ) %>% 38 | readr::write_csv(here("data-generated/daily-cases.csv")) 39 | seeiqr_model <- rstan::stan_model(here("analysis/seeiqr.stan")) 40 | source(here("analysis/fit_seeiqr.R")) 41 | source(here("analysis/functions_sir.R")) 42 | source(here("analysis/make_projection_plot.R")) 43 | source(here("analysis/make_quick_plots.R")) 44 | 45 | .hist_blue <- RColorBrewer::brewer.pal(6, "Blues")[5] 46 | -------------------------------------------------------------------------------- /figs-ms/values.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\fracEstUpr}{0.89} 2 | \newcommand{\fracEstMed}{0.78} 3 | \newcommand{\fracEstLwr}{0.66} 4 | \newcommand{\percEstUpr}{89} 5 | \newcommand{\percEstMed}{78} 6 | \newcommand{\percEstLwr}{66} 7 | \newcommand{\fTwoEstUpr}{0.34} 8 | \newcommand{\fTwoEstMed}{0.22} 9 | \newcommand{\fTwoEstLwr}{0.11} 10 | \newcommand{\totalCases}{1445} 11 | \newcommand{\currentPercInCycles}{78} 12 | \newcommand{\currentFracInCycles}{0.78} 13 | \newcommand{\thresholdPerc}{45} 14 | \newcommand{\thresholdFrac}{0.45} 15 | \newcommand{\thresholdFtwo}{0.55} 16 | \newcommand{\prevDelayFifteenthLwr}{6} 17 | \newcommand{\prevDelayFifteenthMed}{7} 18 | \newcommand{\prevDelayFifteenthUpr}{8} 19 | \newcommand{\prevDelayTwelfthLwr}{9} 20 | \newcommand{\prevDelayTwelfthMed}{10} 21 | \newcommand{\prevDelayTwelfthUpr}{10} 22 | \newcommand{\delayLwr}{4.3} 23 | \newcommand{\delayMed}{4.8} 24 | \newcommand{\delayUpr}{5.4} 25 | \newcommand{\prevalencePeakLwr}{21.4} 26 | \newcommand{\prevalencePeakMed}{21.9} 27 | \newcommand{\prevalencePeakUpr}{22.5} 28 | \newcommand{\currentPercInCycles}{78} 29 | \newcommand{\currentFracInCycles}{0.78} 30 | \newcommand{\thresholdFtwo}{0.55} 31 | \newcommand{\NYlwrRatio}{0.43} 32 | \newcommand{\NYmedRatio}{0.60} 33 | \newcommand{\NYuprRatio}{0.74} 34 | \newcommand{\FLlwrRatio}{0.76} 35 | \newcommand{\FLmedRatio}{0.86} 36 | \newcommand{\FLuprRatio}{0.96} 37 | \newcommand{\WAlwrRatio}{0.79} 38 | \newcommand{\WAmedRatio}{0.84} 39 | \newcommand{\WAuprRatio}{0.90} 40 | \newcommand{\CAlwrRatio}{1.07} 41 | \newcommand{\CAmedRatio}{1.15} 42 | \newcommand{\CAuprRatio}{1.23} 43 | \newcommand{\NZlwrRatio}{0.11} 44 | \newcommand{\NZmedRatio}{0.22} 45 | \newcommand{\NZuprRatio}{0.34} 46 | \newcommand{\BClwrRatio}{0.19} 47 | \newcommand{\BCmedRatio}{0.40} 48 | \newcommand{\BCuprRatio}{0.60} 49 | -------------------------------------------------------------------------------- /analysis/14-sensitivity2.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | pars <- c( 4 | N = 5.1e6, D = 5, k1 = 1 / 5, 5 | k2 = 1, q = 0.05, 6 | r = 0.1, ur = 0.02, f1 = 1.0, 7 | start_decline = 15, 8 | end_decline = 22 9 | ) 10 | 11 | pars[["r"]] <- 1 12 | pars[["ur"]] <- 0.2 13 | pars 14 | 15 | m1 <- fit_seeiqr( 16 | daily_diffs, 17 | chains = 6, iter = 300, 18 | pars = pars, save_state_predictions = TRUE, 19 | seeiqr_model = seeiqr_model 20 | ) 21 | print(m1$fit, pars = c("R0", "f2", "phi")) 22 | 23 | .m1 <- list("r = 1; ur = 0.2" = m1) 24 | g_proj <- make_projection_plot(.m1) + 25 | facet_grid(rows = vars(Scenario)) 26 | 27 | R0 <- purrr::map_df(.m1, function(.x) { 28 | data.frame(theta = "R0b", value = .x$post$R0, stringsAsFactors = FALSE) 29 | }, .id = "Scenario") 30 | f2 <- purrr::map_df(.m1, function(.x) { 31 | data.frame(theta = "Fraction of normal contacts", 32 | value = .x$post$f2, stringsAsFactors = FALSE) 33 | }, .id = "Scenario") 34 | theta_df <- bind_rows(R0, f2) %>% as_tibble() 35 | my_limits <- function(x) if (max(x) < 2) c(0, 1) else c(2.6, 3.5) 36 | g_theta <- ggplot(theta_df, aes(value)) + 37 | facet_grid(Scenario ~ theta, scales = "free") + 38 | geom_histogram(bins = 50, fill = .hist_blue, alpha = .7, 39 | colour = "grey90", lwd = 0.15) + 40 | coord_cartesian(expand = FALSE, ylim = c(0, NA)) + 41 | ylab("") + 42 | scale_x_continuous(limits = my_limits) + 43 | xlab("Parameter value") + 44 | ylab("Density") 45 | 46 | .start <- lubridate::ymd_hms("2020-03-01 00:00:00") 47 | prevalence <- get_prevalence(m1) 48 | g_prev <- ggplot(prevalence, aes(day, prevalence, group = iterations)) + 49 | annotate("rect", 50 | xmin = .start + lubridate::ddays(m1$last_day_obs), 51 | xmax = .start + lubridate::ddays(m1$last_day_obs + 60), ymin = 0, ymax = Inf, fill = "grey95" 52 | ) + 53 | geom_line(alpha = 0.05, col = .hist_blue) + 54 | ylab("Modelled prevalence") + 55 | coord_cartesian(expand = FALSE, xlim = c(.start, .start + lubridate::ddays(m1$last_day_obs + 60)), ylim = c(0, max(prevalence$prevalence) * 1.04)) + 56 | xlab("") 57 | g_prev 58 | 59 | cowplot::plot_grid(g_prev, g_proj, g_theta, 60 | align = "hv", 61 | axis = "bt", rel_widths = c(1.2, 1.2, 2), ncol = 3 62 | ) 63 | 64 | ggsave(paste0("figs-ms/sens2-theta-proj.png"), width = 10, height = 3) 65 | -------------------------------------------------------------------------------- /analysis/07-threshold.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # Identify the point at which prevalence slope goes to 0: --------------------- 4 | 5 | fs <- seq(0.2, 1, 0.2) 6 | plan(multisession, workers = parallel::detectCores()/2) 7 | m_fs <- furrr::future_map(fs, function(.f) { 8 | fit_seeiqr( 9 | daily_diffs, iter = 400, chains = 1, save_state_predictions = TRUE, 10 | seeiqr_model = seeiqr_model, fixed_f_forecast = .f) 11 | }) 12 | plan(future::sequential) 13 | 14 | slopes <- purrr::map2_df(m_fs, fs, get_prevalence_slope) 15 | ggplot(slopes, aes(f, slope)) + 16 | geom_point(alpha = 0.1) 17 | 18 | mlm <- lm(slope ~ f, data = slopes) 19 | nd <- data.frame(f = seq(0, 1, length.out = 5000)) 20 | nd$predicted_slope <- predict(mlm, newdata = nd) 21 | thresh <- dplyr::filter(nd, predicted_slope > 0) %>% `[`(1, 'f') 22 | thresh 23 | ggplot(slopes, aes(f, slope)) + 24 | geom_point(alpha = 0.04) + 25 | geom_line(data = nd, aes(f, predicted_slope), alpha = 0.3) + 26 | geom_vline(xintercept = thresh, lty = 2, alpha = 0.6) + 27 | geom_hline(yintercept = 0, lty = 2, alpha = 0.6) + 28 | ylab("Slope of log(prevalence) vs. day") + 29 | xlab("Fraction of normal contacts") 30 | ggsave("figs-ms/f-threshold.png", width = 3.7, height = 3.5) 31 | 32 | # write_tex(round(1 - thresh, 2) * 100, "thresholdPerc") 33 | # write_tex(round(1 - thresh, 2), "thresholdFrac") 34 | write_tex(round(thresh, 2), "thresholdFtwo") 35 | saveRDS(thresh, file = here::here("data-generated/BC-threshold.rds")) 36 | 37 | # Joint posterior plot with prevalence colouring: ----------------------------- 38 | 39 | m_yhat <- fit_seeiqr( 40 | daily_diffs, iter = 200, chains = 6, save_state_predictions = TRUE, 41 | seeiqr_model = seeiqr_model) 42 | 43 | joint_post <- tibble(R0 = m_yhat$post$R0, f2 = m_yhat$post$f2, iterations = seq_along(f2)) 44 | prev_slopes <- get_prevalence_slope(m_yhat, "estimated") %>% 45 | mutate(perc_change = 100 * (exp(slope) - 1)) 46 | joint_post2 <- left_join(joint_post, prev_slopes) 47 | g <- ggplot(joint_post2, aes(R0, f2, colour = -perc_change)) + 48 | geom_point(alpha = 0.1, size = 2) + 49 | geom_point(alpha = 0.2, size = 2, pch = 21) + 50 | scale_colour_viridis_c(option = "D", direction = -1) + 51 | labs(colour = "Percent decline\nper day", y = "Fraction of normal contacts", 52 | x = expression(italic(R[0 * plain(b)]))) + 53 | # theme(legend.position = c(0.81, 0.78)) + 54 | theme(legend.key.size = unit(11, units = "points")) 55 | ggsave("figs-ms/joint-posterior-prevalence.png", width = 4.7, height = 3.5) 56 | ggsave("figs-ms/joint-posterior-prevalence.pdf", width = 4.7, height = 3.5) 57 | -------------------------------------------------------------------------------- /analysis/17-washington.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(dplyr) 3 | # library(future) 4 | library(covidseir) 5 | # plan(multisession) 6 | options(mc.cores = parallel::detectCores() / 2) 7 | ymd <- lubridate::ymd 8 | 9 | # d <- readr::read_csv("https://covidtracking.com/api/v1/states/daily.csv") 10 | # readr::write_csv(d, here::here("data-generated/us-data.csv")) 11 | d <- readr::read_csv(here::here("data-generated/us-data.csv")) 12 | d$date <- lubridate::ymd(d$date) 13 | 14 | wa <- filter(d, state %in% "WA") %>% 15 | select(date, positiveIncrease, totalTestResultsIncrease, hospitalizedIncrease) %>% 16 | filter(date >= ymd("2020-03-01")) %>% 17 | rename(value = positiveIncrease, tests = totalTestResultsIncrease, hospitalized = hospitalizedIncrease) %>% 18 | arrange(date) %>% 19 | mutate(day = seq_len(n())) 20 | 21 | wa 22 | # View(wa) 23 | 24 | plot(wa$day, wa$value, type = "o") 25 | plot(wa$day, wa$tests, type = "o") 26 | plot(wa$date, wa$value, type = "l") 27 | # lines(wa$date, wa$hospitalized, col = "red") 28 | lines(wa$date, wa$tests/10, col = "blue") 29 | 30 | (.s <- as.numeric(ymd("2020-03-11") - min(wa$date))) 31 | (.e <- as.numeric(ymd("2020-03-23") - min(wa$date))) 32 | 33 | g <- readr::read_csv("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 34 | g1 <- filter(g, country_region == "United States") 35 | g1 <- filter(g, sub_region_1 == "Washington") 36 | ggplot(g1, aes(date, transit_stations_percent_change_from_baseline)) + 37 | geom_point() + 38 | geom_vline(xintercept = ymd("2020-03-11")) + 39 | geom_vline(xintercept = ymd("2020-03-23")) 40 | 41 | # Tests Jump on day 9 from <100 to >2000 42 | # and to > 10,000 by the 16th 43 | 44 | (samp_frac_fixed <- rep(0.25, nrow(wa))) 45 | # (f_seg <- c(rep(0, 11), rep(1, nrow(new_york) - 11))) 46 | 47 | wa$value 48 | stopifnot(unique(wa$value[57:58]) == 0) 49 | wa$value[57:58] <- NA 50 | wa$value 51 | fit <- covidseir::fit_seir( 52 | daily_cases = wa$value, 53 | samp_frac_fixed = samp_frac_fixed, 54 | time_increment = 0.1, 55 | R0_prior = c(log(2.6), 0.2), 56 | iter = 500, 57 | chains = 8, 58 | start_decline_prior = c(log(.s), 0.1), 59 | end_decline_prior = c(log(.e), 0.1), 60 | i0 = 1, 61 | pars = c(N = 7.6e6, D = 5, k1 = 1/5, k2 = 1, 62 | q = 0.05, r = 0.1, ur = 0.02, f0 = 1 63 | )) 64 | fit 65 | p <- covidseir::project_seir(fit, iter = 1:100) 66 | covidseir::tidy_seir(p) %>% 67 | covidseir::plot_projection(wa) + 68 | scale_y_log10() 69 | 70 | saveRDS(fit, file = here::here("data-generated/washington-fit.rds")) 71 | saveRDS(wa, file = here::here("data-generated/washington-dat.rds")) 72 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: 3 | md_document: 4 | variant: markdown_github 5 | --- 6 | 7 | 8 | 9 | ### Quantifying the impact of COVID-19 control measures using a Bayesian model of physical distancing 10 | 11 | This repository contains code associated with a manuscript investigating the impact of COVID-19 control measures in British Columbia, Canada. 12 | 13 | The main statistical model written in [Stan](https://mc-stan.org/) is available [here](analysis/seeiqr.stan) and the main R function that calls this model for a vector of daily case counts is available [here](analysis/fit_seeiqr.R). A function to make projection plots is available [here](analysis/make_projection_plot.R). This model may be released at a later date in a proper R package form. 14 | 15 | A more fully featured and documented version of this model, which can accommodate multiple types of case data at once (e.g., reported cases, hospitalizations, ICU admissions) and estimate segments of positive-case sampling fractions for reported cases, is also available as an R package [covidseir](https://github.com/seananderson/covidseir). 16 | 17 | Generally, any part of the analysis can be re-created by running one of the numbered R files starting with `01-...R` in the [`analysis`](analysis) folder. Alternatively, the file [`00-run-all.R`](analysis/00-run-all.R) can be sourced to run the entire analysis. 18 | 19 | You will need the following packages installed: 20 | 21 | ```{r, eval=FALSE} 22 | install.packages(c("tidyverse", "remotes", "rstan", "here", 23 | "future", "deSolve", "furrr", "cowplot", "reshape2")) 24 | remotes::install_github("seananderson/ggsidekick") 25 | ``` 26 | 27 | See the C++ compiler [installation instructions for covidseir](https://github.com/seananderson/covidseir) first, then: 28 | 29 | ```{r, eval=FALSE} 30 | remotes::install_github("seananderson/covidseir", ref = "preprint") 31 | ``` 32 | 33 | An example of how to run the model: 34 | 35 | ```{r options, echo = FALSE} 36 | knitr::opts_chunk$set( 37 | collapse = TRUE, 38 | comment = "#>", 39 | fig.path = "README-figs/", 40 | cache.path = "README-cache/" 41 | ) 42 | ``` 43 | 44 | ```{r load-data, message=FALSE, warning=FALSE} 45 | library("rstan") 46 | library("dplyr") 47 | library("ggplot2") 48 | rstan_options(auto_write = TRUE) # cache the compiled model 49 | options(mc.cores = parallel::detectCores() / 2) # Stan parallel processing 50 | seeiqr_model <- rstan::stan_model("analysis/seeiqr.stan") 51 | 52 | source("analysis/fit_seeiqr.R") 53 | source("analysis/make_projection_plot.R") 54 | 55 | d <- readr::read_csv("data-generated/daily-cases.csv") 56 | d 57 | ``` 58 | 59 | ```{r fit-model, results='hide', message=FALSE, warning=FALSE} 60 | # Using fewer iterations for a quick example: 61 | fit <- fit_seeiqr(d$cases, seeiqr_model = seeiqr_model, 62 | iter = 300, chains = 4) 63 | ``` 64 | 65 | ```{r summary} 66 | print(fit$fit, pars = c("R0", "f2", "phi")) 67 | ``` 68 | 69 | ```{r proj-plot} 70 | make_projection_plot(list(fit)) + theme_light() 71 | ``` 72 | -------------------------------------------------------------------------------- /analysis/09-delay.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # ----------------------------------------------------------------------------- 4 | # What is the delay between the peak prevalence (I+Id) and the peak in case 5 | # counts? 6 | 7 | m_peak <- readRDS("data-generated/main-fit-500.rds") 8 | 9 | obj <- m_peak 10 | post <- obj$post 11 | variables_df <- dplyr::tibble( 12 | variable = names(obj$state_0), 13 | variable_num = seq_along(obj$state_0) 14 | ) 15 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 16 | states <- reshape2::melt(post$y_hat) %>% 17 | dplyr::rename(time_num = Var2, variable_num = Var3) %>% 18 | dplyr::left_join(variables_df, by = "variable_num") %>% 19 | dplyr::left_join(ts_df, by = "time_num") %>% 20 | as_tibble() %>% 21 | mutate(day = floor(time)) %>% 22 | dplyr::filter(variable %in% c("I", "Id")) %>% 23 | group_by(iterations, time) %>% 24 | summarize( 25 | I = value[variable == "I"], Id = value[variable == "Id"], 26 | prevalence = I + Id 27 | ) %>% 28 | group_by(iterations) %>% 29 | dplyr::summarise(prevalence_peak = time[prevalence == max(prevalence)]) 30 | 31 | lambdas <- obj$post$lambda_d %>% 32 | reshape2::melt() %>% 33 | dplyr::rename(day = Var2) %>% 34 | as_tibble() %>% 35 | rename(case_count = value) %>% 36 | group_by(iterations) %>% 37 | dplyr::summarise(case_peak = day[case_count == max(case_count)]) 38 | 39 | both <- left_join(states, lambdas) %>% 40 | filter(case_peak != prevalence_peak) # one weird draw? 41 | ggplot(tibble(delay = both$case_peak - both$prevalence_peak), aes(delay)) + 42 | geom_histogram(bins = 20) 43 | ggsave("figs/delay-peak-prevalence.png", width = 5, height = 3.5) 44 | 45 | states_timing <- states %>% mutate( 46 | start_decline = obj$stan_data$x_r[["start_decline"]], 47 | end_decline = obj$stan_data$x_r[["end_decline"]] 48 | ) 49 | ggplot(states_timing, aes(prevalence_peak - start_decline)) + 50 | geom_histogram() 51 | ggplot(states_timing, aes(prevalence_peak - end_decline)) + 52 | geom_histogram() 53 | 54 | v <- round(quantile(states_timing$prevalence_peak - states_timing$start_decline, probs = c(0.05, 0.5, 0.95)), 0) 55 | 56 | write_tex(v[[1]], "prevDelayFifteenthLwr") 57 | write_tex(v[[2]], "prevDelayFifteenthMed") 58 | write_tex(v[[3]], "prevDelayFifteenthUpr") 59 | 60 | v <- round(quantile(states_timing$prevalence_peak - 12, probs = c(0.05, 0.5, 0.95)), 0) 61 | 62 | write_tex(v[[1]], "prevDelayTwelfthLwr") 63 | write_tex(v[[2]], "prevDelayTwelfthMed") 64 | write_tex(v[[3]], "prevDelayTwelfthUpr") 65 | 66 | # round(mean(both$case_peak - both$prevalence_peak), 1) 67 | v <- round(quantile(both$case_peak - both$prevalence_peak, probs = c(0.05, 0.5, 0.95)), 1) 68 | 69 | write_tex(v[[1]], "delayLwr") 70 | write_tex(v[[2]], "delayMed") 71 | write_tex(v[[3]], "delayUpr") 72 | 73 | hist(both$prevalence_peak) 74 | p <- sprintf("%.1f", round(quantile(both$prevalence_peak, probs = c(0.05, 0.5, 0.95)), 1)) 75 | write_tex(p[[1]], "prevalencePeakLwr") 76 | write_tex(p[[2]], "prevalencePeakMed") 77 | write_tex(p[[3]], "prevalencePeakUpr") 78 | -------------------------------------------------------------------------------- /analysis/17-california.R: -------------------------------------------------------------------------------- 1 | # timeline: 2 | # Jan 26: first case 3 | # Mar 12: ban mass gatherings 4 | # Mar 13: schools closed 5 | # Mar 15: Bars etc. closed 6 | # Mar 17-24 (?): county stay-at-home orders? Shelter-in-place? seems a bit all over the place 7 | # ca_dat <- filter(dat, state == "CA") 8 | # ca_dat$day <- seq_len(nrow(ca_dat)) 9 | # ca_fit <- fit_seir(ca_dat$positiveIncrease, chains = 4, iter = 250, 10 | # samp_frac_fixed = rep(0.23, nrow(ca_dat)), 11 | # i0=8, 12 | # pars = c( 13 | # N = 39.51e6, D = 5, k1 = 1 / 5, k2 = 1, q = 0.05, 14 | # r = 0.1, ur = 0.02, f0 = 1.0, start_decline = 12, end_decline =24 15 | # )) 16 | 17 | library(ggplot2) 18 | library(dplyr) 19 | library(covidseir) 20 | options(mc.cores = parallel::detectCores() / 2) 21 | ymd <- lubridate::ymd 22 | 23 | # d <- readr::read_csv("https://covidtracking.com/api/v1/states/daily.csv") 24 | # readr::write_csv(d, here::here("data-generated/us-data.csv")) 25 | d <- readr::read_csv(here::here("data-generated/us-data.csv")) 26 | d$date <- lubridate::ymd(d$date) 27 | 28 | ca <- filter(d, state %in% "CA") %>% 29 | select(date, positiveIncrease, totalTestResultsIncrease, hospitalizedIncrease) %>% 30 | filter(date >= ymd("2020-03-05")) %>% 31 | rename(value = positiveIncrease, tests = totalTestResultsIncrease, hospitalized = hospitalizedIncrease) %>% 32 | arrange(date) %>% 33 | mutate(day = seq_len(n())) 34 | 35 | ca 36 | # View(ca) 37 | 38 | plot(ca$day, ca$value, type = "o") 39 | plot(ca$day, ca$tests, type = "o") 40 | plot(ca$date, ca$value, type = "l") 41 | # lines(ca$date, ca$hospitalized, col = "red") 42 | lines(ca$date, ca$tests/10, col = "blue") 43 | 44 | (.s <- as.numeric(ymd("2020-03-12") - min(ca$date))) 45 | (.e <- as.numeric(ymd("2020-03-24") - min(ca$date))) 46 | 47 | # g <- readr::read_csv("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 48 | # g1 <- filter(g, country_region == "United States") 49 | # g1 <- filter(g, sub_region_1 == "California") 50 | # ggplot(g1, aes(date, transit_stations_percent_change_from_baseline)) + 51 | # geom_point() + 52 | # geom_vline(xintercept = ymd("2020-03-12")) + 53 | # geom_vline(xintercept = ymd("2020-03-24")) 54 | 55 | (samp_frac_fixed <- rep(0.25, nrow(ca))) 56 | # (f_seg <- c(rep(0, 11), rep(1, nrow(new_york) - 11))) 57 | 58 | ca$value 59 | stopifnot(unique(ca$value[38]) == 0) 60 | ca$value[38] <- NA 61 | stopifnot(unique(ca$value[9]) == 0) 62 | ca$value[9] <- NA 63 | ca$value 64 | fit <- covidseir::fit_seir( 65 | daily_cases = ca$value, 66 | samp_frac_fixed = samp_frac_fixed, 67 | time_increment = 0.1, 68 | R0_prior = c(log(2.6), 0.2), 69 | iter = 500, 70 | chains = 8, 71 | start_decline_prior = c(log(.s), 0.1), 72 | end_decline_prior = c(log(.e), 0.1), 73 | i0 = 1, 74 | pars = c(N = 39.51e6, D = 5, k1 = 1/5, k2 = 1, 75 | q = 0.05, r = 0.1, ur = 0.02, f0 = 1 76 | )) 77 | fit 78 | p <- covidseir::project_seir(fit, iter = 1:50) 79 | covidseir::tidy_seir(p) %>% 80 | covidseir::plot_projection(ca) + 81 | scale_y_log10() 82 | 83 | saveRDS(fit, file = here::here("data-generated/california-fit.rds")) 84 | saveRDS(ca, file = here::here("data-generated/california-dat.rds")) 85 | -------------------------------------------------------------------------------- /analysis/plot_projection_w_inset.R: -------------------------------------------------------------------------------- 1 | plot_projection_w_inset <- function(proj_dat, obs_dat, obj, ylim = NULL, 2 | col = "#377EB8") { 3 | 4 | date_lookup <- tibble( 5 | date = seq(min(obs_dat$date), max(obs_dat$date) + 0, by = "1 day"), 6 | day = seq_len(max(proj_dat$day))) 7 | p2 <- left_join(proj_dat, date_lookup) %>% 8 | select(-day) %>% 9 | rename(day = date) 10 | obs2 <- obs_dat %>% 11 | select(-day) %>% 12 | rename(day = date) 13 | 14 | # if (is.null(ylim)) ylim <- c(0, max(p2$y_rep_0.95)) 15 | half_line <- 11/2 16 | g <- covidseir::tidy_seir(p2, resample_y_rep = 50) %>% 17 | covidseir::plot_projection(obs2, col = col) + 18 | scale_y_continuous(labels = function(x) x/1) + 19 | facet_null() + 20 | ggsidekick::theme_sleek() + ylab("") + 21 | coord_cartesian(expand = FALSE, xlim = c(lubridate::ymd("2020-03-01"), max(p2$day)), ylim = ylim) + 22 | scale_x_date(date_breaks = "1 month", date_labels = "%b %d") + 23 | theme(axis.title.x.bottom = element_blank(), 24 | plot.margin = 25 | margin(t = 5, r = 1.5, b = -8, l = -3), 26 | axis.title.y = element_text(angle = 90, 27 | margin = margin(r = 2), vjust = 1, size = 10) 28 | ) #+ 29 | # ylab("Reported cases (1000s)") 30 | 31 | # g <- g + geom_vline(xintercept = ymd("2020-03-05") + obj$post$start_decline[1:200], alpha = 0.1) +geom_vline(xintercept = ymd("2020-03-05") + obj$post$end_decline[1:200], alpha = 0.1) 32 | # # g 33 | # 34 | 35 | # browser() 36 | # f2_hist 37 | 38 | # plot_with_inset <- 39 | # cowplot::ggdraw() + 40 | # cowplot::draw_plot(g) #+ 41 | # cowplot::draw_plot(f2_hist, x = inset_x, y = inset_y, width = width, height = height) 42 | 43 | # plot_with_inset 44 | g 45 | } 46 | 47 | f2_plot <- function(obj, threshold, col = "black") { 48 | .hist_blue <- RColorBrewer::brewer.pal(6, "Blues")[5] 49 | f2 <- obj$post$f_s[,1] 50 | .x <- seq(0, 1, length.out = 300) 51 | breaks <- seq(min(.x), max(.x), 0.020) 52 | f2_hist <- ggplot(tibble(f2 = f2)) + 53 | # geom_ribbon( 54 | # data = tibble( 55 | # f2 = 1 - .x, 56 | # density = dbeta(.x, obj$f2_prior_beta_shape1, obj$f2_prior_beta_shape2) 57 | # ), 58 | # aes(x = f2, ymin = 0, ymax = density), alpha = 0.3, colour = "grey50", 59 | # fill = "grey50", size = 0.4 60 | # ) + 61 | geom_histogram( 62 | breaks = breaks, aes(x = f2, y = ..density..), 63 | fill = col, alpha = 1, colour = "grey90", lwd = 0.1 64 | ) + 65 | ylab("Density") + 66 | coord_cartesian(xlim = c(0, .53), expand = FALSE) + 67 | xlab("") + 68 | # xlab("1 - f2") + 69 | scale_x_continuous(breaks = seq(0, .5, 0.1), labels = c("0", "", "0.2", "", "0.4", "")) + 70 | geom_vline(xintercept = threshold, lty = 1, col = "grey50") + 71 | ggsidekick::theme_sleek() + 72 | theme(axis.line.y = element_blank(), panel.border = element_blank(), 73 | axis.text.y = element_blank(), axis.line.x = element_line(colour = "grey75"), 74 | axis.ticks.y = element_blank(), axis.title.y = element_blank(), 75 | axis.title.x.bottom = element_text(size = 9), 76 | axis.text.x = element_text(size = 8), 77 | panel.background = element_rect(fill = "transparent", colour = NA), 78 | plot.background = element_rect(fill = "transparent", colour = NA)) 79 | f2_hist 80 | } 81 | -------------------------------------------------------------------------------- /analysis/18-fl.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(dplyr) 3 | # library(future) 4 | library(covidseir) 5 | # plan(multisession) 6 | options(mc.cores = parallel::detectCores() / 2) 7 | ymd <- lubridate::ymd 8 | 9 | # d <- readr::read_csv("https://covidtracking.com/api/v1/states/daily.csv") 10 | # readr::write_csv(d, here::here("data-generated/us-data.csv")) 11 | d <- readr::read_csv(here::here("data-generated/us-data.csv")) 12 | d$date <- lubridate::ymd(d$date) 13 | 14 | florida <- filter(d, state %in% "FL") %>% 15 | select(date, positiveIncrease, totalTestResultsIncrease, hospitalizedIncrease) %>% 16 | filter(date >= ymd("2020-03-05")) %>% 17 | rename(value = positiveIncrease, tests = totalTestResultsIncrease, hospitalized = hospitalizedIncrease) %>% 18 | arrange(date) %>% 19 | mutate(day = seq_len(n())) 20 | 21 | florida 22 | # View(florida) 23 | 24 | plot(florida$day, florida$value, type = "o") 25 | plot(florida$day, florida$tests, type = "o") 26 | plot(florida$date, florida$value, type = "l") 27 | lines(florida$date, florida$hospitalized, col = "red") 28 | lines(florida$date, florida$tests/10, col = "blue") 29 | 30 | # g <- readr::read_csv("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 31 | # g1 <- filter(g, country_region == "United States") 32 | # g1 <- filter(g, sub_region_1 == "Florida") 33 | # ggplot(g1, aes(date, transit_stations_percent_change_from_baseline)) + 34 | # geom_point() + 35 | # geom_vline(xintercept = ymd("2020-03-16")) + 36 | # geom_vline(xintercept = ymd("2020-03-28")) 37 | 38 | 39 | get_days_since <- function(until, since) { 40 | abs(as.numeric(difftime(until, since, units = "days"))) 41 | } 42 | (start_decline <- get_days_since(ymd("2020-03-16"), min(florida$date))) 43 | (end_decline <- get_days_since(ymd("2020-03-28"), min(florida$date))) 44 | # (f_seg <- c(rep(0, start_decline), rep(1, nrow(florida) - start_decline))) 45 | 46 | (samp_frac_fixed <- rep(0.25, nrow(florida))) 47 | 48 | florida$value 49 | 50 | fit <- covidseir::fit_seir( 51 | daily_cases = florida$value, 52 | samp_frac_fixed = samp_frac_fixed, 53 | time_increment = 0.1, 54 | R0_prior = c(log(2.6), 0.2), 55 | iter = 500, 56 | chains = 8, 57 | start_decline_prior = c(log(start_decline), 0.1), 58 | end_decline_prior = c(log(end_decline), 0.1), 59 | i0 = 1, 60 | pars = c(N = 21.48e6, D = 5, k1 = 1/5, k2 = 1, 61 | q = 0.05, r = 0.1, ur = 0.02, f0 = 1)) 62 | fit 63 | p <- covidseir::project_seir(fit, iter = 1:100) 64 | covidseir::tidy_seir(p) %>% 65 | covidseir::plot_projection(florida)# + 66 | # scale_y_log10() 67 | 68 | saveRDS(fit, file = here::here("data-generated/florida-fit.rds")) 69 | saveRDS(florida, file = here::here("data-generated/florida-dat.rds")) 70 | 71 | # model <- rstan::stan_model("analysis/seeiqr.stan") 72 | # source("analysis/fit_seeiqr.R") 73 | # source("analysis/make_projection_plot.R") 74 | # 75 | # fl_fit <- fit_seeiqr(florida$value, 76 | # seeiqr_model = model, 77 | # forecast_days = 30, 78 | # R0_prior = c(log(3), 0.2), 79 | # chains = 8, 80 | # iter = 500, 81 | # i0 = 1, 82 | # sampled_fraction1 = 0.25, 83 | # sampled_fraction2 = 0.25, 84 | # pars = c(N = 21.48e6, D = 5, k1 = 1/5, k2 = 1, 85 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 86 | # start_decline = 12, end_decline = 27)) 87 | # print(fl_fit$fit, pars = c("R0", "f2", "phi")) 88 | # 89 | # make_projection_plot(list(fl_fit), first_date = as.character(min(florida$date))) 90 | -------------------------------------------------------------------------------- /21-combined-proj-plot.R: -------------------------------------------------------------------------------- 1 | # Start with sourcing `06-cycle-f2.R` and `08-f-projections.R` 2 | # if not run already to create the data objects read in here. 3 | 4 | source(here::here("analysis/data-model-prep.R")) 5 | 6 | # Cycling: ------------------------------------------------------------ 7 | 8 | m <- readRDS("data-generated/main-fit-2000.rds") 9 | 10 | .last_day <- m$last_day_obs 11 | .last_day 12 | 13 | pred_4x4 <- readRDS("data-generated/pred_4x4.rds") 14 | 15 | # re-sample obs. model for smoother plots: 16 | pred_4x4 <- purrr::map_dfr(1:10, function(i) { 17 | pred_4x4$y_rep <- MASS::rnegbin(length(pred_4x4$y_rep), 18 | pred_4x4$lambda_d, 19 | theta = pred_4x4$phi 20 | ) 21 | pred_4x4 22 | }) 23 | 24 | pred_3x3 <- readRDS("data-generated/pred_3x3.rds") 25 | 26 | # re-sample obs. model for smoother plots: 27 | pred_3x3 <- purrr::map_dfr(1:10, function(i) { 28 | pred_3x3$y_rep <- MASS::rnegbin(length(pred_3x3$y_rep), 29 | pred_3x3$lambda_d, 30 | theta = pred_3x3$phi 31 | ) 32 | pred_3x3 33 | }) 34 | 35 | x <- prep_dat(pred_4x4) 36 | .max <- max(x$y_rep$upr) * 1.04 37 | cycling4 <- make_projection_plot( 38 | models = list(m), mu_dat = x$mu, 39 | y_rep_dat = x$y_rep, ylim = c(0, .max), points_size = 1.25 40 | ) + 41 | theme(plot.margin = margin(11 / 2, 11, 11 / 2, 11 / 2)) 42 | for (i in seq(1, 4, 2)) { 43 | .inc <- 7 * 4 44 | g_last_day <- dat$Date[1] + .last_day 45 | cycling4 <- cycling4 + annotate("rect", 46 | xmin = g_last_day + (i - 1) * .inc - 1, 47 | xmax = g_last_day + i * .inc - 1, 48 | ymin = 0, ymax = Inf, fill = "#00000012" 49 | ) 50 | } 51 | 52 | x <- prep_dat(pred_3x3) 53 | cycling3 <- make_projection_plot( 54 | models = list(m), mu_dat = x$mu, 55 | y_rep_dat = x$y_rep, ylim = c(0, .max), points_size = 1.25 56 | ) + 57 | theme(plot.margin = margin(11 / 2, 11, 11 / 2, 11 / 2)) 58 | for (i in seq(1, 6, 2)) { 59 | .inc <- 7 * 3 60 | g_last_day <- dat$Date[1] + .last_day 61 | cycling3 <- cycling3 + annotate("rect", 62 | xmin = g_last_day + (i - 1) * .inc - 1, 63 | xmax = g_last_day + i * .inc - 1, 64 | ymin = 0, ymax = Inf, fill = "#00000012" 65 | ) 66 | } 67 | 68 | # Fixed f2 projections: ----------------------------------------------- 69 | 70 | m_fs <- readRDS("data-generated/f-proj-fits.rds") 71 | 72 | proj0.6 <- make_projection_plot(m_fs[1], facet = TRUE, ylim = c(0, 140)) 73 | 74 | proj0.8 <- make_projection_plot(m_fs[2], facet = TRUE, ylim = c(0, 140)) 75 | 76 | # proj1.0 <- make_projection_plot(m_fs[3], facet = TRUE, ylim = c(0, 130)) 77 | 78 | .coord <- coord_cartesian( 79 | expand = FALSE, ylim = c(0, 140), 80 | xlim = c(lubridate::ymd("2020-03-01"), lubridate::ymd("2020-07-06")) 81 | ) 82 | .coord <- list( 83 | .coord, 84 | theme(plot.margin = margin(t = 0, r = 0, b = -5, l = -10), 85 | axis.title.y.left = element_blank()) 86 | ) 87 | 88 | g <- cowplot::plot_grid( 89 | proj0.6+ .coord + theme(axis.text.x.bottom = element_blank()), 90 | proj0.8+ .coord+ theme(axis.text.x.bottom = element_blank(), axis.text.y = element_blank()), 91 | cycling3 + .coord, 92 | cycling4 + .coord + theme(axis.text.y = element_blank()), 93 | nrow = 2, labels = "AUTO", label_x = 0.06, label_y = 0.995, align = "hv" 94 | ) + theme(plot.margin = margin(t = 5, r = 5, b = 12, l = 26)) + 95 | cowplot::draw_text("Reported cases", x = -0.05, y = 0.5, angle = 90, size = 12, col = "grey35") 96 | 97 | ggsave(here::here("figs-ms/combined-proj-plot.png"), width = 5.7, height = 3.6, dpi = 400) 98 | ggsave(here::here("figs-ms/combined-proj-plot.pdf"), width = 5.7, height = 3.6) 99 | 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### Quantifying the impact of COVID-19 control measures using a Bayesian model of physical distancing 4 | 5 | This repository contains code associated with a manuscript investigating 6 | the impact of COVID-19 control measures in British Columbia, Canada. Here is the preprint: https://www.medrxiv.org/content/10.1101/2020.04.17.20070086v1. 7 | 8 | The main statistical model written in [Stan](https://mc-stan.org/) is 9 | available [here](analysis/seeiqr.stan) and the main R function that 10 | calls this model for a vector of daily case counts is available 11 | [here](analysis/fit_seeiqr.R). A function to make projection plots is 12 | available [here](analysis/make_projection_plot.R). 13 | 14 | A more fully featured and documented version of this model, which can accommodate multiple types of case data at once (e.g., reported cases, hospitalizations, ICU admissions) and estimate segments of positive-case sampling fractions for reported cases, is also available as an R package [covidseir](https://github.com/seananderson/covidseir). 15 | 16 | Generally, any part of the analysis can be re-created by running one of 17 | the numbered R files starting with `01-...R` in the 18 | [`analysis`](analysis) folder. Alternatively, the file 19 | [`00-run-all.R`](analysis/00-run-all.R) can be sourced to run the entire 20 | analysis. 21 | 22 | You will need the following packages installed: 23 | 24 | ``` r 25 | install.packages(c("tidyverse", "remotes", "rstan", "here", 26 | "future", "deSolve", "furrr", "cowplot", "reshape2")) 27 | remotes::install_github("seananderson/ggsidekick") 28 | ``` 29 | 30 | See the C++ compiler [installation instructions for covidseir](https://github.com/seananderson/covidseir) first, then: 31 | 32 | ```{r, eval=FALSE} 33 | remotes::install_github("seananderson/covidseir", ref = "preprint") 34 | ``` 35 | 36 | An example of how to run the model: 37 | 38 | ``` r 39 | library("rstan") 40 | library("dplyr") 41 | library("ggplot2") 42 | rstan_options(auto_write = TRUE) # cache the compiled model 43 | options(mc.cores = parallel::detectCores() / 2) # Stan parallel processing 44 | seeiqr_model <- rstan::stan_model("analysis/seeiqr.stan") 45 | source("analysis/fit_seeiqr.R") 46 | source("analysis/make_projection_plot.R") 47 | 48 | d <- readr::read_csv("data-generated/daily-cases.csv") 49 | d 50 | #> # A tibble: 42 x 2 51 | #> date cases 52 | #> 53 | #> 1 2020-03-01 0 54 | #> 2 2020-03-02 0 55 | #> 3 2020-03-03 1 56 | #> 4 2020-03-04 3 57 | #> 5 2020-03-05 1 58 | #> 6 2020-03-06 8 59 | #> 7 2020-03-07 0 60 | #> 8 2020-03-08 6 61 | #> 9 2020-03-09 5 62 | #> 10 2020-03-10 0 63 | #> # … with 32 more rows 64 | ``` 65 | 66 | ``` r 67 | # Using fewer iterations for a quick example: 68 | fit <- fit_seeiqr(d$cases, seeiqr_model = seeiqr_model, 69 | iter = 300, chains = 4) 70 | ``` 71 | 72 | ``` r 73 | print(fit$fit, pars = c("R0", "f2", "phi")) 74 | #> Inference for Stan model: seeiqr. 75 | #> 4 chains, each with iter=300; warmup=150; thin=1; 76 | #> post-warmup draws per chain=150, total post-warmup draws=600. 77 | #> 78 | #> mean se_mean sd 2.5% 25% 50% 75% 97.5% n_eff Rhat 79 | #> R0 2.95 0.00 0.04 2.88 2.93 2.95 2.97 3.02 373 1 80 | #> f2 0.22 0.00 0.07 0.07 0.17 0.22 0.27 0.35 284 1 81 | #> phi[1] 6.87 0.12 2.38 3.11 5.19 6.41 8.34 12.53 389 1 82 | #> 83 | #> Samples were drawn using NUTS(diag_e) at Thu Apr 16 20:20:05 2020. 84 | #> For each parameter, n_eff is a crude measure of effective sample size, 85 | #> and Rhat is the potential scale reduction factor on split chains (at 86 | #> convergence, Rhat=1). 87 | ``` 88 | 89 | ``` r 90 | make_projection_plot(list(fit)) + theme_light() 91 | ``` 92 | 93 | ![](README-figs/proj-plot-1.png) 94 | -------------------------------------------------------------------------------- /analysis/08-f-projections.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | sd_strength <- seq(0, 1, 0.2)[4:6] %>% purrr::set_names() 4 | m_fs <- purrr::map(sd_strength, ~ { 5 | fit_seeiqr( 6 | daily_diffs, forecast_days = 90, 7 | fixed_f_forecast = .x, 8 | seeiqr_model = seeiqr_model, chains = 8, iter = 900 9 | ) 10 | }) 11 | saveRDS(m_fs, "data-generated/f-proj-fits.rds") 12 | 13 | # If coming back: 14 | m_fs <- readRDS("data-generated/f-proj-fits.rds") 15 | purrr::walk(m_fs, ~ print(.x$fit, pars = c("R0", "f2", "phi"))) 16 | 17 | # Fewer iterations because just plotting 250 draws: 18 | sd_strength2 <- seq(0.6, 1, 0.2) %>% purrr::set_names() 19 | # future::plan(future::multisession) 20 | # m_fs2 <- furrr::future_map(sd_strength2, ~ { 21 | m_fs2 <- purrr::map(sd_strength2, ~ { 22 | fit_seeiqr( 23 | daily_diffs, 24 | seed = 1, forecast_days = 90, 25 | fixed_f_forecast = .x, save_state_predictions = TRUE, 26 | seeiqr_model = seeiqr_model, chains = 2, iter = 350 27 | ) 28 | }) 29 | # future::plan(future::sequential) 30 | saveRDS(m_fs2, "data-generated/f-proj-fits2.rds") 31 | m_fs2 <- readRDS("data-generated/f-proj-fits2.rds") 32 | purrr::walk(m_fs2, ~ print(.x$fit, pars = c("R0", "f2", "phi"))) 33 | 34 | set.seed(13223567) 35 | .draws <- sample(seq_len(350), 75) 36 | prevalence <- purrr::map_dfr(m_fs2, get_prevalence, .id = "scenario", draws = .draws) 37 | 38 | # Plots ----------------------------------------------------------------------- 39 | 40 | # Case count predictions: 41 | 42 | .theme <- theme(title = element_text(size = rel(0.9))) + 43 | theme(strip.text.x = element_text(angle = 0, hjust = 0)) + 44 | theme(axis.title.x = element_blank()) 45 | .coord <- coord_cartesian( 46 | expand = FALSE, ylim = c(0, 150), 47 | xlim = c(lubridate::ymd("2020-03-01"), lubridate::ymd("2020-07-10")) 48 | ) 49 | 50 | .m_fs <- m_fs 51 | 52 | names(.m_fs) <- paste0("Contacts removed: ", sprintf("%.0f", (1 - sd_strength) * 100), "%") 53 | names(.m_fs) 54 | 55 | names(.m_fs) <- paste0("(", LETTERS[1:3], ") ", names(.m_fs)) 56 | names(.m_fs) 57 | sc_order <- names(.m_fs) 58 | g1 <- make_projection_plot(.m_fs, facet = TRUE, ncol = 3, sc_order = sc_order) + 59 | .theme + .coord 60 | 61 | # Prevalence predictions: 62 | 63 | prevalence$scenario2 <- paste0("Contacts removed: ", sprintf("%.0f", (1 - as.numeric(prevalence$scenario)) * 100), "%") 64 | unique(prevalence$scenario2) 65 | 66 | prevalence$scenario2_noletters <- prevalence$scenario2 67 | prevalence$scenario2_noletters <- factor(prevalence$scenario2_noletters, 68 | levels = c("Contacts removed: 40%", "Contacts removed: 20%", "Contacts removed: 0%") 69 | ) 70 | 71 | prevalence$scenario2 <- gsub("Contacts removed: 40%", 72 | "(D) Contacts removed: 40%", prevalence$scenario2) 73 | prevalence$scenario2 <- gsub("Contacts removed: 20%", 74 | "(E) Contacts removed: 20%", prevalence$scenario2) 75 | prevalence$scenario2 <- gsub("Contacts removed: 0%", 76 | "(F) Contacts removed: 0%", prevalence$scenario2) 77 | 78 | unique(prevalence$scenario2) 79 | 80 | .coord_prev <- coord_cartesian( 81 | expand = FALSE, ylim = c(0, 30000), 82 | xlim = c(lubridate::ymd_hms("2020-03-01 00:00:00"), lubridate::ymd_hms("2020-07-10 23:59:00")) 83 | ) 84 | 85 | obj <- m_fs2[[1]] # just for last_day_obs 86 | .start <- prevalence$start[1] 87 | g_prev <- prevalence %>% 88 | ggplot(aes(day, prevalence, group = iterations)) + 89 | annotate("rect", 90 | xmin = .start + lubridate::ddays(obj$last_day_obs), 91 | xmax = .start + lubridate::ddays(obj$last_day_obs + 90), 92 | ymin = 0, ymax = Inf, fill = "grey95" 93 | ) + 94 | geom_line(alpha = 0.11, col = .hist_blue) + 95 | ylab("Modelled prevalence") + 96 | facet_wrap(~scenario2) + 97 | scale_y_continuous(labels = scales::comma) + 98 | .theme + 99 | .coord_prev 100 | 101 | gg <- cowplot::plot_grid(g1, g_prev, nrow = 2, align = "hv", rel_heights = c(1, 3)) 102 | ggsave("figs-ms/f-projections2.png", width = 7, height = 7.25, dpi = 400) 103 | ggsave("figs-ms/f-projections2.pdf", width = 7, height = 7.25, plot = gg) 104 | 105 | .max <- filter(prevalence, scenario2_noletters == "Contacts removed: 0%") %>% 106 | pull(prevalence) %>% 107 | quantile(probs = 0.99) 108 | g <- g_prev + coord_cartesian( 109 | expand = FALSE, ylim = c(0, .max), 110 | xlim = c( 111 | lubridate::ymd_hms("2020-03-01 00:00:00"), 112 | lubridate::ymd_hms("2020-07-11 23:59:00") 113 | ) 114 | ) + facet_wrap(~scenario2_noletters) 115 | ggsave("figs-ms/f-projections-taaaaaaaall.png", width = 5.5, height = 14) 116 | ggsave("figs-ms/f-projections-taaaaaaaall.pdf", width = 5.5, height = 14) 117 | 118 | -------------------------------------------------------------------------------- /analysis/make_projection_plot.R: -------------------------------------------------------------------------------- 1 | make_projection_plot <- function(models, cumulative = FALSE, 2 | first_date = "2020-03-01", ylim = c(0, max(out$upr) * 1.03), outer_quantile = c(0.05, 0.95), 3 | facet = TRUE, ncol = 1, cols = NULL, linetype = c("mu", "obs"), 4 | omitted_days = NULL, y_rep_dat = NULL, mu_dat = NULL, points_size = 1.25, 5 | sc_order = NULL) { 6 | 7 | linetype <- match.arg(linetype) 8 | obj <- models[[1]] 9 | actual_dates <- seq(lubridate::ymd(first_date), 10 | lubridate::ymd(first_date) + max(obj$days), by = "1 day") 11 | 12 | if (is.null(y_rep_dat) || is.null(mu_dat)) { 13 | out <- purrr::map_df(models, function(.x) { 14 | temp <- .x$post$y_rep %>% 15 | reshape2::melt() %>% 16 | dplyr::rename(day = Var2) 17 | 18 | if (cumulative) { 19 | temp <- temp %>% 20 | group_by(iterations) %>% 21 | mutate(value = cumsum(value)) %>% 22 | ungroup() 23 | } 24 | 25 | temp %>% 26 | group_by(day) %>% 27 | summarise( 28 | lwr = quantile(value, probs = outer_quantile[1]), 29 | lwr2 = quantile(value, probs = 0.25), 30 | upr = quantile(value, probs = outer_quantile[2]), 31 | upr2 = quantile(value, probs = 0.75), 32 | med = median(value) 33 | ) %>% 34 | mutate(day = actual_dates[day]) 35 | }, .id = "Scenario") 36 | 37 | lambdas <- purrr::map_df(models, function(.x) { 38 | temp <- .x$post$lambda_d %>% 39 | reshape2::melt() %>% 40 | dplyr::rename(day = Var2) %>% as_tibble() 41 | 42 | if (cumulative) { 43 | temp <- temp %>% 44 | group_by(iterations) %>% 45 | mutate(value = cumsum(value)) %>% 46 | ungroup() 47 | } 48 | 49 | temp %>% 50 | group_by(day) %>% 51 | summarise( 52 | med = median(value) 53 | ) %>% 54 | mutate(day = actual_dates[day]) 55 | }, .id = "Scenario") 56 | } else { 57 | out <- y_rep_dat 58 | lambdas <- mu_dat 59 | } 60 | 61 | if (cumulative) { 62 | dat <- tibble(day = actual_dates[1:obj$last_day_obs], 63 | value = cumsum(obj$daily_cases)) 64 | } else { 65 | dat <- tibble(day = actual_dates[1:obj$last_day_obs], 66 | value = obj$daily_cases) 67 | } 68 | if (is.null(cols)) { 69 | # cols <- RColorBrewer::brewer.pal(8, "Dark2") 70 | # cols <- rep(cols, 5) 71 | cols <- rep("#3182BD", 99) 72 | } 73 | 74 | if (!is.null(sc_order)) { 75 | out$Scenario <- factor(out$Scenario, levels = sc_order) 76 | lambdas$Scenario <- factor(lambdas$Scenario, levels = sc_order) 77 | } 78 | g <- ggplot(out, aes(x = day, y = med, ymin = lwr, ymax = upr, colour = Scenario, 79 | fill = Scenario)) + 80 | annotate("rect", xmin = actual_dates[obj$last_day_obs], xmax = max(out$day), ymin = 0, ymax = ylim[2], fill = "grey95") + 81 | coord_cartesian(expand = FALSE, ylim = ylim, xlim = range(out$day)) + 82 | geom_ribbon(alpha = 0.2, colour = NA) + 83 | geom_ribbon(alpha = 0.2, mapping = aes(ymin = lwr2, ymax = upr2), colour = NA) 84 | 85 | if (linetype == "obs") 86 | g <- g + geom_line(alpha = 1, lwd = 1) 87 | if (linetype == "mu") 88 | g <- g + geom_line(data = lambdas, aes(x = day, y = med, colour = Scenario), alpha = 1, lwd = 1, inherit.aes = FALSE) 89 | 90 | g <- g + 91 | geom_line( 92 | data = dat, 93 | col = "black", inherit.aes = FALSE, aes(x = day, y = value), lwd = 0.35, 94 | alpha = 0.9 95 | ) 96 | 97 | if (!is.null(omitted_days)) { 98 | g <- g + 99 | geom_point( 100 | data = dat[omitted_days,,drop=FALSE], 101 | col = "grey30", inherit.aes = FALSE, aes(x = day, y = value), pch = 4, fill = "grey95", size = points_size 102 | ) + 103 | geom_point( 104 | data = dat[-omitted_days, ,drop=FALSE], 105 | col = "grey30", inherit.aes = FALSE, aes(x = day, y = value), pch = 21, fill = "grey95", size = points_size 106 | ) 107 | } else { 108 | g <- g + geom_point( 109 | data = dat, 110 | col = "grey30", inherit.aes = FALSE, aes(x = day, y = value), pch = 21, fill = "grey95", size = points_size 111 | ) 112 | } 113 | 114 | g <- g + 115 | ylab(if (!cumulative) "Reported cases" else "Cumulative reported cases") + 116 | xlab("Day") + 117 | # xlim(lubridate::ymd("2020-03-01"), lubridate::ymd("2020-06-08")) + 118 | # geom_vline(xintercept = actual_dates[obj$last_day_obs], lty = 2, alpha = 0.6) + 119 | scale_color_manual(values = cols) + 120 | scale_fill_manual(values = cols) + 121 | labs(colour = "Projection scenario", fill = "Projection scenario") + 122 | theme(axis.title.x = element_blank()) 123 | 124 | if (facet && length(unique(out$Scenario)) > 1) 125 | g <- g + facet_wrap(~Scenario, ncol = ncol) + theme(legend.position = "none") 126 | 127 | if (length(unique(out$Scenario)) == 1) { 128 | g <- g + guides(fill = FALSE, colour = FALSE) 129 | } 130 | g 131 | } 132 | -------------------------------------------------------------------------------- /analysis/15-epi-curves.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # m <- fit_seeiqr(daily_diffs, seeiqr_model = seeiqr_model, iter = 2000, chains = 8) 4 | # print(m$fit, pars = c("R0", "f2", "phi")) 5 | # saveRDS(m, file = "data-generated/main-fit-2000.rds") 6 | m <- readRDS("data-generated/main-fit-2000.rds") 7 | 8 | .last_day <- m$last_day_obs 9 | .last_day 10 | 11 | sdtiming0.7 <- function(t, start_decline = 15, end_decline = 22, 12 | last_obs = .last_day, 13 | f_val = 0.7, 14 | f1 = pars$f1, 15 | f2 = pars$f2) { 16 | if (t < start_decline) { 17 | return(f1) 18 | } 19 | if (t >= start_decline & t < end_decline) { 20 | return(f2 + (end_decline - t) * (f1 - f2) / (end_decline - start_decline)) 21 | } 22 | floor_t <- floor(t) 23 | if (t >= end_decline & floor_t <= last_obs) { 24 | return(f2) 25 | } 26 | if (t >= end_decline & floor_t > last_obs) { 27 | return(f_val) 28 | } 29 | } 30 | 31 | sdtiming0.8 <- sdtiming0.7 32 | formals(sdtiming0.8)$f_val <- 0.8 33 | 34 | sdtiming0.9 <- sdtiming0.7 35 | formals(sdtiming0.9)$f_val <- 0.9 36 | 37 | sdtiming1.0 <- sdtiming0.7 38 | formals(sdtiming1.0)$f_val <- 1.0 39 | 40 | sdtiming0.6 <- sdtiming0.7 41 | formals(sdtiming0.6)$f_val <- 0.6 42 | 43 | proj_wrapper <- function(.sdfunction, .n = 20, .proj_days = 500) { 44 | proj_days <- .last_day + .proj_days 45 | .times <- seq(-30, proj_days, 0.1) 46 | list(m$post$R0[1:.n], m$post$f2[1:.n], m$post$phi[1:.n], seq_len(.n)) %>% 47 | purrr::pmap_dfr(reproject_fits, 48 | obj = m, .sdfunc = .sdfunction, 49 | .time = .times, return_ode_dat = TRUE 50 | ) %>% 51 | dplyr::mutate(prevalence = I + Id) %>% 52 | dplyr::as_tibble() 53 | } 54 | 55 | sdfuncs <- list(sdtiming0.6, sdtiming0.7, sdtiming0.8, sdtiming0.9, sdtiming1.0) %>% 56 | purrr::set_names(seq(0.6, 1.0, 0.1)) 57 | 58 | plan(multisession) 59 | prev <- sdfuncs %>% furrr::future_map_dfr(proj_wrapper, 60 | .id = "scenario", 61 | .options = furrr::future_options( 62 | globals = 63 | c( 64 | ".last_day", "m", "sdtiming0.6", "sdtiming0.7", 65 | "sdtiming0.8", "reproject_fits", 66 | "sdtiming0.9", "sdtiming1.0", "socdistmodel", "getlambd" 67 | ) 68 | ) 69 | ) 70 | plan(sequential) 71 | saveRDS(prev, file = "data-generated/prev-epi.rds") 72 | prev <- readRDS("data-generated/prev-epi.rds") 73 | 74 | .start <- lubridate::ymd_hms("2020-03-01 00:00:00") 75 | prev <- mutate(prev, day = .start + lubridate::ddays(time)) 76 | 77 | obj <- m # just for last_day_obs 78 | .theme <- theme(title = element_text(size = rel(0.9))) + 79 | theme(strip.text.x = element_text(angle = 0, hjust = 0)) + 80 | theme(axis.title.x = element_blank()) 81 | 82 | .coord_prev <- coord_cartesian( 83 | expand = FALSE, ylim = c(0, NA), 84 | xlim = c(lubridate::ymd_hms("2020-03-01 00:00:00"), NA) 85 | ) 86 | 87 | g <- prev %>% 88 | mutate(scenario2 = paste0(100 * (as.numeric(scenario)), "%")) %>% 89 | mutate(scenario2 = factor(scenario2, levels = c("60%", "70%", "80%", "90%", "100%"))) %>% 90 | ggplot(aes(day, prevalence, 91 | group = paste(iterations, scenario2), colour = scenario2 92 | )) + 93 | annotate("rect", 94 | xmin = .start + lubridate::ddays(obj$last_day_obs), 95 | xmax = .start + lubridate::ddays(obj$last_day_obs + 500), 96 | ymin = 0, ymax = Inf, fill = "grey96" 97 | ) + 98 | labs(colour = "Fraction of\nnormal contacts") + 99 | geom_line(alpha = 0.35) + 100 | ylab("Modelled prevalence") + 101 | guides(colour = guide_legend(override.aes = list(alpha = 1, lwd = 1))) + 102 | scale_color_viridis_d(direction = 1) + 103 | .theme + 104 | .coord_prev + 105 | theme(legend.position = c(0.82, 0.77)) + 106 | scale_y_continuous(labels = scales::comma) + 107 | annotate("text", x = lubridate::ymd_hms("2020-03-22 00:00:00"), y = 80000, label = "See inset", angle = 90, col = "grey30", size = 3.5) + 108 | scale_x_datetime(date_breaks = "4 months", date_labels = "%b %Y") 109 | 110 | # ggsave("figs-ms/epi-curves.png", width = 5, height = 3.25) 111 | 112 | g3 <- g + theme_void() + 113 | theme(panel.border = element_rect(fill = NA, colour = "grey70", size = 1)) + 114 | coord_cartesian( 115 | expand = FALSE, ylim = c(0, 3000), 116 | xlim = c(lubridate::ymd_hms("2020-02-27 00:00:00"), lubridate::ymd_hms("2020-07-01 00:00:00"))) + 117 | guides(colour = FALSE) 118 | plot_with_inset <- 119 | cowplot::ggdraw() + 120 | cowplot::draw_plot(g) + 121 | cowplot::draw_plot(g3, x = .7, y = .15, width = .25, height = .25) 122 | 123 | ggsave( 124 | filename = "figs-ms/epi-curves-inset.png", 125 | plot = plot_with_inset, 126 | width = 5, height = 3.25, dpi = 400) 127 | 128 | ggsave( 129 | filename = "figs-ms/epi-curves-inset.pdf", 130 | plot = plot_with_inset, 131 | width = 5, height = 3.25) 132 | 133 | # g2 <- g + scale_y_sqrt(labels = scales::comma) 134 | # ggsave("figs-ms/epi-curves-sqrt.png", width = 4.5, height = 3.25) 135 | -------------------------------------------------------------------------------- /analysis/06-cycle-f2.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # m <- fit_seeiqr(daily_diffs, seeiqr_model = seeiqr_model, iter = 2000, chains = 8) 4 | # print(m$fit, pars = c("R0", "f2", "phi")) 5 | # saveRDS(m, file = "data-generated/main-fit-2000.rds") 6 | m <- readRDS("data-generated/main-fit-2000.rds") 7 | 8 | .last_day <- m$last_day_obs 9 | .last_day 10 | .f2_now <- round(mean(m$post$f2), 2) 11 | write_tex(100 * (1 - .f2_now), "currentPercInCycles") 12 | write_tex((1 - .f2_now), "currentFracInCycles") 13 | 14 | sdtiming_cycle_4x4 <- function( 15 | t, start_decline = 15, end_decline = 22, last_obs = .last_day, 16 | f_vec = c(rep(NA, last_obs), rep(c(rep(0.8, 7 * 4), rep(.f2_now, 7 * 4)), 12)), 17 | f1 = pars$f1, 18 | f2 = pars$f2) { 19 | if (t < start_decline) { 20 | return(f1) 21 | } 22 | if (t >= start_decline & t < end_decline) { 23 | return(f2 + (end_decline - t) * (f1 - f2) / (end_decline - start_decline)) 24 | } 25 | floor_t <- floor(t) 26 | if (t >= end_decline & floor_t <= last_obs) { 27 | return(f2) 28 | } 29 | if (t >= end_decline & floor_t > last_obs) { 30 | return(f_vec[floor_t]) 31 | } 32 | } 33 | 34 | sdtiming_cycle_3x3 <- sdtiming_cycle_4x4 35 | formals(sdtiming_cycle_3x3)$f_vec <- 36 | c(rep(NA, .last_day), rep(c(rep(0.8, 7 * 3), rep(.f2_now, 7 * 3)), 12)) 37 | 38 | plan(multisession, workers = parallel::detectCores() / 2) 39 | 40 | proj_days <- .last_day + 4 * 7 * 4 41 | .times <- seq(-30, proj_days, 0.1) 42 | pred_4x4 <- list(m$post$R0, m$post$f2, m$post$phi, seq_along(m$post$R0)) %>% 43 | furrr::future_pmap_dfr(reproject_fits, 44 | obj = m, .sdfunc = sdtiming_cycle_4x4, 45 | .time = .times, .progress = TRUE, 46 | .options = furrr::future_options( 47 | globals = 48 | c(".last_day", "m", "sdtiming_cycle_4x4", "socdistmodel", "getlambd", ".f2_now") 49 | ) 50 | ) 51 | saveRDS(pred_4x4, file = "data-generated/pred_4x4.rds") 52 | pred_4x4 <- readRDS("data-generated/pred_4x4.rds") 53 | 54 | # re-sample obs. model for smoother plots: 55 | pred_4x4 <- purrr::map_dfr(1:10, function(i) { 56 | pred_4x4$y_rep <- MASS::rnegbin(length(pred_4x4$y_rep), 57 | pred_4x4$lambda_d, 58 | theta = pred_4x4$phi 59 | ) 60 | pred_4x4 61 | }) 62 | 63 | pred_3x3 <- list(m$post$R0, m$post$f2, m$post$phi, seq_along(m$post$R0)) %>% 64 | furrr::future_pmap_dfr(reproject_fits, 65 | obj = m, .sdfunc = sdtiming_cycle_3x3, 66 | .time = .times, .progress = TRUE, 67 | .options = furrr::future_options( 68 | globals = 69 | c(".last_day", "m", "sdtiming_cycle_3x3", "socdistmodel", "getlambd", ".f2_now") 70 | ) 71 | ) 72 | saveRDS(pred_3x3, file = "data-generated/pred_3x3.rds") 73 | pred_3x3 <- readRDS("data-generated/pred_3x3.rds") 74 | 75 | # re-sample obs. model for smoother plots: 76 | pred_3x3 <- purrr::map_dfr(1:10, function(i) { 77 | pred_3x3$y_rep <- MASS::rnegbin(length(pred_3x3$y_rep), 78 | pred_3x3$lambda_d, 79 | theta = pred_3x3$phi 80 | ) 81 | pred_3x3 82 | }) 83 | 84 | plan(sequential) 85 | 86 | prep_dat <- function(.dat, Scenario = "") { 87 | actual_dates <- seq(dat$Date[1], dat$Date[1] + proj_days, by = "1 day") 88 | outer_quantile <- c(0.05, 0.95) 89 | y_rep <- .dat %>% 90 | mutate(value = y_rep) %>% 91 | group_by(day) %>% 92 | summarise( 93 | lwr = quantile(value, probs = outer_quantile[1]), 94 | lwr2 = quantile(value, probs = 0.25), 95 | upr = quantile(value, probs = outer_quantile[2]), 96 | upr2 = quantile(value, probs = 0.75), 97 | med = median(value) 98 | ) %>% 99 | mutate(day = actual_dates[day], Scenario = Scenario) 100 | lambdas <- .dat %>% 101 | group_by(day) %>% 102 | mutate(value = lambda_d) %>% 103 | summarise( 104 | med = median(value) 105 | ) %>% 106 | mutate(day = actual_dates[day], Scenario = Scenario) 107 | list(y_rep = y_rep, mu = lambdas) 108 | } 109 | 110 | x <- prep_dat(pred_4x4) 111 | .max <- max(x$y_rep$upr) * 1.04 112 | g1 <- make_projection_plot( 113 | models = list(m), mu_dat = x$mu, 114 | y_rep_dat = x$y_rep, ylim = c(0, .max), points_size = 1.25 115 | ) + 116 | theme(plot.margin = margin(11 / 2, 11, 11 / 2, 11 / 2)) 117 | for (i in seq(1, 4, 2)) { 118 | .inc <- 7 * 4 119 | g_last_day <- dat$Date[1] + .last_day 120 | g1 <- g1 + annotate("rect", 121 | xmin = g_last_day + (i - 1) * .inc - 1, 122 | xmax = g_last_day + i * .inc - 1, 123 | ymin = 0, ymax = Inf, fill = "#00000012" 124 | ) 125 | } 126 | 127 | x <- prep_dat(pred_3x3) 128 | g2 <- make_projection_plot( 129 | models = list(m), mu_dat = x$mu, 130 | y_rep_dat = x$y_rep, ylim = c(0, .max), points_size = 1.25 131 | ) + 132 | theme(plot.margin = margin(11 / 2, 11, 11 / 2, 11 / 2)) 133 | for (i in seq(1, 6, 2)) { 134 | .inc <- 7 * 3 135 | g_last_day <- dat$Date[1] + .last_day 136 | g2 <- g2 + annotate("rect", 137 | xmin = g_last_day + (i - 1) * .inc - 1, 138 | xmax = g_last_day + i * .inc - 1, 139 | ymin = 0, ymax = Inf, fill = "#00000012" 140 | ) 141 | } 142 | 143 | cowplot::plot_grid(g1, g2, ncol = 1, labels = "AUTO", label_x = 0.125, label_y = 0.96) 144 | ggsave("figs-ms/f2-cycling.png", width = 4.5, height = 5, dpi = 400) 145 | ggsave("figs-ms/f2-cycling.pdf", width = 4.5, height = 5) 146 | 147 | -------------------------------------------------------------------------------- /analysis/05-main-fig.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | m <- fit_seeiqr(daily_diffs, seeiqr_model = seeiqr_model, iter = 3000, chains = 8) 4 | print(m$fit, pars = c("R0", "f2", "phi")) 5 | saveRDS(m, file = "data-generated/main-fit-2000.rds") 6 | m <- readRDS("data-generated/main-fit-2000.rds") 7 | 8 | sd_est <- sprintf("%.0f", 9 | 100 * (1 - round(quantile(m$post$f2, c(0.05, 0.5, 0.95)), 2))) 10 | sd_est_frac <- sprintf("%.2f", 11 | (1 - round(quantile(m$post$f2, c(0.05, 0.5, 0.95)), 2))) 12 | write_tex(sd_est_frac[1], "fracEstUpr") 13 | write_tex(sd_est_frac[2], "fracEstMed") 14 | write_tex(sd_est_frac[3], "fracEstLwr") 15 | 16 | write_tex(sd_est[1], "percEstUpr") 17 | write_tex(sd_est[2], "percEstMed") 18 | write_tex(sd_est[3], "percEstLwr") 19 | 20 | sd_est <- sprintf("%.2f", round(quantile(m$post$f2, c(0.05, 0.5, 0.95)), 2)) 21 | write_tex(sd_est[3], "fTwoEstUpr") 22 | write_tex(sd_est[2], "fTwoEstMed") 23 | write_tex(sd_est[1], "fTwoEstLwr") 24 | 25 | write_tex(sum(daily_diffs) + 8, "totalCases") 26 | 27 | make_quick_plots(m, id = "-ms-main", ext = ".png") 28 | file.copy("figs/traceplot-ms-main.png", "figs-ms/traceplots.png", 29 | overwrite = TRUE) 30 | file.copy("figs/posterior-predictive-case-diffs-facet-ms-main.png", 31 | "figs-ms/post-pred-reps.png", overwrite = TRUE) 32 | 33 | fit_array <- as.array(m$fit) 34 | dimnames(fit_array)[[3]] <- gsub("R0", "R0b", dimnames(fit_array)[[3]]) 35 | g <- bayesplot::mcmc_trace(fit_array, pars = c("R0", "f2", "phi[1]")) 36 | 37 | # fewer samples for plot: 38 | m500 <- fit_seeiqr(daily_diffs, 39 | seeiqr_model = seeiqr_model, iter = 500, chains = 8, 40 | save_state_predictions = TRUE 41 | ) 42 | print(m500$fit, pars = c("R0", "f2", "phi")) 43 | saveRDS(m500, file = "data-generated/main-fit-500.rds") 44 | m500 <- readRDS("data-generated/main-fit-500.rds") 45 | 46 | proj <- make_projection_plot(list(m)) 47 | 48 | obj <- m 49 | post <- m$post 50 | R0 <- post$R0 51 | 52 | .x <- seq(2.5, 3.5, length.out = 300) 53 | breaks <- seq(min(.x), max(.x), 0.016) 54 | R0_hist <- ggplot(tibble(R0 = R0)) + 55 | geom_ribbon( 56 | data = tibble( 57 | R0 = .x, 58 | density = dlnorm(.x, obj$R0_prior[1], obj$R0_prior[2]) 59 | ), 60 | aes(x = R0, ymin = 0, ymax = density), alpha = 0.5, colour = "grey50", 61 | fill = "grey50" 62 | ) + 63 | ylab("Density") + 64 | geom_histogram( 65 | breaks = breaks, aes(x = R0, y = ..density..), 66 | fill = .hist_blue, alpha = .7, colour = "grey90", lwd = 0.15 67 | ) + 68 | coord_cartesian(xlim = range(.x), expand = FALSE) + 69 | xlab(expression(italic(R[0 * plain(b)]))) 70 | 71 | R0_hist 72 | 73 | f2 <- post$f2 74 | .x <- seq(0, 1, length.out = 300) 75 | breaks <- seq(min(.x), max(.x), 0.022) 76 | f2_hist <- ggplot(tibble(f2 = f2)) + 77 | geom_ribbon( 78 | data = tibble( 79 | f2 = .x, 80 | density = dbeta(.x, obj$f2_prior_beta_shape1, obj$f2_prior_beta_shape2) 81 | ), 82 | aes(x = f2, ymin = 0, ymax = density), alpha = 0.5, colour = "grey50", 83 | fill = "grey50" 84 | ) + 85 | geom_histogram( 86 | breaks = breaks, aes(x = f2, y = ..density..), 87 | fill = .hist_blue, alpha = .7, colour = "grey90", lwd = 0.15 88 | ) + 89 | ylab("Density") + 90 | coord_cartesian(xlim = range(.x), expand = FALSE) + 91 | xlab("Fraction of normal contacts") + 92 | scale_x_continuous(breaks = seq(0, 1, 0.2)) + 93 | geom_vline(xintercept = .55, lty = 2, col = "grey40") 94 | 95 | f2_hist 96 | 97 | obj <- m500 98 | post <- obj$post 99 | draws <- 1:250 100 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 101 | variables_df <- dplyr::tibble( 102 | variable = names(obj$state_0), 103 | variable_num = seq_along(obj$state_0) 104 | ) 105 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 106 | states <- reshape2::melt(post$y_hat) %>% 107 | dplyr::rename(time_num = Var2, variable_num = Var3) %>% 108 | dplyr::filter(iterations %in% draws) %>% 109 | dplyr::left_join(variables_df, by = "variable_num") %>% 110 | dplyr::left_join(ts_df, by = "time_num") 111 | 112 | .start <- lubridate::ymd_hms("2020-03-01 00:00:00") 113 | prevalence <- states %>% 114 | dplyr::filter(variable %in% c("I", "Id")) %>% 115 | group_by(iterations, time) %>% 116 | summarize( 117 | I = value[variable == "I"], Id = value[variable == "Id"], 118 | prevalence = I + Id 119 | ) %>% 120 | mutate(day = .start + lubridate::ddays(time)) 121 | 122 | g_prev <- ggplot(prevalence, aes(day, prevalence, group = iterations)) + 123 | annotate("rect", 124 | xmin = .start + lubridate::ddays(obj$last_day_obs), 125 | xmax = .start + lubridate::ddays(obj$last_day_obs + 60), 126 | ymin = 0, ymax = Inf, fill = "grey95" 127 | ) + 128 | geom_line(alpha = 0.05, col = .hist_blue) + 129 | ylab("Modelled prevalence") + 130 | coord_cartesian(expand = FALSE, xlim = c(.start, .start + lubridate::ddays(obj$last_day_obs + 60)), ylim = c(0, max(prevalence$prevalence) * 1.04)) + 131 | xlab("") 132 | g_prev 133 | 134 | gg_additions <- list( 135 | theme( 136 | plot.margin = margin(t = 0, r = 5, b = 1, l = 5), 137 | axis.title.y.left = element_text(margin = margin(r = 0))) 138 | ) 139 | 140 | g <- cowplot::plot_grid( 141 | proj + gg_additions, 142 | R0_hist + gg_additions, 143 | g_prev + gg_additions, 144 | f2_hist + gg_additions, 145 | align = "hv", 146 | labels = "AUTO", label_size = 12, label_x = 0.225, label_y = 0.995) + 147 | theme(plot.margin = margin(11 / 2, 11 / 2, 11 / 2, 11 / 2)) 148 | # ggsave(paste0("figs-ms/fig1.png"), width = 5, height = 4, dpi = 400) 149 | ggsave(paste0("figs-ms/fig1.pdf"), width = 5.25, height = 3.8) 150 | 151 | g <- ggplot(states, aes(time, value, group = iterations)) + 152 | geom_line(alpha = 0.1) + 153 | facet_wrap(~variable, scales = "free_y") + 154 | geom_vline(xintercept = obj$last_day_obs, lty = 2, alpha = 0.6) + 155 | xlab("Time (days starting on March 1, 2020)") + 156 | ylab("Individuals") 157 | ggsave(paste0("figs-ms/states.png"), width = 12, height = 7, dpi = 200) 158 | -------------------------------------------------------------------------------- /analysis/01-simulation-test.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | pars <- list( 4 | N = 5.1e6, # population of BC 5 | D = 5, 6 | R0 = 2.6, 7 | k1 = 1 / 5, 8 | k2 = 1, 9 | q = 0.05, 10 | r = 0.1, 11 | ur = 0.02, 12 | f1 = 1.0, 13 | f2 = 0.4, 14 | ratio = 0.3 / 0.1 # 2nd stage sampFrac 15 | ) 16 | fsi <- with( 17 | pars, 18 | r / (r + ur) 19 | ) 20 | nsi <- 1 - fsi 21 | i0 <- 8 22 | state_0 <- c( 23 | S = nsi * (pars$N - i0), 24 | E1 = 0.4 * nsi * i0, 25 | E2 = 0.1 * nsi * i0, 26 | I = 0.5 * nsi * i0, 27 | Q = 0, 28 | R = 0, 29 | Sd = fsi * (pars$N - i0), 30 | E1d = 0.4 * fsi * i0, 31 | E2d = 0.1 * fsi * i0, 32 | Id = 0.5 * fsi * i0, 33 | Qd = 0, 34 | Rd = 0 35 | ) 36 | times <- seq( 37 | from = -30, 38 | to = 45, 39 | by = 0.1 40 | ) 41 | set.seed(128284) 42 | 43 | sim_dat <- purrr::map(1:16, function(x) { 44 | example_simulation <- as.data.frame(deSolve::ode( 45 | y = state_0, 46 | times = times, 47 | func = socdistmodel, 48 | parms = pars, 49 | sdtiming = sdtiming_gradual 50 | )) 51 | dat <- data.frame( 52 | Date = seq(lubridate::ymd("2020-03-01"), 53 | lubridate::ymd("2020-03-01") + max(times) + 1, 54 | by = "day" 55 | ) 56 | ) 57 | dat$day <- seq_along(dat$Date) 58 | lambda_d <- sapply(seq(1, max(times)), function(x) { 59 | getlambd(example_simulation, pars = pars, data = dat, day = x) 60 | }) 61 | sim_dat <- data.frame( 62 | day = seq(1, max(times)), 63 | lambda_d = lambda_d, 64 | obs = MASS::rnegbin(max(times), lambda_d, theta = 5) 65 | ) 66 | sim_dat 67 | }) 68 | 69 | plan(multisession, workers = parallel::detectCores() / 2) 70 | sim <- furrr::future_map(seq_along(sim_dat), function(x) { 71 | fit_seeiqr( 72 | daily_cases = sim_dat[[x]]$obs, 73 | seeiqr_model = seeiqr_model, 74 | forecast_days = 1, 75 | sampFrac2_type = "fixed", 76 | sampled_fraction1 = 0.1, 77 | sampled_fraction2 = 0.3, 78 | iter = 800, 79 | chains = 1, cores = 1 80 | ) 81 | }) 82 | plan(sequential) 83 | saveRDS(sim, "data-generated/sim-fits1.rds") 84 | sim <- readRDS("data-generated/sim-fits1.rds") 85 | 86 | purrr::walk(sim, ~ print(.x$fit, pars = c("R0", "f2", "phi", "sampFrac2"))) 87 | 88 | # Compare posterior predictions to truth: ------------------------------------- 89 | 90 | out <- purrr::map_df(sim, function(.x) { 91 | temp <- .x$post$y_rep %>% 92 | reshape2::melt() %>% 93 | dplyr::rename(day = Var2) 94 | temp <- temp %>% 95 | group_by(day) %>% 96 | summarise( 97 | lwr2 = quantile(value, probs = 0.75), 98 | upr2 = quantile(value, probs = 0.25), 99 | lwr = quantile(value, probs = 0.95), 100 | upr = quantile(value, probs = 0.05), 101 | med = median(value) 102 | ) 103 | temp 104 | }, .id = "simulation") %>% 105 | mutate(simulation = sprintf("%02d", as.numeric(simulation))) 106 | 107 | out_lambd <- purrr::map_df(sim, function(.x) { 108 | temp <- .x$post$lambda_d %>% 109 | reshape2::melt() %>% 110 | dplyr::rename(day = Var2) 111 | temp <- temp %>% 112 | group_by(day) %>% 113 | summarise( 114 | lwr2 = quantile(value, probs = 0.75), 115 | upr2 = quantile(value, probs = 0.25), 116 | lwr = quantile(value, probs = 0.95), 117 | upr = quantile(value, probs = 0.05), 118 | med = median(value) 119 | ) 120 | temp 121 | }, .id = "simulation") %>% 122 | mutate(simulation = sprintf("%02d", as.numeric(simulation))) 123 | 124 | sim_dat_all <- bind_rows(sim_dat, .id = "simulation") %>% 125 | as_tibble() %>% 126 | mutate(simulation = sprintf("%02d", as.numeric(simulation))) 127 | 128 | ggplot(out, aes(x = day, y = med, ymin = lwr2, ymax = upr2)) + 129 | geom_ribbon(alpha = 0.2, colour = NA) + 130 | geom_ribbon(aes(ymin = lwr, ymax = upr), alpha = 0.2, colour = NA) + 131 | geom_line(data = out_lambd, alpha = 0.9, lwd = 0.7) + 132 | geom_point( 133 | data = sim_dat_all, pch = 21, size = 1, 134 | col = "black", inherit.aes = FALSE, aes(x = day, y = obs), 135 | ) + 136 | facet_wrap(~simulation, ncol = 4) + 137 | geom_line( 138 | data = sim_dat_all, 139 | col = "black", inherit.aes = FALSE, aes(x = day, y = lambda_d), lwd = 0.5, 140 | alpha = 1, lty = 2 141 | ) + 142 | ylab("Simulated reported cases") + 143 | xlab("Day") 144 | ggsave("figs-ms/sim-ts-ppd.png", width = 8, height = 6.5) 145 | 146 | # Compare expectations to truth: ---------------------------------------------- 147 | 148 | out <- purrr::map_df(sim, function(.x) { 149 | temp <- .x$post$lambda_d %>% 150 | reshape2::melt() %>% 151 | dplyr::rename(day = Var2) 152 | temp <- temp %>% 153 | group_by(day) %>% 154 | summarise( 155 | lwr2 = quantile(value, probs = 0.75), 156 | upr2 = quantile(value, probs = 0.25), 157 | med = median(value) 158 | ) 159 | temp 160 | }, .id = "simulation") 161 | 162 | ggplot(out, aes(x = day, y = med, ymin = lwr2, ymax = upr2)) + 163 | geom_ribbon(alpha = 0.2, colour = NA) + 164 | geom_line(alpha = 0.9, lwd = 1) + 165 | facet_wrap(~simulation, ncol = 4) + 166 | geom_line( 167 | data = sim_dat[[1]], 168 | col = "black", inherit.aes = FALSE, aes(x = day, y = lambda_d), lwd = 0.3, 169 | alpha = 0.8 170 | ) 171 | ggsave("figs-ms/sim-ts-hat.png", width = 9, height = 5) 172 | 173 | check_sim_theta <- function(.par) { 174 | out <- purrr::map_df(seq_along(sim), function(x) { 175 | data.frame(sim = x, parameter = sim[[x]]$post[[.par]]) 176 | }) 177 | .hline <- if (.par == "R0") { 178 | 2.6 179 | } else if (.par == "f2") { 180 | 0.4 181 | } else if (.par == "phi") { 182 | 5 183 | } 184 | ggplot(out, aes_string("as.factor(sim)", "parameter")) + 185 | geom_violin(colour = .hist_blue, fill = NA) + 186 | geom_violin(fill = .hist_blue, colour = NA, alpha = 0.3) + 187 | geom_hline(yintercept = .hline) + 188 | ylab(.par) + 189 | xlab("Simulation") 190 | } 191 | 192 | g1 <- check_sim_theta("R0") + ylab(expression(italic(R[0 * plain(b)]))) 193 | g2 <- check_sim_theta("phi") + coord_cartesian(ylim = c(0, 30)) + ylab(expression(phi)) 194 | g3 <- check_sim_theta("f2") + ylab(expression(f[2])) 195 | cowplot::plot_grid(g1, g2, g3, ncol = 1) 196 | ggsave("figs-ms/R-sim-test-theta.png", width = 6, height = 7) 197 | -------------------------------------------------------------------------------- /analysis/17-ny.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(dplyr) 3 | # library(future) 4 | library(covidseir) 5 | # plan(multisession) 6 | options(mc.cores = parallel::detectCores() / 2) 7 | ymd <- lubridate::ymd 8 | 9 | # d <- readr::read_csv("https://covidtracking.com/api/v1/states/daily.csv") 10 | # readr::write_csv(d, here::here("data-generated/us-data.csv")) 11 | d <- readr::read_csv(here::here("data-generated/us-data.csv")) 12 | d$date <- lubridate::ymd(d$date) 13 | 14 | new_york <- filter(d, state %in% "NY") %>% 15 | select(date, positiveIncrease, totalTestResultsIncrease, hospitalizedIncrease) %>% 16 | filter(date >= ymd("2020-03-05")) %>% 17 | rename(value = positiveIncrease, tests = totalTestResultsIncrease, hospitalized = hospitalizedIncrease) %>% 18 | arrange(date) %>% 19 | mutate(day = seq_len(n())) 20 | 21 | # NM: first confirmed case was Mar 1st, large gatherings banned Mar 12th, 22 | # increased SD measures until stay-at-home order issued on Mar 22nd. 23 | 24 | # https://en.wikipedia.org/wiki/COVID-19_pandemic_in_New_York_(state)#Timeline 25 | # On March 8, the state reported 16 new confirmed cases and a total of 106 cases 26 | # statewide.[24] New York City issued new commuter guidelines amid the current 27 | # outbreak, asking sick individuals to stay off public transit, encouraging 28 | # citizens to avoid densely packed buses, subways, or trains.[25] 29 | 30 | # On March 11, Cuomo announced that the City University of New York and State 31 | # University of New York schools would be closed for the following week, from 32 | # March 12 to 19. 33 | 34 | # April 26, 2020: https://coronavirus.health.ny.gov/system/files/documents/2020/04/doh_covid19_revisedtestingprotocol_042620.pdf 35 | # Diagnostic and/or serologic testing for COVID-19 shall be authorized by a health care provider when: 36 | # • An individual is symptomatic or has a history of symptoms of COVID-19 (e.g. fever, cough, and/or trouble breathing), particularly if the individual is 70 years of age or older, the individual has a compromised immune system, or the individual has an underlying health condition; or 37 | # • An individual has had close (i.e. within six feet) or proximate contact with a person known to be positive with COVID-19; or 38 | # • An individual is subject to a precautionary or mandatory quarantine; or 39 | # • An individual is employed as a health care worker, first responder, or other essential 40 | # worker who directly interacts with the public while working; or 41 | # • An individual presents with a case where the facts and circumstances – as determined 42 | # by the treating clinician in consultation with state or local department of health officials – warrant testing. 43 | 44 | # https://www.medrxiv.org/content/10.1101/2020.04.20.20073338v1.full.pdf 45 | # "As of April 15, New York still recommended restricting testing to those with a known positive contact or travel history, as well as symptomatic individuals who had tested negative for other infections" 46 | 47 | # https://en.wikipedia.org/wiki/COVID-19_pandemic_in_New_York_(state) 48 | # On March 20, de Blasio called for drastic measures to combat the coronavirus outbreak. "We have to go to a shelter-in-place model," he said, praising California's "stay at home" model for sheltering in place.[91] 49 | 50 | # Cuomo also on March 28 ordered all nonessential construction sites in the state to shut down. This led the developers of the Legoland park under construction in Goshen to postpone their planned July 4 opening date until 2021. A specific date was not set, but Orange County's director of tourism expected it would probably be the normal April opening date.[112] 51 | 52 | new_york 53 | # View(new_york) 54 | 55 | plot(new_york$day, new_york$value, type = "o") 56 | plot(new_york$day, new_york$tests, type = "o") 57 | plot(new_york$date, new_york$value, type = "l") 58 | lines(new_york$date, new_york$hospitalized, col = "red") 59 | lines(new_york$date, new_york$tests/10, col = "blue") 60 | 61 | .s <- as.numeric(ymd("2020-03-13") - min(new_york$date)) 62 | .e <- as.numeric(ymd("2020-03-28") - min(new_york$date)) 63 | 64 | # g <- readr::read_csv("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 65 | # g1 <- filter(g, country_region == "United States") 66 | # g1 <- filter(g, sub_region_1 == "New York") 67 | # ggplot(g1, aes(date, transit_stations_percent_change_from_baseline)) + 68 | # geom_point() + 69 | # # geom_vline(xintercept = ymd("2020-03-16")) + 70 | # geom_vline(xintercept = ymd("2020-03-13")) + 71 | # # geom_vline(xintercept = ymd("2020-03-24")) + 72 | # geom_vline(xintercept = ymd("2020-03-28")) 73 | 74 | # Tests Jump on day 9 from <100 to >2000 75 | # and to > 10,000 by the 16th 76 | 77 | (samp_frac_fixed <- rep(0.25, nrow(new_york))) 78 | # (f_seg <- c(rep(0, 11), rep(1, nrow(new_york) - 11))) 79 | 80 | ny_fit <- covidseir::fit_seir( 81 | daily_cases = new_york$value, 82 | samp_frac_fixed = samp_frac_fixed, 83 | time_increment = 0.1, 84 | R0_prior = c(log(2.6), 0.2), 85 | iter = 500, 86 | chains = 8, 87 | start_decline_prior = c(log(.s), 0.2), 88 | end_decline_prior = c(log(.e), 0.2), 89 | i0 = 0.5, 90 | pars = c(N = 19.45e6, D = 5, k1 = 1/5, k2 = 1, 91 | q = 0.05, r = 0.1, ur = 0.02, f0 = 1 92 | )) 93 | ny_fit 94 | p <- covidseir::project_seir(ny_fit, iter = 1:100) 95 | covidseir::tidy_seir(p) %>% 96 | covidseir::plot_projection(new_york) 97 | 98 | saveRDS(ny_fit, file = here::here("data-generated/new-york-fit.rds")) 99 | saveRDS(new_york, file = here::here("data-generated/new-york-dat.rds")) 100 | 101 | # model <- rstan::stan_model("analysis/seeiqr.stan") 102 | # source("analysis/fit_seeiqr.R") 103 | # source("analysis/make_projection_plot.R") 104 | # 105 | # ny_fit <- fit_seeiqr(new_york$value, 106 | # seeiqr_model = model, 107 | # forecast_days = 30, 108 | # R0_prior = c(log(4), 0.2), 109 | # chains = 3, 110 | # iter = 160, 111 | # i0 = 2, 112 | # sampled_fraction1 = 0.25, 113 | # sampled_fraction2 = 0.25, 114 | # pars = c(N = 19.45e6, D = 5, k1 = 1/5, k2 = 1, 115 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 116 | # start_decline = 12, end_decline = 25)) 117 | # print(ny_fit$fit, pars = c("R0", "f2", "phi")) 118 | # 119 | # make_projection_plot(list(ny_fit), first_date = as.character(min(new_york$date))) 120 | -------------------------------------------------------------------------------- /analysis/19-nz.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(ggplot2) 3 | dmy <- lubridate::dmy 4 | ymd <- lubridate::ymd 5 | options(mc.cores = parallel::detectCores() / 2) 6 | 7 | # https://en.wikipedia.org/wiki/COVID-19_pandemic_in_New_Zealand#Requirements 8 | # Ardern announced that, effective 01:00 on 16 March, all travellers arriving in or returning to New Zealand from outside of the country must self-isolate for 14 days. 9 | # In addition, restrictions were placed on travel to the Pacific islands from New Zealand, barring travel to the region by those showing signs of coronavirus symptoms, as well as close contacts of coronavirus patients. 10 | 11 | # On 16 March, Ardern called for a halt to public gatherings of more than 500 people and warned that the outbreak could lead to a recession greater than the 2008 global financial crisis.[223][224] 12 | 13 | # On 19 March, the Government required the cancellation of indoor gatherings of more than 100 people. 14 | 15 | # On 23 March, Ardern raised the alert level to three and announced the closure of all schools, beginning that day. She also announced that the alert level would rise to four at 11:59pm on 25 March, instituting a nationwide lockdown. 16 | 17 | # g <- readr::read_csv("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 18 | # g <- filter(g, country_region == "New Zealand") 19 | # ggplot(g, aes(date, transit_stations_percent_change_from_baseline)) + 20 | # geom_point() + 21 | # # geom_vline(xintercept = ymd("2020-03-16")) + 22 | # geom_vline(xintercept = ymd("2020-03-18")) + 23 | # # geom_vline(xintercept = ymd("2020-03-24")) + 24 | # geom_vline(xintercept = ymd("2020-03-27")) 25 | 26 | d <- readr::read_csv(here::here("data-raw/covid-cases-7may20-NZ.csv"), skip = 3) 27 | d <- rename(d, date = `Date notified of potential case`, overseas = `Overseas travel`) %>% 28 | select(date, overseas) %>% 29 | mutate(date = dmy(date)) %>% 30 | group_by(date) %>% 31 | summarize(all_cases = n(), 32 | not_overseas_cases = sum(overseas == "No", na.rm = TRUE)) 33 | d 34 | 35 | tidyr::pivot_longer(d, -date) %>% 36 | ggplot(aes(date, value, colour = name)) + 37 | geom_line() 38 | 39 | # get_days_since <- function(until, since) { 40 | # abs(as.numeric(difftime(until, since, units = "days"))) 41 | # } 42 | # (start_decline <- get_days_since(ymd("2020-03-17"), min(florida$date))) 43 | # (end_decline <- get_days_since(ymd("2020-04-01"), min(florida$date))) 44 | # (f_seg <- c(rep(0, start_decline), rep(1, nrow(florida) - start_decline))) 45 | 46 | nz <- filter(d, date >= ymd("2020-03-15")) 47 | nz$all_cases 48 | diff(nz$date) 49 | 50 | nz <- left_join(tibble(date = seq(min(nz$date), max(nz$date), by = "1 day")), nz) 51 | nz$all_cases 52 | nz$not_overseas_cases 53 | # nz$not_overseas_cases[is.na(nz$not_overseas_cases)] <- 0 54 | # nz$not_overseas_cases 55 | diff(nz$date) 56 | nz <- nz %>% 57 | mutate(all_cases = ifelse(!is.na(all_cases), all_cases, 0)) %>% 58 | mutate(not_overseas_cases = ifelse(!is.na(not_overseas_cases), not_overseas_cases, 0)) 59 | 60 | nz$all_cases 61 | nz$not_overseas_cases 62 | diff(nz$date) 63 | 64 | april1 <- as.numeric(ymd("2020-04-01") - min(nz$date)) 65 | 66 | # samp_frac_fixed <- c(rep(0.4, april1 - 1), rep(0.6, 9999)) 67 | samp_frac_fixed <- c(rep(0.4, nrow(nz))) 68 | 69 | # samp_frac_fixed <- c(0.3, 0.3, 0.3, 0.3, 0.3, seq(0.3, 0.6, length.out = 12), rep(0.6, 100)) 70 | samp_frac_fixed <- samp_frac_fixed[1:nrow(nz)] 71 | plot(samp_frac_fixed) 72 | 73 | .s <- as.numeric(ymd("2020-03-18") - min(nz$date)) 74 | .e <- as.numeric(ymd("2020-03-26") - min(nz$date)) 75 | 76 | # (f_seg <- c(rep(0, .s), rep(1, nrow(nz) - .s))) 77 | 78 | # https://www.stats.govt.nz/topics/population # 4951500 79 | 80 | fit <- covidseir::fit_seir( 81 | daily_cases = nz$not_overseas_cases, 82 | samp_frac_fixed = samp_frac_fixed, 83 | time_increment = 0.1, 84 | R0_prior = c(log(2.6), 0.2), 85 | f_prior = c(0.3, 0.2), 86 | iter = 400, 87 | # f_ramp_rate = 0.5, 88 | start_decline_prior = c(log(.s), 0.1), 89 | end_decline_prior = c(log(.e), 0.1), 90 | chains = 6, 91 | i0 = 0.001, 92 | delay_shape = 1.53, 93 | delay_scale = 7.828, 94 | pars = c(N = 4951500, D = 5, k1 = 1/5, k2 = 1, 95 | q = 0.05, r = 0.1, ur = covidseir:::getu(0.95, r = 0.1), f0 = 1)) 96 | print(fit) 97 | 98 | nz$day <- seq_len(nrow(nz)) 99 | nz$value <- nz$not_overseas_cases 100 | # nz$value <- nz$all_cases 101 | p <- covidseir::project_seir(fit, iter = 1:100, forecast_days = 0) 102 | 103 | covidseir::tidy_seir(p) %>% 104 | covidseir::plot_projection(nz) 105 | 106 | # source(here::here("analysis/plot_projection_w_inset.R")) 107 | # plot_projection_w_inset(p, nz, obj = fit) 108 | 109 | saveRDS(fit, file = here::here("data-generated/nz-fit.rds")) 110 | saveRDS(nz, file = here::here("data-generated/nz-dat.rds")) 111 | 112 | # (.s <- as.numeric(ymd("2020-03-18") - min(nz$date))) 113 | # (.e <- as.numeric(ymd("2020-03-27") - min(nz$date))) 114 | # (.e <- as.numeric(ymd("2020-03-18") - min(nz$date))) 115 | # 116 | # model <- rstan::stan_model("analysis/seeiqr.stan") 117 | # source("analysis/fit_seeiqr.R") 118 | # source("analysis/make_projection_plot.R") 119 | 120 | 121 | # 122 | # m <- list() 123 | # m[[1]] <- fit_seeiqr( 124 | # nz$not_overseas_cases, 125 | # seeiqr_model = model, 126 | # forecast_days = 0, 127 | # R0_prior = c(log(2.5), 0.2), 128 | # chains = 3, 129 | # iter = 130, 130 | # i0 = 0.05, 131 | # delayShape = 1.48, 132 | # delayScale = 7.93, 133 | # sampled_fraction1 = 0.4, 134 | # sampled_fraction2 = 0.4, 135 | # pars = c(N = 4951500, D = 5, k1 = 1/5, k2 = 1, 136 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 137 | # start_decline = 3, end_decline = 10)) 138 | # m[[2]] <- fit_seeiqr( 139 | # nz$not_overseas_cases, 140 | # seeiqr_model = model, 141 | # forecast_days = 0, 142 | # R0_prior = c(log(2.5), 0.2), 143 | # chains = 3, 144 | # iter = 130, 145 | # i0 = 0.05, 146 | # delayShape = 1.48, 147 | # delayScale = 7.93, 148 | # sampled_fraction1 = 0.4, 149 | # sampled_fraction2 = 0.4, 150 | # pars = c(N = 4951500, D = 5, k1 = 1/5, k2 = 1, 151 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 152 | # start_decline = 3, end_decline = 12)) 153 | # m[[3]] <- fit_seeiqr( 154 | # nz$not_overseas_cases, 155 | # seeiqr_model = model, 156 | # forecast_days = 0, 157 | # R0_prior = c(log(2.5), 0.2), 158 | # chains = 3, 159 | # iter = 130, 160 | # i0 = 0.05, 161 | # delayShape = 1.48, 162 | # delayScale = 7.93, 163 | # sampled_fraction1 = 0.4, 164 | # sampled_fraction2 = 0.4, 165 | # pars = c(N = 4951500, D = 5, k1 = 1/5, k2 = 1, 166 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 167 | # start_decline = 3, end_decline = 14)) 168 | # 169 | # gg <- lapply(m, function(x) make_projection_plot(list(x), first_date = as.character(min(nz$date)))) 170 | # cowplot::plot_grid(plotlist = gg) 171 | # 172 | # fit2 <- fit_seeiqr(nz$not_overseas_cases, seeiqr_model = model, 173 | # forecast_days = 0, 174 | # R0_prior = c(log(2.5), 0.2), 175 | # chains = 6, 176 | # iter = 130, 177 | # i0 = 1, 178 | # delayShape = 1.48, 179 | # delayScale = 7.93, 180 | # sampled_fraction1 = 0.4, 181 | # sampled_fraction2 = 0.4, 182 | # pars = c(N = 4951500, D = 5, k1 = 1/5, k2 = 1, 183 | # q = 0.05, r = 0.1, ur = 0.02, f1 = 1, 184 | # start_decline = .s, end_decline = .e)) 185 | # print(fit2$fit, pars = c("R0", "f2", "phi")) 186 | 187 | # make_projection_plot(list(fit2), first_date = as.character(min(nz$date))) 188 | -------------------------------------------------------------------------------- /analysis/10-sensitivity.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | # Look at sample fraction scenarios ------------------------------------------- 4 | 5 | sf1 <- tidyr::expand_grid( 6 | sampled_fraction1 = c(0.05), 7 | sampled_fraction2 = c(0.1, 0.2, 0.3) 8 | ) 9 | sf2 <- tidyr::expand_grid( 10 | sampled_fraction1 = c(0.1), 11 | sampled_fraction2 = c(0.2, 0.3, 0.4) 12 | ) 13 | sf <- bind_rows(sf1, sf2) 14 | 15 | m_sf <- purrr::pmap(sf, function(sampled_fraction1, sampled_fraction2) { 16 | fit_seeiqr( 17 | daily_diffs, 18 | chains = 5, iter = 300, save_state_predictions = TRUE, 19 | sampled_fraction1 = sampled_fraction1, 20 | sampled_fraction2 = sampled_fraction2, 21 | seeiqr_model = seeiqr_model 22 | ) 23 | }) 24 | saveRDS(m_sf, file = "data-generated/sf-fit.rds") 25 | m_sf <- readRDS("data-generated/sf-fit.rds") 26 | 27 | purrr::walk(m_sf, ~ print(.x$fit, pars = c("R0", "f2", "phi", "sampFrac2"))) 28 | names(m_sf) <- paste0( 29 | "sampFrac1 = ", sf$sampled_fraction1, 30 | "\nsampFrac2 = ", sf$sampled_fraction2 31 | ) 32 | 33 | g_proj <- make_projection_plot(m_sf) + 34 | facet_grid(rows = vars(Scenario)) 35 | 36 | R0 <- purrr::map_df(m_sf, function(.x) { 37 | data.frame(theta = "R0b", value = .x$post$R0, stringsAsFactors = FALSE) 38 | }, .id = "Scenario") 39 | f2 <- purrr::map_df(m_sf, function(.x) { 40 | data.frame( 41 | theta = "Fraction of normal contacts", 42 | value = .x$post$f2, stringsAsFactors = FALSE 43 | ) 44 | }, .id = "Scenario") 45 | theta_df <- bind_rows(R0, f2) %>% as_tibble() 46 | my_limits <- function(x) if (max(x) < 2) c(0, 1) else c(2.6, 3.5) 47 | g_theta <- ggplot(theta_df, aes(value)) + 48 | facet_grid(Scenario ~ theta, scales = "free") + 49 | geom_histogram( 50 | bins = 50, fill = .hist_blue, 51 | alpha = .7, colour = "grey90", lwd = 0.15 52 | ) + 53 | coord_cartesian(expand = FALSE, ylim = c(0, NA)) + 54 | ylab("") + 55 | scale_x_continuous(limits = my_limits) + 56 | xlab("Parameter value") + 57 | ylab("Density") 58 | 59 | .start <- lubridate::ymd_hms("2020-03-01 00:00:00") 60 | prevalence <- purrr::map_df(m_sf, get_prevalence, .id = "Scenario") 61 | 62 | obj <- m_sf[[1]] 63 | g_prev <- ggplot(prevalence, aes(day, prevalence, group = iterations)) + 64 | annotate("rect", 65 | xmin = .start + lubridate::ddays(obj$last_day_obs), 66 | xmax = .start + lubridate::ddays(obj$last_day_obs + 60), ymin = 0, ymax = Inf, fill = "grey95" 67 | ) + 68 | geom_line(alpha = 0.05, col = .hist_blue) + 69 | ylab("Modelled prevalence") + 70 | facet_grid(rows = vars(Scenario)) + 71 | coord_cartesian(expand = FALSE, xlim = c(.start, .start + lubridate::ddays(obj$last_day_obs + 60)), ylim = c(0, max(prevalence$prevalence) * 1.04)) + 72 | xlab("") 73 | g_prev 74 | 75 | g <- cowplot::plot_grid(g_prev, g_proj, g_theta, 76 | align = "hv", 77 | axis = "bt", rel_widths = c(1.2, 1.2, 2), ncol = 3 78 | ) 79 | 80 | ggsave(paste0("figs-ms/sampFrac-grid-theta-proj.png"), width = 10, height = 8) 81 | ggsave(paste0("figs-ms/sampFrac-grid-theta-proj.pdf"), width = 10, height = 8) 82 | 83 | # More sensitivity tests -------------------------------------------------------------- 84 | 85 | # D=4, k1=1/4, 83% . --- rationale: shorter duration all round, R0 is lower, 86 | # still consistent w data, still consistent message re strength of distancing 87 | # D=6, k1=1/6, 83% --- rationale: longer duration all round, R0 is higher, still 88 | # consistent w data & message about distancing D=5, k=1/5 (which I think are now 89 | # our "default" main text parameters, BUT with 70% (r/(u+r) = 0.7) -- rationale: 90 | # what if we were too optimistic about the portion doing the distancing? how 91 | # sensitive are the results to this choice? 92 | 93 | pars <- c( 94 | N = 5.1e6, D = 5, k1 = 1 / 5, 95 | k2 = 1, q = 0.05, 96 | r = 0.1, ur = 0.02, f1 = 1.0, 97 | start_decline = 15, 98 | end_decline = 22 99 | ) 100 | 101 | pars1 <- pars 102 | pars1[["D"]] <- 4 103 | pars1[["k1"]] <- 1 / 4 104 | 105 | m1 <- fit_seeiqr( 106 | daily_diffs, seed = 1256, 107 | chains = 6, iter = 300, 108 | pars = pars1, save_state_predictions = TRUE, 109 | seeiqr_model = seeiqr_model 110 | ) 111 | 112 | pars2 <- pars 113 | pars2[["D"]] <- 6 114 | pars2[["k1"]] <- 1 / 6 115 | 116 | m2 <- fit_seeiqr( 117 | daily_diffs, 118 | chains = 6, iter = 300, 119 | pars = pars2, save_state_predictions = TRUE, 120 | seeiqr_model = seeiqr_model 121 | ) 122 | 123 | pars3 <- pars 124 | pars3[["D"]] <- 5 125 | pars3[["k1"]] <- 1 / 5 126 | pars3[["ur"]] <- getu(f = 0.7, r = 0.1) # 70% 127 | 128 | m3 <- fit_seeiqr( 129 | daily_diffs, 130 | chains = 6, iter = 300, 131 | pars = pars3, save_state_predictions = TRUE, 132 | seeiqr_model = seeiqr_model 133 | ) 134 | 135 | m_sens <- list(m1, m2, m3) 136 | purrr::walk(m_sens, ~ print(.x$fit, pars = c("R0", "f2", "phi"))) 137 | names(m_sens) <- c( 138 | "D = 4, k1 = 1/4, e = 0.83", 139 | "D = 6, k1 = 1/6, e = 0.83", 140 | "D = 5, k1 = 1/5, e = 0.70" 141 | ) 142 | 143 | get_thresh <- function(.pars) { 144 | fs <- seq(0.25, 1, 0.25) 145 | m_fs <- purrr::map(fs, function(.f) { 146 | fit_seeiqr( 147 | daily_diffs, 148 | pars = .pars, 149 | iter = 200, chains = 1, save_state_predictions = TRUE, 150 | seeiqr_model = seeiqr_model, fixed_f_forecast = .f 151 | ) 152 | }) 153 | slopes <- purrr::map2_df(m_fs, fs, get_prevalence_slope) 154 | mlm <- lm(slope ~ f, data = slopes) 155 | nd <- data.frame(f = seq(0.3, 1, length.out = 5000)) 156 | nd$predicted_slope <- predict(mlm, newdata = nd) 157 | thresh <- dplyr::filter(nd, predicted_slope > 0) %>% `[`(1, "f") 158 | thresh 159 | } 160 | 161 | plan(multisession, workers = parallel::detectCores() / 2) 162 | thresholds <- furrr::future_map_dbl(list(pars1, pars2, pars3), get_thresh) 163 | plan(future::sequential) 164 | saveRDS(thresholds, file = here::here("data-generated/sens1-thresholds.rds")) 165 | thresholds <- readRDS(here::here("data-generated/sens1-thresholds.rds")) 166 | 167 | thresh_df <- tibble(Scenario = names(m_sens), threshold = thresholds) 168 | 169 | R0 <- purrr::map_df(m_sens, function(.x) { 170 | data.frame(theta = "R0b", value = .x$post$R0, stringsAsFactors = FALSE) 171 | }, .id = "Scenario") 172 | f2 <- purrr::map_df(m_sens, function(.x) { 173 | data.frame( 174 | theta = "Fraction of normal contacts", 175 | value = .x$post$f2, stringsAsFactors = FALSE 176 | ) 177 | }, .id = "Scenario") 178 | f2 <- left_join(f2, thresh_df) 179 | 180 | theta_df <- bind_rows(R0, f2) 181 | my_limits <- function(x) if (max(x) < 2) c(0, 1) else range(R0$value) * c(0.98, 1.02) 182 | 183 | g_theta <- ggplot(theta_df, aes(value)) + 184 | facet_grid(Scenario ~ theta, scales = "free") + 185 | geom_histogram(bins = 50, fill = .hist_blue, alpha = .7, colour = "grey90", lwd = 0.15) + 186 | coord_cartesian(expand = FALSE, ylim = c(0, NA)) + 187 | ylab("") + 188 | scale_x_continuous(limits = my_limits) + 189 | xlab("Parameter value") + 190 | ylab("Density") + 191 | geom_vline(aes(xintercept = threshold), lty = 2, col = "grey50") 192 | 193 | g_proj <- make_projection_plot(m_sens) + 194 | facet_grid(rows = vars(Scenario)) 195 | 196 | # prev: 197 | 198 | .start <- lubridate::ymd_hms("2020-03-01 00:00:00") 199 | prevalence <- purrr::map_df(m_sens, get_prevalence, .id = "Scenario") 200 | 201 | obj <- m_sens[[1]] 202 | g_prev <- ggplot(prevalence, aes(day, prevalence, group = iterations)) + 203 | annotate("rect", 204 | xmin = .start + lubridate::ddays(obj$last_day_obs), 205 | xmax = .start + lubridate::ddays(obj$last_day_obs + 60), 206 | ymin = 0, ymax = Inf, fill = "grey95" 207 | ) + 208 | geom_line(alpha = 0.05, col = .hist_blue) + 209 | ylab("Modelled prevalence") + 210 | facet_grid(rows = vars(Scenario)) + 211 | coord_cartesian(expand = FALSE, 212 | xlim = c(.start, .start + lubridate::ddays(obj$last_day_obs + 60)), 213 | ylim = c(0, max(prevalence$prevalence) * 1.04)) + 214 | xlab("") 215 | # g_prev 216 | 217 | g <- cowplot::plot_grid(g_prev, g_proj, g_theta, 218 | align = "hv", 219 | axis = "bt", rel_widths = c(1.2, 1.2, 2), ncol = 3 220 | ) 221 | 222 | ggsave(paste0("figs-ms/sensitivity1-theta-proj.png"), width = 10, height = 6) 223 | ggsave(paste0("figs-ms/sensitivity1-theta-proj.pdf"), width = 10, height = 6) 224 | -------------------------------------------------------------------------------- /analysis/seeiqr.stan: -------------------------------------------------------------------------------- 1 | functions{ 2 | real[] seir(real t, // time (actual time; not an increment starting at 1) 3 | real[] state, // state 4 | real[] theta, // parameters 5 | real[] x_r, // data (real) 6 | int[] x_i) { // data (integer) 7 | real S = state[1]; 8 | real E1 = state[2]; 9 | real E2 = state[3]; 10 | real I = state[4]; 11 | real Q = state[5]; 12 | real R = state[6]; 13 | real Sd = state[7]; 14 | real E1d = state[8]; 15 | real E2d = state[9]; 16 | real Id = state[10]; 17 | real Qd = state[11]; 18 | real Rd = state[12]; 19 | 20 | real R0 = theta[1]; 21 | real f2 = theta[2]; 22 | 23 | real N = x_r[1]; 24 | real D = x_r[2]; 25 | real k1 = x_r[3]; 26 | real k2 = x_r[4]; 27 | real q = x_r[5]; 28 | real r = x_r[6]; 29 | real ur = x_r[7]; 30 | real f1 = x_r[8]; 31 | real start_decline = x_r[9]; 32 | real end_decline = x_r[10]; 33 | real fixed_f_forecast = x_r[11]; 34 | real last_day_obs = x_r[12]; 35 | real day_start_fixed_f_forecast = x_r[13]; 36 | 37 | real dydt[12]; 38 | 39 | real f; 40 | 41 | f = f1; 42 | if (t < start_decline) { 43 | f = f1; 44 | } 45 | if (t >= start_decline && t < end_decline) { 46 | f = f2 + (end_decline - t) * (f1 - f2) / (end_decline - start_decline); 47 | } 48 | if (t >= end_decline) { 49 | f = f2; 50 | } 51 | if (t >= day_start_fixed_f_forecast && fixed_f_forecast != 0) { 52 | f = fixed_f_forecast; 53 | } 54 | 55 | dydt[1] = -(R0/(D+1/k2)) * (I + E2 + f*(Id+E2d)) * S/N - r*S + ur*Sd; 56 | dydt[2] = (R0/(D+1/k2)) * (I + E2 + f*(Id+E2d)) * S/N - k1*E1 -r*E1 + ur*E1d; 57 | dydt[3] = k1*E1 - k2*E2 - r*E2 + ur*E2d; 58 | dydt[4] = k2*E2 - q*I - I/D - r*I + ur*Id; 59 | dydt[5] = q*I - Q/D - r*Q + ur*Qd; 60 | dydt[6] = I/D + Q/D - r*R + ur*Rd; 61 | 62 | dydt[7] = -(f*R0/(D+1/k2)) * (I+E2 + f*(Id+E2d)) * Sd/N + r*S - ur*Sd; 63 | dydt[8] = (f*R0/(D+1/k2)) * (I+E2 + f*(Id+E2d)) * Sd/N - k1*E1d +r*E1 - ur*E1d; 64 | dydt[9] = k1*E1d - k2*E2d + r*E2 - ur*E2d; 65 | dydt[10] = k2*E2d - q*Id - Id/D + r*I - ur*Id; 66 | dydt[11] = q*Id - Qd/D + r*Q - ur*Qd; 67 | dydt[12] = Id/D + Qd/D + r*R - ur*Rd; 68 | 69 | return dydt; 70 | } 71 | } 72 | data { 73 | int T; // number of time steps 74 | int N; // number of days 75 | real y0[12]; // initial state 76 | real t0; // first time step 77 | real time[T]; // time increments 78 | int days[N]; // day increments 79 | int last_day_obs; // last day of observed data; days after this are projections 80 | int daily_cases[last_day_obs]; // daily new case counts 81 | real x_r[13]; // data for ODEs (real numbers) 82 | real sampFrac[N]; // fraction of cases sampled per time step 83 | real delayScale; // Weibull parameter for delay in becoming a case count 84 | real delayShape; // Weibull parameter for delay in becoming a case count 85 | int time_day_id[N]; // last time increment associated with each day 86 | int time_day_id0[N];// first time increment for Weibull integration of case counts 87 | real R0_prior[2]; // lognormal log mean and SD for R0 prior 88 | real phi_prior; // SD of normal prior on 1/sqrt(phi) [NB2(mu, phi)] 89 | real f2_prior[2]; // beta prior for f2 90 | int day_inc_sampling; // day to switch to sampFrac2 91 | real sampFrac2_prior[2]; // beta prior for sampFrac2 92 | int priors_only; // logical: include likelihood or just priors? 93 | int est_phi; // estimate NB phi? 94 | int n_sampFrac2; // number of sampFrac2 95 | int obs_model; // observation model: 0 = Poisson, 1 = NB2 96 | real rw_sigma; 97 | int tests[N]; 98 | real ode_control[3]; 99 | int N_lik; // number of days in the likelihood 100 | int dat_in_lik[N_lik]; // vector of data to include in the likelihood 101 | } 102 | transformed data { 103 | int x_i[0]; // empty; needed for ODE function 104 | } 105 | parameters { 106 | real R0; // Stan ODE solver seems to be more efficient without this bounded at > 0 107 | real f2; // strength of social distancing 108 | real phi[est_phi]; // NB2 (inverse) dispersion; `est_phi` turns on/off 109 | real sampFrac2[n_sampFrac2]; 110 | } 111 | transformed parameters { 112 | real meanDelay = delayScale * tgamma(1 + 1 / delayShape); 113 | real dx = time[2] - time[1]; // time increment 114 | real ft[T]; 115 | real lambda_d[N]; 116 | real sum_ft_inner; 117 | real eta[N]; // expected value on link scale (log) 118 | real k2; 119 | real E2; 120 | real E2d; 121 | real theta[2]; 122 | real y_hat[T,12]; 123 | real this_samp; 124 | real alpha[N]; // 1st shape parameter for the beta distribution 125 | real beta[N]; // 2nd shape parameter for the beta distribution 126 | theta[1] = R0; 127 | theta[2] = f2; 128 | 129 | y_hat = integrate_ode_rk45(seir, y0, t0, time, theta, x_r, x_i, ode_control[1], ode_control[2], ode_control[3]); 130 | 131 | for (n in 1:N) { 132 | this_samp = sampFrac[n]; 133 | if (n_sampFrac2 > 1) { 134 | if (n >= day_inc_sampling && n <= last_day_obs) { 135 | this_samp = sampFrac2[n - day_inc_sampling + 1]; 136 | } 137 | if (n >= day_inc_sampling && n > last_day_obs) { 138 | this_samp = sampFrac2[n_sampFrac2]; // forecast with last value 139 | } 140 | } 141 | if (n_sampFrac2 == 1) { 142 | this_samp = sampFrac2[1]; 143 | } 144 | for (t in 1:T) { 145 | ft[t] = 0; // initialize at 0 across the full 1:T 146 | } 147 | for (t in time_day_id0[n]:time_day_id[n]) { // t is an increment here 148 | k2 = x_r[4]; 149 | E2 = y_hat[t,3]; 150 | E2d = y_hat[t,9]; 151 | 152 | ft[t] = this_samp * k2 * (E2 + E2d) * 153 | exp(weibull_lpdf(time[time_day_id[n]] - time[t] | delayShape, delayScale)); 154 | } 155 | sum_ft_inner = 0; 156 | for (t in (time_day_id0[n] + 1):(time_day_id[n] - 1)) { 157 | sum_ft_inner += ft[t]; 158 | } 159 | lambda_d[n] = 0.5 * dx * 160 | (ft[time_day_id0[n]] + 2 * sum_ft_inner + ft[time_day_id[n]]); 161 | eta[n] = log(lambda_d[n]); 162 | } 163 | 164 | if (obs_model == 2) { // Beta-Binomial 165 | for (n in 1:N) { 166 | eta[n] = inv_logit(exp(eta[n])); 167 | alpha[n] = eta[n] * phi[1]; 168 | beta[n] = (1 - eta[n]) * phi[1]; 169 | } 170 | } else { 171 | for (n in 1:N) { 172 | alpha[n] = 0; 173 | beta[n] = 0; 174 | } 175 | } 176 | 177 | } 178 | model { 179 | // priors: 180 | if (est_phi && obs_model == 1) { // NB2 181 | // https://github.com/stan-dev/stan/wiki/Prior-Choice-Recommendations 182 | // D(expression(1/sqrt(x)), "x"); log(0.5 * x^-0.5/sqrt(x)^2 183 | 1/sqrt(phi[1]) ~ normal(0, phi_prior); 184 | target += log(0.5) - 1.5 * log(phi[1]); // Jacobian adjustment 185 | } 186 | if (est_phi && obs_model == 2) { // Beta-Binomial 187 | phi[1] ~ normal(0, phi_prior); 188 | } 189 | R0 ~ lognormal(R0_prior[1], R0_prior[2]); 190 | f2 ~ beta(f2_prior[1], f2_prior[2]); 191 | if (n_sampFrac2 > 0) { 192 | sampFrac2[1] ~ beta(sampFrac2_prior[1], sampFrac2_prior[2]); 193 | if (n_sampFrac2 > 1) { 194 | for (n in 2:n_sampFrac2) { 195 | sampFrac2[n] ~ normal(sampFrac2[n-1], rw_sigma); // RW 196 | } 197 | } 198 | } 199 | 200 | // data likelihood: 201 | if (!priors_only) { 202 | if (obs_model == 0) { 203 | daily_cases[dat_in_lik] ~ poisson_log(eta[dat_in_lik]); 204 | } else if (obs_model == 1) { 205 | daily_cases[dat_in_lik] ~ neg_binomial_2_log(eta[dat_in_lik], phi[1]); 206 | } else { 207 | daily_cases[dat_in_lik] ~ beta_binomial(tests[dat_in_lik], alpha[dat_in_lik], beta[dat_in_lik]); 208 | } 209 | } 210 | } 211 | generated quantities{ 212 | int y_rep[N]; // posterior predictive replicates 213 | for (n in 1:N) { 214 | if (obs_model == 0) { 215 | y_rep[n] = poisson_log_rng(eta[n]); 216 | } else if (obs_model == 1) { 217 | y_rep[n] = neg_binomial_2_log_rng(eta[n], phi[1]); 218 | } else { 219 | y_rep[n] = beta_binomial_rng(tests[n], alpha[n], beta[n]); 220 | } 221 | } 222 | } 223 | 224 | -------------------------------------------------------------------------------- /analysis/functions_sir.R: -------------------------------------------------------------------------------- 1 | #' Lambda_d: returns expected number of cases on day d 2 | #' @author Caroline Colijn, Jessica Stockdale 3 | getlambd <- function(out, 4 | pars, 5 | day, 6 | data = bcdata, 7 | sampFrac = 0.1, 8 | delayShape = 1.73, 9 | delayScale = 9.85) { 10 | meanDelay <- delayScale * gamma(1 + 1 / delayShape) 11 | try(if (var(diff(out$time)) > 0.005) { 12 | stop("approx integral assumes equal time steps") 13 | }) 14 | try(if (max(out$time) < day) { 15 | stop("model simulation is not long enough for the data") 16 | }) 17 | try(if (min(out$time) > day - (2 * meanDelay + 1)) { 18 | stop("we need an earlier start time for the model") 19 | }) 20 | # relevant times to identify new cases 21 | ii <- which(out$time > day - 45 & out$time <= day) 22 | dx <- out$time[ii[2]] - out$time[ii[1]] # assumes equal time intervals 23 | # all new cases arising at each of those times 24 | incoming <- with(pars, { 25 | k2 * (out$E2[ii] + out$E2d[ii]) 26 | }) 27 | march15_modelform <- data$day[which(data$Date == as.Date("2020-03-14"))] 28 | thisSamp <- ifelse(day < march15_modelform, 29 | sampFrac, 30 | sampFrac * pars$ratio 31 | ) 32 | # each of the past times' contribution to this day's case count 33 | ft <- thisSamp * incoming * dweibull( 34 | x = max(out$time[ii]) - out$time[ii], 35 | shape = delayShape, 36 | scale = delayScale 37 | ) 38 | # return numerical integral of ft 39 | return(0.5 * (dx) * (ft[1] + 2 * sum(ft[2:(length(ft) - 1)]) + ft[length(ft)])) 40 | } 41 | 42 | #' @title Social Distancing Model 43 | #' @author Caroline Colijn 44 | #' @description SEIR-type model with time-dependent social distancing. Social 45 | #' distancing reduces frequency of contact. Individuals can move between 46 | #' distanced and not distanced compartments. 47 | #' @param t time 48 | #' @param state (S, E1, E2, I, Q, R, Sd, E1d, E2d, Id, Qd, Rd) S: Susceptible, 49 | #' E1: Exposed but not infectious, E2: Exposed and Infectious, I: Infectious, 50 | #' can be quarantined, R: Removed. The d compartments denote socially 51 | #' distanced individuals. 52 | #' @param pars (N, D, R0, k1, k2, q, r, ur, f) f: strength of social distancing, 53 | #' r/(r+ur): frac of population who are distancing 54 | #' @param sdtiming timing of social distancing 55 | #' @return time derivatives for input to ODE solver 56 | socdistmodel <- function(t, 57 | state, 58 | parms, 59 | sdtiming) { 60 | with(as.list(c( 61 | state, 62 | parms 63 | )), { 64 | f <- sdtiming(t, f1 = parms$f1, f2 = parms$f2) 65 | dSdt <- -(R0 / (D + 1 / k2)) * (I + E2 + f * (Id + E2d)) * S / N - r * S + ur * Sd 66 | dE1dt <- (R0 / (D + 1 / k2)) * (I + E2 + f * (Id + E2d)) * S / N - k1 * E1 - r * E1 + ur * E1d 67 | dE2dt <- k1 * E1 - k2 * E2 - r * E2 + ur * E2d 68 | dIdt <- k2 * E2 - q * I - I / D - r * I + ur * Id 69 | dQdt <- q * I - Q / D - r * Q + ur * Qd 70 | dRdt <- I / D + Q / D - r * R + ur * Rd 71 | 72 | dSddt <- -(f * R0 / (D + 1 / k2)) * (I + E2 + f * (Id + E2d)) * Sd / N + r * S - ur * Sd 73 | dE1ddt <- (f * R0 / (D + 1 / k2)) * (I + E2 + f * (Id + E2d)) * Sd / N - k1 * E1d + r * E1 - ur * E1d 74 | dE2ddt <- k1 * E1d - k2 * E2d + r * E2 - ur * E2d 75 | dIddt <- k2 * E2d - q * Id - Id / D + r * I - ur * Id 76 | dQddt <- q * Id - Qd / D + r * Q - ur * Qd 77 | dRddt <- Id / D + Qd / D + r * R - ur * Rd 78 | list(c( 79 | dSdt, 80 | dE1dt, 81 | dE2dt, 82 | dIdt, 83 | dQdt, 84 | dRdt, 85 | dSddt, 86 | dE1ddt, 87 | dE2ddt, 88 | dIddt, 89 | dQddt, 90 | dRddt 91 | )) 92 | }) 93 | } 94 | 95 | #' Linear decrease in f between two time points 96 | #' @author Andrew Edwards 97 | sdtiming_gradual <- function(t, 98 | start_decline = 15, # start the decline the next day 99 | end_decline = 22, # end decline at f2 100 | f1 = pars$f1, # f value before decline 101 | f2 = pars$f2) { # f value after decline 102 | if (t < start_decline) { 103 | return(f1) 104 | } 105 | if (t >= start_decline & t < end_decline) { 106 | return(f2 + (end_decline - t) * (f1 - f2) / (end_decline - start_decline)) 107 | } 108 | if (t >= end_decline) { 109 | return(f2) 110 | } 111 | } 112 | 113 | reproject_fits <- function(.R0, .f2, .phi, .i, obj, .sdfunc = sdtiming_gradual, 114 | .time = NULL, return_ode_dat = FALSE, pars = list( 115 | N = 5.1e6, 116 | D = 5, 117 | R0 = 2.6, 118 | k1 = 1 / 5, 119 | k2 = 1, 120 | q = 0.05, 121 | r = 0.1, 122 | ur = 0.02, 123 | f1 = 1.0, 124 | f2 = 0.4, 125 | ratio = 0.3 / 0.1 # 2nd stage sampFrac 126 | )) { 127 | .pars <- pars 128 | .pars$R0 <- .R0 129 | .pars$f2 <- .f2 130 | if (is.null(.time)) { 131 | .time <- obj$time 132 | } 133 | max_day <- max(.time) 134 | .d <- as.data.frame(deSolve::ode( 135 | y = obj$state_0, 136 | times = .time, 137 | func = socdistmodel, 138 | parms = .pars, 139 | method = "rk4", 140 | sdtiming = .sdfunc 141 | )) 142 | dat <- data.frame( 143 | Date = seq(lubridate::ymd("2020-03-01"), 144 | lubridate::ymd("2020-03-01") + max_day, 145 | by = "day" 146 | ) 147 | ) 148 | dat$day <- seq_along(dat$Date) 149 | mu <- purrr::map_dbl(seq(1, max_day), function(x) { 150 | getlambd(.d, pars = .pars, data = dat, day = x) 151 | }) 152 | out <- data.frame( 153 | day = seq(1, max_day), 154 | lambda_d = mu, 155 | y_rep = MASS::rnegbin(max_day, mu, theta = .phi), 156 | iterations = .i, 157 | R0 = .R0, f2 = .f2, phi = .phi 158 | ) 159 | if (return_ode_dat) { 160 | return(dplyr::mutate(.d, iterations = .i)) 161 | } else { 162 | return(out) 163 | } 164 | } 165 | 166 | write_tex <- function(x, macro, ...) { 167 | paste0("\\newcommand{\\", macro, "}{", x, "}") %>% 168 | readr::write_lines("figs-ms/values.tex", append = TRUE) 169 | } 170 | 171 | get_prevalence_slope <- function(obj, f_val) { 172 | post <- obj$post 173 | variables_df <- dplyr::tibble( 174 | variable = names(obj$state_0), 175 | variable_num = seq_along(obj$state_0) 176 | ) 177 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 178 | states <- reshape2::melt(post$y_hat) %>% 179 | dplyr::rename(time_num = Var2, variable_num = Var3) %>% 180 | dplyr::left_join(variables_df, by = "variable_num") %>% 181 | dplyr::left_join(ts_df, by = "time_num") %>% 182 | as_tibble() 183 | temp <- states %>% 184 | dplyr::filter(time > max(states$time) - 30, variable %in% c("I", "Id")) %>% 185 | group_by(iterations, time) %>% 186 | summarize( 187 | I = value[variable == "I"], Id = value[variable == "Id"], 188 | prevalence = I + Id 189 | ) 190 | iters <- temp %>% 191 | group_by(iterations) %>% 192 | summarise(iter = iterations[[1]]) 193 | temp %>% 194 | group_by(iterations) %>% 195 | group_split() %>% 196 | purrr::map(~ lm(log(prevalence) ~ time, data = .x)) %>% 197 | purrr::map_df(~ tibble(slope = coef(.x)[[2]])) %>% 198 | mutate(f = f_val) %>% 199 | ungroup() %>% 200 | mutate(iterations = iters$iter) 201 | } 202 | 203 | get_prevalence <- function(obj, draws = 1:100, 204 | start = lubridate::ymd_hms("2020-03-01 00:00:00")) { 205 | post <- obj$post 206 | 207 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 208 | variables_df <- dplyr::tibble( 209 | variable = names(obj$state_0), 210 | variable_num = seq_along(obj$state_0) 211 | ) 212 | if (!"y_hat" %in% names(post)) { 213 | stop("`obj` must be run with `save_state_predictions = TRUE`") 214 | } 215 | states <- reshape2::melt(post$y_hat) %>% 216 | dplyr::rename(time_num = Var2, variable_num = Var3) %>% 217 | dplyr::filter(iterations %in% draws) %>% 218 | dplyr::left_join(variables_df, by = "variable_num") %>% 219 | dplyr::left_join(ts_df, by = "time_num") 220 | prevalence <- states %>% 221 | dplyr::filter(variable %in% c("I", "Id")) %>% 222 | group_by(iterations, time) %>% 223 | summarize( 224 | I = value[variable == "I"], Id = value[variable == "Id"], 225 | prevalence = I + Id 226 | ) %>% 227 | mutate(day = start + lubridate::ddays(time), start = start) 228 | prevalence 229 | } 230 | 231 | getu <- function(f, r) (r - f*r) / f 232 | -------------------------------------------------------------------------------- /analysis/20-plot-other-regions.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(dplyr) 3 | library(here) 4 | theme_set(ggsidekick::theme_sleek()) 5 | # library(future) 6 | # plan(multisession, workers = 2) 7 | ymd <- lubridate::ymd 8 | 9 | set.seed(1029) 10 | iter <- sample(1:1000, 500) 11 | ny_fit <- readRDS(here("data-generated/new-york-fit.rds")) 12 | ny_dat <- readRDS(here("data-generated/new-york-dat.rds")) 13 | ny_prd <- covidseir::project_seir(ny_fit, forecast_days = 0, iter = iter) 14 | 15 | fl_fit <- readRDS(here("data-generated/florida-fit.rds")) 16 | fl_dat <- readRDS(here("data-generated/florida-dat.rds")) 17 | fl_prd <- covidseir::project_seir(fl_fit, forecast_days = 0, iter = iter) 18 | 19 | wa_fit <- readRDS(here("data-generated/washington-fit.rds")) 20 | wa_dat <- readRDS(here("data-generated/washington-dat.rds")) 21 | wa_prd <- covidseir::project_seir(wa_fit, forecast_days = 0, iter = iter) 22 | 23 | nz_fit <- readRDS(here("data-generated/nz-fit.rds")) 24 | nz_dat <- readRDS(here("data-generated/nz-dat.rds")) 25 | nz_prd <- covidseir::project_seir(nz_fit, forecast_days = 0, iter = iter) 26 | 27 | ca_fit <- readRDS(here("data-generated/california-fit.rds")) 28 | ca_dat <- readRDS(here("data-generated/california-dat.rds")) 29 | ca_prd <- covidseir::project_seir(ca_fit, forecast_days = 0, iter = 1:250) 30 | 31 | save(ny_prd, fl_prd, wa_prd, nz_prd, ca_prd, 32 | file = here("data-generated/other-region-projections.rda")) 33 | load(here("data-generated/other-region-projections.rda")) 34 | 35 | purrr::walk(list(ny_fit, fl_fit, wa_fit, nz_fit, ca_fit), print) 36 | 37 | source(here("analysis/get_thresh_covidseir.R")) 38 | ny_thr <- get_thresh_covidseir(ny_fit, forecast_days = 30, 39 | fs = seq(0.2, 0.6, length.out = 5)) 40 | fl_thr <- get_thresh_covidseir(fl_fit, forecast_days = 30, 41 | fs = seq(0.2, 0.7, length.out = 5)) 42 | wa_thr <- get_thresh_covidseir(wa_fit, forecast_days = 30, 43 | fs = seq(0.2, 0.7, length.out = 5)) 44 | nz_thr <- get_thresh_covidseir(nz_fit, forecast_days = 30, 45 | fs = seq(0.2, 0.7, length.out = 5)) 46 | ca_thr <- get_thresh_covidseir(ca_fit, forecast_days = 30, 47 | fs = seq(0.2, 0.7, length.out = 5)) 48 | save(ny_thr, fl_thr, wa_thr, nz_thr, ca_thr, 49 | file = here("data-generated/other-region-thresholds.rda")) 50 | load(here("data-generated/other-region-thresholds.rda")) 51 | 52 | mean(ny_fit$post$f_s[,1] < ny_thr) 53 | mean(fl_fit$post$f_s[,1] < fl_thr) 54 | mean(wa_fit$post$f_s[,1] < wa_thr) 55 | mean(ca_fit$post$f_s[,1] < ca_thr) 56 | mean(nz_fit$post$f_s[,1] < nz_thr) 57 | 58 | q <- list() 59 | q[[1]] <- quantile(ny_fit$post$f_s[,1] / ny_thr, probs = c(0.05, 0.5, 0.95)) 60 | q[[2]] <- quantile(fl_fit$post$f_s[,1] / fl_thr, probs = c(0.05, 0.5, 0.95)) 61 | q[[3]] <- quantile(wa_fit$post$f_s[,1] / wa_thr, probs = c(0.05, 0.5, 0.95)) 62 | q[[4]] <- quantile(ca_fit$post$f_s[,1] / ca_thr, probs = c(0.05, 0.5, 0.95)) 63 | q[[5]] <- quantile(nz_fit$post$f_s[,1] / nz_thr, probs = c(0.05, 0.5, 0.95)) 64 | 65 | m_bc <- readRDS(here::here("data-generated/main-fit-2000.rds")) 66 | threshold_bc <- readRDS(here::here("data-generated/BC-threshold.rds")) 67 | 68 | q[[6]] <- quantile(m_bc$post$f2 / threshold_bc, probs = c(0.05, 0.5, 0.95)) 69 | 70 | names(q) <- c("NY", "FL", "WA", "CA", "NZ", "BC") 71 | 72 | source(here::here("analysis/functions_sir.R")) 73 | purrr::walk(seq_along(q), function(.x) { 74 | write_tex(sprintf("%.2f", round(q[[.x]][[1]], 2)), 75 | paste0(names(q)[.x], "lwrRatio")) 76 | write_tex(sprintf("%.2f", round(q[[.x]][[2]], 2)), 77 | paste0(names(q)[.x], "medRatio")) 78 | write_tex(sprintf("%.2f", round(q[[.x]][[3]], 2)), 79 | paste0(names(q)[.x], "uprRatio")) 80 | }) 81 | 82 | 83 | cols <- RColorBrewer::brewer.pal(n = 6, "Dark2")[-(5)] 84 | regions <- c("New Zealand", "California" , "Florida" , "New York", "Washington") 85 | names(cols) <- regions 86 | 87 | add_label <- function(letter, region, ymax) { 88 | list(cowplot::draw_label(letter, x = ymd("2020-03-03"), 89 | y = ymax * .88, hjust = 0, vjust = 0, fontface = "bold", size = 12), 90 | cowplot::draw_label(region, x = ymd("2020-03-08") + 0.5, 91 | y = ymax * .88, hjust = 0, vjust = 0,fontface = "plain", size = 10)) 92 | } 93 | 94 | source(here("analysis/plot_projection_w_inset.R")) 95 | ymax <- 22000 96 | ny_g <- plot_projection_w_inset( 97 | ny_prd, ny_dat, ny_fit, ylim = c(0, ymax), col = cols[["New York"]]) + 98 | add_label("A", "New York", ymax) + 99 | theme(axis.text.x.bottom = element_blank()) 100 | # ny_g 101 | 102 | ymax <- 2000 103 | fl_g <- plot_projection_w_inset( 104 | fl_prd, fl_dat, fl_fit, ylim = c(0, ymax), col = cols[["Florida"]]) + 105 | add_label("B", "Florida", ymax) + 106 | theme(axis.title.y = element_blank())+ 107 | theme(axis.text.x.bottom = element_blank()) 108 | # fl_g 109 | 110 | ymax <- 700 111 | wa_g <- plot_projection_w_inset( 112 | wa_prd, wa_dat, wa_fit, ylim = c(0, ymax), col = cols[["Washington"]]) + 113 | # coord_cartesian(expand = FALSE, 114 | # xlim = c(min(ny_dat$date), max(wa_dat$date)), ylim = c(0, ymax)) + 115 | add_label("C", "Washington", ymax)+ 116 | theme(axis.title.y = element_blank())+ 117 | theme(axis.text.x.bottom = element_blank()) 118 | # wa_g 119 | 120 | ymax <- 60 121 | nz_g <- plot_projection_w_inset( 122 | nz_prd, nz_dat, nz_fit, ylim = c(0, ymax), col = cols[["New Zealand"]]) + 123 | coord_cartesian(expand = FALSE, 124 | xlim = c(ymd("2020-03-01"), max(wa_dat$date)), ylim = c(0, ymax)) + 125 | add_label("E", "New Zealand", ymax) + 126 | theme(axis.title.y = element_blank()) 127 | # nz_g 128 | 129 | ymax <- 3500 130 | ca_g <- plot_projection_w_inset( 131 | ca_prd, ca_dat, ca_fit, ylim = c(0, ymax), col = cols[["California"]]) + 132 | add_label("D", "California", ymax) 133 | # ca_g 134 | 135 | # Google data: 136 | if (!file.exists(here("data-generated/google-mobility.rds"))) { 137 | goog_dat <- readr::read_csv( 138 | "https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv?cachebust=722f3143b586a83f") 139 | saveRDS(goog_dat, file = here("data-generated/google-mobility.rds")) 140 | } else { 141 | goog_dat <- readRDS(here("data-generated/google-mobility.rds")) 142 | } 143 | goog_dat$date <- lubridate::ymd(goog_dat$date) 144 | goog_dat <- dplyr:::filter(goog_dat, 145 | country_region == "New Zealand" | sub_region_1 %in% 146 | c("Washington", "California", "New York", "Florida")) 147 | goog_dat <- dplyr::filter(goog_dat, date >= lubridate::ymd("2020-03-01")) 148 | goog_dat <- goog_dat %>% 149 | mutate(region = ifelse(country_region == "New Zealand", 150 | country_region, sub_region_1)) 151 | 152 | # get daily means 153 | goog_dat <- goog_dat %>% 154 | group_by(date, region) %>% 155 | mutate(MeanTransit = mean(transit_stations_percent_change_from_baseline, na.rm = TRUE)) %>% 156 | mutate(MeanWorkplace = mean(workplaces_percent_change_from_baseline, na.rm = TRUE)) %>% 157 | mutate(MeanRec = mean(retail_and_recreation_percent_change_from_baseline, na.rm = TRUE)) 158 | 159 | # # Just transit, using mean 160 | # ggplot(goog_dat, aes(date, MeanTransit, group = region, col = region)) + 161 | # geom_smooth(method = "gam", se = FALSE) + 162 | # geom_line(alpha = 0.5) + 163 | # labs(y = "% change from baseline", x = "") + 164 | # theme_minimal() + 165 | # scale_color_brewer(palette = "Dark2") 166 | 167 | half_line <- 11/2 168 | goog_panel <- 169 | ggplot(goog_dat, aes(date, transit_stations_percent_change_from_baseline, 170 | group = region, col = region)) + 171 | geom_smooth(method = "gam", se = FALSE) + 172 | geom_line(aes(date, MeanTransit), alpha = 0.5) + 173 | labs(y = "% from baseline", x = "") + 174 | ggsidekick::theme_sleek() + 175 | scale_colour_manual(values = cols) + 176 | theme(legend.position = "none") + 177 | theme(axis.title.x.bottom = element_blank(), 178 | plot.margin = 179 | margin(t = 5, r = 1.5, b = -8, l = -3), 180 | axis.title.y = element_text(angle = 90, 181 | margin = margin(r = 2), vjust = 1, size = 10) 182 | ) + 183 | scale_x_date(date_breaks = "1 month", date_labels = "%b %d") + 184 | scale_y_continuous(breaks = c(0, -20, -40, -60, -80), labels = function(x) x/1) + 185 | coord_cartesian(expand = FALSE, xlim = c(ymd("2020-03-01"), max(ny_dat$date)), ylim = c(-95, 25)) + 186 | add_label("F", "Google transit station", 12) 187 | # goog_panel 188 | 189 | g <- cowplot::plot_grid( 190 | ny_g, 191 | fl_g, 192 | wa_g, 193 | ca_g, 194 | nz_g, 195 | goog_panel, 196 | ncol = 3, align = "hv", axis = "lbtr") + 197 | cowplot::draw_text("Reported cases", x = 0.011, y = 0.5, angle = 90, size = 10, col = "grey30") + 198 | theme(axis.title.x.bottom = element_blank(), 199 | plot.margin = 200 | margin(t = 2, r = 4, b = 15, l = 1)) 201 | # g 202 | 203 | .width <- 0.115 204 | .height = 0.24 205 | 206 | xgap <- 0.333 207 | .x1 <- 0.075 208 | .x2 <- .x1 + xgap 209 | .x3 <- .x2 + xgap 210 | 211 | .y2 <- 0.695 212 | .y1 <- 0.19 213 | 214 | g1 <- g + 215 | cowplot::draw_plot(f2_plot(ny_fit, ny_thr, col = cols[["New York"]]), 216 | x = .x1, y = .y2, width = .width, height = .height) + 217 | cowplot::draw_plot(f2_plot(fl_fit, fl_thr, col = cols[["Florida"]]), 218 | x = .x2, y = .y2, width = .width, height = .height) + 219 | cowplot::draw_plot(f2_plot(wa_fit, wa_thr, col = cols[["Washington"]]), 220 | x = .x3 + 0.146, y = .y2 + 0.05, width = .width, height = .height) + 221 | cowplot::draw_plot(f2_plot(ca_fit, ca_thr, col = cols[["California"]]), 222 | x = .x1, y = .y1, width = .width, height = .height) + 223 | cowplot::draw_plot(f2_plot(nz_fit, nz_thr, col = cols[["New Zealand"]]), 224 | x = .x2 + 0.146, y = .y1 + 0.0, width = .width, height = .height) 225 | 226 | ggsave(here("figs-ms/other-regions.pdf"), width = 7.2, height = 3.3) 227 | ggsave(here("figs-ms/other-regions.png"), width = 7.2, height = 3.3, dpi = 400) 228 | -------------------------------------------------------------------------------- /analysis/make_quick_plots.R: -------------------------------------------------------------------------------- 1 | make_quick_plots <- function(obj, id = "", ext = ".pdf", first_date = "2020-03-01") { 2 | post <- obj$post 3 | fit <- obj$fit 4 | 5 | actual_dates <- seq(lubridate::ymd(first_date), 6 | lubridate::ymd(first_date) + max(obj$days), by = "1 day") 7 | 8 | fit_array <- as.array(fit) 9 | if ("phi" %in% names(post)) { 10 | g <- bayesplot::mcmc_trace(fit_array, pars = c("R0", "f2", "phi[1]")) 11 | } else { 12 | g <- bayesplot::mcmc_trace(fit_array, pars = c("R0", "f2")) 13 | } 14 | ggsave(paste0("figs/traceplot", id, ext), width = 6, height = 3) 15 | 16 | R0 <- post$R0 17 | .x <- seq(2, 3.2, length.out = 200) 18 | breaks <- seq(min(.x), max(.x), 0.02) 19 | g1 <- ggplot(tibble(R0 = R0)) + 20 | geom_ribbon( 21 | data = tibble(R0 = .x, 22 | density = dlnorm(.x, obj$R0_prior[1], obj$R0_prior[2])), 23 | aes(x = R0, ymin = 0, ymax = density), alpha = 0.5, colour = "grey50", 24 | fill = "grey50" 25 | ) + 26 | ylab("Probability density") + 27 | geom_histogram( 28 | breaks = breaks, aes(x = R0, y = ..density..), 29 | fill = "blue", alpha = 0.5 30 | ) + 31 | coord_cartesian(xlim = range(.x), expand = FALSE) 32 | 33 | f2 <- post$f2 34 | .x <- seq(0, 1, length.out = 200) 35 | breaks <- seq(min(.x), max(.x), 0.03) 36 | g2 <- ggplot(tibble(f2 = f2)) + 37 | geom_ribbon( 38 | data = tibble(f2 = .x, 39 | density = dbeta(.x, obj$f2_prior_beta_shape1, obj$f2_prior_beta_shape2)), 40 | aes(x = f2, ymin = 0, ymax = density), alpha = 0.5, colour = "grey50", 41 | fill = "grey50" 42 | ) + 43 | geom_histogram( 44 | breaks = breaks, aes(x = f2, y = ..density..), 45 | fill = "blue", alpha = 0.5 46 | ) + 47 | ylab("Probability density") + 48 | coord_cartesian(xlim = range(.x), expand = FALSE) + 49 | xlab("Social distancing effect") + 50 | scale_x_continuous(breaks = seq(0, 1, 0.2)) 51 | 52 | if (obj$stan_data$n_sampFrac2 == 1) { 53 | sampFrac2 <- post$sampFrac2 54 | .x <- seq(0, 1, length.out = 200) 55 | breaks <- seq(min(.x), max(.x), 0.03) 56 | g5 <- ggplot(tibble(sampFrac2 = sampFrac2)) + 57 | geom_ribbon( 58 | data = tibble(sampFrac2 = .x, 59 | density = dbeta(.x, obj$stan_data$sampFrac2_prior[1], obj$stan_data$sampFrac2_prior[2])), 60 | aes(x = sampFrac2, ymin = 0, ymax = density), alpha = 0.5, colour = "grey50", 61 | fill = "grey50" 62 | ) + 63 | geom_histogram( 64 | breaks = breaks, aes(x = sampFrac2, y = ..density..), 65 | fill = "blue", alpha = 0.5 66 | ) + 67 | ylab("Probability density") + 68 | coord_cartesian(xlim = range(.x), expand = FALSE) + 69 | xlab("Fraction sampled") + 70 | scale_x_continuous(breaks = seq(0, 1, 0.2)) 71 | ggsave(paste0("figs/sampFrac2", id, ext), width = 6, height = 4) 72 | } 73 | 74 | if ("phi" %in% names(post)) { 75 | phi_hat <- post$phi[, 1] 76 | .x <- seq(0.001, 100, length.out = 20000) 77 | breaks <- seq(0, 9, 0.2) 78 | g3 <- ggplot(tibble(phi = phi_hat)) + 79 | geom_ribbon( 80 | data = tibble(phi = 1/sqrt(.x), 81 | density = dnorm(.x, 0, obj$phi_prior)), 82 | aes(x = phi, ymin = 0, ymax = density), 83 | alpha = 0.5, colour = "grey50", fill = "grey50" 84 | ) + 85 | ylab("Probability density") + 86 | geom_histogram( 87 | breaks = breaks, aes(x = phi, y = ..density..), 88 | fill = "blue", alpha = 0.5 89 | ) + 90 | coord_cartesian(expand = FALSE, xlim = c(0, 9)) 91 | # ggsave(paste0("figs/phi", id, ext), width = 6, height = 4) 92 | cowplot::plot_grid(g1, g2, ncol = 1) 93 | ggsave(paste0("figs/theta", id, ext), width = 4, height = 5.5) 94 | } else { 95 | cowplot::plot_grid(g1, g2, ncol = 1) 96 | ggsave(paste0("figs/theta", id, ext), width = 4, height = 5.5) 97 | } 98 | 99 | draws <- sample(seq_along(post$lambda_d[, 1]), 100L) 100 | variables_df <- dplyr::tibble( 101 | variable = names(obj$state_0), 102 | variable_num = seq_along(obj$state_0) 103 | ) 104 | 105 | if ("y_hat" %in% names(post)) { 106 | ts_df <- dplyr::tibble(time = obj$time, time_num = seq_along(obj$time)) 107 | states <- reshape2::melt(post$y_hat) %>% 108 | dplyr::rename(time_num = Var2, variable_num = Var3) %>% 109 | dplyr::filter(iterations %in% draws) %>% 110 | dplyr::left_join(variables_df, by = "variable_num") %>% 111 | dplyr::left_join(ts_df, by = "time_num") 112 | 113 | g <- ggplot(states, aes(time, value, group = iterations)) + 114 | geom_line(alpha = 0.1) + 115 | facet_wrap(~variable, scales = "free_y") + 116 | geom_vline(xintercept = obj$last_day_obs, lty = 2, alpha = 0.6) + 117 | scale_x_continuous(breaks = seq(-30, 150, 10)) 118 | ggsave(paste0("figs/states", id, ext), width = 12, height = 7.5) 119 | } 120 | 121 | draws <- sample(seq_along(post$lambda_d[, 1]), 100L) 122 | g <- reshape2::melt(post$lambda_d) %>% 123 | dplyr::rename(day = Var2) %>% 124 | dplyr::filter(iterations %in% draws) %>% 125 | ggplot(aes(day, value, group = iterations)) + 126 | geom_line(alpha = 0.05) + 127 | geom_point( 128 | data = tibble(day = seq_along(obj$daily_cases), value = obj$daily_cases), 129 | inherit.aes = FALSE, aes(x = day, y = value) 130 | ) 131 | ggsave(paste0("figs/expected-case-diffs", id, ext), width = 6, height = 4) 132 | 133 | # Posterior predictive checks: 134 | 135 | draws <- sample(seq_along(post$y_rep[, 1]), 50L) 136 | g <- post$y_rep %>% 137 | reshape2::melt() %>% 138 | dplyr::filter(iterations %in% draws) %>% 139 | dplyr::rename(day = Var2) %>% 140 | ggplot(aes(day, value, group = iterations)) + 141 | geom_line(alpha = 0.1) + 142 | geom_line( 143 | data = tibble(day = seq_len(obj$last_day_obs), value = obj$daily_cases), 144 | col = "red", inherit.aes = FALSE, aes(x = day, y = value) 145 | ) 146 | ggsave(paste0("figs/posterior-predictive-case-diffs", id, ext), width = 6, height = 4) 147 | 148 | set.seed(1929) 149 | draws <- sample(seq_along(post$y_rep[, 1]), 24L) 150 | g <- post$y_rep %>% 151 | reshape2::melt() %>% 152 | dplyr::filter(iterations %in% draws) %>% 153 | dplyr::rename(day = Var2) %>% 154 | mutate(Type = "Posterior\npredictive\nsimulation") %>% 155 | bind_rows(tibble( 156 | iterations = 0, day = seq_len(obj$last_day_obs), 157 | value = obj$daily_cases, Type = "Observed" 158 | )) %>% 159 | ggplot(aes(day, value, colour = Type)) + 160 | geom_line(lwd = 0.7) + 161 | facet_wrap(vars(iterations)) + 162 | ylab("New cases") + 163 | xlab("Day") + 164 | scale_color_manual(values = c("red", "grey40")) + 165 | geom_vline(xintercept = obj$last_day_obs, lty = 2, alpha = 0.6) 166 | ggsave(paste0("figs/posterior-predictive-case-diffs-facet", id, ext), width = 9, height = 6.25) 167 | 168 | dat <- tibble(day = actual_dates[1:obj$last_day_obs], value = obj$daily_cases) 169 | g <- post$y_rep %>% 170 | reshape2::melt() %>% 171 | dplyr::rename(day = Var2) %>% 172 | dplyr::group_by(day) %>% 173 | summarise( 174 | lwr = quantile(value, probs = 0.1), 175 | lwr2 = quantile(value, probs = 0.25), 176 | upr = quantile(value, probs = 0.9), 177 | upr2 = quantile(value, probs = 0.75), 178 | med = median(value) 179 | ) %>% 180 | mutate(day = actual_dates[day]) %>% 181 | ggplot(aes(day, y = med, ymin = lwr, ymax = upr)) + 182 | geom_ribbon(alpha = 0.2) + 183 | geom_ribbon(alpha = 0.2, mapping = aes(ymin = lwr2, ymax = upr2)) + 184 | geom_line(alpha = 0.9, lwd = 1) + 185 | geom_point( 186 | data = dat, 187 | col = "red", inherit.aes = FALSE, aes(x = day, y = value), 188 | ) + 189 | geom_line( 190 | data = dat, 191 | col = "red", inherit.aes = FALSE, aes(x = day, y = value), lwd = 0.2, alpha = 0.5 192 | ) + 193 | ylab("New cases") + 194 | xlab("Day") + 195 | geom_vline(xintercept = actual_dates[obj$last_day_obs], lty = 2, alpha = 0.6) + 196 | coord_cartesian(expand = FALSE) + 197 | theme(plot.margin = margin(11/2,11, 11/2, 11/2)) 198 | ggsave(paste0("figs/posterior-predictive-quantiles-case-diffs", id, ext), width = 6, height = 4) 199 | 200 | # cumulative 201 | 202 | dat <- tibble(day = actual_dates[1:obj$last_day_obs], value = cumsum(obj$daily_cases)) 203 | 204 | g <- post$y_rep %>% 205 | reshape2::melt() %>% 206 | dplyr::rename(day = Var2) %>% 207 | dplyr::group_by(iterations) %>% 208 | mutate(value = cumsum(value)) %>% 209 | dplyr::group_by(day) %>% 210 | summarise( 211 | lwr = quantile(value, probs = 0.1), 212 | lwr2 = quantile(value, probs = 0.25), 213 | upr = quantile(value, probs = 0.9), 214 | upr2 = quantile(value, probs = 0.75), 215 | med = median(value) 216 | ) %>% 217 | mutate(day = actual_dates[day]) %>% 218 | ggplot(aes(day, y = med, ymin = lwr, ymax = upr)) + 219 | geom_ribbon(alpha = 0.2) + 220 | geom_ribbon(alpha = 0.2, mapping = aes(ymin = lwr2, ymax = upr2)) + 221 | geom_line(alpha = 0.9, lwd = 1) + 222 | geom_point( 223 | data = dat, 224 | col = "red", inherit.aes = FALSE, aes(x = day, y = value), 225 | ) + 226 | geom_line( 227 | data = dat, 228 | col = "red", inherit.aes = FALSE, aes(x = day, y = value), lwd = 0.2, alpha = 0.5 229 | ) + 230 | ylab("Cumulative cases") + 231 | xlab("Day") + 232 | geom_vline(xintercept = actual_dates[obj$last_day_obs], lty = 2, alpha = 0.6) + 233 | coord_cartesian(expand = FALSE) + 234 | theme(plot.margin = margin(11/2,11, 11/2, 11/2)) 235 | ggsave(paste0("figs/posterior-predictive-quantiles-case-cumsum", id, ext), width = 6, height = 4) 236 | 237 | } 238 | -------------------------------------------------------------------------------- /analysis/11-onset-date.R: -------------------------------------------------------------------------------- 1 | source(here::here("analysis/data-model-prep.R")) 2 | 3 | .last_day <- lubridate::ymd("2020-04-12") 4 | 5 | load_tidy_delay_data <- function() { 6 | # can't be publicly released 7 | linelist_latest_file <- 8 | here::here("data-raw/2019-nCoV_daily_linelist.csv") 9 | if (!file.exists(linelist_latest_file)) { 10 | stop(paste( 11 | "You need to have the file ", 12 | linelist_latest_file, 13 | " ." 14 | )) 15 | } 16 | linelist <- read.csv(linelist_latest_file, 17 | stringsAsFactors = FALSE, 18 | na.strings = "" 19 | ) 20 | names(linelist)[1] <- "investigation_id" 21 | 22 | delay_data_with_outliers <- as_tibble(linelist) %>% 23 | select(reported_date, symptom_onset_date) %>% 24 | mutate_all(lubridate::ymd) %>% 25 | filter(!is.na(reported_date) & !is.na(symptom_onset_date)) %>% 26 | mutate(time_to_report = reported_date - symptom_onset_date) 27 | 28 | # Removing the following outliers that are $<0$ or $\geq 30$ days, since most 29 | # likely to be data-entry errors, to yield the final dataset. 30 | delay_data <- filter( 31 | delay_data_with_outliers, 32 | time_to_report < 30 & time_to_report >= 0 33 | ) 34 | return(list( 35 | "delay_data" = delay_data, 36 | "delay_data_with_outliers" = delay_data_with_outliers 37 | )) 38 | } 39 | 40 | plot_time_to_report <- function(data, 41 | start_date_report = "2020-02-29", 42 | start_date_onset = "2020-02-29", 43 | show_weekends = FALSE) { 44 | 45 | p <- data %>% 46 | filter(symptom_onset_date > start_date_onset) %>% 47 | mutate(weekday = if_else(lubridate::wday(reported_date) %in% c(7, 1), 48 | "Weekend", 49 | "Weekday" 50 | )) %>% 51 | ggplot(aes( 52 | x = symptom_onset_date, 53 | y = time_to_report 54 | )) + 55 | geom_jitter(height = 0, width = 0.22, alpha = 0.35, size = 0.8, pch = 19, col = .hist_blue) + 56 | geom_boxplot(aes(group = symptom_onset_date), 57 | outlier.shape = NA, fill = NA, colour = "grey40", alpha = 0.6, size = 0.5, coef = 0 58 | ) + 59 | scale_fill_distiller(palette = "Blues", direction = 1, limits = c(1, 10)) + 60 | geom_abline( 61 | slope = -1, 62 | intercept = lubridate::ymd(max(data$reported_date)), 63 | linetype = 2, col = "grey50" 64 | ) + 65 | labs( 66 | fill = "Reported\ncases", 67 | x = "Date of onset of symptoms", 68 | y = "Time from symptom onset\n to reported case (days)" 69 | ) 70 | if (show_weekends) { 71 | p <- p + geom_boxplot(aes( 72 | group = symptom_onset_date, 73 | fill = weekday 74 | )) 75 | } 76 | p + coord_cartesian(expand = FALSE) 77 | } 78 | 79 | delay_data <- load_tidy_delay_data()[["delay_data"]] 80 | plotdelay2 <- plot_time_to_report(delay_data) + 81 | xlim(lubridate::ymd("2020-02-29"), .last_day) + 82 | coord_cartesian(expand = FALSE, ylim = c(0, 32)) 83 | 84 | start_date_report <- "2020-02-29" 85 | 86 | dat2 <- select(dat, Date, daily_diffs) 87 | if (max(dat2$Date) == "2020-04-08") { 88 | dat2 <- data.frame( 89 | Date = c(dat2$Date, max(dat2$Date) + 1:3), 90 | daily_diffs = daily_diffs 91 | ) 92 | } 93 | 94 | ymd <- lubridate::ymd 95 | # 96 | # 97 | # make_seg <- function(.date, .end = 1, .text = "") { 98 | # list( 99 | # geom_segment(x = lubridate::ymd(.date), 100 | # xend = lubridate::ymd(.date), y = 0, yend = 95 + .end * 3.5 , col = "grey60", lwd = 0.5), 101 | # annotate("text", x = lubridate::ymd(.date) + 0.3, y = 95 + .end * 3.5, label = .text, hjust = 0, col = "grey30", size = 3.5) 102 | # ) 103 | # } 104 | # .xlim <- c(lubridate::ymd("2020-02-29"), .last_day) 105 | # # daily_diff_plot <- 106 | # dat2 %>% 107 | # ggplot(aes(x = Date, y = daily_diffs)) + 108 | # geom_col( 109 | # fill = .hist_blue, alpha = .8, 110 | # colour = "grey90", lwd = 0.15 111 | # ) + 112 | # annotate(geom = "segment", y = Inf, yend = Inf, x = .xlim[1], xend = .xlim[2], colour = "grey70") + 113 | # annotate(geom = "segment", y = 0, yend = 0, x = .xlim[1], xend = .xlim[2], colour = "grey70") + 114 | # annotate(geom = "segment", y = -Inf, yend = Inf, x = .xlim[2], xend = .xlim[2], colour = "grey70") + 115 | # annotate(geom = "segment", y = -Inf, yend = Inf, x = .xlim[1], xend = .xlim[1], colour = "grey70") + 116 | # coord_cartesian(expand = FALSE, 117 | # ylim = c(0, max(dat2$daily_diffs) * 1.02), clip = "off") + 118 | # labs( 119 | # fill = "Reported\ncases", 120 | # x = "Date of reported case", 121 | # y = "New reported cases" 122 | # ) + 123 | # xlim(lubridate::ymd("2020-02-29"), .last_day) + 124 | # make_seg("2020-03-08", 8, "Testing") + 125 | # make_seg("2020-03-12", 7, "Testing") + 126 | # make_seg("2020-03-13", 6, "Testing") + 127 | # make_seg("2020-03-14", 5, "Testing") + 128 | # make_seg("2020-03-16", 4, "Testing") + 129 | # make_seg("2020-03-17", 3, "Testing") + 130 | # make_seg("2020-03-20", 2, "Testing") + 131 | # make_seg("2020-03-21", 1, "Testing") + 132 | # 133 | # # geom_segment(x = ymd("2020-03-08"), 134 | # # xend = ymd("2020-03-08"), y = 0, yend = 100, col = "grey50") + 135 | # # 136 | # # geom_segment(x = ymd("2020-03-12"), 137 | # # xend = ymd("2020-03-12"), y = 0, yend = 100, col = "grey50") + 138 | # # 139 | # # geom_segment(x = ymd("2020-03-13"), 140 | # # xend = ymd("2020-03-13"), y = 0, yend = 100, col = "grey50") + 141 | # # 142 | # # geom_segment(x = ymd("2020-03-14"), 143 | # # xend = ymd("2020-03-14"), y = 0, yend = 100, col = "grey50") + 144 | # # 145 | # # geom_segment(x = ymd("2020-03-16"), 146 | # # xend = ymd("2020-03-16"), y = 0, yend = 100, col = "grey50") + 147 | # 148 | # theme(plot.margin = margin(t = 90, r = 11/2, b = 11/2, l = 11/2), panel.border = element_blank()) 149 | 150 | d <- readr::read_csv(here::here("data-raw/timeline.csv"), comment = "#") 151 | d <- d[-1, ] 152 | 153 | daily_diff_plot <- 154 | dat2 %>% 155 | ggplot(aes(x = Date, y = daily_diffs)) + 156 | geom_rect(xmin = min(d$date), xmax = max(d$date), ymin = 0, ymax = Inf, fill = "grey82", col = NA) + 157 | geom_col( 158 | fill = .hist_blue, alpha = .8, 159 | colour = "grey90", lwd = 0.15 160 | ) + 161 | # geom_rect(data = d, mapping = aes(xintercept = date), lty = 1, col = "grey55", lwd = 0.4) + 162 | coord_cartesian(expand = FALSE, 163 | ylim = c(0, max(dat2$daily_diffs) * 1.02), clip = "on") + 164 | labs( 165 | fill = "Reported\ncases", 166 | x = "Date of reported case", 167 | y = "New reported cases" 168 | ) + 169 | xlim(lubridate::ymd("2020-02-29"), .last_day) 170 | 171 | # daily_diff_plot 172 | 173 | # Hospital ---------------------------------------------------------- 174 | 175 | h <- readr::read_csv(here::here("data-raw/hospitalization-data.csv")) 176 | h <- mutate(h, Date = lubridate::dmy(Date)) 177 | h <- bind_rows( 178 | select(h, date = Date, Count = `Hosp Census`) %>% mutate(Type = "Hospital"), 179 | select(dat, date = Date, Count = `ICU Census`) %>% mutate(Type = "ICU") 180 | ) 181 | hosp_plot <- ggplot(h, aes(date, Count, colour = Type)) + 182 | geom_point(aes(shape = Type)) + 183 | geom_line() + 184 | coord_cartesian( 185 | expand = FALSE, ylim = c(0, 160), 186 | xlim = c(lubridate::ymd("2020-02-29"), .last_day) 187 | ) + 188 | theme( 189 | axis.title.x.bottom = element_blank(), 190 | legend.position = c(0.17, 0.25), 191 | legend.text = element_text(size = 9), 192 | legend.title = element_text(size = 11) 193 | ) + 194 | scale_color_manual(values = c(.hist_blue, "grey45")) + 195 | scale_shape_manual(values = c(21, 19)) + 196 | ylab("Census count") + 197 | labs(colour = "Census type", shape = "Census type") 198 | 199 | # Timeline -------------------------------------------------------------------- 200 | 201 | d <- readr::read_csv(here::here("data-raw/timeline.csv"), comment = "#") 202 | d <- d[-1, ] 203 | 204 | d$event <- gsub("outside Canada", "outside\nCanada", d$event) 205 | d$event <- gsub("\\/cafe", "", d$event) 206 | # d$type <- c("A", rep("B", length(d$event) - 1)) 207 | d$type <- c(rep("B", length(d$event))) 208 | g_timeline <- ggplot(d, aes(date, 0, label = event)) + 209 | theme_void() + 210 | ylim(0, 1) + 211 | annotate("line", 212 | x = seq(min(d$date) - 1.15, 213 | max(d$date) + 0.9, by = "1 day"), 214 | y = 0, col = "grey70" 215 | ) + 216 | # coord_flip(clip = "off") + 217 | coord_cartesian(clip = "off", expand = FALSE, ylim = c(0, 1)) + 218 | geom_point(col = "grey30", size = 1.3) + 219 | geom_text(y = 0.04, angle = 90, hjust = 0, aes(colour = type), lineheight = .75, size = 3.3) + 220 | # scale_color_manual(values = c(RColorBrewer::brewer.pal(6, "Blues")[5], "grey10")) + 221 | scale_color_manual(values = c("grey20")) + 222 | guides(colour = FALSE) + 223 | # geom_text(y = -0.05, aes(label = substr(as.character(date), 6, 10)), angle = 30, hjust = 1, size = 3.3) + 224 | geom_text(y = -0.03, aes(label = format(date, "%b %d")), angle = 90, hjust = 1, size = 3.0, col = "grey30") + 225 | theme(plot.margin = margin(t = -10, r = -10, b = -20, l = 5, unit = "pt")) 226 | # xlim(lubridate::ymd("2020-02-29"), .last_day) 227 | 228 | g_timeline 229 | # ggsave("figs-ms/timeline.png", width = 6.45, height = 3.6, dpi = 400) 230 | # ggsave("figs-ms/timeline.pdf", width = 6.45, height = 3.6) 231 | 232 | g <- cowplot::plot_grid(g_timeline, plotdelay2, daily_diff_plot, hosp_plot, 233 | ncol = 2, 234 | labels = "AUTO", align = "hv", label_x = 0.18, label_y = 0.962 235 | ) + 236 | cowplot::draw_line( 237 | x = c(0.203, 0.132), 238 | y = c(0.483, 0.583), 239 | color = "grey70", size = 0.5, alpha = 0.6 240 | ) + 241 | cowplot::draw_line( 242 | x = c(0.284, 0.460), 243 | y = c(0.483, 0.584), 244 | color = "grey70", size = 0.5, alpha = 0.6 245 | ) 246 | 247 | # g 248 | # g <- cowplot::plot_grid(daily_diff_plot, plotdelay2, hosp_plot, g_timeline, 249 | # ncol = 2, 250 | # labels = "AUTO", align = "hv", label_x = 0.18, label_y = 0.962 251 | # ) 252 | # g 253 | # cowplot::plot_grid(g, g_timeline, ncol = 2, rel_widths = c(2, 1)) + 254 | # theme(plot.margin = margin(2, 11, 2, 0)) 255 | 256 | 257 | ggsave("figs-ms/onset-hosp.png", width = 7.7, height = 5.1, dpi = 400) 258 | ggsave("figs-ms/onset-hosp.pdf", width = 7.7, height = 5.1) 259 | -------------------------------------------------------------------------------- /analysis/fit_seeiqr.R: -------------------------------------------------------------------------------- 1 | #' Fit the Stan SEEIQR model 2 | #' 3 | #' @param daily_cases A vector of daily new cases 4 | #' @param daily_tests An optional vector of daily test numbers. Should include 5 | #' assumed tests for the forecast. I.e. `length(daily_cases) + forecast_days = 6 | #' length(daily_tests)`. Only used in the case of the beta-binomial (which 7 | #' isn't working very well). 8 | #' @param Model from `rstan::stan_model(seeiqr_model)`. 9 | #' @param obs_model Type of observation model 10 | #' @param forecast_days Number of days into the future to forecast. The model 11 | #' will run slightly faster with fewer forecasted days. 12 | #' @param time_increment Time increment for ODEs and Weibull delay-model 13 | #' integration 14 | #' @param days_back Number of days to go back for Weibull delay-model 15 | #' integration 16 | #' @param R0_prior Lognormal log mean and SD for R0 prior 17 | #' @param phi_prior SD of `1/sqrt(phi) ~ Normal(0, SD)` prior, where NB2(mu, 18 | #' phi) and `Var(Y) = mu + mu^2 / phi`. 19 | #' 20 | #' @param f2_prior Beta mean and SD for `f2` parameter 21 | #' @param sampFrac2_prior `sampFrac` prior starting on 22 | #' `sampled_fraction_day_change` if `sampFrac2_type` is "estimated" or "rw". 23 | #' In the case of the random walk, this specifies the initial state prior. The 24 | #' two values correspond to the mean and SD of a Beta distribution. 25 | #' @param sampFrac2_type How to treat the sample fraction. Fixed, estimated, or 26 | #' a constrained random walk. 27 | #' @param rw_sigma The standard deviation on the sampFrac2 random walk. 28 | #' @param seed MCMC seed 29 | #' @param chains Number of MCMC chains 30 | #' @param iter MCMC iterations per chain 31 | #' @param sampled_fraction1 Fraction sampled before 32 | #' `sampled_fraction_day_change` 33 | #' @param sampled_fraction2 Fraction sampled at and after 34 | #' `sampled_fraction_day_change` 35 | #' @param sampled_fraction_day_change Date fraction sample changes 36 | #' @param sampled_fraction_vec An optional vector of sampled fractions. Should 37 | #' be of length: `length(daily_cases) + forecast_days`. 38 | #' @param fixed_f_forecast Optional fixed `f` for forecast. 39 | #' @param pars A named numeric vector of fixed parameter values 40 | #' @param i0 A scaling factor FIXME 41 | #' @param fsi Fraction socially distancing. Derived parameter. 42 | #' @param nsi Fraction not socially distancing. Derived parameter. 43 | #' @param state_0 Initial state: a named numeric vector 44 | #' @param save_state_predictions Include the state predictions? `y_hat` Will 45 | #' make the resulting model object much larger. 46 | #' @param delayScale Weibull scale parameter for the delay in reporting. 47 | #' @param delayShape Weibull shape parameter for the delay in reporting. 48 | #' @param ode_control Control options for the Stan ODE solver. First is relative 49 | #' difference, that absolute difference, and then maximum iterations. The 50 | #' values here are the Stan defaults. 51 | #' @param daily_cases_omit An optional vector of days to omit from the data 52 | #' likelihood. 53 | #' @param ... Other arguments to pass to [rstan::sampling()]. 54 | #' @author Sean Anderson 55 | 56 | fit_seeiqr <- function(daily_cases, 57 | daily_tests = NULL, 58 | seeiqr_model, 59 | obs_model = c("NB2", "Poisson", "beta-binomial"), 60 | forecast_days = 60, 61 | time_increment = 0.1, 62 | days_back = 45, 63 | R0_prior = c(log(2.6), 0.2), 64 | phi_prior = 1, 65 | f2_prior = c(0.4, 0.2), 66 | sampFrac2_prior = c(0.4, 0.2), 67 | sampFrac2_type = c("fixed", "estimated", "rw"), 68 | rw_sigma = 0.1, 69 | seed = 42, 70 | chains = 8, 71 | iter = 1000, 72 | sampled_fraction1 = 0.1, 73 | sampled_fraction2 = 0.3, 74 | sampled_fraction_day_change = 14, 75 | sampled_fraction_vec = NULL, 76 | fixed_f_forecast = NULL, 77 | day_start_fixed_f_forecast = length(daily_cases) + 1, 78 | pars = c( 79 | N = 5.1e6, D = 5, k1 = 1 / 5, 80 | k2 = 1, q = 0.05, 81 | r = 0.1, ur = 0.02, f1 = 1.0, 82 | start_decline = 15, 83 | end_decline = 22 84 | ), 85 | i0 = 8, 86 | fsi = pars[["r"]] / (pars[["r"]] + pars[["ur"]]), 87 | nsi = 1 - fsi, 88 | state_0 = c( 89 | S = nsi * (pars[["N"]] - i0), 90 | E1 = 0.4 * nsi * i0, 91 | E2 = 0.1 * nsi * i0, 92 | I = 0.5 * nsi * i0, 93 | Q = 0, 94 | R = 0, 95 | Sd = fsi * (pars[["N"]] - i0), 96 | E1d = 0.4 * fsi * i0, 97 | E2d = 0.1 * fsi * i0, 98 | Id = 0.5 * fsi * i0, 99 | Qd = 0, 100 | Rd = 0 101 | ), 102 | save_state_predictions = FALSE, 103 | delayScale = 9.85, 104 | delayShape = 1.73, 105 | ode_control = c(1e-6, 1e-6, 1e6), 106 | daily_cases_omit = NULL, 107 | ...) { 108 | obs_model <- match.arg(obs_model) 109 | obs_model <- 110 | if (obs_model == "Poisson") { 111 | 0L 112 | } else if (obs_model == "NB2") { 113 | 1L 114 | } else { 115 | 2L 116 | } 117 | x_r <- pars 118 | 119 | sampFrac2_type <- match.arg(sampFrac2_type) 120 | n_sampFrac2 <- 121 | if (sampFrac2_type == "fixed") { 122 | 0L 123 | } else if (sampFrac2_type == "estimated") { 124 | 1L 125 | } else { # random walk: 126 | length(daily_cases) - sampled_fraction_day_change + 1L 127 | } 128 | 129 | if (!is.null(daily_tests)) { 130 | stopifnot(length(daily_cases) + forecast_days == length(daily_tests)) 131 | if (min(daily_tests) == 0) { 132 | warning("Replacing 0 daily tests with 1.") 133 | daily_tests[daily_tests == 0] <- 1 134 | } 135 | } 136 | stopifnot( 137 | names(x_r) == 138 | c("N", "D", "k1", "k2", "q", "r", "ur", "f1", "start_decline", "end_decline") 139 | ) 140 | stopifnot( 141 | names(state_0) == c("S", "E1", "E2", "I", "Q", "R", "Sd", "E1d", "E2d", "Id", "Qd", "Rd") 142 | ) 143 | 144 | days <- seq(1, length(daily_cases) + forecast_days) 145 | last_day_obs <- length(daily_cases) 146 | time <- seq(-30, max(days), time_increment) 147 | x_r <- c(x_r, if (!is.null(fixed_f_forecast)) fixed_f_forecast else 0) 148 | names(x_r)[length(x_r)] <- "fixed_f_forecast" 149 | x_r <- c(x_r, c("last_day_obs" = last_day_obs)) 150 | x_r <- c(x_r, c("day_start_fixed_f_forecast" = day_start_fixed_f_forecast)) 151 | 152 | # find the equivalent time of each day (end): 153 | get_time_id <- function(day, time) max(which(time <= day)) 154 | time_day_id <- vapply(days, get_time_id, numeric(1), time = time) 155 | 156 | get_time_day_id0 <- function(day, time, days_back) { 157 | # go back `days_back` or to beginning if that's negative time: 158 | check <- time <= (day - days_back) 159 | if (sum(check) == 0L) { 160 | 1L 161 | } else { 162 | max(which(check)) 163 | } 164 | } 165 | # find the equivalent time of each day (start): 166 | time_day_id0 <- vapply(days, get_time_day_id0, numeric(1), 167 | time = time, days_back = days_back 168 | ) 169 | 170 | if (is.null(sampled_fraction_vec)) { 171 | sampFrac <- ifelse(days < sampled_fraction_day_change, 172 | sampled_fraction1, sampled_fraction2) 173 | } else { 174 | stopifnot(length(sampled_fraction_vec) == length(days)) 175 | sampFrac <- sampled_fraction_vec 176 | } 177 | 178 | beta_sd <- f2_prior[2] 179 | beta_mean <- f2_prior[1] 180 | beta_shape1 <- get_beta_params(beta_mean, beta_sd)$alpha 181 | beta_shape2 <- get_beta_params(beta_mean, beta_sd)$beta 182 | 183 | sampFrac2_beta_sd <- sampFrac2_prior[2] 184 | sampFrac2_beta_mean <- sampFrac2_prior[1] 185 | sampFrac2_beta_shape1 <- get_beta_params(sampFrac2_beta_mean, sampFrac2_beta_sd)$alpha 186 | sampFrac2_beta_shape2 <- get_beta_params(sampFrac2_beta_mean, sampFrac2_beta_sd)$beta 187 | 188 | dat_in_lik <- seq(1, last_day_obs) 189 | if (!is.null(daily_cases_omit)) { 190 | dat_in_lik <- dat_in_lik[-daily_cases_omit] 191 | } 192 | stan_data <- list( 193 | T = length(time), 194 | days = days, 195 | daily_cases = daily_cases, 196 | tests = if (is.null(daily_tests)) rep(log(1), length(days)) else daily_tests, 197 | N = length(days), 198 | y0 = state_0, 199 | t0 = min(time) - 0.000001, 200 | time = time, 201 | x_r = x_r, 202 | delayShape = delayShape, 203 | delayScale = delayScale, 204 | sampFrac = sampFrac, 205 | time_day_id = time_day_id, 206 | time_day_id0 = time_day_id0, 207 | R0_prior = R0_prior, 208 | phi_prior = phi_prior, 209 | f2_prior = c(beta_shape1, beta_shape2), 210 | sampFrac2_prior = c(sampFrac2_beta_shape1, sampFrac2_beta_shape2), 211 | day_inc_sampling = sampled_fraction_day_change, 212 | n_sampFrac2 = n_sampFrac2, 213 | rw_sigma = rw_sigma, 214 | priors_only = 0L, 215 | last_day_obs = last_day_obs, 216 | obs_model = obs_model, 217 | ode_control = ode_control, 218 | est_phi = if (obs_model %in% c(1L, 2L)) 1L else 0L, 219 | dat_in_lik = dat_in_lik, 220 | N_lik = length(dat_in_lik) 221 | ) 222 | # map_estimate <- optimizing( 223 | # seeiqr_model, 224 | # data = stan_data 225 | # ) 226 | initf <- function(stan_data) { 227 | R0 <- rlnorm(1, R0_prior[1], R0_prior[2]) 228 | f2 <- rbeta( 229 | 1, 230 | get_beta_params(f2_prior[1], f2_prior[2])$alpha, 231 | get_beta_params(f2_prior[1], f2_prior[2])$beta 232 | ) 233 | init <- list(R0 = R0, f2 = f2) 234 | init 235 | } 236 | pars_save <- c("R0", "f2", "phi", "lambda_d", "y_rep", "sampFrac2") 237 | if (save_state_predictions) pars_save <- c(pars_save, "y_hat") 238 | fit <- rstan::sampling( 239 | seeiqr_model, 240 | data = stan_data, 241 | iter = iter, 242 | chains = chains, 243 | init = function() initf(stan_data), 244 | seed = seed, # https://xkcd.com/221/ 245 | pars = pars_save, 246 | ... = ... 247 | ) 248 | post <- rstan::extract(fit) 249 | list( 250 | fit = fit, post = post, phi_prior = phi_prior, R0_prior = R0_prior, 251 | f2_prior = f2_prior, obs_model = obs_model, sampFrac = sampFrac, state_0 = state_0, 252 | daily_cases = daily_cases, daily_tests = daily_tests, days = days, time = time, 253 | last_day_obs = last_day_obs, pars = x_r, f2_prior_beta_shape1 = beta_shape1, 254 | f2_prior_beta_shape2 = beta_shape2, stan_data = stan_data 255 | ) 256 | } 257 | 258 | get_beta_params <- function(mu, sd) { 259 | var <- sd^2 260 | alpha <- ((1 - mu) / var - 1 / mu) * mu^2 261 | beta <- alpha * (1 / mu - 1) 262 | list(alpha = alpha, beta = beta) 263 | } 264 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ### GNU GENERAL PUBLIC LICENSE 2 | 3 | Version 3, 29 June 2007 4 | 5 | Copyright (C) 2007 Free Software Foundation, Inc. 6 | 7 | 8 | Everyone is permitted to copy and distribute verbatim copies of this 9 | license document, but changing it is not allowed. 10 | 11 | ### Preamble 12 | 13 | The GNU General Public License is a free, copyleft license for 14 | software and other kinds of works. 15 | 16 | The licenses for most software and other practical works are designed 17 | to take away your freedom to share and change the works. By contrast, 18 | the GNU General Public License is intended to guarantee your freedom 19 | to share and change all versions of a program--to make sure it remains 20 | free software for all its users. We, the Free Software Foundation, use 21 | the GNU General Public License for most of our software; it applies 22 | also to any other work released this way by its authors. You can apply 23 | it to your programs, too. 24 | 25 | When we speak of free software, we are referring to freedom, not 26 | price. Our General Public Licenses are designed to make sure that you 27 | have the freedom to distribute copies of free software (and charge for 28 | them if you wish), that you receive source code or can get it if you 29 | want it, that you can change the software or use pieces of it in new 30 | free programs, and that you know you can do these things. 31 | 32 | To protect your rights, we need to prevent others from denying you 33 | these rights or asking you to surrender the rights. Therefore, you 34 | have certain responsibilities if you distribute copies of the 35 | software, or if you modify it: responsibilities to respect the freedom 36 | of others. 37 | 38 | For example, if you distribute copies of such a program, whether 39 | gratis or for a fee, you must pass on to the recipients the same 40 | freedoms that you received. You must make sure that they, too, receive 41 | or can get the source code. And you must show them these terms so they 42 | know their rights. 43 | 44 | Developers that use the GNU GPL protect your rights with two steps: 45 | (1) assert copyright on the software, and (2) offer you this License 46 | giving you legal permission to copy, distribute and/or modify it. 47 | 48 | For the developers' and authors' protection, the GPL clearly explains 49 | that there is no warranty for this free software. For both users' and 50 | authors' sake, the GPL requires that modified versions be marked as 51 | changed, so that their problems will not be attributed erroneously to 52 | authors of previous versions. 53 | 54 | Some devices are designed to deny users access to install or run 55 | modified versions of the software inside them, although the 56 | manufacturer can do so. This is fundamentally incompatible with the 57 | aim of protecting users' freedom to change the software. The 58 | systematic pattern of such abuse occurs in the area of products for 59 | individuals to use, which is precisely where it is most unacceptable. 60 | Therefore, we have designed this version of the GPL to prohibit the 61 | practice for those products. If such problems arise substantially in 62 | other domains, we stand ready to extend this provision to those 63 | domains in future versions of the GPL, as needed to protect the 64 | freedom of users. 65 | 66 | Finally, every program is threatened constantly by software patents. 67 | States should not allow patents to restrict development and use of 68 | software on general-purpose computers, but in those that do, we wish 69 | to avoid the special danger that patents applied to a free program 70 | could make it effectively proprietary. To prevent this, the GPL 71 | assures that patents cannot be used to render the program non-free. 72 | 73 | The precise terms and conditions for copying, distribution and 74 | modification follow. 75 | 76 | ### TERMS AND CONDITIONS 77 | 78 | #### 0. Definitions. 79 | 80 | "This License" refers to version 3 of the GNU General Public License. 81 | 82 | "Copyright" also means copyright-like laws that apply to other kinds 83 | of works, such as semiconductor masks. 84 | 85 | "The Program" refers to any copyrightable work licensed under this 86 | License. Each licensee is addressed as "you". "Licensees" and 87 | "recipients" may be individuals or organizations. 88 | 89 | To "modify" a work means to copy from or adapt all or part of the work 90 | in a fashion requiring copyright permission, other than the making of 91 | an exact copy. The resulting work is called a "modified version" of 92 | the earlier work or a work "based on" the earlier work. 93 | 94 | A "covered work" means either the unmodified Program or a work based 95 | on the Program. 96 | 97 | To "propagate" a work means to do anything with it that, without 98 | permission, would make you directly or secondarily liable for 99 | infringement under applicable copyright law, except executing it on a 100 | computer or modifying a private copy. Propagation includes copying, 101 | distribution (with or without modification), making available to the 102 | public, and in some countries other activities as well. 103 | 104 | To "convey" a work means any kind of propagation that enables other 105 | parties to make or receive copies. Mere interaction with a user 106 | through a computer network, with no transfer of a copy, is not 107 | conveying. 108 | 109 | An interactive user interface displays "Appropriate Legal Notices" to 110 | the extent that it includes a convenient and prominently visible 111 | feature that (1) displays an appropriate copyright notice, and (2) 112 | tells the user that there is no warranty for the work (except to the 113 | extent that warranties are provided), that licensees may convey the 114 | work under this License, and how to view a copy of this License. If 115 | the interface presents a list of user commands or options, such as a 116 | menu, a prominent item in the list meets this criterion. 117 | 118 | #### 1. Source Code. 119 | 120 | The "source code" for a work means the preferred form of the work for 121 | making modifications to it. "Object code" means any non-source form of 122 | a work. 123 | 124 | A "Standard Interface" means an interface that either is an official 125 | standard defined by a recognized standards body, or, in the case of 126 | interfaces specified for a particular programming language, one that 127 | is widely used among developers working in that language. 128 | 129 | The "System Libraries" of an executable work include anything, other 130 | than the work as a whole, that (a) is included in the normal form of 131 | packaging a Major Component, but which is not part of that Major 132 | Component, and (b) serves only to enable use of the work with that 133 | Major Component, or to implement a Standard Interface for which an 134 | implementation is available to the public in source code form. A 135 | "Major Component", in this context, means a major essential component 136 | (kernel, window system, and so on) of the specific operating system 137 | (if any) on which the executable work runs, or a compiler used to 138 | produce the work, or an object code interpreter used to run it. 139 | 140 | The "Corresponding Source" for a work in object code form means all 141 | the source code needed to generate, install, and (for an executable 142 | work) run the object code and to modify the work, including scripts to 143 | control those activities. However, it does not include the work's 144 | System Libraries, or general-purpose tools or generally available free 145 | programs which are used unmodified in performing those activities but 146 | which are not part of the work. For example, Corresponding Source 147 | includes interface definition files associated with source files for 148 | the work, and the source code for shared libraries and dynamically 149 | linked subprograms that the work is specifically designed to require, 150 | such as by intimate data communication or control flow between those 151 | subprograms and other parts of the work. 152 | 153 | The Corresponding Source need not include anything that users can 154 | regenerate automatically from other parts of the Corresponding Source. 155 | 156 | The Corresponding Source for a work in source code form is that same 157 | work. 158 | 159 | #### 2. Basic Permissions. 160 | 161 | All rights granted under this License are granted for the term of 162 | copyright on the Program, and are irrevocable provided the stated 163 | conditions are met. This License explicitly affirms your unlimited 164 | permission to run the unmodified Program. The output from running a 165 | covered work is covered by this License only if the output, given its 166 | content, constitutes a covered work. This License acknowledges your 167 | rights of fair use or other equivalent, as provided by copyright law. 168 | 169 | You may make, run and propagate covered works that you do not convey, 170 | without conditions so long as your license otherwise remains in force. 171 | You may convey covered works to others for the sole purpose of having 172 | them make modifications exclusively for you, or provide you with 173 | facilities for running those works, provided that you comply with the 174 | terms of this License in conveying all material for which you do not 175 | control copyright. Those thus making or running the covered works for 176 | you must do so exclusively on your behalf, under your direction and 177 | control, on terms that prohibit them from making any copies of your 178 | copyrighted material outside their relationship with you. 179 | 180 | Conveying under any other circumstances is permitted solely under the 181 | conditions stated below. Sublicensing is not allowed; section 10 makes 182 | it unnecessary. 183 | 184 | #### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 185 | 186 | No covered work shall be deemed part of an effective technological 187 | measure under any applicable law fulfilling obligations under article 188 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 189 | similar laws prohibiting or restricting circumvention of such 190 | measures. 191 | 192 | When you convey a covered work, you waive any legal power to forbid 193 | circumvention of technological measures to the extent such 194 | circumvention is effected by exercising rights under this License with 195 | respect to the covered work, and you disclaim any intention to limit 196 | operation or modification of the work as a means of enforcing, against 197 | the work's users, your or third parties' legal rights to forbid 198 | circumvention of technological measures. 199 | 200 | #### 4. Conveying Verbatim Copies. 201 | 202 | You may convey verbatim copies of the Program's source code as you 203 | receive it, in any medium, provided that you conspicuously and 204 | appropriately publish on each copy an appropriate copyright notice; 205 | keep intact all notices stating that this License and any 206 | non-permissive terms added in accord with section 7 apply to the code; 207 | keep intact all notices of the absence of any warranty; and give all 208 | recipients a copy of this License along with the Program. 209 | 210 | You may charge any price or no price for each copy that you convey, 211 | and you may offer support or warranty protection for a fee. 212 | 213 | #### 5. Conveying Modified Source Versions. 214 | 215 | You may convey a work based on the Program, or the modifications to 216 | produce it from the Program, in the form of source code under the 217 | terms of section 4, provided that you also meet all of these 218 | conditions: 219 | 220 | - a) The work must carry prominent notices stating that you modified 221 | it, and giving a relevant date. 222 | - b) The work must carry prominent notices stating that it is 223 | released under this License and any conditions added under 224 | section 7. This requirement modifies the requirement in section 4 225 | to "keep intact all notices". 226 | - c) You must license the entire work, as a whole, under this 227 | License to anyone who comes into possession of a copy. This 228 | License will therefore apply, along with any applicable section 7 229 | additional terms, to the whole of the work, and all its parts, 230 | regardless of how they are packaged. This License gives no 231 | permission to license the work in any other way, but it does not 232 | invalidate such permission if you have separately received it. 233 | - d) If the work has interactive user interfaces, each must display 234 | Appropriate Legal Notices; however, if the Program has interactive 235 | interfaces that do not display Appropriate Legal Notices, your 236 | work need not make them do so. 237 | 238 | A compilation of a covered work with other separate and independent 239 | works, which are not by their nature extensions of the covered work, 240 | and which are not combined with it such as to form a larger program, 241 | in or on a volume of a storage or distribution medium, is called an 242 | "aggregate" if the compilation and its resulting copyright are not 243 | used to limit the access or legal rights of the compilation's users 244 | beyond what the individual works permit. Inclusion of a covered work 245 | in an aggregate does not cause this License to apply to the other 246 | parts of the aggregate. 247 | 248 | #### 6. Conveying Non-Source Forms. 249 | 250 | You may convey a covered work in object code form under the terms of 251 | sections 4 and 5, provided that you also convey the machine-readable 252 | Corresponding Source under the terms of this License, in one of these 253 | ways: 254 | 255 | - a) Convey the object code in, or embodied in, a physical product 256 | (including a physical distribution medium), accompanied by the 257 | Corresponding Source fixed on a durable physical medium 258 | customarily used for software interchange. 259 | - b) Convey the object code in, or embodied in, a physical product 260 | (including a physical distribution medium), accompanied by a 261 | written offer, valid for at least three years and valid for as 262 | long as you offer spare parts or customer support for that product 263 | model, to give anyone who possesses the object code either (1) a 264 | copy of the Corresponding Source for all the software in the 265 | product that is covered by this License, on a durable physical 266 | medium customarily used for software interchange, for a price no 267 | more than your reasonable cost of physically performing this 268 | conveying of source, or (2) access to copy the Corresponding 269 | Source from a network server at no charge. 270 | - c) Convey individual copies of the object code with a copy of the 271 | written offer to provide the Corresponding Source. This 272 | alternative is allowed only occasionally and noncommercially, and 273 | only if you received the object code with such an offer, in accord 274 | with subsection 6b. 275 | - d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | - e) Convey the object code using peer-to-peer transmission, 288 | provided you inform other peers where the object code and 289 | Corresponding Source of the work are being offered to the general 290 | public at no charge under subsection 6d. 291 | 292 | A separable portion of the object code, whose source code is excluded 293 | from the Corresponding Source as a System Library, need not be 294 | included in conveying the object code work. 295 | 296 | A "User Product" is either (1) a "consumer product", which means any 297 | tangible personal property which is normally used for personal, 298 | family, or household purposes, or (2) anything designed or sold for 299 | incorporation into a dwelling. In determining whether a product is a 300 | consumer product, doubtful cases shall be resolved in favor of 301 | coverage. For a particular product received by a particular user, 302 | "normally used" refers to a typical or common use of that class of 303 | product, regardless of the status of the particular user or of the way 304 | in which the particular user actually uses, or expects or is expected 305 | to use, the product. A product is a consumer product regardless of 306 | whether the product has substantial commercial, industrial or 307 | non-consumer uses, unless such uses represent the only significant 308 | mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to 312 | install and execute modified versions of a covered work in that User 313 | Product from a modified version of its Corresponding Source. The 314 | information must suffice to ensure that the continued functioning of 315 | the modified object code is in no case prevented or interfered with 316 | solely because modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or 331 | updates for a work that has been modified or installed by the 332 | recipient, or for the User Product in which it has been modified or 333 | installed. Access to a network may be denied when the modification 334 | itself materially and adversely affects the operation of the network 335 | or violates the rules and protocols for communication across the 336 | network. 337 | 338 | Corresponding Source conveyed, and Installation Information provided, 339 | in accord with this section must be in a format that is publicly 340 | documented (and with an implementation available to the public in 341 | source code form), and must require no special password or key for 342 | unpacking, reading or copying. 343 | 344 | #### 7. Additional Terms. 345 | 346 | "Additional permissions" are terms that supplement the terms of this 347 | License by making exceptions from one or more of its conditions. 348 | Additional permissions that are applicable to the entire Program shall 349 | be treated as though they were included in this License, to the extent 350 | that they are valid under applicable law. If additional permissions 351 | apply only to part of the Program, that part may be used separately 352 | under those permissions, but the entire Program remains governed by 353 | this License without regard to the additional permissions. 354 | 355 | When you convey a copy of a covered work, you may at your option 356 | remove any additional permissions from that copy, or from any part of 357 | it. (Additional permissions may be written to require their own 358 | removal in certain cases when you modify the work.) You may place 359 | additional permissions on material, added by you to a covered work, 360 | for which you have or can give appropriate copyright permission. 361 | 362 | Notwithstanding any other provision of this License, for material you 363 | add to a covered work, you may (if authorized by the copyright holders 364 | of that material) supplement the terms of this License with terms: 365 | 366 | - a) Disclaiming warranty or limiting liability differently from the 367 | terms of sections 15 and 16 of this License; or 368 | - b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | - c) Prohibiting misrepresentation of the origin of that material, 372 | or requiring that modified versions of such material be marked in 373 | reasonable ways as different from the original version; or 374 | - d) Limiting the use for publicity purposes of names of licensors 375 | or authors of the material; or 376 | - e) Declining to grant rights under trademark law for use of some 377 | trade names, trademarks, or service marks; or 378 | - f) Requiring indemnification of licensors and authors of that 379 | material by anyone who conveys the material (or modified versions 380 | of it) with contractual assumptions of liability to the recipient, 381 | for any liability that these contractual assumptions directly 382 | impose on those licensors and authors. 383 | 384 | All other non-permissive additional terms are considered "further 385 | restrictions" within the meaning of section 10. If the Program as you 386 | received it, or any part of it, contains a notice stating that it is 387 | governed by this License along with a term that is a further 388 | restriction, you may remove that term. If a license document contains 389 | a further restriction but permits relicensing or conveying under this 390 | License, you may add to a covered work material governed by the terms 391 | of that license document, provided that the further restriction does 392 | not survive such relicensing or conveying. 393 | 394 | If you add terms to a covered work in accord with this section, you 395 | must place, in the relevant source files, a statement of the 396 | additional terms that apply to those files, or a notice indicating 397 | where to find the applicable terms. 398 | 399 | Additional terms, permissive or non-permissive, may be stated in the 400 | form of a separately written license, or stated as exceptions; the 401 | above requirements apply either way. 402 | 403 | #### 8. Termination. 404 | 405 | You may not propagate or modify a covered work except as expressly 406 | provided under this License. Any attempt otherwise to propagate or 407 | modify it is void, and will automatically terminate your rights under 408 | this License (including any patent licenses granted under the third 409 | paragraph of section 11). 410 | 411 | However, if you cease all violation of this License, then your license 412 | from a particular copyright holder is reinstated (a) provisionally, 413 | unless and until the copyright holder explicitly and finally 414 | terminates your license, and (b) permanently, if the copyright holder 415 | fails to notify you of the violation by some reasonable means prior to 416 | 60 days after the cessation. 417 | 418 | Moreover, your license from a particular copyright holder is 419 | reinstated permanently if the copyright holder notifies you of the 420 | violation by some reasonable means, this is the first time you have 421 | received notice of violation of this License (for any work) from that 422 | copyright holder, and you cure the violation prior to 30 days after 423 | your receipt of the notice. 424 | 425 | Termination of your rights under this section does not terminate the 426 | licenses of parties who have received copies or rights from you under 427 | this License. If your rights have been terminated and not permanently 428 | reinstated, you do not qualify to receive new licenses for the same 429 | material under section 10. 430 | 431 | #### 9. Acceptance Not Required for Having Copies. 432 | 433 | You are not required to accept this License in order to receive or run 434 | a copy of the Program. Ancillary propagation of a covered work 435 | occurring solely as a consequence of using peer-to-peer transmission 436 | to receive a copy likewise does not require acceptance. However, 437 | nothing other than this License grants you permission to propagate or 438 | modify any covered work. These actions infringe copyright if you do 439 | not accept this License. Therefore, by modifying or propagating a 440 | covered work, you indicate your acceptance of this License to do so. 441 | 442 | #### 10. Automatic Licensing of Downstream Recipients. 443 | 444 | Each time you convey a covered work, the recipient automatically 445 | receives a license from the original licensors, to run, modify and 446 | propagate that work, subject to this License. You are not responsible 447 | for enforcing compliance by third parties with this License. 448 | 449 | An "entity transaction" is a transaction transferring control of an 450 | organization, or substantially all assets of one, or subdividing an 451 | organization, or merging organizations. If propagation of a covered 452 | work results from an entity transaction, each party to that 453 | transaction who receives a copy of the work also receives whatever 454 | licenses to the work the party's predecessor in interest had or could 455 | give under the previous paragraph, plus a right to possession of the 456 | Corresponding Source of the work from the predecessor in interest, if 457 | the predecessor has it or can get it with reasonable efforts. 458 | 459 | You may not impose any further restrictions on the exercise of the 460 | rights granted or affirmed under this License. For example, you may 461 | not impose a license fee, royalty, or other charge for exercise of 462 | rights granted under this License, and you may not initiate litigation 463 | (including a cross-claim or counterclaim in a lawsuit) alleging that 464 | any patent claim is infringed by making, using, selling, offering for 465 | sale, or importing the Program or any portion of it. 466 | 467 | #### 11. Patents. 468 | 469 | A "contributor" is a copyright holder who authorizes use under this 470 | License of the Program or a work on which the Program is based. The 471 | work thus licensed is called the contributor's "contributor version". 472 | 473 | A contributor's "essential patent claims" are all patent claims owned 474 | or controlled by the contributor, whether already acquired or 475 | hereafter acquired, that would be infringed by some manner, permitted 476 | by this License, of making, using, or selling its contributor version, 477 | but do not include claims that would be infringed only as a 478 | consequence of further modification of the contributor version. For 479 | purposes of this definition, "control" includes the right to grant 480 | patent sublicenses in a manner consistent with the requirements of 481 | this License. 482 | 483 | Each contributor grants you a non-exclusive, worldwide, royalty-free 484 | patent license under the contributor's essential patent claims, to 485 | make, use, sell, offer for sale, import and otherwise run, modify and 486 | propagate the contents of its contributor version. 487 | 488 | In the following three paragraphs, a "patent license" is any express 489 | agreement or commitment, however denominated, not to enforce a patent 490 | (such as an express permission to practice a patent or covenant not to 491 | sue for patent infringement). To "grant" such a patent license to a 492 | party means to make such an agreement or commitment not to enforce a 493 | patent against the party. 494 | 495 | If you convey a covered work, knowingly relying on a patent license, 496 | and the Corresponding Source of the work is not available for anyone 497 | to copy, free of charge and under the terms of this License, through a 498 | publicly available network server or other readily accessible means, 499 | then you must either (1) cause the Corresponding Source to be so 500 | available, or (2) arrange to deprive yourself of the benefit of the 501 | patent license for this particular work, or (3) arrange, in a manner 502 | consistent with the requirements of this License, to extend the patent 503 | license to downstream recipients. "Knowingly relying" means you have 504 | actual knowledge that, but for the patent license, your conveying the 505 | covered work in a country, or your recipient's use of the covered work 506 | in a country, would infringe one or more identifiable patents in that 507 | country that you have reason to believe are valid. 508 | 509 | If, pursuant to or in connection with a single transaction or 510 | arrangement, you convey, or propagate by procuring conveyance of, a 511 | covered work, and grant a patent license to some of the parties 512 | receiving the covered work authorizing them to use, propagate, modify 513 | or convey a specific copy of the covered work, then the patent license 514 | you grant is automatically extended to all recipients of the covered 515 | work and works based on it. 516 | 517 | A patent license is "discriminatory" if it does not include within the 518 | scope of its coverage, prohibits the exercise of, or is conditioned on 519 | the non-exercise of one or more of the rights that are specifically 520 | granted under this License. You may not convey a covered work if you 521 | are a party to an arrangement with a third party that is in the 522 | business of distributing software, under which you make payment to the 523 | third party based on the extent of your activity of conveying the 524 | work, and under which the third party grants, to any of the parties 525 | who would receive the covered work from you, a discriminatory patent 526 | license (a) in connection with copies of the covered work conveyed by 527 | you (or copies made from those copies), or (b) primarily for and in 528 | connection with specific products or compilations that contain the 529 | covered work, unless you entered into that arrangement, or that patent 530 | license was granted, prior to 28 March 2007. 531 | 532 | Nothing in this License shall be construed as excluding or limiting 533 | any implied license or other defenses to infringement that may 534 | otherwise be available to you under applicable patent law. 535 | 536 | #### 12. No Surrender of Others' Freedom. 537 | 538 | If conditions are imposed on you (whether by court order, agreement or 539 | otherwise) that contradict the conditions of this License, they do not 540 | excuse you from the conditions of this License. If you cannot convey a 541 | covered work so as to satisfy simultaneously your obligations under 542 | this License and any other pertinent obligations, then as a 543 | consequence you may not convey it at all. For example, if you agree to 544 | terms that obligate you to collect a royalty for further conveying 545 | from those to whom you convey the Program, the only way you could 546 | satisfy both those terms and this License would be to refrain entirely 547 | from conveying the Program. 548 | 549 | #### 13. Use with the GNU Affero General Public License. 550 | 551 | Notwithstanding any other provision of this License, you have 552 | permission to link or combine any covered work with a work licensed 553 | under version 3 of the GNU Affero General Public License into a single 554 | combined work, and to convey the resulting work. The terms of this 555 | License will continue to apply to the part which is the covered work, 556 | but the special requirements of the GNU Affero General Public License, 557 | section 13, concerning interaction through a network will apply to the 558 | combination as such. 559 | 560 | #### 14. Revised Versions of this License. 561 | 562 | The Free Software Foundation may publish revised and/or new versions 563 | of the GNU General Public License from time to time. Such new versions 564 | will be similar in spirit to the present version, but may differ in 565 | detail to address new problems or concerns. 566 | 567 | Each version is given a distinguishing version number. If the Program 568 | specifies that a certain numbered version of the GNU General Public 569 | License "or any later version" applies to it, you have the option of 570 | following the terms and conditions either of that numbered version or 571 | of any later version published by the Free Software Foundation. If the 572 | Program does not specify a version number of the GNU General Public 573 | License, you may choose any version ever published by the Free 574 | Software Foundation. 575 | 576 | If the Program specifies that a proxy can decide which future versions 577 | of the GNU General Public License can be used, that proxy's public 578 | statement of acceptance of a version permanently authorizes you to 579 | choose that version for the Program. 580 | 581 | Later license versions may give you additional or different 582 | permissions. However, no additional obligations are imposed on any 583 | author or copyright holder as a result of your choosing to follow a 584 | later version. 585 | 586 | #### 15. Disclaimer of Warranty. 587 | 588 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 589 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 590 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT 591 | WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT 592 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 593 | A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND 594 | PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE 595 | DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR 596 | CORRECTION. 597 | 598 | #### 16. Limitation of Liability. 599 | 600 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 601 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR 602 | CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 603 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES 604 | ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT 605 | NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR 606 | LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM 607 | TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER 608 | PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 609 | 610 | #### 17. Interpretation of Sections 15 and 16. 611 | 612 | If the disclaimer of warranty and limitation of liability provided 613 | above cannot be given local legal effect according to their terms, 614 | reviewing courts shall apply local law that most closely approximates 615 | an absolute waiver of all civil liability in connection with the 616 | Program, unless a warranty or assumption of liability accompanies a 617 | copy of the Program in return for a fee. 618 | 619 | END OF TERMS AND CONDITIONS 620 | 621 | ### How to Apply These Terms to Your New Programs 622 | 623 | If you develop a new program, and you want it to be of the greatest 624 | possible use to the public, the best way to achieve this is to make it 625 | free software which everyone can redistribute and change under these 626 | terms. 627 | 628 | To do so, attach the following notices to the program. It is safest to 629 | attach them to the start of each source file to most effectively state 630 | the exclusion of warranty; and each file should have at least the 631 | "copyright" line and a pointer to where the full notice is found. 632 | 633 | 634 | Copyright (C) 635 | 636 | This program is free software: you can redistribute it and/or modify 637 | it under the terms of the GNU General Public License as published by 638 | the Free Software Foundation, either version 3 of the License, or 639 | (at your option) any later version. 640 | 641 | This program is distributed in the hope that it will be useful, 642 | but WITHOUT ANY WARRANTY; without even the implied warranty of 643 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 644 | GNU General Public License for more details. 645 | 646 | You should have received a copy of the GNU General Public License 647 | along with this program. If not, see . 648 | 649 | Also add information on how to contact you by electronic and paper 650 | mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands \`show w' and \`show c' should show the 661 | appropriate parts of the General Public License. Of course, your 662 | program's commands might be different; for a GUI interface, you would 663 | use an "about box". 664 | 665 | You should also get your employer (if you work as a programmer) or 666 | school, if any, to sign a "copyright disclaimer" for the program, if 667 | necessary. For more information on this, and how to apply and follow 668 | the GNU GPL, see . 669 | 670 | The GNU General Public License does not permit incorporating your 671 | program into proprietary programs. If your program is a subroutine 672 | library, you may consider it more useful to permit linking proprietary 673 | applications with the library. If this is what you want to do, use the 674 | GNU Lesser General Public License instead of this License. But first, 675 | please read . 676 | --------------------------------------------------------------------------------