├── .github └── workflows │ ├── compile-bc-trends.yaml │ ├── daily_update.yaml │ └── school_update.yaml ├── .gitignore ├── BCCovidSnippets.Rproj ├── R └── helpers.R ├── README.md ├── bc_covid_trends.Rmd ├── bc_covid_trends.md ├── bc_covid_trends_files └── figure-gfm │ ├── bc-trend-1.png │ ├── bc-trend-log-1.png │ ├── bc_age_groups-1.png │ ├── ha-trend-1.png │ ├── ha-trend-log-1.png │ ├── hr-check-1.png │ ├── hr-trend-1.png │ ├── hr-trend-2-1.png │ ├── hr-trend-log-1.png │ ├── main-ha-trend-1.png │ └── relative_age_prevalence-1.png ├── bc_projections.Rmd ├── bc_school_tracker.Rmd ├── bc_school_tracker.md ├── bc_school_tracker_files └── figure-gfm │ ├── school-tracker-children-1.png │ ├── school-tracker-monthly-1.png │ ├── school-tracker-schools-1.png │ └── schools_voc-1.png ├── data ├── CM_data_14cb5e4534337f49721343b7fe7ded32.rda ├── CM_geo_6b42dc9bcf266cb7c9bfbbbf40889c49.geojson ├── CM_geo_e0f185a0c335b032df17fa063ccc9238.geojson ├── COVID19_VoC_data.csv ├── ha_pop.csv ├── ha_pop_age.csv ├── hr_pop.csv ├── n501y.csv ├── prov_pop.csv ├── prov_pop_age.csv ├── prov_pop_data └── wastewater-2022-01-19.csv ├── health_region_data.Rmd ├── open_table.Rmd ├── open_table.md ├── open_table_files └── figure-gfm │ ├── open-table-canada-cities-1.png │ └── open-table-canada-cities-2-1.png ├── reports.Rmd ├── reports.md ├── reports_files └── figure-gfm │ ├── bc-hospitalizations-1.png │ ├── bc-overview-1.png │ ├── hospital-admissions-1.png │ ├── hr-trend-recent-1.png │ ├── icu-share-1.png │ ├── under-10-1.png │ ├── wastewater-covid-1.png │ ├── wastewater-covid-2-1.png │ ├── wastewater-covid-zoomed-1.png │ └── wastewater-covid-zoomed-log-1.png ├── statcan_wastewater.Rmd ├── statcan_wastewater.md ├── statcan_wastewater_files └── figure-gfm │ └── unnamed-chunk-2-1.png ├── two_covid_canadas.Rmd ├── two_covid_canadas.md ├── two_covid_canadas_files └── figure-gfm │ ├── two-covid-canadas-1.png │ ├── two-covid-canadas-overview-1.png │ └── two-covid-canadas-trend-1.png ├── vaccination_tracker.Rmd ├── vaccination_tracker.md ├── vaccination_tracker.old.Rmd └── vaccination_tracker_files └── figure-gfm ├── unnamed-chunk-3-1.png ├── vaccination-complete-1.png ├── vaccination-dose-1.png └── vaccination-status-1.png /.github/workflows/compile-bc-trends.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | paths: 4 | - bc_covid_trends.Rmd 5 | - two_covid_canadas.Rmd 6 | - open_table.Rmd 7 | - vaccination_tracker.Rmd 8 | - reports.Rmd 9 | - .github/workflows/compile-bc-trends.yaml 10 | schedule: 11 | - cron: "35 0,23 * * *" 12 | 13 | name: Render BC Trends 14 | 15 | jobs: 16 | render: 17 | name: Render BC Trends 18 | runs-on: macOS-latest 19 | env: 20 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 21 | nextzen_API_key: ${{ secrets.NEXTZEN_API_KEY }} 22 | AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} 23 | AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} 24 | AWS_DEFAULT_REGION: ${{ secrets.AWS_DEFAULT_REGION }} 25 | steps: 26 | - uses: actions/checkout@v3 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | - uses: r-lib/actions/setup-pandoc@v2 31 | - name: "[Custom block] [macOS] Install spatial libraries" 32 | if: runner.os == 'macOS' 33 | run: | 34 | brew install udunits 35 | brew install pkg-config gdal proj geos udunits 36 | - name: Install rmarkdown, remotes, and required packages 37 | run: | 38 | install.packages("remotes") 39 | install.packages("ggplot2") 40 | install.packages("tidyr") 41 | install.packages("dplyr") 42 | install.packages("roll") 43 | install.packages("readr") 44 | install.packages("MetBrewer") 45 | install.packages("ggrepel") 46 | install.packages("ggtext") 47 | install.packages("rmarkdown") 48 | install.packages("here") 49 | install.packages("sanzo") 50 | install.packages("scales") 51 | install.packages("stringr") 52 | install.packages("rvest") 53 | install.packages("segmented") 54 | install.packages("sf",type="binary") 55 | install.packages("patchwork") 56 | install.packages("broom") 57 | install.packages("cansim") 58 | remotes::install_github("ropensci/weathercan") 59 | remotes::install_github("mountainMath/CanCovidData") 60 | shell: Rscript {0} 61 | - name: Render BC Trends 62 | run: | 63 | Rscript -e 'rmarkdown::render("bc_covid_trends.Rmd")' 64 | - name: Render Vaccination Tracker 65 | run: | 66 | Rscript -e 'rmarkdown::render("vaccination_tracker.Rmd")' 67 | - name: Render Reports 68 | run: | 69 | Rscript -e 'rmarkdown::render("reports.Rmd")' 70 | - name: Commit results 71 | run: | 72 | git config --local user.email "actions@github.com" 73 | git config --local user.name "GitHub Actions" 74 | git commit -m 'Re-build bc_covid_trends.Rmd' || echo "No changes to commit" 75 | git commit bc_covid_trends.md bc_covid_trends_files -m 'Re-build bc_covid_trends.Rmd' || echo "No changes to commit" 76 | git commit open_table.md open_table_files -m 'Re-build open_table.Rmd' || echo "No changes to commit" 77 | git commit reports.md reports_files -m 'Re-build reports.Rmd' || echo "No changes to commit" 78 | git commit vaccination_tracker.md vaccination_tracker_files -m 'Re-build vaccination_tracker.Rmd' || echo "No changes to commit" 79 | git push origin || echo "No changes to commit" -------------------------------------------------------------------------------- /.github/workflows/daily_update.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | schedule: 3 | - cron: "55 0,23 * * *" 4 | 5 | name: Render BC Trends hourly 6 | 7 | jobs: 8 | render: 9 | name: Render BC Trends hourly 10 | runs-on: macOS-latest 11 | env: 12 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 13 | nextzen_API_key: ${{ secrets.NEXTZEN_API_KEY }} 14 | AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} 15 | AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} 16 | AWS_DEFAULT_REGION: ${{ secrets.AWS_DEFAULT_REGION }} 17 | steps: 18 | - uses: actions/checkout@v2 19 | - uses: r-lib/actions/setup-r@v1 20 | - uses: r-lib/actions/setup-pandoc@v1 21 | - name: "[Custom block] [macOS] Install spatial libraries" 22 | if: runner.os == 'macOS' 23 | run: | 24 | # conflicts with gfortran from r-lib/actions when linking gcc 25 | #rm '/usr/local/bin/gfortran' 26 | brew install udunits 27 | brew install pkg-config gdal proj geos udunits 28 | - name: Install rmarkdown, remotes, and required packages 29 | run: | 30 | install.packages("remotes") 31 | install.packages("ggplot2") 32 | install.packages("tidyr") 33 | install.packages("dplyr") 34 | install.packages("roll") 35 | install.packages("readr") 36 | install.packages("MetBrewer") 37 | install.packages("ggrepel") 38 | install.packages("ggtext") 39 | install.packages("rmarkdown") 40 | install.packages("here") 41 | install.packages("sanzo") 42 | install.packages("scales") 43 | install.packages("cansim") 44 | install.packages("stringr") 45 | install.packages("rvest") 46 | install.packages("segmented") 47 | install.packages("sf",type="binary") 48 | install.packages("patchwork") 49 | remotes::install_github("mountainMath/cansim") 50 | remotes::install_github("mountainMath/CanCovidData") 51 | shell: Rscript {0} 52 | - name: Render BC Trends 53 | run: | 54 | Rscript -e 'rmarkdown::render("bc_covid_trends.Rmd")' 55 | - name: Render Two COVID Canadas 56 | run: | 57 | Rscript -e 'rmarkdown::render("two_covid_canadas.Rmd")' 58 | - name: Render Vaccination Tracker 59 | run: | 60 | Rscript -e 'rmarkdown::render("vaccination_tracker.Rmd")' 61 | - name: Commit results 62 | run: | 63 | git config --local user.email "actions@github.com" 64 | git config --local user.name "GitHub Actions" 65 | git commit -m 'Re-build bc_covid_trends.Rmd' || echo "No changes to commit" 66 | git commit bc_covid_trends.md bc_covid_trends_files -m 'Re-build bc_covid_trends.Rmd' || echo "No changes to commit" 67 | git commit two_covid_canadas.md two_covid_canadas_files -m 'Re-build two_covid_canadas.Rmd' || echo "No changes to commit" 68 | git commit open_table.md open_table_files -m 'Re-build open_table.Rmd' || echo "No changes to commit" 69 | git commit vaccination_tracker.md vaccination_tracker_files -m 'Re-build vaccination_tracker.Rmd' || echo "No changes to commit" 70 | git push origin || echo "No changes to commit" 71 | -------------------------------------------------------------------------------- /.github/workflows/school_update.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | paths: 4 | - bc_school_tracker.Rmd 5 | - .github/workflows/school_update.yaml 6 | #schedule: 7 | #- cron: "0 8 * * *" 8 | 9 | name: Render BC School Tracker 10 | 11 | jobs: 12 | render: 13 | name: Render BC School Tracker 14 | runs-on: macOS-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | nextzen_API_key: ${{ secrets.NEXTZEN_API_KEY }} 18 | AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} 19 | AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} 20 | AWS_DEFAULT_REGION: ${{ secrets.AWS_DEFAULT_REGION }} 21 | steps: 22 | - uses: actions/checkout@v2 23 | - uses: r-lib/actions/setup-r@v1 24 | - uses: r-lib/actions/setup-pandoc@v1 25 | - name: "[Custom block] [macOS] Install spatial libraries" 26 | if: runner.os == 'macOS' 27 | run: | 28 | # conflicts with gfortran from r-lib/actions when linking gcc 29 | rm '/usr/local/bin/gfortran' 30 | brew install pkg-config gdal proj geos udunits 31 | - name: Install rmarkdown, remotes, and required packages 32 | run: | 33 | install.packages("remotes") 34 | install.packages("ggplot2") 35 | install.packages("tidyr") 36 | install.packages("dplyr") 37 | install.packages("roll") 38 | install.packages("readr") 39 | install.packages("ggrepel") 40 | install.packages("ggtext") 41 | install.packages("rmarkdown") 42 | install.packages("here") 43 | install.packages("sanzo") 44 | install.packages("scales") 45 | install.packages("cansim") 46 | install.packages("cancensus") 47 | install.packages("stringr") 48 | install.packages("rvest") 49 | install.packages("lubridate") 50 | install.packages("sf",type="binary") 51 | install.packages("PROJ",type="binary") 52 | install.packages("geojsonsf") 53 | remotes::install_github("mountainMath/mountainmathHelpers") 54 | remotes::install_github("mountainMath/dotdensity") 55 | remotes::install_github("mountainMath/cansim") 56 | remotes::install_github("mountainMath/CanCovidData") 57 | shell: Rscript {0} 58 | - name: Render BC School Tracker 59 | run: | 60 | Rscript -e 'rmarkdown::render("bc_school_tracker.Rmd")' 61 | - name: Commit results 62 | run: | 63 | git config --local user.email "actions@github.com" 64 | git config --local user.name "GitHub Actions" 65 | git commit -m 'Re-build bc_school_tracker.Rmd' || echo "No changes to commit" 66 | git commit bc_school_tracker.md bc_school_tracker_files -m 'Re-build bc_school_tracker.Rmd' || echo "No changes to commit" 67 | git push origin || echo "No changes to commit" 68 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .DS_Store -------------------------------------------------------------------------------- /BCCovidSnippets.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | extract_stl_trend <- function(c,s.window=21,t.window=14){ 2 | #print(length(c)) 3 | cc <- c %>% 4 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 5 | stl(s.window=s.window,t.window=t.window) 6 | 7 | as_tibble(cc$time.series)$trend 8 | } 9 | 10 | extract_stl_seasonal <- function(c,s.window=21,t.window=14){ 11 | #print(length(c)) 12 | cc <- c %>% 13 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 14 | stl(s.window=s.window,t.window=t.window) 15 | 16 | as_tibble(cc$time.series)$seasonal 17 | } 18 | 19 | 20 | extract_stl_trend_m <- function(c,s.window=21,t.window=14){ 21 | #print(length(c)) 22 | cc <- c %>% 23 | log %>% 24 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 25 | stl(s.window=s.window,t.window=t.window) 26 | 27 | as_tibble(cc$time.series)$trend %>% exp() 28 | } 29 | 30 | extract_stl_seasonal_m <- function(c,s.window=21,t.window=14){ 31 | #print(length(c)) 32 | cc <- c %>% 33 | log() %>% 34 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 35 | stl(s.window=s.window,t.window=t.window) 36 | 37 | as_tibble(cc$time.series)$seasonal%>% exp() 38 | } 39 | 40 | 41 | add_stl_trend_m <- function(c,s.window=21,t.window=14){ 42 | #print(length(c)) 43 | cc <- c %>% 44 | log() %>% 45 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 46 | stl(s.window=s.window,t.window=t.window) 47 | 48 | as_tibble(cc$time.series) %>% 49 | mutate_all(exp) 50 | } 51 | 52 | get_stl_trend_uncertainty <- function(c,s.window=21,t.window=14,level=0.8,gr_add=c(0,0)){ 53 | #print(length(c)) 54 | lc <- log(c) 55 | cc0 <- lc %>% 56 | ts(frequency = 7,start = as.numeric(format(Sys.Date(), "%j"))) %>% 57 | stl(s.window=s.window,t.window=t.window) 58 | 59 | sc <- as_tibble(cc0$time.series)$seasonal 60 | sa <- exp(lc-sc) 61 | pre_trend <- exp(as_tibble(cc0$time.series)$trend) 62 | 63 | fit21<-glm(c~d,data=tibble(c=tail(sa,21),d=seq(0,20)),family=quasipoisson(link = "log")) 64 | fit14<-glm(c~d,data=tibble(c=tail(sa,14),d=seq(0,13)),family=quasipoisson(link = "log")) 65 | fit7<-glm(c~d,data=tibble(c=tail(sa,7),d=seq(0,6)),family=quasipoisson(link = "log")) 66 | 67 | gr21 <- suppressMessages(fit14 %>% confint(level=level)) 68 | gr14 <- suppressMessages(fit14 %>% confint(level=level)) 69 | gr7 <- suppressMessages(fit7 %>% confint(level=level)) 70 | 71 | 72 | 73 | anchor <- tibble(start=c(#log(pre_trend[length(pre_trend)-5])+5*gr21[2,], 74 | log(pre_trend[length(pre_trend)-3])+3*(gr14[2,]+gr_add), 75 | log(pre_trend[length(pre_trend)-3])+3*(gr7[2,]+gr_add)) %>% exp(), 76 | fit=c("fit14-","fit14+","fit7-","fit7+"), 77 | dd=length(c) %>% as.character, 78 | slope=c(#gr21[2,], 79 | gr14[2,],gr7[2,])) %>% 80 | complete(dd=seq(length(c),length(c)+7) %>% as.character,nesting(fit,start,slope)) %>% 81 | mutate(d=as.integer(dd)) %>% 82 | group_by(fit) %>% 83 | arrange(d) %>% 84 | mutate(s=sc[seq(length(sc)-7,length(sc))]) %>% 85 | ungroup %>% 86 | mutate(Cases=exp((log(start)+(d-length(c))*slope)+s)) %>% 87 | filter(d>length(c)) %>% 88 | bind_rows(tibble(Cases=c,fit="fit14-") %>% 89 | mutate(d=row_number()) %>% 90 | complete(fit=c("fit14-","fit14+","fit7-","fit7+"),nesting(Cases,d))) %>% 91 | arrange(fit,d) %>% 92 | select(d,Cases,fit) 93 | 94 | anchor <- anchor %>% 95 | group_by(.data$fit) %>% 96 | arrange(.data$d) %>% 97 | mutate(stl=add_stl_trend_m(Cases)) %>% 98 | mutate(trend=stl$trend) 99 | 100 | dd<-anchor %>% 101 | arrange(d) %>% 102 | filter(d<=length(c)) %>% 103 | group_by(fit) %>% 104 | group_map(~ .x$stl %>% mutate(fit=.y$fit,d=.x$d)) %>% 105 | bind_rows() 106 | 107 | ddd<-dd %>% 108 | left_join(tibble(Cases=c,pre_trend=pre_trend) %>% mutate(d=row_number()),by="d") %>% 109 | group_by(d) %>% 110 | mutate(diff=max(abs(pre_trend-trend))) %>% 111 | ungroup() %>% 112 | filter(d>=min(filter(.,diff>0.25)$d)-1) %>% 113 | group_by(d) %>% 114 | summarise(max=max(trend),min=min(trend),Cases=mean(Cases),pre_trend=mean(pre_trend),diff=mean(diff)) %>% 115 | ungroup %>% 116 | mutate(dm=d-max(d)) %>% 117 | mutate(min=pmin(min,pre_trend), 118 | max=pmax(max,pre_trend)) %>% 119 | select(d=dm,min,max) 120 | } 121 | 122 | get_stl_fan <- function(data,stl_floor=5,level=0.5,gr_add=c(-0.01,0.01)) { 123 | gs <- groups(data) %>% as.character() %>% syms 124 | data %>% 125 | arrange(Date) %>% 126 | group_map(~get_stl_trend_uncertainty(.x$Cases+stl_floor,level=level,gr_add=gr_add) %>% 127 | mutate(HA=.y$HA,AG=.y$AG,HR=.y$HR)) %>% 128 | bind_rows() %>% 129 | mutate_at(c("min","max"),function(d)pmax(0,d-stl_floor)) %>% 130 | mutate(Date=max(data$Date)+d) %>% 131 | mutate(run=0) %>% 132 | complete(run=seq(0,5),nesting(!!!gs,Date,min,max)) %>% 133 | mutate(p=run/5) %>% 134 | mutate(value=min*p+max*(1-p)) 135 | } 136 | 137 | compute_rolling_exp_fit <- function(r,window_width=7,min_obs=window_width-1,se=3){ 138 | reg<-roll::roll_lm(seq(1,length(r)),log(r),width=window_width,min_obs=min_obs) 139 | reg$coefficients %>% 140 | as_tibble %>% 141 | select(shift=`(Intercept)`,slope=x1) %>% 142 | cbind(reg$std.error %>% 143 | as_tibble %>% 144 | select(shift_e=`(Intercept)`,slope_e=x1)) %>% 145 | mutate(low=slope-se*slope_e,high=slope+se*slope_e) %>% 146 | select(r=slope,low,high) 147 | } 148 | 149 | clean_missing_weekend_data <- function(tl){ 150 | zeros <- which(tl==0) 151 | blocks <- which(!(zeros %in% (zeros+1))) 152 | lengths <-lead(blocks)-blocks 153 | lengths[length(lengths)]=length(zeros[zeros>=zeros[blocks[length(blocks)]]]) 154 | for (i in seq(1,length(blocks))){ 155 | b=zeros[blocks[i]] 156 | l=lengths[i] 157 | e=b+l 158 | if (e>length(tl)) { 159 | l=l-1 160 | e=e-1 161 | } 162 | v=tl[e]/(l+1) 163 | for (j in seq(0,l)) { 164 | tl[b+j]=v 165 | } 166 | } 167 | tl 168 | } 169 | 170 | 171 | graph_to_s3 <- function(graph,s3_bucket,s3_path,content_type="image/png",width=7,height=7,dpi = 150){ 172 | tmp <- tempfile(fileext = ".png") 173 | ggsave(tmp,plot=graph,width=width,height=height,dpi = dpi) 174 | 175 | result <- aws.s3::put_object(file=tmp, 176 | object=s3_path, 177 | bucket=s3_bucket, 178 | multipart = TRUE, 179 | acl="public-read", 180 | headers=list("Content-Type"=content_type, 181 | "Cache-Control"="no-cache", 182 | "Etag"=digest::digest(Sys.time()))) 183 | 184 | } 185 | 186 | body_for_plant <- function(plant,type){ 187 | if (type=="concentration") { 188 | body=paste0('5a8cb96f-9e2f-49f2-b863-65de98c03b33true<View> <ViewFields> <FieldRef Name="LinkTitle" /> <FieldRef Name="Plant" /> <FieldRef Name="Date" /> <FieldRef Name="Value" /> <FieldRef Name="Note" /> <FieldRef Name="CalculatedDate" /> </ViewFields> <RowLimit Paged="TRUE">1000</RowLimit> <Query> <Where><Eq> <FieldRef Name="Plant" /> <Value Type="text">',plant,'</Value> </Eq></Where> <OrderBy> <FieldRef Name="Date" Ascending="TRUE" /> </OrderBy> </Query> </View> ') 189 | #body = paste0('5a8cb96f-9e2f-49f2-b863-65de98c03b33true<View> <ViewFields> <FieldRef Name="LinkTitle" /> <FieldRef Name="Plant" /> <FieldRef Name="Date" /> <FieldRef Name="Value" /> <FieldRef Name="Note" /> <FieldRef Name="CalculatedDate" /> </ViewFields> <RowLimit Paged="TRUE">1000</RowLimit> <Query> <Where><Eq> <FieldRef Name="Plant" /> <Value Type="text">',plant,'</Value> </Eq></Where> <OrderBy> <FieldRef Name="Date" Ascending="TRUE" /> </OrderBy> </Query> </View> ') 190 | } else if (type=="flow_normalized") { 191 | body <- paste0('5a8cb96f-9e2f-49f2-b863-65de98c03b33true<View> <ViewFields> <FieldRef Name="LinkTitle"/> <FieldRef Name="Plant"/> <FieldRef Name="Date"/> <FieldRef Name="Note"/> <FieldRef Name="CalculatedDate"/> <FieldRef Name="DailyLoad"/> </ViewFields> <RowLimit Paged="TRUE">1000</RowLimit> <Query> <Where><Eq> <FieldRef Name="Plant" /> <Value Type="text">',plant,'</Value> </Eq></Where> <OrderBy> <FieldRef Name="Date" Ascending="TRUE"/> </OrderBy> </Query> </View> ') 192 | } else { 193 | stop("unknown type") 194 | } 195 | body 196 | } 197 | 198 | get_data_for_plant_and_type <- function(plant,type="concentration"){ 199 | url <- "http://www.metrovancouver.org/services/liquid-waste/environmental-management/covid-19-wastewater/_vti_bin/client.svc/ProcessQuery" 200 | 201 | r<-httr::POST(url,body=body_for_plant(plant,type), 202 | httr::add_headers("Content-Type"="text/xml", 203 | "Accept"= "*/*", 204 | "Accept-Encoding"= "gzip, deflate", 205 | "X-Requested-With"= "XMLHttpRequest", 206 | "X-RequestDigest"= 207 | "0x1F23E733AF354BD8BA79396EE3A8F6307FDFB48F08B04BA9AA0005F58971EA9A936845E31FC3C144A447DA60DB6A6798F7AE8E054146DFE10F3A6A757929B5AA,21 Aug 2021 01:01:59 -0000"), 208 | httr::set_cookies("SPUsageId"="3332b361-25e6-4386-9dbc-eacf5c2212b5")) 209 | c<-httr::content(r) 210 | 211 | headers<- c("CalculatedDate","Plant","Value","DailyLoad") 212 | d<-c[[17]][["_Child_Items_"]] %>% 213 | lapply(function(e){ 214 | #as_tibble(e[headers]) 215 | v<-e$Value 216 | if (is.null(v)) v <- NA 217 | v2<-e$DailyLoad 218 | if (is.null(v2)) v2 <- NA 219 | tibble(Date=gsub("\\/Date\\(|\\)\\/","",e$Date), 220 | CalculatedDate=e$CalculatedDate, 221 | Plant=e$Plant, 222 | Version=e$`_ObjectVersion_`, 223 | Value=v, 224 | DailyLoad=v2) 225 | }) %>% 226 | bind_rows() %>% 227 | mutate(DateTime=as.POSIXct(as.numeric(Date)/1000, 228 | origin="1970-01-01", tz="America/Vancouver")) %>% 229 | mutate(Date=as.Date(CalculatedDate,format="%Y/%m/%d")) 230 | d 231 | } 232 | 233 | get_data_for_plant <- function(plant){ 234 | d1<-get_data_for_plant_and_type(plant,"concentration") 235 | d2<-get_data_for_plant_and_type(plant,"flow_normalized") 236 | 237 | d<-d1 %>% select(-DailyLoad) %>% 238 | left_join(d2 %>% select(Date,DailyLoad),by="Date") 239 | d 240 | } 241 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # BC Covid Snippets 2 | 3 | Some snippets for basic descriptive COVID-19 analysis in BC. Code can be found in the notebooks. 4 | 5 | Two notebooks are recompiled daily with high-resolution images at 5pm Pacific time: 6 | 7 | * [BC Trends](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_covid_trends.md) 8 | * [Two COVID Canadas](https://github.com/mountainMath/BCCovidSnippets/blob/main/two_covid_canadas.md) 9 | * [Open Table dine-in reservations](https://github.com/mountainMath/BCCovidSnippets/blob/main/open_table.md) 10 | * [BC School Tracker](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_school_tracker.md) 11 | * [Vaccination Tracker](https://github.com/mountainMath/BCCovidSnippets/blob/main/vaccination_tracker.md) 12 | 13 | -------------------------------------------------------------------------------- /bc_covid_trends.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "BC Covid Trends" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | 9 | ```{r setup, include=FALSE} 10 | knitr::opts_chunk$set( 11 | echo = FALSE, 12 | message = FALSE, 13 | warning = FALSE, 14 | fig.retina = 2, 15 | dpi = 150, 16 | fig.width = 7, 17 | fig.height = 5 18 | ) 19 | library(ggplot2) 20 | library(readr) 21 | library(tidyr) 22 | library(dplyr) 23 | library(ggrepel) 24 | library(ggtext) 25 | library(here) 26 | library(sanzo) 27 | library(CanCovidData) 28 | 29 | source(here("R/helpers.R")) 30 | 31 | major_restrictions <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged","2021-03-29"="No indoor dining\nNo indoor group activity\nMasks grades 4-12", 32 | "2021-08-25"="Indoor Masks") 33 | major_restriction_labels <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged","2021-03-07"="No indoor dining\nNo indoor group activity\nMasks grades 4-12", 34 | "2021-08-25"="Indoor Masks") 35 | major_restrictions_y <- c("2020-03-18"=1,"2020-11-07"=0.1,"2020-11-19"=0.3,"2020-03-29"=0.1,"2021-08-25"=1) 36 | minor_restrictions <- c("2020-03-11","2020-03-12","2020-03-16","2020-03-17", 37 | "2020-03-21","2020-03-22","2020-03-26","2020-04-18", 38 | "2020-06-18","2020-08-21","2020-09-08","2020-10-26","2021-04-30", 39 | "2021-07-28","2021-08-06") 40 | major_reopenings <- c("2020-05-19"="Phase 2","2020-06-24"="Phase 3", 41 | "2021-05-25"="Step 1\nreopening","2021-06-15"="Step 2\nreopening", 42 | "2021-07-01"="Step 3\nreopening") 43 | major_reopenings_y_fact <- c(1,1,1,0.8,0.6) 44 | minor_reopenings <- c("2020-05-14","2020-06-01","2020-06-08", 45 | "2020-06-30","2020-07-02","2020-09-10","2020-12-15") 46 | 47 | restriction_markers <- function(major_size=1,minor_size=0.5){ 48 | list( 49 | geom_vline(xintercept = as.Date(minor_reopenings), 50 | linetype="dashed",color="darkgreen",size=minor_size), 51 | geom_vline(xintercept = as.Date(names(major_reopenings)),linetype="dashed",color="darkgreen",size=major_size), 52 | geom_vline(xintercept = as.Date(names(major_restrictions)),linetype="dashed",color="brown",size=major_size), 53 | geom_vline(xintercept = as.Date(minor_restrictions), 54 | linetype="dashed",color="brown",size=minor_size) 55 | )} 56 | 57 | full_labels <- function(label_y, 58 | major_restriction_labels = c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings"), 59 | major_restrictions_y = c(1,0.15)){ 60 | c(restriction_markers(),list( 61 | geom_label(data = tibble(Date=as.Date(names(major_reopenings)), 62 | count=label_y*major_reopenings_y_fact, 63 | label=as.character(major_reopenings)), 64 | aes(label=label),size=4,alpha=0.7,color="darkgreen"), 65 | geom_label(data = tibble(Date=as.Date(names(major_restriction_labels)), 66 | label=as.character(major_restriction_labels), 67 | count=as.numeric(major_restrictions_y)), 68 | aes(label=label),size=4,alpha=0.7,color="brown") 69 | )) 70 | } 71 | 72 | ha_colours <- setNames(c(trios$c157,trios$c149), 73 | c("Fraser","Rest of BC","Vancouver Coastal" , "Vancouver Island", "Interior", "Northern")) 74 | 75 | share_to_ratio <- function(s)1/(1/s-1) 76 | ratio_to_share <- function(r)1/(1+1/r) 77 | if (FALSE) { 78 | n501y <- read_csv("http://www.bccdc.ca/Health-Info-Site/Documents/VoC/Figure1_weeklyreport_data.csv") %>% 79 | #read_csv(here::here("data/COVID19_VoC_data.csv")) %>% 80 | # bind_rows(tibble(epi_cdate=as.Date(c("2021-05-02","2021-05-09")), 81 | # prop_voc=c(83,85), 82 | # epiweek=c(18,19), 83 | # patient_ha="British Columbia")) %>% 84 | mutate(Date=as.Date(`Epiweek - Start Date`)+4, 85 | share_voc=`Proportion of VoC`/100) %>% 86 | filter(Region=="British Columbia") %>% 87 | select(Date,Week=Epiweek,share_voc) %>% 88 | mutate(ratio_voc=share_to_ratio(share_voc)) %>% 89 | mutate(Day=difftime(Date,min(Date),units = "day") %>% unclass) 90 | } else { 91 | n501y<-read_csv(here::here("data/COVID19_VoC_data.csv")) %>% 92 | bind_rows(tibble(patient_ha=c("British Columbia", "Fraser", "Interior", "Northern", 93 | "Vancouver Coastal", "Island"), 94 | epiweek=18, 95 | epi_cdate=as.Date("2021-05-02"), 96 | prop_voc=c(83,82,83,45,92,82))) %>% 97 | #prop_voc=c(85,86,83,45,93,84))) %>% 98 | bind_rows(tibble(patient_ha=c("British Columbia", "Fraser", "Interior", "Northern", 99 | "Vancouver Coastal", "Island"), 100 | epiweek=19, 101 | epi_cdate=as.Date("2021-05-09"), 102 | prop_voc=c(85,82,89,63,94,77))) %>% 103 | mutate(prop_voc=as.numeric(prop_voc)) %>% 104 | mutate(Date=as.Date(epi_cdate)+4, 105 | share_voc=prop_voc/100) %>% 106 | #left_join(get_b.1.617(),by=c("patient_ha","epiweek")) %>% 107 | #mutate(share_voc=share_voc+coalesce(prop_b.1.617,0)/100) %>% 108 | mutate(ratio_voc=share_to_ratio(share_voc)) %>% 109 | filter(patient_ha=="British Columbia") %>% 110 | select(Date,Week=epiweek,share_voc) %>% 111 | mutate(ratio_voc=share_to_ratio(share_voc)) %>% 112 | mutate(Day=difftime(Date,min(Date),units = "day") %>% unclass) 113 | } 114 | 115 | break_day <- n501y %>% filter(Date>=as.Date("2021-04-01")) %>% 116 | head(1) %>% 117 | pull(Day) 118 | 119 | model.n501y <- lm(log(ratio_voc)~Day,data=n501y%>% filter(as.integer(Week)>=7)) 120 | model.n501y.s <- segmented::segmented(model.n501y,psi = break_day) 121 | prediction.n501y <- tibble(Date=seq(as.Date("2021-02-01"),Sys.Date(),by="day")) %>% 122 | mutate(Day=difftime(Date,min(n501y$Date),units = "day") %>% unclass) %>% 123 | mutate(share_voc = predict(model.n501y.s,newdata = .) %>% exp %>% ratio_to_share) 124 | ``` 125 | 126 | 127 | This notebook is intended to give a daily overview over BC Covid Trends. It utilizes a (multiplicative) STL decomposition to esimate a seasonally adjusted time series controlling for the strong weekly pattern in the COVID-19 case data and the trend line. For details check the [R notebook in this GitHub repo](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_covid_trends.Rmd). 128 | 129 | ## Overall BC Trend 130 | 131 | ```{r bc-trend} 132 | data <- get_british_columbia_case_data() %>% 133 | #filter(`Health Authority` %in% c("Vancouver Coastal","Fraser")) %>% 134 | count(Date=`Reported Date`,name="Cases") %>% 135 | filter(Date>=as.Date("2020-03-01")) %>% 136 | mutate(Trend=extract_stl_trend_m(Cases), 137 | Seasonal=extract_stl_seasonal_m(Cases)) %>% 138 | mutate(Cleaned=Cases/Seasonal) %>% 139 | cbind(compute_rolling_exp_fit(.$Trend)) %>% 140 | left_join(prediction.n501y,by="Date") %>% 141 | mutate(`Wild Type`=(1-share_voc)*Trend) 142 | 143 | label_y <- max(data$Cases) * 0.9 144 | 145 | g <- data %>% 146 | pivot_longer(c("Cases","Trend","Cleaned"),#"Wild Type"), 147 | names_to="type",values_to="count") %>% 148 | #filter(Date>=as.Date("2020-11-01")) %>% 149 | ggplot(aes(x = Date, y = count)) + 150 | geom_point(data=~filter(.,type=="Cases"),aes(color=type),size=0.5,shape=21) + 151 | geom_line(data=~filter(.,type=="Cleaned"),aes(color=type),size=0.5,alpha=0.5) + 152 | #geom_line(data=~filter(.,type=="Wild Type",Date<=max(n501y$Date)+3),aes(color=type),size=1) + 153 | #geom_line(data=~filter(.,type=="Wild Type",Date>max(n501y$Date)+3),aes(color=type),size=1,linetype="dotted") + 154 | geom_line(data=~filter(.,type=="Trend"),aes(color=type),size=1) + 155 | theme_bw() + 156 | theme(legend.position = "bottom") + 157 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 158 | full_labels(label_y,major_restriction_labels=major_restriction_labels, 159 | major_restrictions_y=major_restrictions_y*label_y) + 160 | scale_color_manual(values=c("Cases"="darkgrey","Cleaned"="darkgrey", 161 | "Trend"="black"),#,"Wild Type"="steelblue"), 162 | labels=c("Cases"="Reported cases","Cleaned"="Adjusted for weekly pattern", 163 | "Trend"="Overall trend")) + #,"Wild Type"="Wild Type")) + 164 | guides(color = guide_legend(override.aes = list(linetype = c("Cases"=0, "Cleaned"=1,"Trend"=1),#"Wild Type"=1), 165 | shape = c("Cases"=21,"Cleaned"=NA, 166 | "Trend"=NA)))) +#"Wild Type"=NA)) )) + 167 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ", 168 | strftime(max(data$Date),"%a %b %d"),")"), 169 | subtitle="Timeline of closure and reopening events", 170 | x=NULL,y="Number of daily cases",color=NULL,caption="MountainMath, Data: BCCDC") + 171 | theme(plot.subtitle = element_markdown()) + 172 | expand_limits(x=as.Date("2021-09-08")) 173 | g 174 | #r<-graph_to_s3(g,"bccovid","bc-trend.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 175 | ``` 176 | 177 | ## Log scale 178 | The underlying process that generates case data is, to first approximation, exponential. Plotting cases on a log scale makes it easier to spot trends. 179 | 180 | Real development in case data differs from pure exponential growth in three important ways: 181 | 182 | * Change in NPI via change regulation or change in behaviour impacts the trajectory. In BC behaviour has been generally fairly constant over longer time periods, with changes initiated by changes in public health regulations. These changes in increase or decrease the growth rate. (Growth can be negative or positive.) 183 | * Increasing vaccinations lead to sub-exponential growth, on a log plot the case numbers will bend downward. 184 | * Changing mix in COVID variants, this will lead to faster than exponential growth. When some variants are more transmissibly than others and thus incease their share among the cases, the effective rate of growth of cases will accelerate and the cases will bend upwards on a log plot. This is because each variant should be modelled as a separate exponential process, and the sum of exponential processes is not an exponential process. In the long run, the more transmissible variant will take over and the growth rate will follow a simple exponential growth model with growth rate given by the more transmissible variant. 185 | 186 | 187 | ```{r bc-trend-log} 188 | g <- data %>% 189 | pivot_longer(c("Cases","Trend","Cleaned"),#"Wild Type"), 190 | names_to="type",values_to="count") %>% 191 | #filter(Date>=as.Date("2020-11-01")) %>% 192 | ggplot(aes(x = Date, y = count)) + 193 | geom_point(data=~filter(.,type=="Cases"),aes(color=type),size=0.5,shape=21) + 194 | geom_line(data=~filter(.,type=="Cleaned"),aes(color=type),size=0.5,alpha=0.5) + 195 | #geom_line(data=~filter(.,type=="Wild Type",Date<=max(n501y$Date)+3),aes(color=type),size=1) + 196 | #geom_line(data=~filter(.,type=="Wild Type",Date>max(n501y$Date)+3),aes(color=type),size=1,linetype="dotted") + 197 | geom_line(data=~filter(.,type=="Trend"),aes(color=type),size=1) + 198 | theme_bw() + 199 | theme(legend.position = "bottom") + 200 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 201 | full_labels(label_y,major_restriction_labels=major_restriction_labels, 202 | major_restrictions_y=major_restrictions_y*200) + 203 | scale_color_manual(values=c("Cases"="darkgrey","Cleaned"="darkgrey", 204 | "Trend"="black"),#,"Wild Type"="steelblue"), 205 | labels=c("Cases"="Reported cases","Cleaned"="Adjusted for weekly pattern", 206 | "Trend"="Overall trend")) + #,"Wild Type"="Wild Type")) + 207 | guides(color = guide_legend(override.aes = list(linetype = c("Cases"=0, "Cleaned"=1,"Trend"=1),#"Wild Type"=1), 208 | shape = c("Cases"=21,"Cleaned"=NA, 209 | "Trend"=NA)))) +#"Wild Type"=NA)) )) + 210 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ", 211 | strftime(max(data$Date),"%a %b %d"),")"), 212 | subtitle="Timeline of closure and reopening events", 213 | x=NULL,y="Number of daily cases",color=NULL,caption="MountainMath, Data: BCCDC") + 214 | theme(plot.subtitle = element_markdown()) + 215 | scale_y_continuous(trans="log", 216 | breaks=2^seq(0,15)) + 217 | coord_cartesian(ylim=c(4,NA), 218 | xlim=c(as.Date("2020-05-15"),NA)) + 219 | labs(y="Number of daily cases (log scale)") + 220 | expand_limits(x=as.Date("2021-09-08")) 221 | g 222 | ``` 223 | 224 | 225 | ## Main Health Authority Trends 226 | 227 | ```{r main-ha-trend} 228 | pop_data <- read_csv(here("data/ha_pop.csv")) %>% 229 | select(`Health Authority`,Population=Total) 230 | 231 | data <- get_british_columbia_case_data() %>% 232 | mutate(HA=ifelse(`Health Authority` %in% c("Fraser","Vancouver Coastal"),`Health Authority`,"Rest of BC")) %>% 233 | #mutate(HA=`Health Authority`) %>% 234 | count(Date=`Reported Date`,HA, name="Cases") %>% 235 | filter(Date>=as.Date("2020-03-01")) %>% 236 | group_by(HA) %>% 237 | mutate(Trend=extract_stl_trend_m(Cases), 238 | Seasonal=extract_stl_seasonal_m(Cases)) %>% 239 | mutate(Cleaned=Cases/Seasonal) %>% 240 | left_join(read_csv(here("data/ha_pop.csv")) %>% 241 | filter(`Health Authority` != "British Columbia") %>% 242 | mutate(HA=ifelse(`Health Authority` %in% c("Fraser","Vancouver Coastal"), 243 | `Health Authority`,"Rest of BC")) %>% 244 | group_by(HA) %>% 245 | summarize(Population=sum(Total), .groups="drop"), by="HA") %>% 246 | ungroup() %>% 247 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 248 | 249 | label_y <- max(data$Cases) * 0.9 250 | 251 | g <- data %>% 252 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 253 | ggplot(aes(x = Date, y = count)) + 254 | geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.25,aes(color=HA,group=HA)) + 255 | geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.25,aes(color=HA,group=HA)) + 256 | geom_line(data=~filter(.,type=="Trend"),aes(color=HA,group=HA),size=1) + 257 | theme_bw() + 258 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 259 | theme(legend.position = "bottom") + 260 | full_labels(label_y, 261 | major_restriction_labels=c("2020-03-18"="Phase 1"), 262 | major_restrictions_y=label_y) + 263 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 264 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 265 | subtitle="Timeline of closure and reopening events", 266 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 267 | theme(plot.subtitle = element_markdown()) + 268 | expand_limits(x=as.Date("2021-09-08")) 269 | 270 | g 271 | #r<-graph_to_s3(g,"bccovid","main-ha-trend.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 272 | ``` 273 | 274 | ## Health Authority Trends 275 | 276 | ```{r ha-trend} 277 | pop_data <- read_csv(here("data/ha_pop.csv")) %>% 278 | select(`Health Authority`,Population=Total) 279 | 280 | data <- get_british_columbia_case_data() %>% 281 | mutate(HA=`Health Authority`) %>% 282 | filter(HA!="Out of Canada") %>% 283 | #mutate(HA=ifelse(`Health Authority` %in% c("Fraser","Vancouver Coastal"),`Health Authority`,"Rest of BC")) %>% 284 | #mutate(HA=`Health Authority`) %>% 285 | count(Date=`Reported Date`,HA, name="Cases") %>% 286 | filter(Date>=as.Date("2020-03-01")) %>% 287 | #expand(Date=(.)$Date %>% unique,HA,Cases) %>% 288 | #mutate(Cases=coalesce(Cases,0)) %>% 289 | group_by(HA) %>% 290 | mutate(Trend=extract_stl_trend_m(Cases), 291 | Seasonal=extract_stl_seasonal_m(Cases)) %>% 292 | mutate(Cleaned=Cases/Seasonal) %>% 293 | left_join(read_csv(here("data/ha_pop.csv")) %>% 294 | filter(`Health Authority` != "British Columbia") %>% 295 | mutate(HA=`Health Authority`) %>% 296 | group_by(HA) %>% 297 | summarize(Population=sum(Total), .groups="drop"), by="HA") %>% 298 | ungroup() %>% 299 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 300 | 301 | label_y <- max(data$Cases) * 0.9 302 | 303 | g <- data %>% 304 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 305 | ggplot(aes(x = Date, y = count)) + 306 | #geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.25,aes(color=HA,group=HA)) + 307 | #geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.25,aes(color=HA,group=HA)) + 308 | geom_line(data=~filter(.,type=="Trend"),aes(color=HA,group=HA),size=1) + 309 | theme_bw() + 310 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 311 | theme(legend.position = "bottom") + 312 | full_labels(label_y, 313 | major_restriction_labels=c("2020-03-18"="Phase 1"), 314 | major_restrictions_y=label_y) + 315 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 316 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 317 | subtitle="Timeline of closure and reopening events", 318 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 319 | theme(plot.subtitle = element_markdown()) + 320 | expand_limits(x=as.Date("2021-09-08")) 321 | 322 | g 323 | #r<-graph_to_s3(g,"bccovid","ha-trend.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 324 | ``` 325 | A log plot helps identify trends. 326 | 327 | ```{r ha-trend-log} 328 | g+ scale_y_continuous(trans="log", breaks=0.05*2^seq(1,10)) + 329 | labs(y="Daily cases per 100k population (log scale)") + 330 | coord_cartesian(ylim=c(0.1,NA),xlim=c(as.Date("2020-05-15"),NA)) 331 | 332 | ``` 333 | 334 | 335 | ## Health Region Trends 336 | 337 | ```{r hr-trend} 338 | pop_data <- read_csv(here("data/hr_pop.csv")) %>% 339 | select(HR_UID=Region,HR=`Health Service Delivery Area`,Population=Total) 340 | 341 | data <- get_british_columbia_hr_case_data() %>% 342 | rename(HA=`Health Authority`,HR=`Health Region`) %>% 343 | filter(!(HA %in% c("Out of Canada","All")),!(HR %in% c("All","Unknown"))) %>% 344 | filter(Date>=as.Date("2020-03-01")) %>% 345 | group_by(HR,HA) %>% 346 | mutate(Trend=extract_stl_trend_m(Cases+1)-1, 347 | Seasonal=extract_stl_seasonal_m(Cases+1)) %>% 348 | mutate(Cleaned=Cases/Seasonal-1) %>% 349 | left_join(read_csv(here("data/ha_pop.csv")) %>% 350 | select(HA=`Health Authority`,HA_Population=Total), by="HA") %>% 351 | left_join(pop_data, by="HR") %>% 352 | mutate(Population=coalesce(Population,HA_Population)) %>% 353 | ungroup() %>% 354 | mutate(Cases_0=Cases,Trend_0=Trend,Cleand_0=Cleaned) %>% 355 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 356 | 357 | label_y <- max(data$Cases) * 0.9 358 | 359 | g <- data %>% 360 | filter(!(HR %in% c("All","Unknown"))) %>% 361 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 362 | ggplot(aes(x = Date, y = count)) + 363 | #geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 364 | #geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 365 | geom_line(data=~filter(.,type=="Trend"),aes(color=HA,group=HR),size=0.75) + 366 | theme_bw() + 367 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 368 | theme(legend.position = "bottom") + 369 | full_labels(label_y, 370 | major_restriction_labels=c("2020-03-18"="Phase 1"), 371 | major_restrictions_y=label_y) + 372 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 373 | ggrepel::geom_text_repel(data = ~filter(.,Date==max(Date),type=="Trend",count>=5), 374 | aes(label=HR,color=HA),show.legend=FALSE, 375 | nudge_x = 7,direction="y",size=3,hjust=0, 376 | segment.color="black",segment.size = 0.25) + 377 | labs(title=paste0("Covid-19 daily new cases trend lines in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 378 | subtitle="Timeline of closure and reopening events", 379 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 380 | theme(plot.subtitle = element_markdown()) + 381 | expand_limits(x=max(data$Date)+40) 382 | 383 | g 384 | #r<-graph_to_s3(g,"bccovid","hr-trend.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 385 | ``` 386 | 387 | 388 | 389 | 390 | ```{r hr-trend-2} 391 | pop_data <- read_csv(here("data/hr_pop.csv")) %>% 392 | select(HR_UID=Region,HR=`Health Service Delivery Area`,Population=Total) 393 | 394 | 395 | data <- get_british_columbia_hr_case_data() %>% 396 | rename(HA=`Health Authority`,HR=`Health Region`) %>% 397 | filter(!(HA %in% c("Out of Canada","All")),!(HR %in% c("All","Unknown"))) %>% 398 | filter(Date>=as.Date("2020-03-01")) %>% 399 | group_by(HR,HA) %>% 400 | mutate(Trend=extract_stl_trend_m(Cases+1), 401 | Seasonal=extract_stl_seasonal_m(Cases+1)) %>% 402 | mutate(Cleaned=Cases/Seasonal-1) %>% 403 | left_join(read_csv(here("data/ha_pop.csv")) %>% 404 | select(HA=`Health Authority`,HA_Population=Total), by="HA") %>% 405 | left_join(pop_data, by="HR") %>% 406 | mutate(Population=coalesce(Population,HA_Population)) %>% 407 | ungroup() %>% 408 | mutate(Cases_0=Cases,Trend_0=Trend,Cleand_0=Cleaned) %>% 409 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 410 | 411 | hr_colours <- data$HA %>% 412 | unique() %>% 413 | lapply(function(ha){ 414 | hrs <- data %>% filter(HA==ha) %>% pull(HR) %>% unique 415 | setNames(RColorBrewer::brewer.pal(length(hrs),"Dark2"),hrs) 416 | }) %>% 417 | unlist() 418 | 419 | 420 | label_y <- max(data$Cases) * 0.9 421 | 422 | g <- data %>% 423 | filter(!(HR %in% c("All","Unknown"))) %>% 424 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 425 | ggplot(aes(x = Date, y = count)) + 426 | #geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 427 | #geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 428 | restriction_markers(0.5,0.25) + 429 | geom_line(data=~filter(.,type=="Trend"),aes(color=HR,group=HR),size=0.75) + 430 | theme_bw() + 431 | facet_wrap("HA",scales="free_y",ncol=2) + 432 | scale_x_date(breaks="2 months",labels=function(d)strftime(d,"%b")) + 433 | theme(legend.position = "bottom") + 434 | # full_labels(label_y, 435 | # major_restriction_labels=c("2020-03-18"="Phase 1"), 436 | # major_restrictions_y=label_y) + 437 | scale_color_manual(values=hr_colours,guide=FALSE) + 438 | ggrepel::geom_text_repel(data = ~filter(.,Date==max(Date),type=="Trend"),#,count>=5), 439 | aes(label=HR,color=HR),show.legend=FALSE, 440 | nudge_x = 7,direction="y",size=2,hjust=0, 441 | segment.color="black",segment.size = 0.25) + 442 | labs(title=paste0("Covid-19 daily new cases trend lines in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 443 | subtitle="Timeline of closure and reopening events", 444 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 445 | theme(plot.subtitle = element_markdown()) + 446 | expand_limits(x=max(data$Date)+40) 447 | 448 | g 449 | #r<-graph_to_s3(g,"bccovid","hr-trend.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 450 | ``` 451 | 452 | ## Recent trends 453 | ```{r hr-trend-log} 454 | pop_data <- read_csv(here("data/hr_pop.csv")) %>% 455 | select(HR_UID=Region,HR=`Health Service Delivery Area`,Population=Total) 456 | 457 | data <- get_british_columbia_hr_case_data() %>% 458 | rename(HA=`Health Authority`,HR=`Health Region`) %>% 459 | filter(!(HA %in% c("Out of Canada","All")),!(HR %in% c("All","Unknown"))) %>% 460 | filter(Date>=as.Date("2020-03-01")) %>% 461 | group_by(HR,HA) %>% 462 | mutate(Trend=extract_stl_trend_m(Cases+1)-1, 463 | Seasonal=extract_stl_seasonal_m(Cases+1)) %>% 464 | mutate(Cleaned=Cases/Seasonal-1) %>% 465 | left_join(read_csv(here("data/ha_pop.csv")) %>% 466 | select(HA=`Health Authority`,HA_Population=Total), by="HA") %>% 467 | left_join(pop_data, by="HR") %>% 468 | mutate(Population=coalesce(Population,HA_Population)) %>% 469 | ungroup() %>% 470 | mutate(Cases_0=Cases,Trend_0=Trend,Cleand_0=Cleaned) %>% 471 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 472 | 473 | label_y <- max(data$Cases) * 0.9 474 | 475 | g <- data %>% 476 | filter(!(HR %in% c("All","Unknown")),Date>=as.Date("2021-05-15")) %>% 477 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 478 | filter(count>0) %>% 479 | ggplot(aes(x = Date, y = count)) + 480 | #geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 481 | #geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 482 | geom_line(data=~filter(.,type=="Trend"),aes(color=HA,group=HR),size=0.75) + 483 | theme_bw() + 484 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 485 | theme(legend.position = "bottom") + 486 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 487 | ggrepel::geom_text_repel(data = ~filter(.,Date==max(Date),type=="Trend",count>=2), 488 | aes(label=HR,color=HA),show.legend=FALSE, 489 | nudge_x = 7,direction="y",size=3,hjust=0, 490 | segment.color="black",segment.size = 0.25) + 491 | labs(title=paste0("Covid-19 daily new cases trend lines in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 492 | subtitle="Timeline of closure and reopening events", 493 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 494 | theme(plot.subtitle = element_markdown()) + 495 | restriction_markers(0.5,0.25) + 496 | expand_limits(x=max(data$Date)+40) 497 | 498 | g + scale_y_continuous(trans="log", breaks=2^seq(-5,10)) + 499 | labs(y="Daily cases per 100k population (log scale)") + 500 | coord_cartesian(ylim=c(0.1,NA),xlim=c(as.Date("2021-05-15"),NA)) 501 | 502 | ``` 503 | 504 | ### Age groups 505 | Case incidence by age group. 506 | 507 | ```{r bc_age_groups} 508 | bc_pop_age <- read_csv(here::here("data/ha_pop_age.csv")) %>% 509 | pivot_longer(matches("\\d+"),names_to="Age",values_to="Count") %>% 510 | mutate(Age=ifelse(Age=="LT1",0,Age)) %>% 511 | mutate(top=strsplit(Age,"-") %>% lapply(last) %>% unlist %>% as.integer()) %>% 512 | mutate(t=floor(top/10)*10+9) %>% 513 | mutate(`Age group`=paste0(t-9,"-",t)) %>% 514 | mutate(`Age group`=recode(`Age group`,"0-9"="<10","NA-NA"="90+")) %>% 515 | group_by(`Health Authority`,`Age group`) %>% 516 | summarize(Total=first(Total),Count=sum(Count),.groups="drop") %>% 517 | mutate(Share=Count/Total) 518 | 519 | bc_cases_age_date <- get_british_columbia_case_data() %>% 520 | count(`Age group`,Date=`Reported Date`,name="Cases") %>% 521 | complete(`Age group`=unique(.data$`Age group`), 522 | Date=seq(min(.data$Date),max(.data$Date),by="day"), 523 | fill=list(Cases=0)) %>% 524 | left_join(bc_pop_age %>% filter(`Health Authority`=="British Columbia"),by="Age group") %>% 525 | bind_rows(group_by(.,Date) %>% summarize(Cases=sum(Cases),Count=sum(Count,na.rm = TRUE)) %>% mutate(`Age group`="All ages")) %>% 526 | group_by(`Age group`) %>% 527 | arrange(Date) %>% 528 | filter(Date>=as.Date("2020-03-01"),`Age group`!="Unknown") %>% 529 | mutate(Trend=pmax(0,(extract_stl_trend_m(Cases+5)-5))/Count*100000) 530 | 531 | ages <- bc_cases_age_date %>% filter(`Age group`!="Unknown") %>% pull(`Age group`) %>% unique %>% sort %>% 532 | setdiff("All ages") 533 | 534 | age_colours <- setNames(c(RColorBrewer::brewer.pal(length(ages),"Paired"),"black"),c(ages,"All ages")) 535 | 536 | 537 | bc_cases_age_date %>% 538 | group_by(`Age group`) %>% 539 | arrange(Date) %>% 540 | filter(Date>=as.Date("2020-06-01")) %>% 541 | filter(`Age group`!="Unknown") %>% 542 | #mutate(highlight=`Age group` %in% c("<10","10-19","Total")) %>% 543 | ggplot(aes(x=Date,y=Trend,color=highlight,group=`Age group`)) + 544 | #geom_line(size=0.5,color="grey") + 545 | #geom_line(data=~filter(.,highlight),aes(color=`Age group`),size=1) + 546 | geom_line(aes(color=`Age group`),size=0.5) + 547 | theme_bw() + 548 | scale_colour_manual(values=age_colours) + 549 | #scale_y_continuous(trans="log",breaks=c(0.1,0.2,0.5,1,2,5,10,20)) + 550 | scale_x_date(labels=function(d)strftime(d,"%b"),breaks="month") + 551 | #scale_color_manual(values=sanzo::trios$c157) + 552 | labs(title=paste0("Case trend lines by age group in British Columbia (up to ", 553 | strftime(max(bc_cases_age_date$Date),"%a %b %d"),")"), 554 | colour="Age group", 555 | x=NULL,y="Daily case counts trend per 100k population", 556 | caption="MountainMath, Data: BCCDC, BC Stats Population estimates 2019") 557 | ``` 558 | 559 | 560 | ```{r relative_age_prevalence} 561 | bc_cases_prevalence_date <- get_british_columbia_case_data() %>% 562 | count(`Age group`,Date=`Reported Date`,name="Cases") %>% 563 | filter(Date>=as.Date("2020-03-01")) %>% 564 | complete(`Age group`=unique(.data$`Age group`), 565 | Date=seq(min(.data$Date),max(.data$Date),by="day"), 566 | fill=list(Cases=0)) %>% 567 | filter(`Age group`!="Unknown") %>% 568 | #filter(!(`Age group` %in% c("80-89","90+"))) %>% 569 | group_by(`Age group`) %>% 570 | mutate(Trend=pmax(0.01,extract_stl_trend_m(Cases+0.00001))) %>% 571 | group_by(Date) %>% 572 | mutate(share=Trend/sum(Trend)) %>% 573 | left_join(bc_pop_age %>% filter(`Health Authority`=="British Columbia"), by="Age group") %>% 574 | mutate(prevalence=share/Share) 575 | 576 | 577 | bc_cases_prevalence_date %>% 578 | filter(Date>=as.Date("2020-10-01")) %>% 579 | ggplot(aes(x=Date,y=prevalence,color=`Age group`,group=`Age group`)) + 580 | geom_line(aes(color=`Age group`),size=0.5) + 581 | theme_bw() + 582 | #geom_smooth(method="lm",se=FALSE) + 583 | scale_color_manual(values=age_colours) + 584 | scale_x_date(labels=function(d)strftime(d,"%b"),breaks="month") + 585 | labs(title=paste0("Relative incidence by age group in British Columbia (up to ", 586 | strftime(max(bc_cases_prevalence_date$Date),"%a %b %d"),")"), 587 | colour="Age group", 588 | x=NULL,y="Relative incidence\n(share of cases by share of population)", 589 | caption="MountainMath, Data: BCCDC, BC Stats Population estimates 2019") 590 | ``` 591 | 592 | ### Health Region geocoding problems 593 | Health Authorities may lag in geocoding cases to Health Region geographies, which makes the above Health Region level graph difficult to interpret. This graph shows the share of cases in each Health Authority that were geocoded to Health Region geographies. 594 | 595 | ```{r hr-check} 596 | data_u <- get_british_columbia_hr_case_data() %>% 597 | rename(HA=`Health Authority`,HR=`Health Region`) %>% 598 | filter(HA != "Out of Canada") 599 | 600 | pd <- data_u %>% 601 | filter(HA!="All") %>% 602 | left_join(data_u %>% 603 | filter(HA=="All") %>% 604 | select(Date,BC_Cases=Cases), 605 | by="Date") %>% 606 | left_join(data_u %>% 607 | filter(HR!="All") %>% 608 | group_by(Date,HA) %>% 609 | summarize(HR_sum=sum(Cases),.groups="drop"), 610 | by=c("Date","HA")) %>% 611 | mutate(Cases2=ifelse(HR=="All",Cases-HR_sum,Cases)) %>% 612 | mutate(share=Cases/HR_sum) 613 | 614 | g <- pd %>% 615 | filter(HR=="Unknown") %>% 616 | filter(Date>=as.Date("2020-07-01")) %>% 617 | group_by(HA) %>% 618 | arrange(Date) %>% 619 | filter(cumsum(Cases)>0) %>% 620 | ggplot(aes(x=Date,color=HA,group=HA)) + 621 | geom_point(aes(y=share),shape=21) + 622 | geom_line(aes(y=share)) + 623 | theme_bw() + 624 | theme(legend.position = "bottom") + 625 | scale_y_continuous(labels = scales::percent) + 626 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),c("Fraser","Vancouver Coastal", "Vancouver Island", "Interior", "Northern"))])+ 627 | labs(title="Cases with missing Health Region level geocoding", 628 | x=NULL,y="Share of cases", 629 | color=NULL,caption="MountainMath, Data: BCCDC") 630 | 631 | g 632 | #r<-graph_to_s3(g,"bccovid","hr-check.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 633 | ``` 634 | 635 | -------------------------------------------------------------------------------- /bc_covid_trends.md: -------------------------------------------------------------------------------- 1 | BC Covid Trends 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 06 July, 2023 - 18:06 5 | 6 | This notebook is intended to give a daily overview over BC Covid Trends. 7 | It utilizes a (multiplicative) STL decomposition to esimate a seasonally 8 | adjusted time series controlling for the strong weekly pattern in the 9 | COVID-19 case data and the trend line. For details check the [R notebook 10 | in this GitHub 11 | repo](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_covid_trends.Rmd). 12 | 13 | ## Overall BC Trend 14 | 15 | 16 | 17 | ## Log scale 18 | 19 | The underlying process that generates case data is, to first 20 | approximation, exponential. Plotting cases on a log scale makes it 21 | easier to spot trends. 22 | 23 | Real development in case data differs from pure exponential growth in 24 | three important ways: 25 | 26 | - Change in NPI via change regulation or change in behaviour impacts the 27 | trajectory. In BC behaviour has been generally fairly constant over 28 | longer time periods, with changes initiated by changes in public 29 | health regulations. These changes in increase or decrease the growth 30 | rate. (Growth can be negative or positive.) 31 | - Increasing vaccinations lead to sub-exponential growth, on a log plot 32 | the case numbers will bend downward. 33 | - Changing mix in COVID variants, this will lead to faster than 34 | exponential growth. When some variants are more transmissibly than 35 | others and thus incease their share among the cases, the effective 36 | rate of growth of cases will accelerate and the cases will bend 37 | upwards on a log plot. This is because each variant should be modelled 38 | as a separate exponential process, and the sum of exponential 39 | processes is not an exponential process. In the long run, the more 40 | transmissible variant will take over and the growth rate will follow a 41 | simple exponential growth model with growth rate given by the more 42 | transmissible variant. 43 | 44 | 45 | 46 | ## Main Health Authority Trends 47 | 48 | 49 | 50 | ## Health Authority Trends 51 | 52 | 53 | A log plot helps identify trends. 54 | 55 | 56 | 57 | ## Health Region Trends 58 | 59 | 60 | 61 | 62 | 63 | ## Recent trends 64 | 65 | 66 | 67 | ### Age groups 68 | 69 | Case incidence by age group. 70 | 71 | 72 | 73 | 74 | 75 | ### Health Region geocoding problems 76 | 77 | Health Authorities may lag in geocoding cases to Health Region 78 | geographies, which makes the above Health Region level graph difficult 79 | to interpret. This graph shows the share of cases in each Health 80 | Authority that were geocoded to Health Region geographies. 81 | 82 | 83 | -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/bc-trend-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/bc-trend-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/bc-trend-log-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/bc-trend-log-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/bc_age_groups-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/bc_age_groups-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/ha-trend-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/ha-trend-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/ha-trend-log-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/ha-trend-log-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/hr-check-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/hr-check-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/hr-trend-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/hr-trend-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/hr-trend-2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/hr-trend-2-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/hr-trend-log-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/hr-trend-log-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/main-ha-trend-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/main-ha-trend-1.png -------------------------------------------------------------------------------- /bc_covid_trends_files/figure-gfm/relative_age_prevalence-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_covid_trends_files/figure-gfm/relative_age_prevalence-1.png -------------------------------------------------------------------------------- /bc_projections.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Log trend" 3 | author: "Jens von Bergmann" 4 | date: "08/02/2021" 5 | output: html_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE, 13 | fig.retina = 2, 14 | dpi = 150, 15 | fig.width = 7, 16 | fig.height = 5 17 | ) 18 | library(ggplot2) 19 | library(readr) 20 | library(tidyr) 21 | library(dplyr) 22 | library(ggrepel) 23 | library(ggtext) 24 | library(here) 25 | library(sanzo) 26 | library(CanCovidData) 27 | 28 | source(here("R/helpers.R")) 29 | 30 | major_restrictions <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged") 31 | major_restriction_labels <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged") 32 | major_restrictions_y <- c("2020-03-18"=1,"2020-11-07"=0.1,"2020-11-19"=0.3) 33 | minor_restrictions <- c("2020-03-11","2020-03-12","2020-03-16","2020-03-17", 34 | "2020-03-21","2020-03-22","2020-03-26","2020-04-18", 35 | "2020-06-18","2020-08-21","2020-09-08","2020-10-26") 36 | major_reopenings <- c("2020-05-19"="Phase 2","2020-06-24"="Phase 3") 37 | minor_reopenings <- c("2020-05-14","2020-06-01","2020-06-08", 38 | "2020-06-30","2020-07-02","2020-09-10","2020-12-15") 39 | 40 | restriction_markers <- function(major_size=1,minor_size=0.5){ 41 | list( 42 | geom_vline(xintercept = as.Date(minor_reopenings), 43 | linetype="dashed",color="darkgreen",size=minor_size), 44 | geom_vline(xintercept = as.Date(names(major_reopenings)),linetype="dashed",color="darkgreen",size=major_size), 45 | geom_vline(xintercept = as.Date(names(major_restrictions)),linetype="dashed",color="brown",size=major_size), 46 | geom_vline(xintercept = as.Date(minor_restrictions), 47 | linetype="dashed",color="brown",size=minor_size) 48 | )} 49 | 50 | full_labels <- function(label_y, 51 | major_restriction_labels = c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings"), 52 | major_restrictions_y = c(1,0.15)){ 53 | c(restriction_markers(),list( 54 | geom_label(data = tibble(Date=as.Date(names(major_reopenings)), 55 | count=c(label_y,label_y), 56 | label=as.character(major_reopenings)), 57 | aes(label=label),size=4,alpha=0.7,color="darkgreen"), 58 | geom_label(data = tibble(Date=as.Date(names(major_restriction_labels)), 59 | label=as.character(major_restriction_labels), 60 | count=as.numeric(major_restrictions_y)), 61 | aes(label=label),size=4,alpha=0.7,color="brown") 62 | )) 63 | } 64 | 65 | ha_colours <- setNames(c(trios$c157,trios$c149), 66 | c("Fraser","Rest of BC","Vancouver Coastal" , "Vancouver Island", "Interior", "Northern")) 67 | 68 | ``` 69 | 70 | ```{r fig.height=3, fig.width=5} 71 | data <- get_british_columbia_case_data() %>% 72 | #filter(`Age group`=="20-29") %>% 73 | #filter(`Health Authority` %in% c("Vancouver Coastal","Fraser")) %>% 74 | count(Date=`Reported Date`,name="Cases") %>% 75 | filter(Date>=as.Date("2020-03-01")) %>% 76 | mutate(Trend=extract_stl_trend_m(Cases), 77 | Seasonal=extract_stl_seasonal_m(Cases)) %>% 78 | mutate(Cleaned=Cases/Seasonal) 79 | 80 | label_y <- max(data$Cases) * 0.9 81 | 82 | cutoff <- as.Date("2020-11-23") 83 | 84 | 85 | cutoff_data <- tibble(min=c("2020-07-01","2020-08-20","2020-10-01","2020-11-17")) %>% 86 | mutate(max=lead(min) %>% coalesce(.,max(data$Date) %>% as.character()), 87 | predict_max=lead(min) %>% coalesce(.,"2021-09-01")) %>% 88 | mutate_all(as.Date) %>% 89 | mutate(t=as.character(row_number() %% 2)) 90 | 91 | models <- seq(1,nrow(cutoff_data)) %>% 92 | lapply(function(i) { 93 | r=cutoff_data[i,] 94 | data %>% 95 | filter(Date>=r$min,Date<=r$max) %>% 96 | mutate(t=log(Trend)) %>% 97 | lm(t~Date,data=.) 98 | }) 99 | 100 | 101 | predictions <-seq(1,nrow(cutoff_data)) %>% 102 | lapply(function(i){ 103 | r=cutoff_data[i,] 104 | m=models[[i]] 105 | tibble(Date=seq(r$min,r$predict_max,by="day")) %>% 106 | mutate(Prediction=predict(m,newdata=.) %>% exp) 107 | }) 108 | 109 | 110 | g <- data %>% 111 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 112 | #filter(Date>=as.Date("2020-10-01")) %>% 113 | #filter(Date>=as.Date("2020-11-01")) %>% 114 | ggplot(aes(x = Date, y = count)) + 115 | geom_rect(data=cutoff_data,aes(xmin=min,xmax=max,fill=t), inherit.aes = FALSE, 116 | ymin=0,ymax=Inf,show.legend = FALSE,aplha=0.2) + 117 | scale_fill_manual(values=c("#dddddd","#aaaaaa")) + 118 | geom_point(data=~filter(.,type=="Cases"),color="grey",size=0.5) + 119 | geom_line(data=~filter(.,type=="Cleaned"),color="grey",size=0.5,alpha=0.5) + 120 | geom_line(data=~filter(.,type=="Trend"),color="black",size=1) + 121 | geom_line(data=predictions %>% 122 | lapply(function(d) d %>% mutate(min=min(Date))) %>% 123 | bind_rows(),# %>% 124 | #filter(Date<=max(data$Date)), 125 | color="#7c00f0",size=2,alpha=0.7,aes(group=min,y=Prediction)) + 126 | theme_bw() + 127 | theme(legend.position = "bottom") + 128 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 129 | # scale_y_continuous(trans="log",breaks=c(25,50,100,200,400,800))+ 130 | # coord_cartesian(y=c(5,NA)) + 131 | full_labels(label_y,major_restriction_labels=major_restriction_labels, 132 | major_restrictions_y=major_restrictions_y*label_y) + 133 | geom_hline(yintercept = 100) + 134 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 135 | subtitle="Timeline of closure and reopening events", 136 | x=NULL,y=NULL,color=NULL,caption="MountainMath, Data: BCCDC") + 137 | theme(plot.subtitle = element_markdown()) 138 | g 139 | ``` 140 | 141 | ```{r} 142 | 143 | label_y <- max(data$r,na.rm = TRUE) *0.9 144 | 145 | data %>% 146 | cbind(compute_rolling_exp_fit(.$Trend,window_width = 21)) %>% #pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 147 | #filter(Date>=as.Date("2020-10-01")) %>% 148 | #filter(Date>=as.Date("2020-11-01")) %>% 149 | ggplot(aes(x = Date,y=count)) + 150 | geom_line(color="black",size=1,aes(y = r)) + 151 | theme_bw() + 152 | theme(legend.position = "bottom") + 153 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 154 | #scale_y_continuous(trans="log",breaks=c(25,50,100,200,400,800))+ 155 | full_labels(label_y,major_restriction_labels=major_restriction_labels, 156 | major_restrictions_y=label_y*c(1,1,0.8)) + 157 | labs(title=paste0("Covid-19 daily new cases in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 158 | subtitle="Timeline of closure and reopening events", 159 | x=NULL,y=NULL,color=NULL,caption="MountainMath, Data: BCCDC") + 160 | theme(plot.subtitle = element_markdown()) 161 | ``` 162 | 163 | 164 | 165 | 166 | ```{r} 167 | data <- get_british_columbia_case_data() %>% 168 | mutate(`Age group`=recode(`Age group`,"80-89"="80+","90+"="80+")) %>% 169 | #filter(`Health Authority` %in% c("Vancouver Coastal","Fraser")) %>% 170 | count(`Age group`,Date=`Reported Date`,name="Cases") %>% 171 | filter(Date>=as.Date("2020-03-01")) %>% 172 | group_by(`Age group`) %>% 173 | mutate(Trend=extract_stl_trend_m(Cases), 174 | Seasonal=extract_stl_seasonal_m(Cases)) %>% 175 | mutate(Cleaned=Cases/Seasonal) %>% 176 | mutate(rm=zoo::rollmean(Cases,7,align="right",na.pad=TRUE)) 177 | 178 | data %>% 179 | ggplot(aes(x=Date,y=rm,color=`Age group`)) + 180 | geom_line() + 181 | scale_x_continuous(breaks=seq(as.Date("2020-03-14"),as.Date("2021-02-13"),by="2 week"), 182 | labels=function(d)strftime(d,"%b %d")) + 183 | theme(axis.text.x = element_text(angle=90)) 184 | 185 | ``` 186 | 187 | -------------------------------------------------------------------------------- /bc_school_tracker.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "BC School Tracker" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | fig.height = 5, 12 | fig.retina = 2, 13 | fig.width = 7, 14 | message = FALSE, 15 | warning = FALSE, 16 | dpi = 150 17 | ) 18 | library(ggplot2) 19 | library(dplyr) 20 | library(tidyr) 21 | library(stringr) 22 | library(rvest) 23 | library(mountainmathHelpers) 24 | library(sf) 25 | library(PROJ) 26 | library(cancensus) 27 | library(lubridate) 28 | library(sanzo) 29 | source(here::here("R/helpers.R")) 30 | 31 | options("cancensus.cache_path"=here::here("data")) 32 | ha_colours <- setNames(c(trios$c157,trios$c149), 33 | c("Fraser","Rest of BC","Vancouver Coastal" , "Vancouver Island", "Interior", "Northern")) 34 | 35 | extract_table_data <- function(node){ 36 | h <- node %>% rvest::html_nodes("thead th") %>% rvest::html_text() 37 | rows <- node %>% rvest::html_nodes("tbody tr") 38 | data <- rows %>% lapply(function(d) d %>% 39 | rvest::html_nodes("td") %>% 40 | rvest::html_text() %>% 41 | t() %>% 42 | as.data.frame) %>% 43 | bind_rows() %>% 44 | setNames(h) 45 | 46 | data 47 | } 48 | ``` 49 | 50 | ```{r} 51 | get_data_for_page <- function(p=1){ 52 | url = "https://us-east-1-renderer-read.knack.com/v1/scenes/scene_1/views/view_3/records?callback=jQuery17201415845315599671_1606757085608&format=both&rows_per_page=100&sort_field=field_16&sort_order=desc&_=1606757085628" 53 | url <- paste0(url,"&page=",p) 54 | 55 | d <- httr::GET(url,httr::set_cookies( "connect.sid"="s%3A51R3S-8YTv08QV_IejVfqJsW1RxnUdln.WuHEEIrAF6niDEAB3MWgjvWA%2FkzArewbBDZ%2FppCUdVY"), 56 | httr::accept("text/javascript, application/javascript, application/ecmascript, application/x-ecmascript, */*; q=0.01"), 57 | httr::add_headers("X-Knack-Application-Id"= "5faae3b10442ac00165da195", 58 | "Accept-Encoding"="gzip, deflate, br", 59 | "X-Knack-REST-API-Key"= "renderer", 60 | "x-knack-new-builder"= "true")) 61 | 62 | c <- httr::content(d,"text") %>% 63 | gsub("^.*\\(\\{","{",.) %>% 64 | gsub("\\}\\);$","}",.) %>% 65 | jsonlite::fromJSON() 66 | 67 | data <- c$records %>% as_tibble() 68 | 69 | #print(paste0("Got data for page ",c$current_page," of ",c$total_pages)) 70 | 71 | 72 | attr(data,"total_pages") <- c$total_pages 73 | data 74 | } 75 | 76 | clean_data <- function(d){ 77 | tibble(Date=as.Date(d$field_16,format="%m/%d/%Y"), 78 | Name=d$field_13_raw %>% lapply(function(f)f$identifier) %>% as.character, 79 | `Health Authority`=d$field_26_raw %>% lapply(function(f)f$identifier) %>% as.character, 80 | Verification=d$field_14_raw %>% lapply(function(f)f$identifier) %>% as.character, 81 | `Exposure dates`=d$field_15, 82 | `Exposure count`=d$field_25, 83 | #Status =d$field_30, 84 | Variant=d$field_38) %>% 85 | bind_cols(d$field_19_raw %>% as_tibble) %>% 86 | mutate(E=str_extract(`Exposure count`,"Exposure \\d+|Secondary \\d+") %>% 87 | unlist() %>% 88 | gsub("Exposure |Secondary ","",.) %>% 89 | as.integer()) %>% 90 | mutate_at(c("latitude","longitude"),as.numeric) 91 | } 92 | 93 | get_all_data <- function(){ 94 | p=1 95 | raw_data <- get_data_for_page(p) 96 | data <- clean_data(raw_data) 97 | while (attr(raw_data,"total_pages")>p) { 98 | p <- p + 1 99 | raw_data <- get_data_for_page(p) 100 | data <- bind_rows(data, clean_data(raw_data)) 101 | } 102 | data 103 | } 104 | 105 | extract_first_exposure_date <- function(ed){ 106 | ed %>% 107 | gsub("

|

|
|Exposure date |Exposure dates |Exposures dates |
","",.) %>% 108 | strsplit(",|and") %>% 109 | map(trimws) %>% 110 | map(function(d)d[d!=""]) %>% 111 | map(first) %>% 112 | gsub("-.+| \\(.+| \\[.+","",.) %>% 113 | unlist 114 | } 115 | 116 | add_first_exposure_date <- function(data){ 117 | data %>% 118 | mutate(fe=extract_first_exposure_date(.data$`Exposure dates`)) 119 | } 120 | 121 | data <- get_all_data() 122 | ``` 123 | 124 | In BC we don't have good data on community level COVID cases. But we can, somewhat cynically, use school exposures as a proxy. The [BC School Covid Tracker project](https://bcschoolcovidtracker.knack.com/bc-school-covid-tracker#home/) has been keeping count of school exposures and meticulously documenting and geocoding the data. That makes is easy for use to create a heatmap of school exposures. 125 | 126 | The code for this notebook is [available for anyone to adapt and use for their own purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_school_tracker.Rmd). 127 | 128 | ## Variants of concern 129 | The share of school exposures that are related to variants of concern can give an indication of the general proliferation of variants of concern. 130 | 131 | We look at the share of school exposures involving variants of concern for each week, where we split the week between Monday and Tuesday as exposure notifications coming out on Monday usually relate to exposures in the preceding week. Variant of concern screening takes some extra time and exposures might get identified as realting to variants of concern a couple of days later, so shares in the most recent week (and sometimes also the week before that) may rise as exposures gets updated. In particular, the lag will bias the share of exposures involving variants of concern in the current week downward. 132 | 133 | Shares are computed separately for each Health Authority, we only show Health Authorities that have flagged exposure events as relating to variants of concern. 134 | 135 | ```{r schools_voc} 136 | plot_data <- data %>% 137 | mutate(`Health Authority`=recode(`Health Authority`, 138 | "Fraser Health Authority"="Fraser", 139 | "Interior Health Authority"="Interior", 140 | "Vancouver Coastal Health"="Vancouver Coastal", 141 | "Vancouver Island Health Authority"="Vancouver Island", 142 | "Northern Health"="Northern")) %>% 143 | mutate(VOC=grepl("concern|variant",`Variant`,ignore.case = TRUE)) %>% 144 | mutate(Week=ceiling_date(Date,"week",week_start=2)-1) %>% 145 | count(Week,VOC,`Health Authority`) %>% 146 | complete(Week,VOC,`Health Authority`,fill=list(n=0)) %>% 147 | group_by(Week,`Health Authority`) %>% 148 | mutate(share=n/sum(n)) %>% 149 | #filter(Week >= min(filter(.,VOC)$Week)) %>% 150 | filter(VOC) %>% 151 | filter(Week >= min(filter(.,VOC,n>0)$Week)) %>% 152 | ungroup %>% 153 | mutate(week=factor(strftime(Week,"%b %d"),levels=sort(unique(Week)) %>% strftime(.,"%b %d")), 154 | w=strftime(Week-2,format = "%U") %>% as.integer) 155 | 156 | plot_data %>% 157 | group_by(`Health Authority`) %>% 158 | filter(sum(n)>0) %>% 159 | ggplot(aes(x=week,y=share,fill=`Health Authority`)) + 160 | geom_bar(stat="identity") + 161 | scale_y_continuous(labels=scales::percent) + 162 | scale_fill_manual(values=ha_colours,guide='none') + 163 | facet_wrap("`Health Authority`",ncol=2) + 164 | labs(title="School exposures involving variants of concern", 165 | x="Initial exposure letter in week ending", 166 | y="Share of exposures involving variant of concern", 167 | caption="MountainMath, Data: BC School Covid Tracker") 168 | ``` 169 | 170 | 171 | 172 | ## School Exposure Heat Map 173 | This data is not normalized by population, so it should be viewd in context of the school aged (5-17yo) population further down. 174 | 175 | ```{r school-tracker-schools} 176 | bb<-metro_van_bbox() 177 | m <- cancensus::get_census("CA16",regions=list(CMA="59933"),geo_format = "sf",level="CSD",quiet = TRUE) 178 | 179 | 180 | school_data <- data %>% 181 | mutate_at(c("latitude","longitude"),as.numeric) %>% 182 | filter(!is.na(latitude)) %>% 183 | filter(between(latitude,bb$ymin,bb$ymax), 184 | between(longitude,bb$xmin,bb$xmax)) %>% 185 | mutate(E=coalesce(E,1)) %>% 186 | group_by(Name) %>% 187 | top_n(1,E) %>% 188 | expand(latitude,longitude,E,count = seq(1:E)) %>% 189 | st_as_sf(coords=c("longitude","latitude"),crs=4326,agr="constant") %>% 190 | ungroup() %>% 191 | st_jitter(amount=0.005) %>% 192 | cbind(st_coordinates(.)) %>% 193 | rename(!!!c("longitude"="X","latitude"="Y")) 194 | 195 | 196 | #sf::st_as_sf(coords=c("longitude","latitude"),agr="constant",na.fail = FALSE) %>% 197 | g <- ggplot(m) + 198 | stat_density2d(data=school_data, 199 | aes(x=longitude,y=latitude, fill = ..level.., alpha = ..level..), 200 | h=c(0.05,0.05*cos(pi/180*49)),#n=1000, 201 | bins = 16, geom = "polygon", breaks=c(1,2.5,5,7.5,10,15,20,25,30,40,50,60)) + 202 | scale_fill_viridis_c(guide='none',option="magma") + 203 | scale_alpha_continuous(guide='none') + 204 | geom_roads() + 205 | geom_water(color="grey",size=0.1) + 206 | geom_sf(data=school_data,size=0.1,alpha=0.4) + 207 | geom_sf(fill=NA,color="brown",size=0.1) + 208 | coord_bbox(metro_van_bbox("tight")) + 209 | labs(x=NULL,y=NULL,fill=NULL, 210 | title="Geographic distribution of school exposure notifications", 211 | caption="MountainMath, Data: BC School Covid Tracker") 212 | 213 | g 214 | #r<-graph_to_s3(g,"bccovid","school-tracker-schools.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 215 | 216 | ``` 217 | 218 | 219 | ## Monthly exposure density 220 | Looking at monthly school exposure denisty gives us some sense of how the distribution of exposure notifications has changed over time. The last month only has partial data and the heat map will appear to have lower values in comparison until the month is complete.. 221 | 222 | 223 | ```{r school-tracker-monthly, fig.height=10, fig.height=13} 224 | school_data <- data %>% 225 | mutate_at(c("latitude","longitude"),as.numeric) %>% 226 | filter(!is.na(latitude)) %>% 227 | filter(between(latitude,bb$ymin,bb$ymax), 228 | between(longitude,bb$xmin,bb$xmax)) %>% 229 | mutate(Period=strftime(Date,"%b %Y")) %>% 230 | mutate(Period=factor(Period, levels= arrange(.,Date)$Period %>% unique)) %>% 231 | st_as_sf(coords=c("longitude","latitude"),crs=4326,agr="constant") %>% 232 | ungroup() %>% 233 | st_jitter(amount=0.005) %>% 234 | cbind(st_coordinates(.)) %>% 235 | rename(!!!c("longitude"="X","latitude"="Y")) 236 | 237 | bb <- c(1,2.5,5,7.5,10,15,20,25,30,40,50,60,100) 238 | bb <- c(1000,2500,5000,7500,10000,15000,20000,25000,30000) 239 | #sf::st_as_sf(coords=c("longitude","latitude"),agr="constant",na.fail = FALSE) %>% 240 | g <- ggplot(m) + 241 | stat_density_2d(data=school_data, 242 | contour_var="count", 243 | aes(x=longitude,y=latitude, fill = ..level.., alpha = ..level..), 244 | h=c(0.05,0.05*cos(pi/180*49)),#n=1000, 245 | geom = "polygon", breaks=bb 246 | ) + 247 | scale_fill_viridis_c(guide='none',option="magma",limits=c(0,30000)) + 248 | scale_alpha_continuous(guide='none',limits=c(0,30000)) + 249 | geom_roads() + 250 | geom_water(color="grey",size=0.1) + 251 | geom_sf(data=school_data,size=0.1,alpha=0.4) + 252 | geom_sf(fill=NA,color="brown",size=0.1) + 253 | facet_wrap("Period",ncol=2) + 254 | coord_bbox(metro_van_bbox("tight")) + 255 | labs(x=NULL,y=NULL,fill=NULL, 256 | title="Geographic distribution of school exposure notifications", 257 | caption="MountainMath, Data: BC School Covid Tracker") 258 | 259 | g 260 | ``` 261 | 262 | 263 | ## Children density heat map for comparison 264 | 265 | ```{r school-tracker-children} 266 | d <- get_census("CA16",regions=list(CMA="59933"),level="DA",geo_format = "sf",vectors=c("v_CA16_25","v_CA16_43","v_CA16_67","v_CA16_70","v_CA16_73"),labels="short", quiet=TRUE) %>% 267 | mutate(children=select(.,matches("v_")) %>% st_drop_geometry()%>% rowSums(na.rm=TRUE)) 268 | 269 | dd <- d %>% 270 | select(children) %>% 271 | filter(children>0) %>% 272 | mutate(children=as.integer(children/5)) %>% 273 | dotdensity::compute_dots("children") %>% 274 | #st_sample((.)$children) %>% 275 | st_coordinates() %>% 276 | as_tibble() 277 | 278 | 279 | g <- ggplot(m) + 280 | stat_density2d(data=dd, 281 | aes(x=X,y=Y, fill = ..level.., alpha = ..level..), 282 | h=c(0.05,0.05*cos(pi/180*49)),#n=1000, 283 | bins = 16, geom = "polygon") + #, breaks=c(1,2.5,5,7.5,10,12.5,15,17.5,20,25,30,35)) + 284 | scale_fill_viridis_c(guide='none',option="viridis") + 285 | scale_alpha_continuous(guide='none') + 286 | geom_roads() + 287 | geom_water(color="grey",size=0.1) + 288 | #geom_sf(data=school_data,size=0.1,alpha=0.4) + 289 | geom_sf(fill=NA,color="brown",size=0.1) + 290 | coord_bbox(metro_van_bbox("tight")) + 291 | labs(x=NULL,y=NULL,fill=NULL, 292 | title="Geographic distribution of children 5-17yo", 293 | caption="MountainMath, StatCan Census 2016") 294 | 295 | g 296 | #r<-graph_to_s3(g,"bccovid","school-tracker-children.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 297 | ``` 298 | 299 | 300 | -------------------------------------------------------------------------------- /bc_school_tracker.md: -------------------------------------------------------------------------------- 1 | BC School Tracker 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 23 June, 2022 - 01:21 5 | 6 | In BC we don’t have good data on community level COVID cases. But we 7 | can, somewhat cynically, use school exposures as a proxy. The [BC School 8 | Covid Tracker 9 | project](https://bcschoolcovidtracker.knack.com/bc-school-covid-tracker#home/) 10 | has been keeping count of school exposures and meticulously documenting 11 | and geocoding the data. That makes is easy for use to create a heatmap 12 | of school exposures. 13 | 14 | The code for this notebook is [available for anyone to adapt and use for 15 | their own 16 | purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/bc_school_tracker.Rmd). 17 | 18 | ## Variants of concern 19 | 20 | The share of school exposures that are related to variants of concern 21 | can give an indication of the general proliferation of variants of 22 | concern. 23 | 24 | We look at the share of school exposures involving variants of concern 25 | for each week, where we split the week between Monday and Tuesday as 26 | exposure notifications coming out on Monday usually relate to exposures 27 | in the preceding week. Variant of concern screening takes some extra 28 | time and exposures might get identified as realting to variants of 29 | concern a couple of days later, so shares in the most recent week (and 30 | sometimes also the week before that) may rise as exposures gets updated. 31 | In particular, the lag will bias the share of exposures involving 32 | variants of concern in the current week downward. 33 | 34 | Shares are computed separately for each Health Authority, we only show 35 | Health Authorities that have flagged exposure events as relating to 36 | variants of concern. 37 | 38 | 39 | 40 | ## School Exposure Heat Map 41 | 42 | This data is not normalized by population, so it should be viewd in 43 | context of the school aged (5-17yo) population further down. 44 | 45 | 46 | 47 | ## Monthly exposure density 48 | 49 | Looking at monthly school exposure denisty gives us some sense of how 50 | the distribution of exposure notifications has changed over time. The 51 | last month only has partial data and the heat map will appear to have 52 | lower values in comparison until the month is complete.. 53 | 54 | 55 | 56 | ## Children density heat map for comparison 57 | 58 | 59 | -------------------------------------------------------------------------------- /bc_school_tracker_files/figure-gfm/school-tracker-children-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_school_tracker_files/figure-gfm/school-tracker-children-1.png -------------------------------------------------------------------------------- /bc_school_tracker_files/figure-gfm/school-tracker-monthly-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_school_tracker_files/figure-gfm/school-tracker-monthly-1.png -------------------------------------------------------------------------------- /bc_school_tracker_files/figure-gfm/school-tracker-schools-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_school_tracker_files/figure-gfm/school-tracker-schools-1.png -------------------------------------------------------------------------------- /bc_school_tracker_files/figure-gfm/schools_voc-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/bc_school_tracker_files/figure-gfm/schools_voc-1.png -------------------------------------------------------------------------------- /data/CM_data_14cb5e4534337f49721343b7fe7ded32.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/data/CM_data_14cb5e4534337f49721343b7fe7ded32.rda -------------------------------------------------------------------------------- /data/COVID19_VoC_data.csv: -------------------------------------------------------------------------------- 1 | patient_ha,epiweek,epi_cdate,percent_screened_presumptive_positives,prop_voc,total_nat_positives,total_voc,total_non_voc 2 | British Columbia,1,2021-01-03,0,0,3857,0,3857 3 | Fraser,1,2021-01-03,0,0,2113,0,2113 4 | Interior,1,2021-01-03,0,0,424,0,424 5 | Northern,1,2021-01-03,0,0,368,0,368 6 | Vancouver Coastal,1,2021-01-03,0,0,788,0,788 7 | Island,1,2021-01-03,0,0,144,0,144 8 | British Columbia,2,2021-01-10,0.9,0.9,3498,31.48,3466.52 9 | Fraser,2,2021-01-10,1.8,1.8,1550,27.9,1522.1 10 | Interior,2,2021-01-10,0,0,605,0,605 11 | Northern,2,2021-01-10,0,0,334,0,334 12 | Vancouver Coastal,2,2021-01-10,0,0,739,0,739 13 | Island,2,2021-01-10,0,0,158,0,158 14 | British Columbia,3,2021-01-17,1,1,3477,34.77,3442.23 15 | Fraser,3,2021-01-17,2,2,1618,32.36,1585.64 16 | Interior,3,2021-01-17,0,0,551,0,551 17 | Northern,3,2021-01-17,0,0,300,0,300 18 | Vancouver Coastal,3,2021-01-17,0,0,804,0,804 19 | Island,3,2021-01-17,0,0,185,0,185 20 | British Columbia,4,2021-01-24,1,1,3327,33.27,3293.73 21 | Fraser,4,2021-01-24,1.2,1.2,1453,17.44,1435.56 22 | Interior,4,2021-01-24,0,0,489,0,489 23 | Northern,4,2021-01-24,0,0,283,0,283 24 | Vancouver Coastal,4,2021-01-24,3.8,3.8,880,33.44,846.56 25 | Island,4,2021-01-24,0,0,216,0,216 26 | British Columbia,5,2021-01-31,1,1,3125,31.25,3093.75 27 | Fraser,5,2021-01-31,1.6,1.6,1536,24.58,1511.42 28 | Interior,5,2021-01-31,0,0,399,0,399 29 | Northern,5,2021-01-31,0,0,309,0,309 30 | Vancouver Coastal,5,2021-01-31,3.8,3.8,673,25.57,647.43 31 | Island,5,2021-01-31,0,0,203,0,203 32 | British Columbia,6,2021-02-07,2.5,2.5,3125,78.12,3046.88 33 | Fraser,6,2021-02-07,3.7,3.7,1670,61.79,1608.21 34 | Interior,6,2021-02-07,0,0,273,0,273 35 | Northern,6,2021-02-07,0,0,297,0,297 36 | Vancouver Coastal,6,2021-02-07,1.5,1.5,752,11.28,740.72 37 | Island,6,2021-02-07,3.4,3.4,123,4.18,118.82 38 | British Columbia,7,2021-02-14,3.7,3.7,3457,127.91,3329.09 39 | Fraser,7,2021-02-14,5.2,5.2,1949,101.35,1847.65 40 | Interior,7,2021-02-14,1.3,1.3,192,2.5,189.5 41 | Northern,7,2021-02-14,0,0,293,0,293 42 | Vancouver Coastal,7,2021-02-14,2.8,2.8,821,22.99,798.01 43 | Island,7,2021-02-14,0,0,194,0,194 44 | British Columbia,8,2021-02-21,7.3,7.3,3634,265.28,3368.72 45 | Fraser,8,2021-02-21,9.5,9.5,2067,196.37,1870.63 46 | Interior,8,2021-02-21,2.5,2.5,223,5.58,217.42 47 | Northern,8,2021-02-21,1,1,232,2.32,229.68 48 | Vancouver Coastal,8,2021-02-21,6.4,6.4,867,55.49,811.51 49 | Island,8,2021-02-21,0.4,0.4,232,0.93,231.07 50 | British Columbia,9,2021-02-28,11.5,11.5,3844,442.06,3401.94 51 | Fraser,9,2021-02-28,15,15,2142,321.3,1820.7 52 | Interior,9,2021-02-28,4.3,4.3,191,8.21,182.79 53 | Northern,9,2021-02-28,0.4,0.4,290,1.16,288.84 54 | Vancouver Coastal,9,2021-02-28,10.3,10.3,1025,105.58,919.42 55 | Island,9,2021-02-28,0.5,0.5,186,0.93,185.07 56 | British Columbia,10,2021-03-07,16.2,16.2,3851,623.86,3227.14 57 | Fraser,10,2021-03-07,19.7,19.7,2212,435.76,1776.24 58 | Interior,10,2021-03-07,6.5,6.5,216,14.04,201.96 59 | Northern,10,2021-03-07,1.4,1.4,306,4.28,301.72 60 | Vancouver Coastal,10,2021-03-07,16.9,16.9,960,162.24,797.76 61 | Island,10,2021-03-07,3.4,3.4,149,5.07,143.93 62 | British Columbia,11,2021-03-14,26.2,26.2,4144,1085.73,3058.27 63 | Fraser,11,2021-03-14,31.2,31.2,2461,767.83,1693.17 64 | Interior,11,2021-03-14,19.4,19.4,161,31.23,129.77 65 | Northern,11,2021-03-14,0.9,0.9,340,3.06,336.94 66 | Vancouver Coastal,11,2021-03-14,25.3,25.3,1100,278.3,821.7 67 | Island,11,2021-03-14,5.2,5.2,77,4,73 68 | British Columbia,12,2021-03-21,38.3,38.3,5695,2181.18,3513.82 69 | Fraser,12,2021-03-21,40.5,40.5,2973,1204.07,1768.93 70 | Interior,12,2021-03-21,36.3,36.3,282,102.37,179.63 71 | Northern,12,2021-03-21,4.3,4.3,329,14.15,314.85 72 | Vancouver Coastal,12,2021-03-21,45.1,45.1,1809,815.86,993.14 73 | Island,12,2021-03-21,13.3,13.3,284,37.77,246.23 74 | British Columbia,13,2021-03-28,51.3,51.3,6976,3578.69,3397.31 75 | Fraser,13,2021-03-28,54.9,54.9,3504,1923.7,1580.3 76 | Interior,13,2021-03-28,39.2,39.2,426,166.99,259.01 77 | Northern,13,2021-03-28,6.2,6.2,332,20.58,311.42 78 | Vancouver Coastal,13,2021-03-28,58.6,58.6,2283,1337.84,945.16 79 | Island,13,2021-03-28,28.6,28.6,413,118.12,294.88 80 | British Columbia,14,2021-04-04,65.9,65.9,8107,5342.51,2764.49 81 | Fraser,14,2021-04-04,68.2,68.2,4485,3058.77,1426.23 82 | Interior,14,2021-04-04,55.3,55.3,644,356.13,287.87 83 | Northern,14,2021-04-04,16.5,16.5,301,49.66,251.34 84 | Vancouver Coastal,14,2021-04-04,74,74,2249,1664.26,584.74 85 | Island,14,2021-04-04,47,47,413,194.11,218.89 86 | British Columbia,15,2021-04-11,71,71,7206,5116.26,2089.74 87 | Fraser,15,2021-04-11,73.1,73.1,4305,3146.95,1158.05 88 | Interior,15,2021-04-11,63.8,63.8,519,331.12,187.88 89 | Northern,15,2021-04-11,22.3,22.3,269,59.99,209.01 90 | Vancouver Coastal,15,2021-04-11,75.7,75.7,1808,1368.66,439.34 91 | Island,15,2021-04-11,68.8,68.8,287,197.46,89.54 92 | British Columbia,16,2021-04-18,77,77,6383,4914.91,1468.09 93 | Fraser,16,2021-04-18,77,77,4133,3182.41,950.59 94 | Interior,16,2021-04-18,80.6,80.6,378,304.67,73.33 95 | Northern,16,2021-04-18,32.9,32.9,224,73.7,150.3 96 | Vancouver Coastal,16,2021-04-18,83.6,83.6,1421,1187.96,233.04 97 | Island,16,2021-04-18,79.9,79.9,221,176.58,44.42 98 | British Columbia,17,2021-04-25,80.3,80.3,5514,4427.74,1086.26 99 | Fraser,17,2021-04-25,79.6,79.6,3680,2929.28,750.72 100 | Interior,17,2021-04-25,78.8,78.8,333,262.4,70.6 101 | Northern,17,2021-04-25,31.4,31.4,167,52.44,114.56 102 | Vancouver Coastal,17,2021-04-25,87.5,87.5,1148,1004.5,143.5 103 | Island,17,2021-04-25,77,77,181,139.37,41.63 -------------------------------------------------------------------------------- /data/ha_pop.csv: -------------------------------------------------------------------------------- 1 | "Region","Health Authority","Year","Gender","Total" 2 | 0,"British Columbia",2019,"T",5071336 3 | 1,"Interior",2019,"T",827314 4 | 2,"Fraser",2019,"T",1906933 5 | 3,"Vancouver Coastal",2019,"T",1193977 6 | 4,"Vancouver Island",2019,"T",858785 7 | 5,"Northern",2019,"T",284327 8 | -------------------------------------------------------------------------------- /data/ha_pop_age.csv: -------------------------------------------------------------------------------- 1 | "Region","Health Authority","Year","Gender","Total","LT1","1-4","5-9","10-14","15-19","20-24","25-29","30-34","35-39","40-44","45-49","50-54","55-59","60-64","65-69","70-74","75-79","80-84","85-89","90+" 2 | 0,"British Columbia",2019,"T",5071336,43319,183799,241803,244657,277122,336531,354021,366111,351725,315716,330697,345770,377943,354060,305446,246972,166322,110843,71831,46648 3 | 1,"Interior",2019,"T",827314,6242,27985,37617,38785,40893,44520,47787,51021,51748,46703,49820,54530,68956,70436,61353,50217,34023,22543,13835,8300 4 | 2,"Fraser",2019,"T",1906933,18235,76749,103394,104134,118823,140014,130330,135970,136240,124882,129182,132553,134982,118928,97561,78598,53259,35638,22881,14580 5 | 3,"Vancouver Coastal",2019,"T",1193977,9712,37080,45685,47237,59437,83956,103969,104423,89466,77422,81818,84042,85757,76741,65747,52276,35414,25075,17143,11577 6 | 4,"Vancouver Island",2019,"T",858785,6309,28444,38095,37736,41359,48691,50655,53600,54701,49564,51643,55211,66924,68835,66045,54945,36663,23356,15448,10561 7 | 5,"Northern",2019,"T",284327,2821,13541,17012,16765,16610,19350,21280,21097,19570,17145,18234,19434,21324,19120,14740,10936,6963,4231,2524,1630 8 | -------------------------------------------------------------------------------- /data/hr_pop.csv: -------------------------------------------------------------------------------- 1 | "Region","Health Service Delivery Area","Year","Gender","Total" 2 | 0,"British Columbia",2019,"T",5071336 3 | 11,"East Kootenay",2019,"T",88871 4 | 12,"Kootenay Boundary",2019,"T",87529 5 | 13,"Okanagan",2019,"T",401832 6 | 14,"Thompson Cariboo Shuswap",2019,"T",249082 7 | 21,"Fraser East",2019,"T",330268 8 | 22,"Fraser North",2019,"T",695027 9 | 23,"Fraser South",2019,"T",881638 10 | 31,"Richmond",2019,"T",210344 11 | 32,"Vancouver",2019,"T",683812 12 | 33,"North Shore/Coast Garibaldi",2019,"T",299821 13 | 41,"South Vancouver Island",2019,"T",426268 14 | 42,"Central Vancouver Island",2019,"T",299772 15 | 43,"North Vancouver Island",2019,"T",132745 16 | 51,"Northwest",2019,"T",74282 17 | 52,"Northern Interior",2019,"T",145847 18 | 53,"Northeast",2019,"T",64198 19 | -------------------------------------------------------------------------------- /data/n501y.csv: -------------------------------------------------------------------------------- 1 | Epi Week # (date),Total NAT positive tests,Total Samples Screened for VoC mutations (%),Total presumptive VoCs (%),Total sequenceda,B.1.1.7 (UK) (%),B.1.351 (SA) (%),P.1 (BR) (%),Total,V1,V2,Week,Date,share_voc,ratio_voc,Date2 2 | 1 (Jan 03-Jan 09),3878,19,0,330,0,0,0,0,NA,NA,1,2021-01-03T00:00:00Z,0,0,2021-01-10T00:00:00Z 3 | 2 (Jan 10-Jan 16),3507,234,2,475,1,2,0,3,NA,NA,2,2021-01-10T00:00:00Z,0.00854700854700855,0.00862068965517242,2021-01-17T00:00:00Z 4 | 3 (Jan 17-Jan 23),3488,870,9,214,4,7,0,11,NA,NA,3,2021-01-17T00:00:00Z,0.0103448275862069,0.0104529616724739,2021-01-24T00:00:00Z 5 | 4 (Jan 24-Jan 30),3337,796,8,569,8,4,0,12,NA,NA,4,2021-01-24T00:00:00Z,0.0100502512562814,0.0101522842639594,2021-01-31T00:00:00Z 6 | 5 (Jan 31-Feb 06),3134,2204,22,508,24,2,0,26,NA,NA,5,2021-01-31T00:00:00Z,0.00998185117967332,0.0100824931255729,2021-02-07T00:00:00Z 7 | 6 (Feb 07-Feb 13),3154,2272,57,826,53,1,0,54,NA,NA,6,2021-02-07T00:00:00Z,0.0250880281690141,0.0257336343115124,2021-02-14T00:00:00Z 8 | 7 (Feb 14-Feb 20),3464,2826,103,525,110,0,0,110,NA,NA,7,2021-02-14T00:00:00Z,0.0364472753007785,0.0378259272860815,2021-02-21T00:00:00Z 9 | 8 (Feb 21-Feb 27),3649,3351,242,436,193,5,10,208,NA,NA,8,2021-02-21T00:00:00Z,0.0722172485825127,0.0778385332904471,2021-02-28T00:00:00Z 10 | 9 (Feb 28-Mar 06),3929,3791,438,811,363,7,23,393,NA,NA,9,2021-02-28T00:00:00Z,0.115536797678713,0.130629287205488,2021-03-07T00:00:00Z 11 | 10 (Mar 07-Mar 13),3815,3810,627,1139,427,3,104,534,NA,NA,10,2021-03-07T00:00:00Z,0.164566929133858,0.19698397737983,2021-03-14T00:00:00Z 12 | 11 (Mar 14-Mar 20),4150,4102,1080,1651,765,6,246,1017,NA,NA,11,2021-03-14T00:00:00Z,0.263286201852755,0.357379219060225,2021-03-21T00:00:00Z 13 | 12 (Mar 21-Mar 27),5692,5249,2004,2062,726,1,456,1183,NA,NA,12,2021-03-21T00:00:00Z,0.381787007048962,0.617565485362095,2021-03-28T00:00:00Z 14 | 13 (Mar 28-Apr 03),6811,4915,2514,471,3,0,4,7,NA,"a Whole genome sequencing for week 13, Mar 28 to April 3, is still being completed so data is not final.",13,2021-03-28T00:00:00Z,0.511495422177009,1.04706372344856,2021-04-04T00:00:00Z 15 | 14 (Apr 04-Apr 10),NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,14,2021-04-04T00:00:00Z,0.63,NA,2021-04-11T00:00:00Z 16 | -------------------------------------------------------------------------------- /data/prov_pop.csv: -------------------------------------------------------------------------------- 1 | Province,shortProvince,Population 2 | Canada,CAN,38037204 3 | Newfoundland and Labrador,NL,521364 4 | Prince Edward Island,PE,161329 5 | Nova Scotia,NS,981889 6 | New Brunswick,NB,783204 7 | Quebec,QC,8578300 8 | Ontario,ON,14745712 9 | Manitoba,MB,1380648 10 | Saskatchewan,SK,1179300 11 | Alberta,AB,4420029 12 | British Columbia,BC,5158728 13 | Yukon,YT,42174 14 | Northwest Territories,NT,45372 15 | Nunavut,NU,39155 16 | -------------------------------------------------------------------------------- /data/prov_pop_age.csv: -------------------------------------------------------------------------------- 1 | GeoUID,GEO,age,Value,Total 2 | 10,Newfoundland and Labrador,0-4,19556,520553 3 | 10,Newfoundland and Labrador,12-17,31452,520553 4 | 10,Newfoundland and Labrador,18-29,67473,520553 5 | 10,Newfoundland and Labrador,30-39,58693,520553 6 | 10,Newfoundland and Labrador,40-49,65483,520553 7 | 10,Newfoundland and Labrador,5-11,33237,520553 8 | 10,Newfoundland and Labrador,50-59,82009,520553 9 | 10,Newfoundland and Labrador,60-69,82446,520553 10 | 10,Newfoundland and Labrador,70-79,56623,520553 11 | 10,Newfoundland and Labrador,80+,23581,520553 12 | 11,Prince Edward Island,0-4,7095,164318 13 | 11,Prince Edward Island,12-17,10977,164318 14 | 11,Prince Edward Island,18-29,28385,164318 15 | 11,Prince Edward Island,30-39,19183,164318 16 | 11,Prince Edward Island,40-49,19899,164318 17 | 11,Prince Edward Island,5-11,11792,164318 18 | 11,Prince Edward Island,50-59,22238,164318 19 | 11,Prince Edward Island,60-69,21923,164318 20 | 11,Prince Edward Island,70-79,15433,164318 21 | 11,Prince Edward Island,80+,7393,164318 22 | 1,Canada,0-4,1882571,38246108 23 | 1,Canada,12-17,2468487,38246108 24 | 1,Canada,18-29,5938174,38246108 25 | 1,Canada,30-39,5364435,38246108 26 | 1,Canada,40-49,4894137,38246108 27 | 1,Canada,5-11,2879112,38246108 28 | 1,Canada,50-59,5130515,38246108 29 | 1,Canada,60-69,4840878,38246108 30 | 1,Canada,70-79,3134079,38246108 31 | 1,Canada,80+,1713720,38246108 32 | 12,Nova Scotia,0-4,41451,992055 33 | 12,Nova Scotia,12-17,58119,992055 34 | 12,Nova Scotia,18-29,148522,992055 35 | 12,Nova Scotia,30-39,124396,992055 36 | 12,Nova Scotia,40-49,118355,992055 37 | 12,Nova Scotia,5-11,66251,992055 38 | 12,Nova Scotia,50-59,141897,992055 39 | 12,Nova Scotia,60-69,145576,992055 40 | 12,Nova Scotia,70-79,99128,992055 41 | 12,Nova Scotia,80+,48360,992055 42 | 13,New Brunswick,0-4,33048,789225 43 | 13,New Brunswick,12-17,48489,789225 44 | 13,New Brunswick,18-29,105394,789225 45 | 13,New Brunswick,30-39,92799,789225 46 | 13,New Brunswick,40-49,99464,789225 47 | 13,New Brunswick,5-11,54298,789225 48 | 13,New Brunswick,50-59,116038,789225 49 | 13,New Brunswick,60-69,119236,789225 50 | 13,New Brunswick,70-79,80740,789225 51 | 13,New Brunswick,80+,39719,789225 52 | 24,Quebec,0-4,421670,8604495 53 | 24,Quebec,12-17,529424,8604495 54 | 24,Quebec,18-29,1213604,8604495 55 | 24,Quebec,30-39,1127027,8604495 56 | 24,Quebec,40-49,1124776,8604495 57 | 24,Quebec,5-11,650354,8604495 58 | 24,Quebec,50-59,1159373,8604495 59 | 24,Quebec,60-69,1170511,8604495 60 | 24,Quebec,70-79,783582,8604495 61 | 24,Quebec,80+,424174,8604495 62 | 35,Ontario,0-4,712821,14826276 63 | 35,Ontario,12-17,961857,14826276 64 | 35,Ontario,18-29,2454802,14826276 65 | 35,Ontario,30-39,2077137,14826276 66 | 35,Ontario,40-49,1855340,14826276 67 | 35,Ontario,5-11,1075423,14826276 68 | 35,Ontario,50-59,2019276,14826276 69 | 35,Ontario,60-69,1813493,14826276 70 | 35,Ontario,70-79,1181151,14826276 71 | 35,Ontario,80+,674976,14826276 72 | 46,Manitoba,0-4,82260,1383765 73 | 46,Manitoba,12-17,101481,1383765 74 | 46,Manitoba,18-29,228304,1383765 75 | 46,Manitoba,30-39,195317,1383765 76 | 46,Manitoba,40-49,170811,1383765 77 | 46,Manitoba,5-11,125477,1383765 78 | 46,Manitoba,50-59,167717,1383765 79 | 46,Manitoba,60-69,157579,1383765 80 | 46,Manitoba,70-79,98850,1383765 81 | 46,Manitoba,80+,55969,1383765 82 | 47,Saskatchewan,0-4,72825,1179844 83 | 47,Saskatchewan,12-17,89350,1179844 84 | 47,Saskatchewan,18-29,178239,1179844 85 | 47,Saskatchewan,30-39,171720,1179844 86 | 47,Saskatchewan,40-49,146160,1179844 87 | 47,Saskatchewan,5-11,110123,1179844 88 | 47,Saskatchewan,50-59,139721,1179844 89 | 47,Saskatchewan,60-69,139508,1179844 90 | 47,Saskatchewan,70-79,81696,1179844 91 | 47,Saskatchewan,80+,50502,1179844 92 | 48,Alberta,0-4,258669,4442879 93 | 48,Alberta,12-17,322828,4442879 94 | 48,Alberta,18-29,680472,4442879 95 | 48,Alberta,30-39,714987,4442879 96 | 48,Alberta,40-49,619281,4442879 97 | 48,Alberta,5-11,392380,4442879 98 | 48,Alberta,50-59,546826,4442879 99 | 48,Alberta,60-69,489094,4442879 100 | 48,Alberta,70-79,274088,4442879 101 | 48,Alberta,80+,144254,4442879 102 | 59,British Columbia,0-4,224047,5214805 103 | 59,British Columbia,12-17,303934,5214805 104 | 59,British Columbia,18-29,811394,5214805 105 | 59,British Columbia,30-39,762718,5214805 106 | 59,British Columbia,40-49,657647,5214805 107 | 59,British Columbia,5-11,346009,5214805 108 | 59,British Columbia,50-59,718744,5214805 109 | 59,British Columbia,60-69,689368,5214805 110 | 59,British Columbia,70-79,457714,5214805 111 | 59,British Columbia,80+,243230,5214805 112 | 60,Yukon,0-4,2204,42986 113 | 60,Yukon,12-17,2616,42986 114 | 60,Yukon,18-29,6297,42986 115 | 60,Yukon,30-39,7284,42986 116 | 60,Yukon,40-49,6087,42986 117 | 60,Yukon,5-11,3579,42986 118 | 60,Yukon,50-59,5841,42986 119 | 60,Yukon,60-69,5681,42986 120 | 60,Yukon,70-79,2555,42986 121 | 60,Yukon,80+,842,42986 122 | 61,Northwest Territories,0-4,2850,45504 123 | 61,Northwest Territories,12-17,3519,45504 124 | 61,Northwest Territories,18-29,7807,45504 125 | 61,Northwest Territories,30-39,7179,45504 126 | 61,Northwest Territories,40-49,6317,45504 127 | 61,Northwest Territories,5-11,4290,45504 128 | 61,Northwest Territories,50-59,6622,45504 129 | 61,Northwest Territories,60-69,4620,45504 130 | 61,Northwest Territories,70-79,1792,45504 131 | 61,Northwest Territories,80+,508,45504 132 | 62,Nunavut,0-4,4075,39403 133 | 62,Nunavut,12-17,4441,39403 134 | 62,Nunavut,18-29,7481,39403 135 | 62,Nunavut,30-39,5995,39403 136 | 62,Nunavut,40-49,4517,39403 137 | 62,Nunavut,5-11,5899,39403 138 | 62,Nunavut,50-59,4213,39403 139 | 62,Nunavut,60-69,1843,39403 140 | 62,Nunavut,70-79,727,39403 141 | 62,Nunavut,80+,212,39403 142 | -------------------------------------------------------------------------------- /data/prov_pop_data: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/data/prov_pop_data -------------------------------------------------------------------------------- /health_region_data.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Health Region Incidence" 3 | author: "Jens von Bergmann" 4 | date: "01/12/2020" 5 | output: html_document 6 | --- 7 | 8 | 9 | ```{r setup, include=FALSE} 10 | knitr::opts_chunk$set(echo = TRUE) 11 | library(tidyverse) 12 | library(CanCovidData) 13 | library(googlesheets4) 14 | library(mountainmathHelpers) 15 | library(sf) 16 | library(gganimate) 17 | ``` 18 | 19 | ```{r} 20 | hr_pop <- read_csv(here::here("data/hr_pop.csv")) %>% 21 | select(HR_UID=Region,Name=`Health Service Delivery Area`,Population=Total) %>% 22 | mutate(HR_UID=as.character(HR_UID)) %>% 23 | filter(HR_UID!="0") 24 | 25 | hr_case_data <- read_csv("http://www.bccdc.ca/Health-Info-Site/Documents/BCCDC_COVID19_Regional_Summary_Data.csv") %>% 26 | mutate(HSDA=recode(HSDA,"North Shore / Coast Garibaldi"="North Shore/Coast Garibaldi")) 27 | d<- hr_case_data %>% 28 | mutate(Date=as.Date(Date)) %>% 29 | filter(Date% 30 | select(Date,Name=HSDA,Count=Cases_Reported) %>% 31 | mutate(Count=coalesce(Count,0)) %>% 32 | filter(!(Name %in% c("All","Out of Canada"))) %>% 33 | group_by(Name) %>% 34 | arrange(Date) %>% 35 | mutate(c = RcppRoll::roll_sum(x = Count, 7, align = "right", fill = NA)) %>% 36 | left_join(hr_pop,by="Name") %>% 37 | mutate(incidence=c/Population*100000) %>% 38 | mutate(stage=pretty_cut(incidence,c(-Inf,0,5,10,25,50,100,Inf)),ordered=TRUE) %>% 39 | mutate(stage=fct_recode(stage,"0"="< 0")) %>% 40 | group_by(Date) %>% 41 | arrange(Name) %>% 42 | mutate(r=rank(incidence, ties.method= "first")) %>% 43 | filter(Date>=as.Date("2020-03-01")) %>% 44 | ungroup() %>% 45 | mutate(Name=factor(Name,levels=c(filter(.,Date==max(Date),Name!="Unknown") %>% arrange(incidence) %>% pull(Name),"Unknown"))) 46 | 47 | stage_colours <- setNames(RColorBrewer::brewer.pal(d$stage %>% levels %>% length,"YlOrRd"), 48 | d$stage %>% levels) 49 | ``` 50 | 51 | 52 | ## Heatmap 53 | ```{r} 54 | weeks = 40 55 | d %>% 56 | filter(Date %in% (max(Date)-seq(0,weeks-1)*7)) %>% 57 | filter(Name!="Unknown") %>% 58 | ggplot(aes(x=Date,y=Name,fill=stage)) + 59 | geom_tile() + 60 | scale_fill_manual(values=c("0"="#ffffdd",stage_colours)) + 61 | theme_dark() + 62 | theme(legend.position = "bottom") + 63 | theme(axis.text.x = element_text(angle=90,hjust=1)) + 64 | labs(title="COVID-19 7 day incidence", 65 | caption = "MountainMath, Data: BCCDC", 66 | x=NULL,y=NULL,fill="Cumulative 7 day cases\nper 100k population") 67 | ``` 68 | 69 | ## Bar race 70 | ```{r} 71 | staticplot <- d %>% 72 | mutate(rank=r,value=incidence) %>% 73 | filter(Date>=as.Date("2020-07-01")) %>% 74 | filter(Name!="Unknown",incidence>0) %>% 75 | #filter(Date>=as.Date("2020-11-01")) %>% 76 | ggplot(aes(x=rank, group = Name, 77 | fill = stage, color = stage)) + 78 | geom_tile(aes(y = value/2, 79 | height = value, 80 | width = 0.9), alpha = 0.8, color = NA) + 81 | geom_text(aes(y = 0, label = paste(Name, " ")), vjust = 0.2, hjust = 1) + 82 | #geom_text(aes(y=value,label = round(incidence), hjust=0)) + 83 | coord_flip(clip = "off") +#, expand = FALSE) + 84 | scale_y_continuous(labels = scales::comma, breaks=c(0,10,25,50,100)) + 85 | scale_fill_manual(values=stage_colours,guide=FALSE) + 86 | scale_colour_manual(values=stage_colours,guide=FALSE) + 87 | guides(color = FALSE, fill = FALSE) + 88 | #theme_dark() + 89 | theme(axis.line=element_blank(), 90 | axis.text.x=element_text(color="white"), 91 | axis.text.y=element_blank(), 92 | axis.ticks=element_blank(), 93 | #axis.title.x=element_blank(), 94 | axis.title.x=element_text(color="white"), 95 | legend.position="none", 96 | panel.background=element_rect(fill="#666666"), 97 | #panel.border=element_rect(fill="#444444"), 98 | panel.grid.major.y=element_blank(), 99 | panel.grid.minor.y=element_blank(), 100 | #panel.grid.major.x = element_line( size=.1, color="grey" ), 101 | panel.grid.minor.x = element_blank(), 102 | plot.title=element_text(size=12, hjust=0.5, face="bold", colour="white"),#, vjust=-1), 103 | #plot.subtitle=element_text(size=18, hjust=0.5, face="italic", color="grey"), 104 | plot.caption =element_text(size=8, hjust=1, face="italic", color="white"), 105 | plot.background=element_rect(fill="#666666"), 106 | plot.margin = margin(2,2, 2, 4.3, "cm")) 107 | 108 | anim <- staticplot + transition_time(Date) + 109 | #view_follow(fixed_x = TRUE) + 110 | labs(title = 'COVID-19 7 day incidence {frame_time}', 111 | caption = "MountainMath, Data: BCCDC", 112 | x=NULL, 113 | y="Cumulative 7 day cases per 100k population") 114 | 115 | #anim 116 | 117 | animate(anim, 400, fps = 20, width = 1200, height = 900, res = 150, 118 | start_pause = 20, end_pause = 50, rewind = FALSE, 119 | renderer = gifski_renderer("~/Desktop/hr_covid.gif")) 120 | ``` 121 | 122 | 123 | 124 | 125 | 126 | ## Bar static 127 | 128 | ```{r} 129 | staticplot <- d %>% 130 | mutate(rank=as.integer(Name),value=incidence) %>% 131 | filter(Name!="Unknown") %>% 132 | filter(Date>=as.Date("2020-07-01")) %>% 133 | ggplot(aes(x=rank, group = Name, 134 | fill = stage, color = stage)) + 135 | geom_tile(aes(y = value/2, 136 | height = value, 137 | width = 0.9), alpha = 0.8, color = NA) + 138 | geom_text(aes(y = 0, label = paste(Name, " ")), vjust = 0.2, hjust = 1) + 139 | #geom_text(aes(y=value,label = round(incidence), hjust=0)) + 140 | coord_flip(clip = "off") +#, expand = FALSE) + 141 | scale_y_continuous(labels = scales::comma, breaks=c(0,10,25,50,100)) + 142 | scale_fill_manual(values=stage_colours,guide=FALSE) + 143 | scale_colour_manual(values=stage_colours,guide=FALSE) + 144 | guides(color = FALSE, fill = FALSE) + 145 | #theme_dark() + 146 | theme(axis.line=element_blank(), 147 | axis.text.x=element_text(color="white"), 148 | axis.text.y=element_blank(), 149 | axis.ticks=element_blank(), 150 | #axis.title.x=element_blank(), 151 | axis.title.x=element_text(color="white"), 152 | legend.position="none", 153 | panel.background=element_rect(fill="#666666"), 154 | #panel.border=element_rect(fill="#444444"), 155 | panel.grid.major.y=element_blank(), 156 | panel.grid.minor.y=element_blank(), 157 | #panel.grid.major.x = element_line( size=.1, color="grey" ), 158 | panel.grid.minor.x = element_blank(), 159 | plot.title=element_text(size=12, hjust=0.5, face="bold", colour="white"),#, vjust=-1), 160 | #plot.subtitle=element_text(size=18, hjust=0.5, face="italic", color="grey"), 161 | plot.caption =element_text(size=8, hjust=1, face="italic", color="white"), 162 | plot.background=element_rect(fill="#666666"), 163 | plot.margin = margin(2,2, 2, 4.3, "cm")) 164 | 165 | anim = staticplot + 166 | transition_time(Date) + 167 | #view_follow(fixed_x = TRUE) + 168 | labs(title = 'COVID-19 7 day incidence {frame_time}', 169 | caption = "MountainMath, Data: BCCDC", 170 | x=NULL, 171 | y="Cumulative 7 day cases per 100k population") 172 | 173 | #anim 174 | 175 | animate(anim, 400, fps = 20, width = 1200, height = 900, res = 150, 176 | start_pause = 20, end_pause = 50, rewind = FALSE, 177 | renderer = gifski_renderer("~/Desktop/hr_covid2.gif")) 178 | ``` 179 | ## Map 180 | 181 | ```{r} 182 | geos <- get_health_region_geographies_2018() %>% 183 | select(-Name) %>% 184 | inner_join(d %>% filter(Date>=as.Date("2020-07-01")),by="HR_UID") %>% 185 | mutate(label=paste0(Name,"\n",round(incidence),"/100k")) 186 | 187 | geos_van <- geos %>% 188 | st_transform(4326) %>% 189 | st_intersection(metro_van_bbox() %>% st_as_sfc() %>% st_buffer(0.1)) 190 | 191 | geos_van_label <- geos_van %>% 192 | st_intersection(metro_van_bbox() %>% st_as_sfc() %>% st_buffer(-0.05)) %>% 193 | st_point_on_surface() 194 | 195 | mr <- metro_van_vector_tiles()$roads %>% rmapzen::as_sf() %>% filter(!grepl("ferry",kind)) %>% st_collection_extract("LINE") 196 | mw <- metro_van_vector_tiles()$water %>% rmapzen::as_sf() %>% st_collection_extract("POLYGON") 197 | 198 | #anim <- ggplot(geos %>% st_transform(4236) %>% filter(HR_UID %in% (geos_van$HR_UID %>% unique))) + 199 | g <- ggplot(geos_van %>% st_transform(4326)) + 200 | geom_sf(aes(fill=stage,group=Name)) + 201 | #scale_fill_viridis_c(option = "magma") + 202 | scale_fill_manual(values=stage_colours) + 203 | geom_sf(data=mw,fill="lightblue",size=0.1) + 204 | geom_sf(data=mr,color="black",size=0.1) + 205 | #geom_sf_label(data=geos_van_label,aes(label=label),alpha=0.8) + 206 | coord_bbox(metro_van_bbox()) + 207 | labs(title="7 day COVID-19 case incidence per 100k population", 208 | subtitle="({frame_time})", 209 | caption = "MountainMath, Data: BCCDC", 210 | fill="cumulative 7 day\nnew cases per\n100k population",x=NULL,y=NULL) 211 | 212 | 213 | 214 | animate(g + transition_time(Date), 215 | 350, fps = 20, width = 950, height = 650, res = 150, 216 | start_pause = 10, end_pause = 40, rewind = FALSE, 217 | renderer = gifski_renderer("~/Desktop/hr_covid_map.gif")) 218 | 219 | ``` 220 | 221 | 222 | ## Validation 223 | ```{r} 224 | cases <- get_british_columbia_case_data() %>% 225 | count(Date=`Reported Date`,`Health Authority`,name="Cases") 226 | 227 | ha_lookup <- c("591"="Interior","593"="Vancouver Coastal","594"="Vancouver Island", 228 | "595"="Northern","592"="Fraser") 229 | 230 | cases2 <- get_canada_covid_working_group_cases() %>% 231 | filter(province=="BC") %>% 232 | count(`Health Authority`=health_region,Date,name="Cases") %>% 233 | mutate(`Health Authority`=recode(`Health Authority`,"Island"="Vancouver Island")) 234 | 235 | if (cases2 %>% filter(Date==as.Date("2020-12-03")) %>% nrow() == 0) { # manually add data if needed 236 | cases2 <- cases2 %>% 237 | bind_rows(tibble(`Health Authority`=c("Fraser","Interior","Vancouver Island","Northern","Vancouver Coastal"), 238 | Date=as.Date("2020-12-03"), 239 | Cases=c(465,82,10,23,114))) 240 | } 241 | 242 | map_data <- hr_data %>% 243 | left_join(cdp %>% select(HR_UID,Population=Total,Name),by="Name") %>% 244 | mutate(HA_UID=substr(HR_UID,1,3)) %>% 245 | mutate(`Health Authority`=ha_lookup[HA_UID]) %>% 246 | select(-Name,-HR_UID,-HA_UID) %>% 247 | group_by(`Health Authority`) %>% 248 | summarise_all(sum) %>% 249 | pivot_longer(-one_of("Health Authority"),names_to="Date",values_to="Map count") 250 | 251 | 252 | 253 | 254 | compare_data <- end_dates %>% 255 | lapply(function(date){ 256 | map_data %>% filter(Date==date) %>% 257 | left_join(cases %>% 258 | filter(Date% 259 | group_by(`Health Authority`) %>% 260 | summarize(Cases=sum(Cases),.groups="drop"), 261 | by="Health Authority") %>% 262 | left_join(cases2 %>% 263 | filter(Date<=date) %>% 264 | group_by(`Health Authority`) %>% 265 | summarize(Cases2=sum(Cases),.groups="drop"),by="Health Authority") 266 | }) %>% 267 | bind_rows() %>% 268 | mutate(diff=Cases-`Map count`, 269 | rel=diff/Cases, 270 | diff2=Cases2-`Map count`, 271 | rel2=diff2/Cases2) 272 | ``` 273 | 274 | 275 | ```{r} 276 | 277 | ggplot(compare_data,aes(x=Date,y=rel)) + 278 | geom_bar(stat="identity") + 279 | facet_wrap("`Health Authority`") + 280 | theme_bw() + 281 | scale_y_continuous(labels=scales::percent) + 282 | theme(axis.text.x = element_text(angle=90,hjust=1)) + 283 | labs(title="Comparing dashboard and health region map case counts", 284 | y="Relative difference in case counts",x="Map version date", 285 | caption="MountainMath, BCCDC, scrapes by @ty_olson and a special 10yo") 286 | ``` 287 | 288 | 289 | ```{r} 290 | 291 | ggplot(compare_data,aes(x=Date,y=rel2)) + 292 | geom_bar(stat="identity") + 293 | facet_wrap("`Health Authority`") + 294 | theme_bw() + 295 | scale_y_continuous(labels=scales::percent) + 296 | theme(axis.text.x = element_text(angle=90,hjust=1)) + 297 | labs(title="Comparing COVID Data Working Group and health region map case counts", 298 | y="Relative difference in case counts",x="Map version date", 299 | caption="MountainMath, Canada COVID Data Working Group, scrapes by @ty_olson and a special 10yo") 300 | ``` 301 | 302 | 303 | 304 | 305 | -------------------------------------------------------------------------------- /open_table.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Open Table" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE, 13 | fig.retina = 2, 14 | dpi = 150, 15 | fig.width = 7, 16 | fig.height = 5 17 | ) 18 | library(ggplot2) 19 | library(dplyr) 20 | library(tidyr) 21 | library(CanCovidData) 22 | 23 | source(here::here("R/helpers.R")) 24 | ``` 25 | 26 | These graphs show Open Table year over year change in reservations for seated diners and share of restaurants that accept reservations from the [Open Table State of the industry report](https://www.opentable.com/state-of-industry). The code for this notebook is [available for anyone to adapt and use for their own purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/open_table.Rmd). 27 | 28 | 29 | ## Seated diners from online, phone, and walk-in reservations 30 | 31 | ```{r open-table-canada-cities} 32 | open_table <- get_open_table_data("fullbook") %>% 33 | mutate(value=value/100) %>% 34 | rename(Name=name) 35 | 36 | g <- open_table %>% 37 | filter(grepl("Vancouver|Toronto|Calgary|Montr|Edmon|Otta",Name)) %>% 38 | group_by(Name) %>% 39 | arrange(Date) %>% 40 | mutate(Trend=extract_stl_trend(value)) %>% 41 | ggplot(aes(x=Date,y=Trend,color=Name,group=Name)) + 42 | geom_point(shape=21,aes(y=value),alpha=0.5) + 43 | geom_line(size=0.75) + 44 | scale_y_continuous(labels=scales::percent)+ 45 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 46 | theme_dark() + 47 | theme(panel.background = element_rect(fill="#444444"), 48 | plot.background = element_rect(fill="#444444"), 49 | legend.background = element_rect(fill="#444444"), 50 | legend.key = element_rect(fill="#444444"), 51 | axis.text = element_text(color="whitesmoke"), 52 | text = element_text(color="whitesmoke"), 53 | legend.position="bottom") + 54 | labs(title="OpenTable seated diners restaurant reservations (STL trend lines)", 55 | x=NULL,y="Year over year change",colour=NULL,caption="MountainMath, Data: OpenTable") 56 | 57 | g 58 | #r<-graph_to_s3(g,"bccovid","open_table_canada_cities.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 59 | ``` 60 | 61 | 62 | ## Restaurants open for reservations 63 | 64 | 65 | ```{r open-table-canada-cities-2} 66 | open_table <- get_open_table_data("reopening") %>% 67 | mutate(value=value/100) %>% 68 | rename(Name=name) 69 | 70 | g <- open_table %>% 71 | filter(grepl("Vancouver|Toronto|Calgary|Montr|Edmon|Otta",Name)) %>% 72 | group_by(Name) %>% 73 | arrange(Date) %>% 74 | mutate(Trend=extract_stl_trend(value)) %>% 75 | ggplot(aes(x=Date,y=Trend,color=Name,group=Name)) + 76 | geom_point(shape=21,aes(y=value),alpha=0.5) + 77 | geom_line(size=0.75) + 78 | scale_y_continuous(labels=scales::percent)+ 79 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 80 | theme_dark() + 81 | theme(panel.background = element_rect(fill="#444444"), 82 | plot.background = element_rect(fill="#444444"), 83 | legend.background = element_rect(fill="#444444"), 84 | legend.key = element_rect(fill="#444444"), 85 | axis.text = element_text(color="whitesmoke"), 86 | text = element_text(color="whitesmoke"), 87 | legend.position="bottom") + 88 | labs(title="OpenTable share of restaurants accepting reservations (STL trend lines)", 89 | x=NULL,y="Share of restaurants accepting reservations",colour=NULL,caption="MountainMath, Data: OpenTable") 90 | 91 | g 92 | #r<-graph_to_s3(g,"bccovid","open_table_canada_cities-2.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 93 | ``` 94 | -------------------------------------------------------------------------------- /open_table.md: -------------------------------------------------------------------------------- 1 | Open Table 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 10 November, 2021 - 15:51 5 | 6 | These graphs show Open Table year over year change in reservations for 7 | seated diners and share of restaurants that accept reservations from the 8 | [Open Table State of the industry 9 | report](https://www.opentable.com/state-of-industry). The code for this 10 | notebook is [available for anyone to adapt and use for their own 11 | purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/open_table.Rmd). 12 | 13 | ## Seated diners from online, phone, and walk-in reservations 14 | 15 | 16 | 17 | ## Restaurants open for reservations 18 | 19 | 20 | -------------------------------------------------------------------------------- /open_table_files/figure-gfm/open-table-canada-cities-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/open_table_files/figure-gfm/open-table-canada-cities-1.png -------------------------------------------------------------------------------- /open_table_files/figure-gfm/open-table-canada-cities-2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/open_table_files/figure-gfm/open-table-canada-cities-2-1.png -------------------------------------------------------------------------------- /reports.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Images for reports" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | 9 | ```{r setup, include=FALSE} 10 | knitr::opts_chunk$set( 11 | echo = FALSE, 12 | message = FALSE, 13 | warning = FALSE, 14 | fig.retina = 2, 15 | dpi = 150, 16 | fig.width = 7, 17 | fig.height = 5 18 | ) 19 | library(dplyr) 20 | library(tidyr) 21 | library(ggplot2) 22 | library(readr) 23 | library(CanCovidData) 24 | library(lubridate) 25 | library(ggtext) 26 | #library(segmented) 27 | library(broom) 28 | source(here::here("R/helpers.R")) 29 | 30 | 31 | major_restrictions <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged","2021-03-29"="No indoor dining\nNo indoor group activity\nMasks grades 4-12", 32 | "2021-08-25"="Indoor Masks") 33 | major_restriction_labels <- c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings","2020-11-19"="Masks in stores\nTravel discouraged","2021-03-07"="No indoor dining\nNo indoor group activity\nMasks grades 4-12", 34 | "2021-08-25"="Indoor Masks") 35 | major_restrictions_y <- c("2020-03-18"=1,"2020-11-07"=0.1,"2020-11-19"=0.3,"2020-03-29"=0.1,"2021-08-25"=1) 36 | minor_restrictions <- c("2020-03-11","2020-03-12","2020-03-16","2020-03-17", 37 | "2020-03-21","2020-03-22","2020-03-26","2020-04-18", 38 | "2020-06-18","2020-08-21","2020-09-08","2020-10-26","2021-04-30", 39 | "2021-07-28","2021-08-06") 40 | major_reopenings <- c("2020-05-19"="Phase 2","2020-06-24"="Phase 3", 41 | "2021-05-25"="Step 1\nreopening","2021-06-15"="Step 2\nreopening", 42 | "2021-07-01"="Step 3\nreopening") 43 | major_reopenings_y_fact <- c(1,1,1,0.8,0.6) 44 | minor_reopenings <- c("2020-05-14","2020-06-01","2020-06-08", 45 | "2020-06-30","2020-07-02","2020-09-10","2020-12-15") 46 | 47 | restriction_markers <- function(major_size=1,minor_size=0.25){ 48 | list( 49 | geom_vline(xintercept = as.Date(minor_reopenings), 50 | linetype="dashed",color="darkgreen",size=minor_size), 51 | geom_vline(xintercept = as.Date(names(major_reopenings)),linetype="dashed",color="darkgreen",size=major_size), 52 | geom_vline(xintercept = as.Date(names(major_restrictions)),linetype="dashed",color="brown",size=major_size), 53 | geom_vline(xintercept = as.Date(minor_restrictions), 54 | linetype="dashed",color="brown",size=minor_size) 55 | )} 56 | 57 | full_labels <- function(label_y, 58 | major_restriction_labels = c("2020-03-18"="Phase 1","2020-11-07"="No private\ngatherings"), 59 | major_restrictions_y = c(1,0.15)){ 60 | c(restriction_markers(),list( 61 | geom_label(data = tibble(Date=as.Date(names(major_reopenings)), 62 | count=label_y*major_reopenings_y_fact, 63 | label=as.character(major_reopenings)), 64 | aes(label=label),size=4,alpha=0.7,color="darkgreen"), 65 | geom_label(data = tibble(Date=as.Date(names(major_restriction_labels)), 66 | label=as.character(major_restriction_labels), 67 | count=as.numeric(major_restrictions_y)), 68 | aes(label=label),size=4,alpha=0.7,color="brown") 69 | )) 70 | } 71 | 72 | 73 | ha_colours <- setNames(c(sanzo::trios$c157,sanzo::trios$c149), 74 | c("Fraser","Rest of BC","Vancouver Coastal" , "Vancouver Island", "Interior", "Northern")) 75 | 76 | share_to_ratio <- function(s)1/(1/s-1) 77 | ratio_to_share <- function(r)1/(1+1/r) 78 | get_n501y_data <- function(live=FALSE){ 79 | if (live) 80 | read_csv("http://www.bccdc.ca/Health-Info-Site/Documents/VoC/Figure1_weeklyreport_data.csv") %>% 81 | rename(epiweek=Epiweek,epi_cdate=`Epiweek - Start Date`,patient_ha=Region, 82 | prop_voc=`Proportion of VoC`) 83 | else 84 | read_csv(here::here("data/COVID19_VoC_data.csv"),col_types = cols(.default="c")) %>% 85 | mutate(across(c("epiweek",prop_voc),as.numeric),epi_cdate=as.Date(epi_cdate)) %>% 86 | bind_rows(tibble(patient_ha=c("British Columbia", "Fraser", "Interior", "Northern", 87 | "Vancouver Coastal", "Island"), 88 | epiweek=18, 89 | epi_cdate=as.Date("2021-05-02"), 90 | prop_voc=c(83,82,83,45,92,82))) %>% 91 | #prop_voc=c(85,86,83,45,93,84))) %>% 92 | bind_rows(tibble(patient_ha=c("British Columbia", "Fraser", "Interior", "Northern", 93 | "Vancouver Coastal", "Island"), 94 | epiweek=19, 95 | epi_cdate=as.Date("2021-05-09"), 96 | prop_voc=c(85,82,89,63,94,77))) 97 | #prop_voc=c(89,88,89,63,94,78))) 98 | } 99 | 100 | ``` 101 | 102 | ```{r} 103 | 104 | bc_voc_data <- get_n501y_data() %>% 105 | mutate(prop_voc=as.numeric(prop_voc)) %>% 106 | mutate(Date=as.Date(epi_cdate)+4, 107 | share_voc=prop_voc/100) %>% 108 | #left_join(get_b.1.617(),by=c("patient_ha","epiweek")) %>% 109 | #mutate(share_voc=share_voc+coalesce(prop_b.1.617,0)/100) %>% 110 | mutate(ratio_voc=share_to_ratio(share_voc)) %>% 111 | mutate(Day=difftime(Date,min(Date),units = "day") %>% unclass) 112 | 113 | n501y <- bc_voc_data %>% 114 | filter(patient_ha=="British Columbia") %>% 115 | select(Date,Week=epiweek,share_voc,ratio_voc,Day) 116 | 117 | # break_day <- n501y %>% filter(Date>=as.Date("2021-04-01")) %>% 118 | # head(1) %>% 119 | # pull(Day) 120 | break_day <- #as.Date(c("2021-04-01","2021-05-20")) %>% 121 | as.Date(c("2021-04-01")) %>% 122 | difftime(min(n501y$Date),units = "day") %>% 123 | as.integer 124 | 125 | model.n501y <- lm(log(ratio_voc)~Day,data=n501y%>% filter(as.integer(Week)>=7),Week<22) 126 | model.n501y.s <- segmented::segmented(model.n501y,psi = break_day) 127 | prediction.n501y <- tibble(Date=seq(as.Date("2021-02-01"),Sys.Date(),by="day")) %>% 128 | mutate(Day=difftime(Date,min(n501y$Date),units = "day") %>% unclass) %>% 129 | mutate(share_voc = predict(model.n501y.s,newdata = .) %>% exp %>% ratio_to_share) 130 | 131 | ``` 132 | 133 | ```{r} 134 | all_data <- get_british_columbia_case_data() %>% 135 | count(Date=`Reported Date`,name="Cases") %>% 136 | filter(Date>=as.Date("2020-03-01")) %>% 137 | mutate(stl=add_stl_trend_m(Cases)) %>% 138 | mutate(Trend=stl$trend, 139 | Random=stl$remainder, 140 | Seasonal=stl$seasonal) %>% 141 | select(-stl) %>% 142 | mutate(Cleaned=Cases/Seasonal) %>% 143 | left_join(prediction.n501y, by="Date") %>% 144 | mutate(`Wild type`=Trend*(1-share_voc)) %>% 145 | mutate(`Wild type`=coalesce(`Wild type`,Trend)) %>% 146 | mutate(Combined=Trend) %>% 147 | mutate(Trend=`Wild type`) 148 | 149 | # stl_fan <- all_data %>% 150 | # get_stl_fan(stl_floor = 0) 151 | 152 | 153 | start_date <- as.Date("2020-04-25") 154 | end_predict_date<- as.Date("2021-06-01") 155 | projection_days <- 14 156 | 157 | model_data <- all_data %>% 158 | filter(Date>=start_date) %>% 159 | filter(Date<=end_predict_date) %>% 160 | mutate(day=difftime(Date,start_date,units="day") %>% as.integer) %>% 161 | mutate(log_Trend=log(Trend)) 162 | 163 | model.lm <- lm(log_Trend ~ day,data=model_data) 164 | 165 | 166 | model.s <- segmented::segmented(model.lm,npsi=6) 167 | 168 | change_points <- model.s$psi %>% 169 | as_tibble() %>% 170 | mutate(Date=start_date+Est.) 171 | 172 | if (FALSE){ 173 | added_change_points <- as.Date(c("2020-05-09")) %>% 174 | #as.Date(c("2020-05-09")) %>% 175 | difftime(start_date) %>% 176 | as.integer 177 | model.s <- segmented::segmented(model.lm,psi=c(change_points$Est.,added_change_points) %>% sort) 178 | 179 | change_points <- model.s$psi %>% 180 | as_tibble() %>% 181 | mutate(Date=start_date+Est.) 182 | } 183 | # initial_phase <- tidy(model.s) %>% 184 | # slice(1,2) %>% 185 | # pull(estimate) 186 | 187 | 188 | predict_data <- list(seq(as.Date("2020-03-20"),start_date,by="day"), 189 | seq(max(all_data$Date),max(all_data$Date)+projection_days,by="day")) %>% 190 | lapply(function(dates){ 191 | tibble(Date=dates) %>% 192 | mutate(day=difftime(Date,start_date,units = "day") %>% as.integer) %>% 193 | mutate(log_count=predict(model.s,newdata=.)) %>% 194 | mutate(count=exp(log_count)) 195 | }) 196 | 197 | growth_rates <- tidy(model.s) %>% 198 | filter(term!="(Intercept)",!grepl("psi",term)) %>% 199 | mutate(r=cumsum(estimate)) %>% 200 | mutate(R=exp(r*6.5)) 201 | 202 | cutoff_data <- tibble(min=c(start_date,sort(change_points$Date)) %>% as.character()) %>% 203 | mutate(max=lead(min) %>% coalesce(.,end_predict_date %>% as.character()), 204 | predict_max=lead(min) %>% coalesce(.,as.character(end_predict_date+projection_days))) %>% 205 | mutate_all(as.Date) %>% 206 | mutate(t=as.character(row_number() %% 2)) %>% 207 | mutate(mid=min+as.numeric(difftime(max,min,units="day"))/2) %>% 208 | bind_cols(growth_rates %>% select(r,R)) %>% 209 | mutate(label=paste0("Wild type\nr=",scales::percent(r,accuracy = 0.1),"\nR=",round(R,2))) %>% 210 | mutate(mid=case_when(mid==min(mid) ~ mid-12,TRUE ~ mid)) #%>% 211 | #filter(min% 220 | left_join(model_data %>% 221 | mutate(Fitted=predict(model.s,new_data=.) %>% exp()) %>% 222 | select(Date,Fitted),by="Date")%>% 223 | #filter(Date<=min(filter(stl_fan,max-min>0.8)$Date)) %>% 224 | #filter(Date<=stl_fan$Date) %>% 225 | pivot_longer(c("Cases","Wild type","Cleaned","Combined","Fitted"),names_to="type",values_to="count") %>% 226 | filter(type!="Wild type" | Date>=as.Date("2021-02-01")) %>% 227 | mutate(type=factor(type,levels=c("Cases","Cleaned","Wild type","Fitted","Combined"))) %>% 228 | filter(Date<=end_predict_date|type!="Wild type") %>% 229 | #filter(Date>=as.Date("2020-11-01")) %>% 230 | ggplot(aes(x = Date, y = count,color=type,size=type)) + 231 | geom_rect(data=cutoff_data,# %>% filter(max% bind_rows(tibble(Date=start_date)),aes(xintercept = Date)) + 246 | theme_bw() + 247 | theme(legend.position = "bottom") + 248 | theme(panel.grid.major = element_blank(), 249 | panel.grid.minor = element_blank()) + 250 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 251 | scale_color_manual(values=c("Cases"="grey","Cleaned"="darkgrey", 252 | "Wild type"="grey40", 253 | "Combined"="black","Fitted"="steelblue"), 254 | labels=c("Cases"="Raw cases","Cleaned"="Cases adjusted for weekly pattern", 255 | "Wild type"="Wild type", 256 | "Combined"="Wild type and VOC","Fitted"="Fitted wild type")) + 257 | #geom_line(data=predict_data[[1]],color="steelblue",size=1,linetype="dotted") + 258 | #geom_line(data=predict_data[[2]],color="steelblue",size=1,linetype="dotted") + 259 | guides(color = guide_legend(override.aes = list(linetype = c("Cases"=NA, "Cleaned"=1, 260 | "Wild type"=1,"Fitted"=1, "Combined"=1), 261 | shape = c("Cases"=21,"Cleaned"=NA, 262 | "Wild type"=NA,"Fitted"=NA, "Combined"=NA)) ) ) + 263 | geom_label(data=cutoff_data,# %>% filter(max% 277 | mutate(Date=as.Date(date)) 278 | 279 | dd<-get_british_columbia_case_data() %>% 280 | count(Date=`Reported Date`,name="Cases") 281 | 282 | d %>% 283 | pivot_longer(c("total_hospitalizations","total_criticals","change_cases")) %>% 284 | select(Date,name,value) %>% 285 | mutate(value=as.integer(value)) %>% 286 | bind_rows(dd %>% rename(value=Cases) %>% mutate(name="Cases")) %>% 287 | filter(Date>=as.Date("2020-08-01")) %>% 288 | mutate(value=pmax(1,value)) %>% 289 | group_by(name) %>% 290 | arrange(desc(Date)) %>% 291 | filter(cumsum(value)>0) %>% 292 | mutate(stl=add_stl_trend_m(value)) %>% 293 | mutate(trend=stl$trend) %>% 294 | filter(name!="change_cases") %>% 295 | filter(Date>=as.Date("2020-09-01")) %>% 296 | mutate(name=recode(name,"total_criticals"="ICU census","total_hospitalizations"="Hospital census")) %>% 297 | ggplot(aes(x=Date,y=trend,colour=name)) + 298 | geom_point(aes(y=value),size=0.5,shape=21) + 299 | geom_line() + 300 | scale_y_continuous(trans="log",breaks=2^seq(0,10)) + 301 | scale_x_date(date_labels = "%b %Y",breaks = "month") + 302 | theme_bw() + 303 | scale_colour_manual(values=c("ICU census"="#ff80ff","Hospital census"="#008080",Cases="#008000")) + 304 | theme(legend.position = "bottom", 305 | axis.text.x = element_text(angle=60,hjust=1)) + 306 | labs(title="British Columbia COVID-19 cases, hospital and ICU census", 307 | x=NULL,y=NULL,colour=NULL, 308 | caption="Data: BCCDC for cases, Canada Covid-19 tracker for hospital and ICU census") 309 | ``` 310 | 311 | ```{r icu-share} 312 | d %>% 313 | #pivot_longer(c("total_hospitalizations","total_criticals","change_cases")) %>% 314 | mutate_at(c("total_criticals","total_hospitalizations","change_cases"),as.integer) %>% 315 | mutate(`ICU share`=total_criticals/total_hospitalizations, 316 | `Hospitalization rate`=total_hospitalizations/lag(change_cases,n=14,order_by = Date)) %>% 317 | pivot_longer(c("ICU share","Hospitalization rate")) %>% 318 | select(Date,name,value) %>% 319 | #mutate(value=as.integer(value)) %>% 320 | #bind_rows(dd %>% rename(value=Cases) %>% mutate(name="Cases")) %>% 321 | filter(Date>=as.Date("2020-08-01")) %>% 322 | #mutate(value=pmax(1,value)) %>% 323 | group_by(name) %>% 324 | arrange(desc(Date)) %>% 325 | filter(cumsum(value)>0) %>% 326 | #mutate(stl=add_stl_trend(value)) %>% 327 | #mutate(trend=stl$trend) %>% 328 | filter(name!="change_cases") %>% 329 | filter(Date>=as.Date("2020-09-01")) %>% 330 | filter(grepl("ICU",name)) %>% 331 | #mutate(name=recode(name,"total_criticals"="ICU census","total_hospitalizations"="Hospital census")) %>% 332 | ggplot(aes(x=Date,y=value,colour=name)) + 333 | geom_point(aes(y=value),size=0.5,shape=21) + 334 | geom_smooth(span=0.3,se=FALSE) + 335 | scale_y_continuous(labels=scales::percent) + 336 | expand_limits(y=0) + 337 | #scale_y_continuous(trans="log",breaks=2^seq(0,10)) + 338 | scale_x_date(date_labels = "%b %Y",breaks = "month") + 339 | theme_bw() + 340 | theme(legend.position = "bottom", 341 | axis.text.x = element_text(angle=60,hjust=1)) + 342 | labs(title="British Columbia share of COVID-19 hospitalizations in ICU", 343 | x=NULL,y=NULL,colour=NULL, 344 | caption="Data: Canada Covid-19 tracker") 345 | ``` 346 | 347 | 348 | ```{r hospital-admissions} 349 | admissions <- read_csv("https://mountainmath.ca/bc_total_hospitalizations.csv") 350 | plot_data<-admissions %>% 351 | #bind_rows(new_data) %>% 352 | group_by(HA) %>% 353 | mutate(change=total_hospitalized-lag(total_hospitalized,order_by = ScrapeDate)) %>% 354 | filter(!is.na(change)) 355 | 356 | 357 | 358 | plot_data %>% 359 | filter(ScrapeDate %in% ((.) %>%filter(HA=="BC",change>0) %>% pull(ScrapeDate))) %>% 360 | mutate(lastDate=lag(ScrapeDate,order_by = ScrapeDate)) %>% 361 | mutate(diff=difftime(ScrapeDate,lastDate,units = "day") %>% as.integer) %>% 362 | mutate(Date=ScrapeDate, 363 | estimate=change/diff) %>% 364 | group_by(HA) %>% 365 | complete(Date=seq(min(ScrapeDate),max(ScrapeDate),by="day")) %>% 366 | arrange(Date) %>% 367 | fill(estimate,.direction = "up") %>% 368 | select(HA,Date,change,estimate) %>% 369 | ungroup %>% 370 | ggplot(aes(x=Date,y=estimate,fill=HA)) + 371 | #scale_y_continuous(trans="log") + 372 | geom_bar(stat="identity") + 373 | geom_smooth(se=FALSE,span=0.3,colour="black") + 374 | scale_fill_discrete(guide="none") + 375 | facet_wrap("HA",scales="free_y") + 376 | labs(y="Hospital admissions") + 377 | labs(title="Hospital admissions", 378 | caption="Scraped from BCCDC Dashboard",x=NULL,y="Number of daily hospitalizations") 379 | ``` 380 | 381 | 382 | 383 | 384 | ```{r hr-trend-recent} 385 | pop_data <- read_csv(here::here("data/hr_pop.csv")) %>% 386 | select(HR_UID=Region,HR=`Health Service Delivery Area`,Population=Total) 387 | 388 | data <- get_british_columbia_hr_case_data() %>% 389 | rename(HA=`Health Authority`,HR=`Health Region`) %>% 390 | filter(!(HA %in% c("Out of Canada","All")),!(HR %in% c("All","Unknown"))) %>% 391 | filter(Date>=as.Date("2020-03-01")) %>% 392 | group_by(HR,HA) %>% 393 | mutate(Trend=extract_stl_trend_m(Cases+1)-1, 394 | Seasonal=extract_stl_seasonal_m(Cases+1)) %>% 395 | mutate(Cleaned=Cases/Seasonal-1) %>% 396 | left_join(read_csv(here::here("data/ha_pop.csv")) %>% 397 | select(HA=`Health Authority`,HA_Population=Total), by="HA") %>% 398 | left_join(pop_data, by="HR") %>% 399 | mutate(Population=coalesce(Population,HA_Population)) %>% 400 | ungroup() %>% 401 | mutate(Cases_0=Cases,Trend_0=Trend,Cleand_0=Cleaned) %>% 402 | mutate_at(c("Cases","Cleaned","Trend"),function(d)d/.$Population*100000) 403 | 404 | 405 | # stl_fan <- data %>% 406 | # filter(!(HR %in% c("All","Unknown"))) %>% 407 | # group_by(HA,HR) %>% 408 | # get_stl_fan() 409 | 410 | 411 | 412 | label_y <- max(data$Cases) * 0.9 413 | 414 | g <- data %>% 415 | filter(!(HR %in% c("All","Unknown")),Date>=as.Date("2021-07-01")) %>% 416 | pivot_longer(c("Cases","Trend","Cleaned"),names_to="type",values_to="count") %>% 417 | filter(count>0) %>% 418 | #left_join(stl_fan %>% group_by(HA,HR) %>% summarize(max_date=min(Date),.groups="drop"), by=c("HA","HR")) %>% 419 | #filter(Date<=max_date) %>% 420 | ggplot(aes(x = Date, y = count)) + 421 | #geom_point(data=~filter(.,type=="Cases"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 422 | #geom_line(data=~filter(.,type=="Cleaned"),size=0.5,alpha=0.1,aes(color=HA,group=HR)) + 423 | # geom_ribbon(data=stl_tail,aes(x=Date,ymin=min,ymax=max,fill=HA,color=HA,group=HR),size=0.75, 424 | # inherit.aes=FALSE,show.legend = 'none') + 425 | geom_line(data=~filter(.,type=="Trend"),aes(color=HA,group=HR),size=0.75) + 426 | #geom_line(data=stl_fan,aes(x=Date,y=value,color=HA,group=interaction(HR,run)),size=0.75) + 427 | theme_bw() + 428 | scale_x_date(breaks="month",labels=function(d)strftime(d,"%b")) + 429 | theme(legend.position = "bottom") + 430 | scale_color_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 431 | scale_fill_manual(values=ha_colours[intersect(names(ha_colours),unique(data$HA))]) + 432 | ggrepel::geom_text_repel(data = ~filter(.,Date==max(Date),type=="Trend",count>=2), 433 | aes(label=HR),show.legend=FALSE, 434 | nudge_x = 7,direction="y",size=3,hjust=0, 435 | segment.color="black",segment.size = 0.25,colour="black") + 436 | labs(title=paste0("Covid-19 daily new cases trend lines in British Columbia (up to ",strftime(max(data$Date),"%a %b %d"),")"), 437 | subtitle="Timeline of closure and reopening events", 438 | x=NULL,y="Daily cases per 100k population",color=NULL,caption="MountainMath, Data: BCCDC, BC Stats") + 439 | theme(plot.subtitle = element_markdown()) + 440 | restriction_markers(0.5,0.25) + 441 | expand_limits(x=max(data$Date)+40) 442 | 443 | g + scale_y_continuous(trans="log", breaks=2^seq(-5,10)) + 444 | labs(y="Daily cases per 100k population (log scale)") + 445 | facet_wrap("HA") + 446 | coord_cartesian(ylim=c(0.1,NA)) 447 | 448 | ``` 449 | 450 | ```{r wastewater-covid} 451 | plants <- c("Annacis Island","Iona Island","Lions Gate","Lulu Island","Northwest Langley") 452 | 453 | phac_wastewater <- read_csv("https://health-infobase.canada.ca/src/data/covidLive/wastewater/covid19-wastewater.csv") |> 454 | filter(region=="Vancouver") |> 455 | mutate(Plant=gsub("Vancouver ","",Location),measure="PHAC") |> 456 | select(Date,Plant,measure,value=viral_load) 457 | 458 | wastewater_data <- plants %>% 459 | lapply(get_data_for_plant) %>% 460 | bind_rows() %>% 461 | complete(Date=as.Date(c("2021-12-25","2020-12-25")),Plant,Version) %>% 462 | rename(Concentration=Value,`Flow adjusted`=DailyLoad) |> 463 | pivot_longer(c("Concentration","Flow adjusted"),names_to="measure",values_to = "value") |> 464 | select(Date,Plant,measure,value) |> 465 | bind_rows(phac_wastewater) #|> 466 | #filter(!is.na(value)) 467 | 468 | 469 | 470 | bc_cases <- CanCovidData::get_british_columbia_hr_case_data() %>% 471 | select(Date, HA=`Health Authority`,HR=`Health Region`,Cases) %>% 472 | filter(Date>=min(wastewater_data$Date)-7) 473 | 474 | 475 | joint_data_for <- function(HRs, WPs,label=NULL){ 476 | if (length(WPs)==1 & is.null(names(WPs))) WPs=setNames(1,WPs) 477 | if (is.null(label)) label = paste0(paste0(names(WPs),collapse = " & ")," / ", 478 | paste0(HRs,collapse = " & ")) 479 | wd<-wastewater_data %>% 480 | filter(Plant %in% names(WPs)) %>% 481 | mutate(weight=WPs[Plant]) %>% 482 | group_by(Date,measure) %>% 483 | mutate(weight=weight/sum(weight)) %>% 484 | #filter(!(Plant%in% c("Northwest Langley","Annacis Island") & weight==1)) %>% 485 | summarise(value=sum(value*weight), .groups="drop") 486 | cs <- bc_cases %>% 487 | filter(HR %in% HRs) %>% 488 | group_by(Date) %>% 489 | summarize(Cases=sum(Cases),.groups="drop") %>% 490 | mutate(Trend=add_stl_trend_m(Cases+1)$trend-1 %>% pmax(0)) |> 491 | pivot_longer(c("Cases","Trend"),names_to = "measure",values_to = "value") 492 | 493 | bind_rows(wd,cs) %>% 494 | mutate(region=label) 495 | } 496 | 497 | plot_data <- bind_rows( 498 | joint_data_for("Vancouver","Iona Island"), 499 | joint_data_for("Richmond","Lulu Island"), 500 | #joint_data_for(c("Fraser North","Fraser South"),c("Annacis Island"=0.8,"Northwest Langley"=0.2)), 501 | joint_data_for(c("Fraser North","Fraser South"),"Annacis Island",label="Annacis / Fraser North/South"), 502 | joint_data_for("North Shore/Coast Garibaldi","Lions Gate"), 503 | ) 504 | 505 | stations <- c("Iona Island / Vancouver"=51442, 506 | "Lions Gate / North Shore/Coast Garibaldi"=833, 507 | "Lulu Island / Richmond"=837, 508 | "Annacis / Fraser North/South"=43723) 509 | weather_data<-weathercan::weather_dl(stations,interval = "day",start=min(wastewater_data$Date)-3) %>% 510 | mutate(Date=date) %>% 511 | mutate(region=setNames(names(stations),as.integer(stations))[as.character(station_id)]) %>% 512 | select(Date,total_rain,region) %>% 513 | mutate(total_rain=coalesce(total_rain,0)) %>% 514 | group_by(region) %>% 515 | arrange(Date)%>% 516 | mutate(rain=roll::roll_mean(total_rain,3)) %>% 517 | #mutate(rain=zoo::rollmean(total_rain,3,na.pad = TRUE,align = "right")) %>% 518 | #mutate(rain=(total_rain+lag(total_rain,1,order_by = Date)+lag(total_rain,2,order_by = Date))/3)%>% 519 | mutate(s=rain/mean(rain,na.rm=TRUE), 520 | value=rain) 521 | 522 | beginning_date <- as.Date("2020-10-01") 523 | change_methods_date <- as.Date("2021-01-01") 524 | change_methods_end_date <- as.Date("2021-12-15") 525 | 526 | 527 | 528 | wastewater_colours<- setNames(c(MetBrewer::met.brewer("Egypt",4),"darkgrey"), 529 | c("Cases","Concentration","Flow adjusted","PHAC","Rainfall")) 530 | 531 | pd <- plot_data %>% 532 | filter(measure!="Cases") |> 533 | mutate(measure=recode(measure,"Trend"="Cases")) |> 534 | bind_rows(weather_data %>% mutate(measure="Rainfall")) %>% 535 | mutate(measure=factor(measure,levels=c("Cases","Concentration","Flow adjusted","PHAC","Rainfall") %>% rev)) %>% 536 | group_by(measure,region) %>% 537 | filter(Date>=beginning_date) %>% 538 | left_join((.) %>% filter(Date>=change_methods_date,Date<=change_methods_end_date) %>% 539 | group_by(measure,region) %>% 540 | summarise(mean_value=mean(value,na.rm=TRUE)),by=c("measure","region")) %>% 541 | mutate(s=value/mean_value) 542 | 543 | pd %>% 544 | #filter(name!="Rainfall") %>% 545 | #filter(!is.na(s)) %>% 546 | ggplot(aes(x=Date,y=s,colour=measure)) + 547 | geom_vline(xintercept = change_methods_date,linetype="dotted") + 548 | geom_rect(data=as_tibble(1),xmin=-Inf,xmax=change_methods_date,ymin=-Inf,ymax=Inf, 549 | fill="grey",colour=NA,inherit.aes = FALSE,alpha=0.5) + 550 | geom_rect(data=as_tibble(1),xmin=change_methods_end_date,xmax=Inf,ymin=-Inf,ymax=Inf, 551 | fill="grey",colour=NA,inherit.aes = FALSE,alpha=0.5) + 552 | geom_line() + 553 | #geom_point(shape=21,data=~filter(.,name=="Wastewater")) + 554 | facet_wrap(~region) + 555 | theme_bw() + 556 | scale_colour_manual(values=wastewater_colours[(unique(as.character(pd$measure)))]) + 557 | scale_y_continuous() + 558 | theme(legend.position = "bottom", 559 | axis.text.y = element_blank(), 560 | axis.ticks.y = element_blank()) + 561 | labs(title="Wastewater COVID concentration vs case counts", 562 | x=NULL,y=NULL,colour=NULL) 563 | ``` 564 | 565 | ```{r wastewater-covid-zoomed} 566 | pd %>% filter(Date>=as.Date("2021-12-01")) %>% 567 | #filter(!is.na(s)) %>% 568 | ggplot(aes(x=Date,y=s,colour=measure)) + 569 | geom_vline(xintercept = change_methods_date,linetype="dotted") + 570 | geom_line() + 571 | geom_point(shape=21,data=~filter(.,measure %in% c("Concentration","Flow adjusted","PHAC"))) + 572 | facet_wrap(~region) + 573 | theme_bw() + 574 | scale_colour_manual(values=wastewater_colours[(unique(as.character(pd$measure)))]) + 575 | scale_y_continuous() + 576 | theme(legend.position = "bottom", 577 | axis.text.y = element_blank(), 578 | axis.ticks.y = element_blank()) + 579 | labs(title="Recent wastewater COVID concentration vs case counts", 580 | x=NULL,y=NULL,colour=NULL) 581 | ``` 582 | 583 | ```{r wastewater-covid-zoomed-log} 584 | ppd <- pd %>% filter(Date>=as.Date("2021-12-01")) %>% 585 | filter(measure!="Rainfall") |> 586 | mutate(s=pmax(s,0.01)) |> 587 | filter(!is.na(s)) 588 | 589 | ppd |> 590 | ggplot(aes(x=Date,y=s,colour=measure)) + 591 | geom_vline(xintercept = change_methods_date,linetype="dotted") + 592 | geom_line() + 593 | geom_point(shape=21,data=~filter(.,measure %in% c("Concentration","Flow adjusted","PHAC"))) + 594 | facet_wrap(~region) + 595 | theme_bw() + 596 | scale_colour_manual(values=wastewater_colours[(unique(as.character(ppd$measure)))]) + 597 | scale_y_continuous(trans="log",breaks=10^seq(-1,3),labels=function(d)round(log10(d*100))) + 598 | theme(legend.position = "bottom", 599 | #axis.text.y = element_blank(), 600 | #axis.ticks.y = element_blank(), 601 | #panel.grid.major.y = element_blank(), 602 | panel.grid.minor.y = element_blank()) + 603 | labs(title="Recent wastewater COVID concentration vs case counts", 604 | x=NULL,y="(log scale, orders of magnitude)",colour=NULL) 605 | ``` 606 | 607 | ```{r wastewater-covid-2, eval=FALSE, include=FALSE} 608 | plot_data %>% 609 | group_by(region)%>% 610 | arrange(Date) %>% 611 | mutate(Cases=Trend) %>% 612 | #mutate(Cases=zoo::rollmean(Cases,7,na.pad = TRUE,align = "center")) %>% 613 | pivot_longer(c("Cases","Concentration","Flow adjusted")) %>% 614 | group_by(name,region) %>% 615 | bind_rows(weather_data %>% mutate(name="Rainfall")) %>% 616 | mutate(name=factor(name,levels=c("Cases","Concentration","Flow adjusted","Rainfall"))) %>% 617 | filter(Date>=change_methods_date) %>% 618 | mutate(s=value/mean(value,na.rm=TRUE)) %>% 619 | ggplot(aes(x=Date,y=s,colour=name)) + 620 | geom_line() + 621 | facet_wrap(~region) + 622 | theme_bw() + 623 | scale_colour_manual(values=wastewater_colours) + 624 | scale_y_continuous() + 625 | theme(legend.position = "bottom", 626 | axis.text.y = element_blank(), 627 | axis.ticks.y = element_blank()) + 628 | labs(title="Wastewater COVID concentration vs case counts", 629 | x=NULL,y=NULL,colour=NULL) + 630 | coord_cartesian(ylim = c(0,7)) 631 | ``` 632 | 633 | 634 | ## Cases in young children 635 | ```{r under-10} 636 | data <- get_british_columbia_case_data() %>% 637 | count(Date=`Reported Date`,HA=`Health Authority`,Age=`Age group`,name="Cases") %>% 638 | complete(Date,HA,Age,fill=list(Cases=0)) 639 | 640 | ha_pop_age <- read_csv(here::here("data/ha_pop_age.csv")) %>% 641 | pivot_longer(matches("\\d+"),names_to="Age",values_to="Count") %>% 642 | mutate(Age=ifelse(Age=="LT1",0,Age)) %>% 643 | mutate(top=strsplit(Age,"-") %>% lapply(last) %>% unlist %>% as.integer()) %>% 644 | mutate(t=floor(top/10)*10+9) %>% 645 | mutate(`Age group`=paste0(t-9,"-",t)) %>% 646 | mutate(`Age group`=recode(`Age group`,"0-9"="<10","NA-NA"="90+")) %>% 647 | group_by(HA=`Health Authority`,Age=`Age group`) %>% 648 | summarize(Total=first(Total),Count=sum(Count),.groups="drop") %>% 649 | mutate(Share=Count/Total) 650 | 651 | dd<-data %>% 652 | filter(HA!="Out of Canada",Age!="Unknown") %>% 653 | filter(Date>=as.Date("2020-07-01")) %>% 654 | left_join(ha_pop_age,by=c("HA","Age")) %>% 655 | mutate(AG=case_when(Age=="<10" ~ "Under 10", TRUE ~ "10 and over")) %>% 656 | mutate(AG=factor(AG,levels=c("Under 10","10 and over"))) %>% 657 | group_by(Date,HA,AG) %>% 658 | summarise(Population=sum(Count),Cases=sum(Cases),Total=first(Total),.groups="drop") %>% 659 | bind_rows((.) %>% 660 | group_by(Date,AG) %>% 661 | summarize(Population=sum(Population), 662 | Total=sum(Total), 663 | Cases=sum(Cases)) %>% 664 | mutate(HA="British Columbia")) %>% 665 | group_by(HA,AG) %>% 666 | arrange(Date) %>% 667 | mutate(Trend=pmax(0,add_stl_trend_m(Cases+5)$trend-5)) %>% 668 | mutate(across(c(Trend,Cases),function(d)d/.data$Population*100000)) 669 | 670 | # stl_fan <- dd %>% 671 | # group_by(HA,AG) %>% 672 | # get_stl_fan() 673 | 674 | 675 | dd %>% 676 | filter(Date>=as.Date("2020-08-01")) %>% 677 | #left_join(stl_fan %>% group_by(HA,AG) %>% summarize(max_date=min(Date),.groups="drop"), by=c("HA","AG")) %>% 678 | #filter(Date<=max_date) %>% 679 | ggplot(aes(x=Date,y=Trend,colour=AG)) + 680 | geom_point(shape=21,aes(y=Cases),alpha=0.5,size=0.5) + 681 | # geom_ribbon(data=stl_tail,aes(x=Date,ymin=min,ymax=max,fill=AG,color=AG,group=AG), 682 | # inherit.aes=FALSE,show.legend = FALSE,alpha=0.5) + 683 | geom_line() + 684 | #geom_line(data=stl_fan,aes(x=Date,y=value,colour=AG,group=interaction(run,AG)),size=0.25) + 685 | theme_bw() + 686 | scale_x_date(breaks="month",date_labels = "%b") + 687 | scale_y_continuous() + 688 | scale_color_manual(values=sanzo::duos$c070) + 689 | scale_fill_manual(values=sanzo::duos$c070,guide='none') + 690 | theme(legend.position = "bottom", 691 | axis.text.x = element_text(angle=40,hjust=1)) + 692 | #scale_y_continuous(labels=scales::comma) + 693 | labs(title=paste0("BC COVID-19 cases", 694 | " (up to ",strftime(max(data$Date),format="%b %d, %Y"),")"), 695 | x=NULL,y="Daily COVID-19 incidence per 100k population", 696 | colour=NULL, 697 | caption="MountainMath, Data: BCCDC") + 698 | facet_wrap(~HA,scales="free_y") 699 | ``` 700 | -------------------------------------------------------------------------------- /reports.md: -------------------------------------------------------------------------------- 1 | Images for reports 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 06 July, 2023 - 18:08 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | ## Cases in young children 23 | 24 | 25 | -------------------------------------------------------------------------------- /reports_files/figure-gfm/bc-hospitalizations-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/bc-hospitalizations-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/bc-overview-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/bc-overview-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/hospital-admissions-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/hospital-admissions-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/hr-trend-recent-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/hr-trend-recent-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/icu-share-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/icu-share-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/under-10-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/under-10-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/wastewater-covid-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/wastewater-covid-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/wastewater-covid-2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/wastewater-covid-2-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/wastewater-covid-zoomed-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/wastewater-covid-zoomed-1.png -------------------------------------------------------------------------------- /reports_files/figure-gfm/wastewater-covid-zoomed-log-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/reports_files/figure-gfm/wastewater-covid-zoomed-log-1.png -------------------------------------------------------------------------------- /statcan_wastewater.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "statcan_wastewater" 3 | author: "Jens von Bergmann" 4 | date: "28/02/2022" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE 13 | ) 14 | library(tidyverse) 15 | source(here::here("R/helpers.R")) 16 | ``` 17 | 18 | ```{r} 19 | tmp <- tempfile() 20 | download.file("https://www150.statcan.gc.ca/n1/pub/38-26-0002/2022001/Wastewater_COVID19_2022_02_18.zip",tmp) 21 | 22 | file.exists(tmp) 23 | ls <- unzip(tmp,exdir = tempdir()) 24 | 25 | overview <- read_csv(ls[13]) 26 | sites <- read_csv(ls[grepl("Site\\.",ls)]) %>% 27 | filter(grepl("Vancouver",name)) %>% 28 | mutate(Plant=gsub(" +Vancouver$","",name)) %>% 29 | select(siteID,Plant) 30 | lookup <- read_csv(ls[grepl("Lookup\\.",ls)]) 31 | 32 | sample <- read_csv(ls[grepl("Sample\\.",ls)]) 33 | 34 | ww_data <- read_csv(ls[grepl("WWMeasure",ls)]) %>% 35 | mutate(siteID=substr(sampleID,1,3)) %>% 36 | inner_join(sites,by="siteID") %>% 37 | left_join(sample %>% select(sampleID,dateTimeStart,dateTimeEnd) %>% 38 | mutate(Date=as.Date(dateTimeEnd)),by="sampleID") 39 | 40 | # vli_data <- CanCovidData::get_british_columbia_hr_case_data() %>% 41 | # filter(`Health Region`=="Vancouver") %>% 42 | # filter(Date>=as.Date("2020-03-01")) %>% 43 | # arrange(Date) %>% 44 | # mutate(stl=add_stl_trend_m(Cases+5)) %>% 45 | # mutate(Trend=pmax(0,stl$trend-5)) 46 | 47 | bc_cases <- CanCovidData::get_british_columbia_hr_case_data() %>% 48 | select(Date, HA=`Health Authority`,HR=`Health Region`,Cases) %>% 49 | mutate(Plant=case_when(HR=="Vancouver" ~ "Iona Island", 50 | HR=="Richmond" ~ "Lulu Island", 51 | HR=="North Shore/Coast Garibaldi" ~ "Lions Gate", 52 | HR %in% c("Fraser North","Fraser South") ~ "Annacis Island", 53 | TRUE ~ "Other")) %>% 54 | filter(Plant!="Other") %>% 55 | group_by(Date,Plant) %>% 56 | summarise(Cases=sum(Cases),.groups="drop") %>% 57 | filter(Date>=as.Date("2020-07-01")) %>% 58 | group_by(Plant) %>% 59 | arrange(Date) %>% 60 | mutate(stl=add_stl_trend_m(Cases+5)) %>% 61 | mutate(Trend=pmax(0,stl$trend-5)) 62 | 63 | stations <- c("Iona Island"=51442, 64 | "Lions Gate"=833, 65 | "Lulu Island"=837, 66 | "Annacis Island"=43723) 67 | weather_data<-weathercan::weather_dl(stations,interval = "day",start=min(ww_data$Date)-5) %>% 68 | mutate(Date=date) %>% 69 | mutate(Plant=setNames(names(stations),as.integer(stations))[as.character(station_id)]) %>% 70 | select(Date,total_rain,Plant,mean_temp) %>% 71 | left_join(filter(.,Plant=="Iona Island") %>% select(Date,mean_temp_fallback=mean_temp),by="Date") %>% 72 | mutate(mean_temp=coalesce(mean_temp,mean_temp_fallback)) %>% 73 | select(-mean_temp_fallback) %>% 74 | mutate(total_rain=coalesce(total_rain,0)) %>% 75 | group_by(Plant) %>% 76 | arrange(Date)%>% 77 | mutate(rain=roll::roll_mean(total_rain,3)) %>% 78 | #mutate(rain=zoo::rollmean(total_rain,3,na.pad = TRUE,align = "right")) %>% 79 | #mutate(rain=(total_rain+lag(total_rain,1,order_by = Date)+lag(total_rain,2,order_by = Date))/3)%>% 80 | mutate(s=rain/mean(rain,na.rm=TRUE), 81 | value=rain) 82 | 83 | plants <- c("Annacis Island","Iona Island","Lions Gate","Lulu Island","Northwest Langley") 84 | used_plants <- c("Annacis Island","Iona Island","Lions Gate","Lulu Island") 85 | 86 | wastewater_data <- plants %>% 87 | lapply(get_data_for_plant) %>% 88 | bind_rows() %>% 89 | complete(Date=as.Date(c("2021-12-25","2020-12-25")),Plant,Version) 90 | 91 | 92 | wd<-ww_data %>% 93 | mutate(t=case_when(grepl("cov",type) ~ "cov", 94 | TRUE ~ type)) %>% 95 | group_by(reportDate,t) %>% 96 | summarise(value=mean(value)) 97 | ``` 98 | 99 | 100 | ```{r} 101 | all_data <- ww_data %>% 102 | group_by(Plant,Date,type) %>% 103 | summarise(value=mean(value),.groups="drop") %>% 104 | pivot_wider(names_from = type,values_from = value) %>% 105 | left_join(bc_cases %>% select(Date,Plant,Trend), by=c("Date","Plant")) %>% 106 | left_join(weather_data %>% select(Date,Plant,rain=total_rain,mrain=rain,mean_temp),by=c("Date","Plant")) %>% 107 | mutate(d=difftime(Date,min(Date),units="days") %>% as.integer) %>% 108 | mutate(wastewater=covN1+covN2) %>% 109 | mutate(cov=(covN1+covN2)/2) %>% 110 | mutate_at(c("Trend","covN1","covN2","nPPMoV","cov"),log) %>% 111 | mutate_at(c("rain","mrain"),function(d)log(d+1)) %>% 112 | group_by(Plant) %>% 113 | mutate(lagc=lag(cov,order_by = Date), 114 | leadc=lead(cov,order_by = Date), 115 | leadc2=lead(cov,n=2,order_by = Date), 116 | leadc3=lead(cov,n=3,order_by = Date), 117 | CnPPMoV=(cov)/nPPMoV, 118 | lagCnPPMoV=lag(CnPPMoV,order_by = Date), 119 | leadCnPPMoV=lead(CnPPMoV,order_by = Date), 120 | leadCnPPMoV2=lead(CnPPMoV,n=2,order_by = Date), 121 | leadCnPPMoV3=lead(CnPPMoV,n=3,order_by = Date), 122 | leadCnPPMoV4=lead(CnPPMoV,n=4,order_by = Date), 123 | lagRain=lag(rain,n=3,order_by = Date) 124 | ) %>% 125 | ungroup() 126 | 127 | 128 | predictions_for <- function(plant){ 129 | l_data <- all_data %>% filter(Plant==plant) 130 | model_data <- l_data %>% 131 | filter(Date<=as.Date("2021-12-20")) 132 | 133 | formula <- Trend~covN1+covN2+nPPMoV+lagc+leadc+leadc2+leadc3+mean_temp+mrain 134 | 135 | m.rf <- randomForest::randomForest(formula,#+ 136 | #CnPPMoV+lagCnPPMoV+leadCnPPMoV+leadCnPPMoV2+leadCnPPMoV3+leadCnPPMoV4, 137 | data=model_data, 138 | mtry = 3, 139 | importance = TRUE, 140 | na.action = na.omit) 141 | 142 | #randomForest::varImpPlot(m.rf) 143 | #m.glm_plain <- glm(formula, data=model_data) 144 | m.glm <- glm(formula,#+ 145 | #CnPPMoV+lagCnPPMoV+leadCnPPMoV+leadCnPPMoV2+leadCnPPMoV3+leadCnPPMoV4 146 | data=model_data) 147 | 148 | 149 | # m.glm.rf <- randomForest::randomForest(res.glm~nPPMoV+lagc+leadc+leadc2+leadc3+mean_temp+mrain, 150 | # #CnPPMoV+lagCnPPMoV+leadCnPPMoV+leadCnPPMoV2+leadCnPPMoV3+leadCnPPMoV4, 151 | # data=model_data %>% mutate(res.glm=c(m.glm_plain$residuals)), 152 | # mtry = 3, 153 | # importance = TRUE, 154 | # na.action = na.omit) 155 | 156 | m.arima<-forecast::Arima(ts(model_data$Trend),xreg = model_data %>% 157 | select(covN1, covN2, nPPMoV,mrain,mean_temp) %>% as.matrix, 158 | lambda="auto") 159 | 160 | 161 | 162 | m.svm <- e1071::svm(formula, 163 | kernel="linear", 164 | data=model_data) 165 | 166 | wastewater_fac <- mean(exp(model_data$Trend))/mean(model_data$wastewater) 167 | 168 | pd <- l_data %>% 169 | mutate(n=row_number() %>% as.character) %>% 170 | mutate(rf=predict(m.rf,newdata = .) %>% exp) %>% 171 | mutate(glm=predict(m.glm,newdata = .) %>% exp) %>% 172 | #mutate(glm.rf=predict(m.glm_plain,newdata = .)+predict(m.glm.rf,newdata = .) %>% exp) %>% 173 | left_join(predict(m.svm,newdata=l_data) %>% 174 | as.data.frame() %>% 175 | setNames("svm") %>% 176 | mutate(n=rownames(.), 177 | svm=exp(svm)) %>% 178 | as_tibble(),by="n") %>% 179 | #mutate(svm=c(NA,NA,NA,NA,predict(m.svm,newdata = .),NA,NA,NA) %>% exp) %>% 180 | mutate(arima=predict(m.arima,newxreg = l_data %>% 181 | select(covN1, covN2, nPPMoV,mrain,mean_temp) %>% 182 | as.matrix)$pred %>% 183 | forecast::InvBoxCox(lambda=m.arima$lambda) %>% exp) %>% 184 | #mutate(wastewater_scaled=wastewater*wastewater_fac) 185 | mutate(wastewater_scaled=zoo::rollmean(wastewater,k=5,na.pad=TRUE)*wastewater_fac) 186 | 187 | pd %>% 188 | mutate(Cases=exp(Trend)) %>% 189 | #filter(name!="arima") %>% 190 | mutate(Plant=plant) 191 | } 192 | 193 | model_colours <- c(Cases="black",svm="brown",wastewater_scaled="steelblue",glm="purple") 194 | 195 | used_plants %>% 196 | lapply(predictions_for) %>% 197 | bind_rows() %>% 198 | #pivot_longer(c("Cases","rf","glm","arima","svm","wastewater_scaled")) %>% 199 | pivot_longer(c("Cases","svm","wastewater_scaled","glm")) %>% 200 | ggplot(aes(x=Date,y=value,colour=name)) + 201 | geom_line() + 202 | scale_colour_manual(values=model_colours) + 203 | facet_wrap(~Plant,scales="free_y") + 204 | #coord_cartesian(y=c(0,400)) + 205 | scale_y_continuous(trans="log",breaks=5*2^seq(0,10)) + 206 | theme(legend.position = "bottom") + 207 | geom_vline(xintercept = as.Date("2021-12-15")) + 208 | #geom_line(aes(y=Trend),data=bc_cases %>% filter(Date>=as.Date("2021-12-15")),colour="steelblue") + 209 | scale_x_date(breaks = "month",date_labels = "%b") 210 | 211 | ``` 212 | -------------------------------------------------------------------------------- /statcan_wastewater.md: -------------------------------------------------------------------------------- 1 | statcan_wastewater 2 | ================ 3 | Jens von Bergmann 4 | 28/02/2022 5 | 6 | ## [1] TRUE 7 | 8 | ![](statcan_wastewater_files/figure-gfm/unnamed-chunk-2-1.png) 9 | -------------------------------------------------------------------------------- /statcan_wastewater_files/figure-gfm/unnamed-chunk-2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/statcan_wastewater_files/figure-gfm/unnamed-chunk-2-1.png -------------------------------------------------------------------------------- /two_covid_canadas.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Two Covid Canadas" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE, 13 | fig.retina = 2, 14 | dpi = 150, 15 | fig.width = 7, 16 | fig.height = 5 17 | ) 18 | library(ggplot2) 19 | library(dplyr) 20 | library(tidyr) 21 | library(here) 22 | library(cansim) 23 | library(CanCovidData) 24 | 25 | source(here("R/helpers.R")) 26 | ``` 27 | 28 | This notebook has been discontinued 29 | 30 | This notebook shows the confirmed COVID cases for Canadian provinces. The code for this notebook is [available for anyone to adapt and use for their own purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/two_covid_canadas.Rmd). 31 | 32 | ```{r} 33 | pop_data <- simpleCache(get_cansim("17-10-0005") %>% 34 | filter(REF_DATE==2020,`Age group`=="All ages",Sex=="Both sexes") %>% 35 | select(Province=GEO,Population=VALUE),"prov_pop_data",path = here::here("data")) 36 | 37 | covid_data <- get_canada_official_provincial_data() %>% 38 | mutate(shortProvince=recode(shortProvince,"Nouveau-Brunswick"="NB")) %>% 39 | mutate(Province=recode(prname,"Nouveau-Brunswick"="New Brunswick")) %>% 40 | filter(!(Province %in% c("Canada","Repatriated"))) %>% 41 | mutate(update=coalesce(update,FALSE)) 42 | 43 | 44 | successful_provinces <- c("NL","NT","NS","YT","PE","NB") 45 | 46 | province_colours <- c(setNames(RColorBrewer::brewer.pal(6,"Dark2"),c("SK","AB","BC","MB","ON","QC")), 47 | setNames(RColorBrewer::brewer.pal(4,"Dark2"),c("NL","NS","PE","NB"))) 48 | successful_label <- "Atlantic provinces" 49 | 50 | successful_provinces <- c("NT","NS","YT","PE","NB") 51 | 52 | province_colours <- c(setNames(RColorBrewer::brewer.pal(7,"Dark2"),c("SK","AB","BC","MB","ON","QC","NS")), 53 | setNames(RColorBrewer::brewer.pal(3,"Dark2"),c("NL","PE","NB"))) 54 | successful_label <- "Atlantic provinces sans NL" 55 | ``` 56 | 57 | ```{r eval=FALSE, include=FALSE} 58 | 59 | plot_data <- covid_data %>% 60 | select(Date,Province,shortProvince,Cases,update) %>% 61 | complete(Date,Province) %>% 62 | mutate(Cases=replace_na(Cases,0)) %>% 63 | left_join(pop_data,by="Province") %>% 64 | group_by(Province) %>% 65 | arrange(desc(Date)) %>% 66 | filter(cumsum(Cases)>0) %>% # remove trailing zeros 67 | arrange(Date) %>% 68 | mutate(Cases=clean_missing_weekend_data(Cases)) %>% 69 | mutate(incidence=roll::roll_sum(Cases,7)/Population*100000) %>% 70 | mutate(type=ifelse(shortProvince %in% successful_provinces,"Atlantic bubble & Territories","Rest of Canada")) 71 | 72 | plot_data %>% 73 | filter(Date>=as.Date("2020-03-01"),shortProvince!="CAN") %>% 74 | #filter(Date>=as.Date("2020-11-01")) %>% 75 | ggplot(aes(x=Date,y=incidence,group=shortProvince)) + 76 | geom_line(data=~filter(.,shortProvince %in% successful_provinces), 77 | color="grey") + 78 | geom_point(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 79 | color="grey") + 80 | ggrepel::geom_text_repel(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 81 | aes(label=shortProvince),nudge_x = 50,min.segment.length = 0,color="grey",direction="y") + 82 | geom_line(data=~filter(.,!(shortProvince %in% successful_provinces)), 83 | aes(color=shortProvince)) + 84 | geom_point(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 85 | aes(color=shortProvince)) + 86 | ggrepel::geom_text_repel(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 87 | aes(color=shortProvince,label=shortProvince),nudge_x = 50,min.segment.length = 0,direction="y") + 88 | scale_color_brewer(palette = "Dark2",guide=FALSE) + 89 | facet_wrap("type",ncol=1,scales ="free_y") + 90 | expand_limits(x=max(plot_data$Date)+7) + 91 | theme_bw() + 92 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 93 | labs(title=paste0("7 day incidence for Canadian provinces (as of ",plot_data$Date %>% last,")"), 94 | x=NULL,y="Cumulative 7 day cases per 100k population", 95 | color=NULL, 96 | caption="MountainMath, Data: PHAC") 97 | ``` 98 | 99 | The Atlantic provinces have pursued very different COVID-19 strategies from the other provinces and have seen very different outcomes. The 7-day incidence, that is the cumulative number of cases over the past 7 days per 100,000 population, has been used by many jurisdictions as a key metric to trigger policy interventions. 100 | 101 | ```{r two-covid-canadas-overview} 102 | 103 | plot_data <- covid_data %>% 104 | select(Date,Province,shortProvince,Cases,TotalDeaths=Deaths,Deaths=numdeathstoday,update) %>% 105 | complete(Date,Province) %>% 106 | mutate(Cases=replace_na(Cases,0), 107 | Deaths=replace_na(Deaths,0)) %>% 108 | left_join(pop_data,by="Province") %>% 109 | group_by(Province) %>% 110 | arrange(desc(Date)) %>% 111 | filter(cumsum(update)>0) %>% # remove trailing zeros 112 | arrange(Date) %>% 113 | mutate(Cases=clean_missing_weekend_data(Cases)) %>% 114 | mutate(incidence=roll::roll_sum(Cases,7)/Population*100000) %>% 115 | mutate(type=ifelse(shortProvince %in% successful_provinces,successful_label,"Other provinces")) 116 | 117 | g <- plot_data %>% 118 | filter(Date>=as.Date("2020-03-01"),shortProvince!="CAN") %>% 119 | filter(!(shortProvince %in% c("NT","YT","NU"))) %>% 120 | #filter(Date>=as.Date("2020-11-01")) %>% 121 | ggplot(aes(x=Date,y=incidence,group=shortProvince,color=type)) + 122 | geom_line() + 123 | #geom_point(shape=21) + 124 | scale_color_manual(values=sanzo::duos$c079 %>% rev) + 125 | #facet_wrap("type",ncol=1,scales ="free_y") + 126 | expand_limits(x=max(plot_data$Date)+7) + 127 | theme_bw() + 128 | theme(legend.position="bottom") + 129 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 130 | labs(title="Two COVID Canadas", 131 | x=NULL,y="Cumulative 7 day cases per 100k population", 132 | color=NULL, 133 | caption="MountainMath, Data: PHAC") 134 | 135 | g 136 | #r<-graph_to_s3(g,"bccovid","two-covid-canadas.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 137 | ``` 138 | 139 | For better comparison we can plot the Atlantic provinces and the other provinces on different scales. 140 | 141 | 142 | ```{r two-covid-canadas} 143 | plot_data <- covid_data %>% 144 | filter(Province!="Repatriated") %>% 145 | select(Date,Province,shortProvince,Cases,TotalDeaths=Deaths,Deaths=numdeathstoday,update) %>% 146 | # complete(Date,Province) %>% 147 | # mutate(Cases=replace_na(Cases,0), 148 | # Deaths=replace_na(Deaths,0)) %>% 149 | left_join(pop_data,by="Province") %>% 150 | group_by(Province) %>% 151 | arrange(desc(Date)) %>% 152 | filter(cumsum(update)>0) %>% # remove trailing zeros 153 | arrange(Date) %>% 154 | mutate(Cases=clean_missing_weekend_data(Cases)) %>% 155 | mutate(incidence=roll::roll_sum(Cases,7)/Population*100000) %>% 156 | #mutate(incidence=zoo::rollsum(Cases,7,align="center",fill=as.numeric(NA))/Population*100000) %>% 157 | mutate(type=ifelse(shortProvince %in% successful_provinces,successful_label,"Other provinces")) 158 | 159 | g <- plot_data %>% 160 | filter(Date>=as.Date("2020-03-01"),shortProvince!="CAN") %>% 161 | filter(!(shortProvince %in% c("NT","YT","NU"))) %>% 162 | #filter(Date>=as.Date("2020-11-01")) %>% 163 | ggplot(aes(x=Date,y=incidence,group=shortProvince)) + 164 | geom_line(data=~filter(.,shortProvince %in% successful_provinces), 165 | aes(color=shortProvince)) + 166 | geom_point(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 167 | aes(color=shortProvince)) + 168 | ggrepel::geom_text_repel(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 169 | aes(label=shortProvince,color=shortProvince),nudge_x = 15,direction="y", 170 | segment.colour="darkgrey") + 171 | geom_line(data=~filter(.,!(shortProvince %in% successful_provinces)), 172 | aes(color=shortProvince)) + 173 | geom_point(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 174 | aes(color=shortProvince)) + 175 | ggrepel::geom_text_repel(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 176 | aes(color=shortProvince,label=shortProvince),nudge_x = 15,direction="y", 177 | segment.colour="darkgrey") + 178 | #scale_color_brewer(palette = "Dark2",guide=FALSE) + 179 | scale_color_manual(values=province_colours,guide=FALSE) + 180 | facet_wrap("type",ncol=1,scales ="free_y") + 181 | expand_limits(x=max(plot_data$Date)+7) + 182 | theme_bw() + 183 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 184 | labs(title="Two COVID Canadas", 185 | x=NULL,y="Cumulative 7 day cases per 100k population", 186 | color=NULL, 187 | caption="MountainMath, Data: PHAC") 188 | 189 | g 190 | #r<-graph_to_s3(g,"bccovid","two-covid-canadas-overview.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 191 | ``` 192 | 193 | ## Trend lines 194 | Sometimes it is useful to get a clearer view on trend lines. Rolling 7-day sums (like above) or rolling averages (as often emplyed) are a problematic way to represent trend lines as the lag actual trends by 3 days. 195 | 196 | A fairly simple trend line model like a (multiplicative) STL decomposition can extract cleaner trend lines that also cover the most recent 3 days of data, at the expense of a bit of added volatility at the very end of the trend line where the trend line may shift slightly when new data comes in. 197 | 198 | 199 | ```{r two-covid-canadas-trend} 200 | successful_provinces <- c("NL","NT","NS","YT","PE","NB") 201 | 202 | province_colours <- c(setNames(RColorBrewer::brewer.pal(6,"Dark2"),c("SK","AB","BC","MB","ON","QC")), 203 | setNames(RColorBrewer::brewer.pal(4,"Dark2"),c("NL","NS","PE","NB"))) 204 | successful_label <- "Atlantic provinces" 205 | 206 | plot_data <- covid_data %>% 207 | filter(Province!="Repatriated") %>% 208 | select(Date,Province,shortProvince,Cases,TotalDeaths=Deaths,Deaths=numdeathstoday,update) %>% 209 | #complete(Date,Province) %>% 210 | mutate(Cases=replace_na(Cases,0), 211 | Deaths=replace_na(Deaths,0)) %>% 212 | left_join(pop_data,by="Province") %>% 213 | group_by(Province) %>% 214 | arrange(desc(Date)) %>% 215 | filter(cumsum(update)>0) %>% # remove trailing zeros 216 | arrange(Date) %>% 217 | mutate(Cases=clean_missing_weekend_data(Cases)) %>% 218 | mutate(Cases=pmax(0,Cases)) %>% 219 | mutate(trend=(extract_stl_trend_m(Cases+1)-1)/Population*100000) %>% 220 | mutate(type=ifelse(shortProvince %in% successful_provinces,successful_label,"Other provinces")) 221 | 222 | g <- plot_data %>% 223 | filter(Date>=as.Date("2020-03-01"),shortProvince!="CAN") %>% 224 | filter(!(shortProvince %in% c("NT","YT","NU"))) %>% 225 | #filter(Date>=as.Date("2020-11-01")) %>% 226 | ggplot(aes(x=Date,y=trend,group=shortProvince)) + 227 | geom_line(data=~filter(.,shortProvince %in% successful_provinces), 228 | aes(color=shortProvince)) + 229 | geom_point(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 230 | aes(color=shortProvince)) + 231 | ggrepel::geom_text_repel(data=~filter(.,shortProvince %in% successful_provinces,Date==max(Date)), 232 | aes(label=shortProvince,color=shortProvince),nudge_x = 15,direction="y", 233 | segment.colour="darkgrey") + 234 | geom_line(data=~filter(.,!(shortProvince %in% successful_provinces)), 235 | aes(color=shortProvince)) + 236 | geom_point(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 237 | aes(color=shortProvince)) + 238 | ggrepel::geom_text_repel(data=~filter(.,!(shortProvince %in% successful_provinces),Date==max(Date)), 239 | aes(color=shortProvince,label=shortProvince),nudge_x = 15,direction="y", 240 | segment.colour="darkgrey") + 241 | #scale_color_brewer(palette = "Dark2",guide=FALSE) + 242 | scale_color_manual(values=province_colours,guide=FALSE) + 243 | facet_wrap("type",ncol=1,scales ="free_y") + 244 | expand_limits(x=max(plot_data$Date)+7) + 245 | theme_bw() + 246 | scale_x_date(breaks="months",labels=function(d)strftime(d,"%b")) + 247 | labs(title="Two COVID Canadas (STL trend lines)", 248 | x=NULL,y="Daily cases per 100k population", 249 | color=NULL, 250 | caption="MountainMath, Data: PHAC") 251 | 252 | g 253 | #r<-graph_to_s3(g,"bccovid","two-covid-canadas-overview.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 254 | ``` 255 | -------------------------------------------------------------------------------- /two_covid_canadas.md: -------------------------------------------------------------------------------- 1 | Two Covid Canadas 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 21 July, 2022 - 18:07 5 | 6 | This notebook shows the confirmed COVID cases for Canadian provinces. 7 | The code for this notebook is [available for anyone to adapt and use for 8 | their own 9 | purposes](https://github.com/mountainMath/BCCovidSnippets/blob/main/two_covid_canadas.Rmd). 10 | 11 | The Atlantic provinces have pursued very different COVID-19 strategies 12 | from the other provinces and have seen very different outcomes. The 13 | 7-day incidence, that is the cumulative number of cases over the past 7 14 | days per 100,000 population, has been used by many jurisdictions as a 15 | key metric to trigger policy interventions. 16 | 17 | 18 | 19 | For better comparison we can plot the Atlantic provinces and the other 20 | provinces on different scales. 21 | 22 | 23 | 24 | ## Trend lines 25 | 26 | Sometimes it is useful to get a clearer view on trend lines. Rolling 27 | 7-day sums (like above) or rolling averages (as often emplyed) are a 28 | problematic way to represent trend lines as the lag actual trends by 3 29 | days. 30 | 31 | A fairly simple trend line model like a (multiplicative) STL 32 | decomposition can extract cleaner trend lines that also cover the most 33 | recent 3 days of data, at the expense of a bit of added volatility at 34 | the very end of the trend line where the trend line may shift slightly 35 | when new data comes in. 36 | 37 | 38 | -------------------------------------------------------------------------------- /two_covid_canadas_files/figure-gfm/two-covid-canadas-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/two_covid_canadas_files/figure-gfm/two-covid-canadas-1.png -------------------------------------------------------------------------------- /two_covid_canadas_files/figure-gfm/two-covid-canadas-overview-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/two_covid_canadas_files/figure-gfm/two-covid-canadas-overview-1.png -------------------------------------------------------------------------------- /two_covid_canadas_files/figure-gfm/two-covid-canadas-trend-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/two_covid_canadas_files/figure-gfm/two-covid-canadas-trend-1.png -------------------------------------------------------------------------------- /vaccination_tracker.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Vaccination Tracker" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE, 13 | fig.retina = 2, 14 | dpi = 150, 15 | fig.width = 7, 16 | fig.height = 5 17 | ) 18 | library(dplyr) 19 | library(ggplot2) 20 | library(readr) 21 | library(tidyr) 22 | library(CanCovidData) 23 | library(cansim) 24 | source(here::here("R/helpers.R")) 25 | 26 | ``` 27 | 28 | Vaccination tracker is no longer functional. -------------------------------------------------------------------------------- /vaccination_tracker.md: -------------------------------------------------------------------------------- 1 | Vaccination Tracker 2 | ================ 3 | Jens von Bergmann 4 | Last updated at 06 July, 2023 - 18:08 5 | 6 | Vaccination tracker is no longer functional. 7 | -------------------------------------------------------------------------------- /vaccination_tracker.old.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Vaccination Tracker" 3 | author: "Jens von Bergmann" 4 | date: "Last updated at `r format(Sys.time(), '%d %B, %Y - %H:%M',tz='America/Vancouver')`" 5 | output: rmarkdown::github_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set( 10 | echo = FALSE, 11 | message = FALSE, 12 | warning = FALSE, 13 | fig.retina = 2, 14 | dpi = 150, 15 | fig.width = 7, 16 | fig.height = 5 17 | ) 18 | library(dplyr) 19 | library(ggplot2) 20 | library(readr) 21 | library(tidyr) 22 | library(CanCovidData) 23 | library(cansim) 24 | source(here::here("R/helpers.R")) 25 | 26 | ``` 27 | 28 | Vaccinations have arrived in Canada, and the [Canada COVID-19 Data Working Group](https://opencovid.ca) is collecting data on vaccinations. 29 | 30 | The first round of vaccines Canada got is the mRNA vaccine from BioNTech that requires two doses, spaced 21 days apart, to be fully (~95%) effective, with the Moderna vaccine coming soon with similar requirements with the second dose administered after 28 days. Moreover, people are only considered vaccinated one week after having received the second vaccine. So it takes about a month from getting the first shot until a person is considered vaccinated. 31 | 32 | ## How to use the vaccine 33 | There are two basic ways how local Health Authorities can utilize the vaccine. 34 | 35 | 1. The first approach is to think of vaccines as an extra layer of protection and as saving lives. This approach would aim to keep current COVID-19 spread low irrespective of vaccines and see vaccines as an add-on until we reach acceptable levels of herd immunity. Herd immunity is generally pegged at around 70% of people immune to COVID-19, which translates to a similar share of the population being vaccinated. Herd immunity does not guarantee localized outbreaks though, especially given the overdispersed nature of COVID-19, so it will be important to have some level of distancing in place even past the herd immunity threshold. The goal of this approach is CovidZero, with vaccines protecting vulnerable populations, as well as helping to get to Zero via decreasing the pool of susceptible people. 36 | 2. The second approach would be to not focus on saving lives and morbidity but to keep these levels roughly constant and open up more instead. 37 | 38 | The question of which approach to choose might seem like a question about values, but economists have been pretty clear that the evidence shows that reducing the spread of COVID-19 is the best way to open up the economy and that the second approach is misguided. In the background of all of this is the fact that it is not yet clear how robust the vaccine is in handling mutations, which again points toward the first approach being the only reasonable choice. 39 | 40 | ## Tracking vaccines 41 | 42 | ```{r} 43 | if (FALSE) { 44 | pop_data <- get_cansim("17-10-0005") %>% 45 | filter(REF_DATE==2020,`Age group`=="All ages",Sex=="Both sexes") %>% 46 | add_provincial_abbreviations() %>% 47 | select(Province=GEO,shortProvince=GEO.abb,Population=VALUE) 48 | } else { 49 | pop_data <- read_csv(here::here("data/prov_pop.csv")) 50 | } 51 | 52 | provinces <- c("BC", "AB", "SK", "MB", "ON" , "QC" , "NB" , "PE" , "NS", "NL", "CAN") 53 | 54 | vaccination_data <- get_canada_covid_working_group_timeseries("cvaccine") %>% 55 | select(shortProvince,Date=date_vaccine_completed,cumulative_cvaccine,cvaccine) %>% 56 | left_join(get_canada_covid_working_group_timeseries("avaccine") %>% 57 | select(shortProvince,Date=date_vaccine_administered,cumulative_avaccine,avaccine), 58 | by=c("shortProvince","Date")) %>% 59 | left_join(get_canada_covid_working_group_timeseries("dvaccine") %>% 60 | select(shortProvince,Date=date_vaccine_distributed,cumulative_dvaccine,dvaccine), 61 | by=c("shortProvince","Date")) %>% 62 | left_join(pop_data,by="shortProvince") %>% 63 | mutate(`First dose`=cumulative_avaccine-2*cumulative_cvaccine, 64 | `Both doses`=cumulative_cvaccine) %>% 65 | bind_rows((.) %>% 66 | mutate(shortProvince="CAN",Province="Canada") %>% 67 | group_by(Date,shortProvince,Province) %>% 68 | summarize_all(sum) %>% 69 | ungroup()) %>% 70 | mutate(Province=factor(Province,levels=arrange(pop_data,-Population)$Province)) 71 | 72 | ``` 73 | 74 | 75 | With vaccines coming in two doses we can track how doses are delivered to provinces and administered to people. The first vaccine already gives some protection, which is the reason some provinces have decided to space out the period between the first and the second shot a little to stretch the overall protective value of our currently scarce vaccine supply. 76 | 77 | ```{r vaccination-dose} 78 | g <- vaccination_data %>% 79 | mutate(Administered=cumulative_avaccine/Population*100,Warehoused=cumulative_dvaccine/Population*100-Administered) %>% 80 | tidyr::pivot_longer(c("Administered","Warehoused")) %>% 81 | mutate(name=factor(name,levels=c("Warehoused","Administered"))) %>% 82 | filter(shortProvince %in% provinces) %>% 83 | #filter(total_vaccinations>0) %>% 84 | ggplot(aes(x=Date,y=value,fill=name)) + 85 | geom_area(stat="identity",position="stack") + 86 | facet_wrap("Province") + 87 | scale_y_continuous() + 88 | theme_bw() + 89 | theme(legend.position = "bottom") + 90 | scale_fill_manual(values=sanzo::duos$c033) + 91 | labs(title="COVID-19 vaccine doses",y="Doses per 100 population", 92 | x=NULL, fill=NULL, 93 | caption="MountainMath, Data: Canada Covid Data Working Group") 94 | 95 | g 96 | #r<-graph_to_s3(g,"bccovid","vaccination-status.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 97 | ``` 98 | 99 | From an immunization point of view it's more important what share of the population has recieved both vaccines and is considered immunized (with 95% efficacy a week after receiving the second shot). 100 | 101 | ```{r vaccination-complete} 102 | g <- vaccination_data %>% 103 | filter(cumulative_cvaccine>0) %>% 104 | ggplot(aes(x=Date,y=cumulative_cvaccine/Population)) + 105 | geom_area(stat="identity",fill="purple") + 106 | facet_wrap("Province") + 107 | scale_y_continuous(labels=scales::percent) + 108 | theme_bw() + 109 | labs(title="People vaccinated against COVID-19",y="Share vaccination completed", 110 | x=NULL, 111 | caption="MountainMath, Data: Canada Covid Data Working Group") 112 | 113 | g 114 | #r<-graph_to_s3(g,"bccovid","vaccination-status.png",width=knitr::opts_chunk$get('fig.width'),height=knitr::opts_chunk$get('fig.height')) 115 | ``` 116 | 117 | The first does does grant some partial immunity, we can also look at the share of the population that got both doses vs only the first dose of the vaccine. This view might get more complicated once single-dose vaccines become available in Canada. 118 | 119 | ```{r vaccination-status} 120 | vaccination_data %>% 121 | filter(shortProvince %in% provinces) %>% 122 | mutate(`First dose`=cumulative_avaccine-2*cumulative_cvaccine, 123 | `Both doses`=cumulative_cvaccine) %>% 124 | tidyr::pivot_longer(c("First dose","Both doses")) %>% 125 | mutate(name=factor(name,levels=c("First dose","Both doses"))) %>% 126 | mutate(Share=value/Population) %>% 127 | ggplot(aes(x=Date,y=Share,fill=name)) + 128 | geom_area(stat="identity",position="stack") + 129 | facet_wrap("Province") + 130 | scale_y_continuous(labels=scales::percent) + 131 | theme_bw() + 132 | theme(legend.position = "bottom") + 133 | scale_fill_manual(values=sanzo::duos$c035) + 134 | labs(title="COVID-19 vaccination status",y="People per 100 population", 135 | x=NULL, fill=NULL, 136 | caption="MountainMath, Data: Canada Covid Data Working Group") 137 | ``` 138 | 139 | If your goal is to use vaccinations to reduce deaths and morbidity, the share of the population who received vaccinations gives a rough indicator of the reduction a month from now when the vaccines take full effect. Since vaccinations are initially focused on vulnerable populations, the effect will be significantly higher than the shown percentage. 140 | 141 | If your goal is to use vaccinations to keep deaths and morbidity roughly constant and instead open up faster, the share gives a rough indicator of by how much we can increase contacts a month from now when the vaccines take full effect. Again, because vaccinations are initially focused on vulnerable populations, we can probably increase contacts significantly more without increasing deaths, although this will likely have detrimental effects on morbidity. (If this sounds really cynical and like a terrible idea, that's probably because it is.) 142 | 143 | ## Age-specific vaccination progress 144 | 145 | ```{r} 146 | age_levels <- c("fill1","fill2","0-4","5-11", "12-17", "18-29", "30-39", "40-49", "50-59", "60-69", "70-79", "80+") 147 | 148 | age1 <- c("0 to 4 years","5 to 9 years","10 to 14 years","15 years", "16 years", "17 years") 149 | age1.0 <- c("0 to 4 years") 150 | age1.01 <- c("5 to 9 years","10 years","11 years") 151 | age1.1 <- c("0 to 4 years","5 to 9 years","10 years","11 years") 152 | age1.2 <- c("12 years","13 years","14 years","15 years", "16 years", "17 years") 153 | age2 <- c("18 years", "19 years", "20 to 24 years" , "25 to 29 years", 154 | "30 to 34 years" , "35 to 39 years", "40 to 44 years" , "45 to 49 years") 155 | age2.1 <- c("18 years", "19 years", "20 to 24 years" , "25 to 29 years") 156 | age2.2 <- c("30 to 34 years" , "35 to 39 years") 157 | age2.3 <- c("40 to 44 years" , "45 to 49 years") 158 | age3 <- c("50 to 54 years" , "55 to 59 years") 159 | age4 <- c("60 to 64 years" , "65 to 69 years") 160 | age5 <- c("70 to 74 years") 161 | age6 <- c("75 to 79 years") 162 | age7 <- c("80 to 84 years","85 to 89 years","90 years and over") 163 | 164 | if (FALSE) { 165 | pop <- get_cansim("17-10-0005") %>% 166 | normalize_cansim_values() %>% 167 | filter(Date==max(Date),Sex=="Both sexes") %>% 168 | mutate(age=case_when(`Age group` %in% age1.0 ~ "0-4", 169 | `Age group` %in% age1.01 ~ "5-11", 170 | `Age group` %in% age1.2 ~ "12-17", 171 | `Age group` %in% age2.1 ~ "18-29", 172 | `Age group` %in% age2.2 ~ "30-39", 173 | `Age group` %in% age2.3 ~ "40-49", 174 | `Age group` %in% age3 ~ "50-59", 175 | `Age group` %in% age4 ~ "60-69", 176 | `Age group` %in% c(age5,age6) ~ "70-79", 177 | #`Age group` %in% age6 ~ "75-79", 178 | `Age group` %in% age7 ~ "80+", 179 | `Age group` == "All ages" ~ "Total", 180 | TRUE ~ NA_character_)) %>% 181 | filter(!is.na(age)) %>% 182 | group_by(GeoUID,GEO,age) %>% 183 | summarise(Value=sum(VALUE),.groups="drop") %>% 184 | left_join(filter(.,age=="Total") %>% select(GeoUID,Total=Value),by="GeoUID") %>% 185 | filter(age!="Total") %>% 186 | mutate(GeoUID=ifelse(GEO=="Canada","1",GeoUID)) 187 | } else { 188 | pop <- read_csv(here::here("data/prov_pop_age.csv"),col_types = cols(.default = "c")) %>% 189 | mutate_at(c("Value","Total"),as.numeric) 190 | } 191 | 192 | geo_levels <- pop %>% select(GEO,Total) %>% unique %>% arrange(Total) %>% pull(GEO) 193 | 194 | vaccine_age <- read_csv("https://health-infobase.canada.ca/src/data/covidLive/vaccination-coverage-byAgeAndSex.csv", 195 | col_types = cols(.default="c"),na = c("", "NA","na")) %>% 196 | mutate_at(vars(matches("num")),as.numeric) %>% 197 | mutate(age=recode(age,"05-11"="5-11")) 198 | 199 | dose_levels <- c("Fully vaccinated","Partially vaccinated","Unvaccinated") 200 | 201 | plot_data <- vaccine_age %>% 202 | filter(week_end==max(week_end)) %>% 203 | filter(age %in% age_levels) %>% 204 | group_by(pruid,prename,age) %>% 205 | summarize(`Partially vaccinated`=sum(numtotal_partially,na.rm=TRUE), 206 | `Fully vaccinated`=sum(numtotal_fully,na.rm=TRUE)) %>% 207 | left_join(pop,by=c("pruid"="GeoUID","age"="age")) %>% 208 | pivot_longer(c("Partially vaccinated","Fully vaccinated")) %>% 209 | mutate(share=value/Value) %>% 210 | bind_rows((.) %>% group_by(pruid,GEO,prename,age) %>% 211 | summarize(share=1-sum(share),.groups="drop") %>% 212 | mutate(name="Unvaccinated")) %>% 213 | mutate(age=factor(age,levels=age_levels %>% rev), 214 | name=factor(name,levels=dose_levels %>% rev), 215 | GEO=factor(GEO,levels=geo_levels %>% rev)) %>% 216 | mutate(share=pmax(0,share)) %>% 217 | group_by(pruid,age) %>% 218 | mutate(share=share/sum(share)) %>% 219 | fill(Value,Total) 220 | 221 | pd <- plot_data %>% 222 | mutate(pop_share=Value/Total) %>% 223 | group_by(pruid,name) %>% 224 | arrange(age) %>% 225 | mutate(pop_max=cumsum(pop_share)) %>% 226 | mutate(pop_min=lag(pop_max,order_by = age)) %>% 227 | mutate(pop_min=coalesce(pop_min,0)) %>% 228 | group_by(pruid,age) %>% 229 | arrange(desc(name)) %>% 230 | mutate(max_share=cumsum(share)) %>% 231 | mutate(min_share=lead(max_share,order_by = name)) %>% 232 | mutate(min_share=coalesce(min_share,0)) 233 | 234 | pr <- "British Columbia" 235 | 236 | mean_vaccine_level_d <- pd %>% 237 | filter(prename==pr) %>% 238 | filter(name!="Unvaccinated") %>% 239 | group_by(age) %>% 240 | summarize(fd=sum(value),pop=first(Value),.groups="drop") %>% 241 | ungroup() %>% 242 | summarize(pop=sum(pop),fd=sum(fd)) %>% 243 | mutate(share=fd/pop) 244 | 245 | mean_vaccine_level <- mean_vaccine_level_d$share 246 | 247 | world_vaccine <- read_csv("https://covid.ourworldindata.org/data/owid-covid-data.csv") 248 | 249 | vaccine_comparison_table<-world_vaccine %>% 250 | filter(iso_code %in% c("GBR","ISR","USA"), 251 | !is.na(people_vaccinated_per_hundred), 252 | !is.na(people_fully_vaccinated_per_hundred)) %>% 253 | select(Date=date,Region=location,`Partially vaccinated`=people_vaccinated_per_hundred, 254 | `Fully vaccinated`=people_fully_vaccinated_per_hundred) %>% 255 | group_by(Region) %>% 256 | filter(Date==max(Date)) %>% 257 | mutate(`Partially vaccinated`=`Partially vaccinated`-`Fully vaccinated`) %>% 258 | mutate_at(vars(matches("vaccinated")),function(d)d/100) 259 | 260 | 261 | bc_av <- get_canada_covid_working_group_timeseries(type="avaccine") %>% 262 | filter(Province==pr) 263 | bc_cv <- get_canada_covid_working_group_timeseries(type="cvaccine") %>% 264 | filter(Province==pr) 265 | bc_current <- (max(bc_av$cumulative_avaccine) - max(bc_cv$cumulative_cvaccine))/mean_vaccine_level_d$pop 266 | bc_current_f <- (max(bc_cv$cumulative_cvaccine))/mean_vaccine_level_d$pop 267 | 268 | bc_current_date <- bc_cv$date_vaccine_completed %>% max 269 | 270 | 271 | vaccine_comparison <- tibble(Region=c("British Columbia"), 272 | Date=bc_current_date, 273 | `Fully vaccinated`=c(bc_current_f), 274 | `Partially vaccinated`=c(bc_current-bc_current_f)) %>% 275 | bind_rows(vaccine_comparison_table) %>% 276 | mutate(Unvaccinated=1-`Fully vaccinated`-`Partially vaccinated`) %>% 277 | pivot_longer(matches("vaccinated")) %>% 278 | mutate(Region=factor(Region,levels=c("British Columbia","United Kingdom","United States","Israel"))) %>% 279 | mutate(name=factor(name,levels=c("Fully vaccinated","Partially vaccinated","Unvaccinated") %>% rev)) 280 | 281 | vaccine_colours <- setNames(RColorBrewer::brewer.pal(3,"YlGn") %>% rev,c("Fully vaccinated","Partially vaccinated","Unvaccinated")) 282 | ``` 283 | 284 | 285 | 286 | 287 | 288 | 289 | ```{r fig.height=5, fig.width=6} 290 | g<-vaccine_comparison %>% 291 | mutate(Region=factor(Region,levels=filter(.,name=="Fully vaccinated") %>%arrange(value) %>% pull(Region))) %>% 292 | ggplot(aes(x=Region,y=value,fill=name)) + 293 | geom_bar(stat="identity") + 294 | theme_bw() + 295 | scale_y_continuous(labels = scales::percent) + 296 | coord_flip() + 297 | scale_fill_manual(values=vaccine_colours, guide=FALSE) +#sanzo::duos$c047 %>% rev) + 298 | expand_limits(y=c(0,1)) + 299 | theme(legend.position = "bottom", 300 | plot.background = element_rect(colour = "black",size=1), 301 | axis.text = element_text(size=5)) + 302 | labs(#title="Vaccination progress international comparison", 303 | x=NULL, 304 | y=NULL, 305 | #y="Share of population", 306 | fill=NULL, 307 | caption=NULL#"Data: PHAC, Our World in Data" 308 | ) 309 | 310 | 311 | pd %>% 312 | filter(GEO %in% c("British Columbia")) %>% 313 | mutate_at(c("pop_min","pop_max"),function(d)1-d) %>% 314 | ggplot() + 315 | theme_bw() + 316 | geom_rect(aes(xmin = pop_min, xmax = pop_max, ymax = max_share, ymin=min_share, fill = name)) + 317 | scale_fill_manual(values=vaccine_colours) + 318 | #scale_fill_brewer(palette = "YlGn") + 319 | facet_wrap("GEO") + 320 | scale_y_continuous(labels=scales::percent) + 321 | theme(legend.position = "bottom") + 322 | theme(axis.line.x = element_blank(), 323 | axis.text.x = element_blank(), 324 | axis.ticks.x = element_blank()) + 325 | theme(panel.grid.major.x = element_blank(), panel.grid.minor.x = element_blank()) + 326 | geom_text(data=~filter(.,name=="Unvaccinated"), 327 | aes(x=(pop_min+pop_max)/2,y=0,label=age),nudge_y = -0.05) + 328 | geom_vline(aes(xintercept = pop_min)) + 329 | labs(x=NULL,y=NULL,fill=NULL,pattern="Minimum herd immunity range\n(depending on share of 2nd doses)", 330 | title=paste0("Vaccination status by age group as of ",max(vaccine_age$week_end)), 331 | caption="Data: PHAC, StatCan Table 17-10-0005, Our World in Data") + 332 | patchwork::inset_element(g, 0.65, 0.1, 0.95, 0.4) 333 | ``` 334 | 335 | 336 | -------------------------------------------------------------------------------- /vaccination_tracker_files/figure-gfm/unnamed-chunk-3-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/vaccination_tracker_files/figure-gfm/unnamed-chunk-3-1.png -------------------------------------------------------------------------------- /vaccination_tracker_files/figure-gfm/vaccination-complete-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/vaccination_tracker_files/figure-gfm/vaccination-complete-1.png -------------------------------------------------------------------------------- /vaccination_tracker_files/figure-gfm/vaccination-dose-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/vaccination_tracker_files/figure-gfm/vaccination-dose-1.png -------------------------------------------------------------------------------- /vaccination_tracker_files/figure-gfm/vaccination-status-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mountainMath/BCCovidSnippets/e735b7c27cdcfc39ed69a280034e7e75bed9d946/vaccination_tracker_files/figure-gfm/vaccination-status-1.png --------------------------------------------------------------------------------