├── .DS_Store ├── data ├── cfr.xlsx ├── .DS_Store ├── pop10.rda ├── reg_okato.rda ├── vent.csv └── analysis.R ├── README.md ├── .gitignore ├── LICENSE └── R ├── vent_analysis.R └── analysis.R /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ikashnitsky/covid19-russia/HEAD/.DS_Store -------------------------------------------------------------------------------- /data/cfr.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ikashnitsky/covid19-russia/HEAD/data/cfr.xlsx -------------------------------------------------------------------------------- /data/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ikashnitsky/covid19-russia/HEAD/data/.DS_Store -------------------------------------------------------------------------------- /data/pop10.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ikashnitsky/covid19-russia/HEAD/data/pop10.rda -------------------------------------------------------------------------------- /data/reg_okato.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ikashnitsky/covid19-russia/HEAD/data/reg_okato.rda -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Data and R Code for the covid-19 analysis on Russian regions 2 | 3 | Analysis by [Ilya Kashnitsky][ik] and [Anton Barchuck][ab] 4 | 5 | Published with MEDUZA: [Russian version][ru] 6 | 7 | Edited by [Alexandr Ershov][ae] 8 | 9 | [ik]: https://twitter.com/ikashnitsky 10 | [ab]: https://twitter.com/AntonBarchuk 11 | [ae]: https://twitter.com/anershov 12 | 13 | [ru]: https://meduza.io/feature/2020/03/30/epidemiyu-koronavirusa-zhdut-v-bolshih-gorodah-no-osnovnoy-udar-mozhet-priytis-na-stareyuschie-regiony -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Session Data files 6 | .RData 7 | 8 | # User-specific files 9 | .Ruserdata 10 | 11 | # Example code in package build process 12 | *-Ex.R 13 | 14 | # Output files from R CMD build 15 | /*.tar.gz 16 | 17 | # Output files from R CMD check 18 | /*.Rcheck/ 19 | 20 | # RStudio files 21 | .Rproj.user/ 22 | 23 | # produced vignettes 24 | vignettes/*.html 25 | vignettes/*.pdf 26 | 27 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 28 | .httr-oauth 29 | 30 | # knitr and R markdown default cache directories 31 | *_cache/ 32 | /cache/ 33 | 34 | # Temporary files created by R markdown 35 | *.utf8.md 36 | *.knit.md 37 | 38 | # R Environment Variables 39 | .Renviron 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Ilya Kashnitsky 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /R/vent_analysis.R: -------------------------------------------------------------------------------- 1 | 2 | #vent analysis 3 | 4 | # 5 | # df_calc_40<-ru_calc %>% 6 | # filter(variable=="icu") %>% 7 | # select(id, reg, abs, vent) 8 | 9 | 10 | library(magicfor) 11 | 12 | #20 weeks and 5 days per ICU stay 13 | 14 | magic_for(silent = TRUE) 15 | 16 | for (k in df_calc_40$abs) { 17 | 18 | date<-rgamma(k,2.7,scale=30) #distribution of icu cases 19 | length=rnorm(k,5,2) #distribution of length of stay in icu 20 | 21 | in_icu<- rep(0,150) 22 | #date is the day of start of stay in icu 23 | #end is the day of end of stay 24 | # max is 1 if date of start is before certain day and date of end is after certain day of stay 25 | for (i in 0:150) { 26 | dd<-as.data.frame(cbind(date,length)) %>% 27 | mutate(cases=1,end=date+length) %>% 28 | mutate(max=case_when( 29 | date<=i & end>=i ~ 1, 30 | TRUE ~ 0 31 | )) 32 | in_icu[i]<-sum(dd$max) 33 | 34 | } 35 | plot(in_icu) 36 | max20<-max(in_icu) 37 | put(max20) 38 | 39 | } 40 | 41 | res20<-magic_result_as_dataframe() %>% rename(abs=k) 42 | 43 | #10 weeks and 5 days per ICU stay 44 | 45 | magic_for(silent = TRUE) 46 | 47 | for (k in df_calc_40$abs) { 48 | 49 | date<-rgamma(k,3.8,scale=10) #distribution of icu cases 50 | length=rnorm(k,5,2) #distribution of length of stay in icu 51 | 52 | in_icu<- rep(0,70) 53 | #date is the day of start of stay in icu 54 | #end is the day of end of stay 55 | # max is 1 if date of start is before certain day and date of end is after certain day of stay 56 | for (i in 0:70) { 57 | dd<-as.data.frame(cbind(date,length)) %>% 58 | mutate(cases=1,end=date+length) %>% 59 | mutate(max=case_when( 60 | date<=i & end>=i ~ 1, 61 | TRUE ~ 0 62 | )) 63 | in_icu[i]<-sum(dd$max) 64 | 65 | } 66 | plot(in_icu) 67 | max10<-max(in_icu) 68 | put(max10) 69 | 70 | } 71 | 72 | res10<-magic_result_as_dataframe() %>% rename(abs=k) 73 | 74 | 75 | #40 weeks and 5 days per ICU stay 76 | 77 | magic_for(silent = TRUE) 78 | 79 | for (k in df_calc_40$abs) { 80 | 81 | date<-rgamma(k,2.5,scale=63) #distribution of icu cases 82 | length=rnorm(k,5,2) #distribution of length of stay in icu 83 | 84 | in_icu<- rep(0,300) 85 | #date is the day of start of stay in icu 86 | #end is the day of end of stay 87 | # max is 1 if date of start is before certain day and date of end is after certain day of stay 88 | for (i in 0:300) { 89 | dd<-as.data.frame(cbind(date,length)) %>% 90 | mutate(cases=1,end=date+length) %>% 91 | mutate(max=case_when( 92 | date<=i & end>=i ~ 1, 93 | TRUE ~ 0 94 | )) 95 | in_icu[i]<-sum(dd$max) 96 | 97 | } 98 | plot(in_icu) 99 | max40<-max(in_icu) 100 | put(max40) 101 | 102 | } 103 | 104 | res40<-magic_result_as_dataframe() %>% rename(abs=k) 105 | 106 | ru_v <- df_calc_40 %>% 107 | left_join(res10) %>% 108 | left_join(res20) %>% 109 | left_join(res40) %>% 110 | mutate( 111 | vent10weeks=round(max10/vent,2), 112 | vent20weeks=round(max20/vent,2), 113 | vent40weeks=round(max40/vent,2), 114 | ) %>% 115 | # mutate(name = name %>% str_trunc(20, side = "center")) %>% 116 | arrange(vent40weeks) %>% 117 | mutate(reg = reg %>% as_factor %>% fct_inorder) %>% 118 | pivot_longer(vent10weeks:vent40weeks, 119 | names_to = "epi_scenario", 120 | values_to = "peak_patients_per_vent") 121 | 122 | 123 | # ru_v %>% 124 | # ggplot(aes(y = reg))+ 125 | # geom_point(aes(x=peak_patients_per_vent, color=epi_scenario ))+ 126 | # scale_x_log10()+ 127 | # theme_minimal()+ 128 | # labs(y = "") + 129 | # geom_vline(xintercept=1)+ 130 | # scale_y_discrete(limits=ru_v$name) 131 | # 132 | -------------------------------------------------------------------------------- /data/vent.csv: -------------------------------------------------------------------------------- 1 | reg;vent;id;name;vent2;vent3 2 | Алтайский край;604;01000000000;Алтайский край;802; 3 | Амурская область;248;10000000000;Амурская область;336; 4 | Архангельская область;628;11001000000;Архангельская область;419; 5 | Астраханская область;185;12000000000;Астраханская область;240; 6 | Белгородская область;302;14000000000;Белгородская область;260; 7 | Брянская область;184;15000000000;Брянская область;; 8 | Владимирская область;365;17000000000;Владимирская область;426; 9 | Волгоградская область;519;18000000000;Волгоградская область;257; 10 | Вологодская область;293;19000000000;Вологодская область;; 11 | Воронежская область;316;20000000000;Воронежская область;348; 12 | Еврейская автономная область;100;99000000000;Еврейская автономная область;; 13 | Забайкальский край;301;76000000000;Забайкальский край;242; 14 | Ивановская область;241;24000000000;Ивановская область;178; 15 | Ингушская республика;48;26000000000;Республика Ингушетия ;; 16 | Иркутская область;627;25000000000;Иркутская область;633; 17 | Кабардино-балкарская республика;128;83000000000;Кабардино-Балкарская Республика;190; 18 | Калининградская область;317;27000000000;Калининградская область;; 19 | Калужская область;110;29000000000;Калужская область;48; 20 | Камчатский край;100;30000000000;Камчатский край;; 21 | Карачаево-черкесская республика;120;91000000000;Карачаево-Черкесская Республика;; 22 | Кемеровская область;578;32000000000;Кемеровская область - Кузбасс;726; 23 | Кировская область;379;33000000000;Кировская область;500; 24 | Костромская область;201;34000000000;Костромская область;121; 25 | Краснодарский край;1000;03000000000;Краснодарский край;; 26 | Красноярский край;795;04000000000;Красноярский край;; 27 | Курганская область;80;37000000000;Курганская область;; 28 | Курская область;383;38000000000;Курская область;242; 29 | Ленинградская область;162;41000000000;Ленинградская область;268;342 30 | Липецкая область;337;42000000000;Липецкая область;400; 31 | Магаданская область;60;44000000000;Магаданская область;; 32 | Москва;6414;45000000000;Москва;5540; 33 | Московская область;2270;46000000000;Московская область;; 34 | Мурманская область;327;47000000000;Мурманская область;226; 35 | Ненецкий автономный округ;24;11100000000;Ненецкий автономный округ (Архангельская область);; 36 | Нижегородская область;674;22000000000;Нижегородская область;; 37 | Новгородская область;120;49000000000;Новгородская область;; 38 | Новосибирская область;982;50000000000;Новосибирская область;; 39 | Омская область;358;52000000000;Омская область;361; 40 | Оренбургская область;404;53000000000;Оренбургская область;542; 41 | Орловская область;342;54000000000;Орловская область;160; 42 | Пензенская область;294;56000000000;Пензенская область;400; 43 | Пермский край;734;57000000000;Пермский край;; 44 | Приморский край;374;05000000000;Приморский край;; 45 | Псковская область;141;58000000000;Псковская область;190; 46 | Республика Адыгея;100;79000000000;Республика Адыгея (Адыгея);; 47 | Республика Алтай;168;84000000000;Республика Алтай;; 48 | Республика Башкортостан;751;80000000000;Республика Башкортостан;; 49 | Республика Бурятия;172;81000000000;Республика Бурятия;246; 50 | Республика Дагестан;188;82000000000;Республика Дагестан;; 51 | Республика Калмыкия;60;85000000000;Республика Калмыкия;; 52 | Республика Карелия;174;86000000000;Республика Карелия;200; 53 | Республика Коми;272;87000000000;Республика Коми;; 54 | Республика Крым;684;35000000000;Республика Крым;656; 55 | Республика Марий Эл;300;88000000000;Республика Марий Эл;124; 56 | Республика Мордовия;124;89000000000;Республика Мордовия;; 57 | Республика Саха (Якутия);260;98000000000;Республика Саха (Якутия);361; 58 | Республика Северная Осетия;180;90000000000;Республика Северная Осетия-Алания;; 59 | Республика Татарстан;1571;92000000000;Республика Татарстан (Татарстан);; 60 | Республика Тыва;176;93000000000;Республика Тыва;; 61 | Республика Хакасия;192;95000000000;Республика Хакасия;; 62 | Ростовская область;724;60000000000;Ростовская область;; 63 | Рязанская область;203;61000000000;Рязанская область;300; 64 | Самарская область;954;36000000000;Самарская область;; 65 | Санкт-Петербург;2348;40000000000;Санкт-Петербург;; 66 | Саратовская область;490;63000000000;Саратовская область;536; 67 | Сахалинская область;302;64000000000;Сахалинская область;181; 68 | Свердловская область;1101;65000000000;Свердловская область;; 69 | Севастополь;151;67000000000;Севастополь;58; 70 | Смоленская область;108;66000000000;Смоленская область;; 71 | Ставропольский край;2264;07000000000;Ставропольский край;; 72 | Тамбовская область;771;68000000000;Тамбовская область;; 73 | Тверская область;217;28000000000;Тверская область;118; 74 | Томская область;338;69000000000;Томская область;400; 75 | Тульская область;241;70000000000;Тульская область;297; 76 | Тюменская область;609;71001000000;Тюменская область (кроме Ханты-Мансийского автономного округа-Югры и Ямало-Ненецкого автономного округа);; 77 | Удмуртская республика;191;94000000000;Удмуртская Республика;303; 78 | Ульяновская область;135;73000000000;Ульяновская область;; 79 | Хабаровский край;303;08000000000;Хабаровский край;; 80 | ХМАО;1082;71100000000;Ханты-Мансийский автономный округ - Югра (Тюменская область);; 81 | Челябинская область;780;75000000000;Челябинская область;; 82 | Чеченская республика;160;96000000000;Чеченская Республика*;; 83 | Чувашская республика ;388;97000000000;Чувашская Республика - Чувашия;422; 84 | Чукотский автономный округ;12;77000000000;Чукотский автономный округ;; 85 | Ямало-Ненецкий автономный округ;160;71140000000;Ямало-Ненецкий автономный округ (Тюменская область);; 86 | Ярославская область;379;78000000000;Ярославская область;395; -------------------------------------------------------------------------------- /data/analysis.R: -------------------------------------------------------------------------------- 1 | #=============================================================================== 2 | # 2020-03-28 -- covid19 3 | # calculate and map burden on Russain regions 4 | # Ilya Kashnitsky, ilya.kashnitsky@gmail.com 5 | # Anton Barchuk, barchuk.anton@gmail.com 6 | #=============================================================================== 7 | 8 | library(tidyverse) 9 | library(magrittr) 10 | library(sf) 11 | library(hrbrthemes) 12 | library(stringi) 13 | 14 | options(scipen = 9999) 15 | library(showtext) 16 | font_add_google("Roboto Condensed", "Roboto Condensed") 17 | showtext::showtext_auto() 18 | 19 | library(cowplot) 20 | library(plotly) 21 | 22 | 23 | 24 | # load the datasets ------------------------------------------------------- 25 | 26 | load("data/reg_okato.rda") 27 | load("data/pop10.rda") 28 | 29 | # CFR Italian 26 March 30 | # https://www.epicentro.iss.it/coronavirus/bollettino/Bollettino-sorveglianza-integrata-COVID-19_26-marzo%202020.pdf 31 | cfr <- tibble::tribble( 32 | ~age, ~b, ~m, ~f, 33 | "0-9", 0.0001, 0.0001, 0.0001, 34 | "10-19", 0.0001, 0.0001, 0.0001, 35 | "20-29", 0.0001, 0.0001, 0.0001, 36 | "30-39", 0.3, 0.6, 0.1, 37 | "40-49", 0.7, 1.1, 0.4, 38 | "50-59", 1.7, 2.4, 0.8, 39 | "60-69", 5.7, 6.9, 3.5, 40 | "70-79", 16.9, 19.8, 11.6, 41 | "80-89", 24.6, 29.2, 18.9, 42 | "90+", 24, 30.8, 20.4 43 | ) 44 | 45 | cfr_sr <- cfr %>% 46 | mutate(mfratio=round(m/f, 1)) %>% 47 | select(age,mfratio) %>% 48 | filter(!age=="90+") %>% 49 | mutate(age = age %>% paste %>% str_replace("80-89", "80+")) 50 | 51 | # Ferguson report table 1 52 | # http://spiral.imperial.ac.uk/handle/10044/1/77482 53 | ifr <- tibble::tribble( 54 | ~age, ~hosp, ~i, ~ifr, 55 | "0-9", 0.01, 5.0, 0.002, 56 | "10-19", 0.04, 5.0, 0.006, 57 | "20-29", 1.1, 5.0, 0.03, 58 | "30-39", 3.4, 5.0, 0.08, 59 | "40-49", 4.3, 6.3, 0.15, 60 | "50-59", 8.2, 12.2, 0.60, 61 | "60-69", 11.8, 27.4, 2.2, 62 | "70-79", 16.6, 43.2, 5.1, 63 | "80+", 18.4, 70.9, 9.3 64 | ) %>% 65 | mutate(icu=hosp*i/100) %>% 66 | select(-i) %>% 67 | pivot_longer(hosp:icu, names_to = "variable", values_to = "prop") %>% 68 | left_join(cfr_sr) %>% 69 | mutate(f=round(2*prop/(1+mfratio),6), #calculate male and female proportions 70 | m=round(2*prop*mfratio/(1+mfratio),6)) %>% 71 | pivot_longer(m:f, names_to = "sex", values_to = "adj_prop") %>% 72 | rename(new_age=age) %>% 73 | select(-mfratio,-prop) 74 | 75 | 76 | 77 | # Italian CFR plot -------------------------------------------------------- 78 | 79 | # age profile of case fatality ratios 80 | ( 81 | gg_cfr <- cfr %>% 82 | pivot_longer(b:f, names_to = "sex", values_to = "cfr") %>% 83 | ggplot(aes(cfr, age, color = sex))+ 84 | geom_point(size = 3, shape = c(16, 1, 1) %>% rep(10))+ 85 | scale_color_manual(values = c("#df356b", "#009C9C", "#eec21f"), guide = NULL)+ 86 | scale_x_continuous(position = "top")+ 87 | theme_minimal(base_family = font_rc)+ 88 | theme(panel.grid = element_blank(), 89 | axis.ticks.x.top = element_line(colour = "#7F7F7F", .22), 90 | axis.ticks.length.x = unit(.5, "lines"))+ 91 | labs(x = NULL, 92 | y = NULL, 93 | title = "Летальность COVID-19 по возрасту и полу, %", 94 | caption = "Итальянские данные за 26 марта 2020 г., 6801 смертей")+ 95 | annotate("text", x = 19.4, y = 10, hjust = 1, size = 4, 96 | label = "женщины", family = font_rc, color = "#009C9C")+ 97 | annotate("text", x = 20.8, y = 8, hjust = 0, size = 4, 98 | label = "мужчины", family = font_rc, color = "#eec21f") 99 | ) 100 | 101 | ggsave(filename = "figures/cfr-italy.pdf", gg_cfr, width = 5, height = 5) 102 | ggsave(filename = "figures/cfr-italy.svg", gg_cfr, width = 5, height = 5) 103 | 104 | 105 | # calculate --------------------------------------------------------------- 106 | 107 | # filter out only regions 108 | reg_only <- df_reg_10 %>% 109 | filter(nchar(id)==11, 110 | # remove pooled population of Arkhangelk and Tumen 111 | !id %in% c("71000000000", "11000000000")) %>% 112 | mutate(new_age=case_when( 113 | age=="0-9"~ "0-9", 114 | age=="10-19"~ "10-19", 115 | age=="20-29"~"20-29", 116 | age=="30-39"~"30-39", 117 | age=="40-49"~ "40-49", 118 | age=="50-59" ~ "50-59", 119 | age=="60-69" ~ "60-69", 120 | age=="70-79" ~ "70-79" , 121 | age=="80-89" ~ "80+", 122 | age=="90+" ~ "80+", 123 | TRUE~"other")) %>% 124 | group_by(new_age,name,id, sex,year,type) %>% 125 | summarise(value=sum(value)) %>% ungroup() %>% 126 | filter(type=="pooled", !sex=="b", year==2020) %>% 127 | select(-year, -type) 128 | 129 | # add vent 130 | vent <- read.csv2( 131 | "data/vent.csv", colClasses = c("id" = "character") 132 | ) %>% 133 | group_by(id) %>% 134 | mutate(vent = max(vent, vent2, vent3, na.rm = T)) %>% 135 | select(reg, id, vent) %>% 136 | ungroup() %>% 137 | mutate(reg_en = reg %>% stringi::stri_trans_general("ru-ru_Latn/BGN")) 138 | 139 | 140 | # with varying attack rate ------------------------------------------------ 141 | 142 | 143 | calc_attack_rates <- function(rate = 2/3) { 144 | 145 | dfi <- reg_only %>% 146 | left_join(ifr, c("new_age", "sex")) %>% 147 | # assumption on the attack rate 148 | mutate(abs = round ((value*rate) * (adj_prop/100),0)) %>% 149 | group_by(id, name, variable) %>% 150 | summarise( 151 | value = value %>% sum(na.rm = T), 152 | abs = abs %>% sum(na.rm = T) 153 | ) %>% 154 | left_join(vent) %>% 155 | ungroup() %>% 156 | drop_na() %>% 157 | group_by(variable) %>% # to calculate average prop for Russia 158 | mutate( 159 | prop = abs / value * 100, 160 | avg_prop = weighted.mean(prop, value), # average prop for Russia 161 | rel_prop = prop / avg_prop 162 | ) %>% 163 | ungroup() %>% 164 | # discrete 165 | group_by(variable) %>% 166 | mutate( 167 | rel_prop_gr = rel_prop %>% 168 | cut(c(0, .5, 2/3, 4/5, .95, 100/95, 5/4, 3/2, Inf)) 169 | ) %>% 170 | ungroup() %>% 171 | drop_na() 172 | 173 | return(dfi) 174 | 175 | } 176 | 177 | df_calc <- seq(.4, .8, .1) %>% 178 | map_df(calc_attack_rates, .id = "attack_rate") %>% 179 | mutate(attack_rate = attack_rate %>% as_factor %>% 180 | lvls_revalue(seq(40, 80, 10) %>% paste0("%")) %>% 181 | paste) %>% 182 | left_join( 183 | reg_okato, 184 | ., 185 | by = c("okato"="id") 186 | ) 187 | 188 | # map -- RUS labels 189 | p_arates <- df_calc %>% 190 | filter(variable == "icu") %>% 191 | plot_ly() %>% 192 | add_sf( 193 | color = ~ prop, 194 | colors = "RdPu", 195 | midpoint = 1, 196 | split = ~ okato, 197 | alpha = 1, 198 | stroke = I("#ebebeb"), 199 | span = I(.1), 200 | text = ~ paste0( 201 | reg, 202 | "\n", 203 | "Интенсивная терапия понадобится: ", 204 | (abs / 1e3) %>% round(1), 205 | " тыс. чел.", 206 | "\n" 207 | ), 208 | frame = ~ attack_rate, 209 | hoverinfo = "text", 210 | hoveron = "fills" 211 | ) %>% 212 | hide_colorbar() %>% 213 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 214 | animation_slider(currentvalue = list(prefix = "Доля зараженного населения: ")) %>% 215 | animation_button(hide = T) %>% 216 | hide_legend() 217 | 218 | htmlwidgets::saveWidget(p_arates, file = "map-arates.html") 219 | 220 | 221 | # map -- ENG labels 222 | p_arates_en <- df_calc %>% 223 | filter(variable == "icu") %>% 224 | plot_ly() %>% 225 | add_sf( 226 | color = ~ prop, 227 | colors = "RdPu", 228 | midpoint = 1, 229 | split = ~ okato, 230 | alpha = 1, 231 | stroke = I("#ebebeb"), 232 | span = I(.1), 233 | text = ~ paste0( 234 | reg_en, 235 | "\n", 236 | "Demand for intensive care units: ", 237 | (abs / 1e3) %>% round(1), 238 | " thous.", 239 | "\n" 240 | ), 241 | frame = ~ attack_rate, 242 | hoverinfo = "text", 243 | hoveron = "fills" 244 | ) %>% 245 | hide_colorbar() %>% 246 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 247 | animation_slider(currentvalue = list(prefix = "Proportion of the population infected: ")) %>% 248 | animation_button(hide = T) %>% 249 | hide_legend() 250 | 251 | htmlwidgets::saveWidget(p_arates_en, file = "map-arates-en.html") 252 | 253 | 254 | 255 | 256 | # venitlators ------------------------------------------------------------- 257 | 258 | # filter the 40% scenario 259 | df_calc_40 <- df_calc %>% 260 | st_drop_geometry() %>% 261 | filter(attack_rate == "40%", variable == "icu") %>% 262 | transmute(id = okato, reg, reg_en, value, abs, vent) 263 | 264 | # run all the loops script -- output is ru_v df 265 | source("R/vent_analysis.R") # it takes several minutes 266 | 267 | save(ru_v, file = "data/ru_v.rda") 268 | 269 | # # NOT USED in the end 270 | # # interpolate color palete 271 | # pal_func <- colorRamp( 272 | # colors = RColorBrewer::brewer.pal(n = 11, name = "Reds") 273 | # ) 274 | # 275 | # # convert to hex colors 276 | # pal_calc <- function(x) { 277 | # x %>% pal_func() %>% divide_by(255) %>% rgb 278 | # } 279 | # 280 | # 281 | # c(0, .1, .9) %>% pal_calc %>% color 282 | 283 | 284 | # join the data and calculate manual colors 285 | df_vent <- ru_v %>% 286 | mutate( 287 | peak_week = epi_scenario %>% as_factor %>% fct_inorder() %>% 288 | lvls_revalue(c("05", "10", "20")), 289 | log_peak_demand_0_1 = peak_patients_per_vent %>% log %>% scales::rescale(), 290 | log_peak_demand_0_1_rev = 1 - log_peak_demand_0_1 291 | ) %>% 292 | # group_by(id, epi_scenario) %>% 293 | # mutate(manual_color = log_peak_demand_0_1 %>% pal_calc) %>% 294 | # ungroup() %>% 295 | left_join( 296 | reg_okato, 297 | ., 298 | by = c("okato"="id") 299 | ) 300 | 301 | # map -- RUS labels 302 | p_vents <- df_vent %>% 303 | group_by(epi_scenario) %>% 304 | plot_ly() %>% 305 | add_sf( 306 | color = ~ log_peak_demand_0_1_rev, 307 | colors = ~ "BrBG", 308 | split = ~ okato, 309 | alpha = 1, 310 | stroke = I("#ebebeb"), 311 | span = I(.1), 312 | text = ~ paste0( 313 | reg, 314 | "\n", 315 | "При пике эпидемии на ", peak_week %>% str_replace("05", "5"), 316 | " неделе", "\n", 317 | "Пациентов на один аппарат ИВЛ: " , 318 | peak_patients_per_vent %>% round(1), 319 | "\n" 320 | ), 321 | frame = ~ peak_week, 322 | hoverinfo = "text", 323 | hoveron = "fills" 324 | ) %>% 325 | hide_colorbar() %>% 326 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 327 | animation_slider(currentvalue = list(prefix = "Длительность эпидемии в неделях от начала до пика: ")) %>% 328 | animation_button(hide = T) %>% 329 | hide_legend() 330 | 331 | htmlwidgets::saveWidget(p_vents, file = "map-vents.html") 332 | 333 | 334 | # map -- ENG labels 335 | p_vents_en <- df_vent %>% 336 | group_by(epi_scenario) %>% 337 | plot_ly() %>% 338 | add_sf( 339 | color = ~ log_peak_demand_0_1_rev, 340 | colors = ~ "BrBG", 341 | split = ~ okato, 342 | alpha = 1, 343 | stroke = I("#ebebeb"), 344 | span = I(.1), 345 | text = ~ paste0( 346 | reg_en, 347 | "\n", 348 | "Epidemic peaks at the ", peak_week %>% str_replace("05", "5"), 349 | "th week", "\n", 350 | "Peak number of patients per one ICU: " , 351 | peak_patients_per_vent %>% round(1), 352 | "\n" 353 | ), 354 | frame = ~ peak_week, 355 | hoverinfo = "text", 356 | hoveron = "fills" 357 | ) %>% 358 | hide_colorbar() %>% 359 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 360 | animation_slider(currentvalue = list(prefix = "Duration of the epidemic form the beginning to the peak, in weeks: ")) %>% 361 | animation_button(hide = T) %>% 362 | hide_legend() 363 | 364 | htmlwidgets::saveWidget(p_vents_en, file = "map-vents-en.html") 365 | 366 | 367 | # export tables in CSV ---------------------------------------------------- 368 | 369 | out_abs_icu <- df_calc %>% 370 | st_drop_geometry() %>% 371 | filter(variable == "icu") %>% 372 | transmute(okato, reg, reg_en, attack_rate, abs) %>% 373 | pivot_wider(names_from = attack_rate, values_from = abs) 374 | 375 | rio::export(out_abs_icu, file = "data/out-abs-icu.csv") 376 | 377 | 378 | out_vent <- df_vent %>% 379 | st_drop_geometry() %>% 380 | transmute(okato, reg, reg_en, epi_scenario, peak_patients_per_vent) %>% 381 | pivot_wider(names_from = epi_scenario, values_from = peak_patients_per_vent) 382 | rio::export(out_vent, file = "data/out-vent.csv") 383 | -------------------------------------------------------------------------------- /R/analysis.R: -------------------------------------------------------------------------------- 1 | #=============================================================================== 2 | # 2020-03-28 -- covid19 3 | # calculate and map burden on Russain regions 4 | # Ilya Kashnitsky, ilya.kashnitsky@gmail.com 5 | # Anton Barchuk, barchuk.anton@gmail.com 6 | #=============================================================================== 7 | 8 | library(tidyverse) 9 | library(magrittr) 10 | library(sf) 11 | library(hrbrthemes) 12 | library(stringi) 13 | 14 | options(scipen = 9999) 15 | library(showtext) 16 | font_add_google("Roboto Condensed", "Roboto Condensed") 17 | showtext::showtext_auto() 18 | 19 | library(cowplot) 20 | library(plotly) 21 | 22 | 23 | 24 | # load the datasets ------------------------------------------------------- 25 | 26 | load("data/reg_okato.rda") 27 | load("data/pop10.rda") 28 | 29 | # CFR Italian 26 March 30 | # https://www.epicentro.iss.it/coronavirus/bollettino/Bollettino-sorveglianza-integrata-COVID-19_26-marzo%202020.pdf 31 | cfr <- tibble::tribble( 32 | ~age, ~b, ~m, ~f, 33 | "0-9", 0.0001, 0.0001, 0.0001, 34 | "10-19", 0.0001, 0.0001, 0.0001, 35 | "20-29", 0.0001, 0.0001, 0.0001, 36 | "30-39", 0.3, 0.6, 0.1, 37 | "40-49", 0.7, 1.1, 0.4, 38 | "50-59", 1.7, 2.4, 0.8, 39 | "60-69", 5.7, 6.9, 3.5, 40 | "70-79", 16.9, 19.8, 11.6, 41 | "80-89", 24.6, 29.2, 18.9, 42 | "90+", 24, 30.8, 20.4 43 | ) 44 | 45 | cfr_sr <- cfr %>% 46 | mutate(mfratio=round(m/f, 1)) %>% 47 | select(age,mfratio) %>% 48 | filter(!age=="90+") %>% 49 | mutate(age = age %>% paste %>% str_replace("80-89", "80+")) 50 | 51 | #ferguson report table 1 52 | ifr <- tibble::tribble( 53 | ~age, ~hosp, ~i, ~ifr, 54 | "0-9", 0.01, 5.0, 0.002, 55 | "10-19", 0.04, 5.0, 0.006, 56 | "20-29", 1.1, 5.0, 0.03, 57 | "30-39", 3.4, 5.0, 0.08, 58 | "40-49", 4.3, 6.3, 0.15, 59 | "50-59", 8.2, 12.2, 0.60, 60 | "60-69", 11.8, 27.4, 2.2, 61 | "70-79", 16.6, 43.2, 5.1, 62 | "80+", 18.4, 70.9, 9.3 63 | ) %>% 64 | mutate(icu=hosp*i/100) %>% 65 | select(-i) %>% 66 | pivot_longer(hosp:icu, names_to = "variable", values_to = "prop") %>% 67 | left_join(cfr_sr) %>% 68 | mutate(f=round(2*prop/(1+mfratio),6), #calculate male and female proportions 69 | m=round(2*prop*mfratio/(1+mfratio),6)) %>% 70 | pivot_longer(m:f, names_to = "sex", values_to = "adj_prop") %>% 71 | rename(new_age=age) %>% 72 | select(-mfratio,-prop) 73 | 74 | 75 | 76 | # Italian CFR plot -------------------------------------------------------- 77 | 78 | # age profile of case fatality ratios 79 | ( 80 | gg_cfr <- cfr %>% 81 | pivot_longer(b:f, names_to = "sex", values_to = "cfr") %>% 82 | ggplot(aes(cfr, age, color = sex))+ 83 | geom_point(size = 3, shape = c(16, 1, 1) %>% rep(10))+ 84 | scale_color_manual(values = c("#df356b", "#009C9C", "#eec21f"), guide = NULL)+ 85 | scale_x_continuous(position = "top")+ 86 | theme_minimal(base_family = font_rc)+ 87 | theme(panel.grid = element_blank(), 88 | axis.ticks.x.top = element_line(colour = "#7F7F7F", .22), 89 | axis.ticks.length.x = unit(.5, "lines"))+ 90 | labs(x = NULL, 91 | y = NULL, 92 | title = "Летальность COVID-19 по возрасту и полу, %", 93 | caption = "Итальянские данные за 26 марта 2020 г., 6801 смертей")+ 94 | annotate("text", x = 19.4, y = 10, hjust = 1, size = 4, 95 | label = "женщины", family = font_rc, color = "#009C9C")+ 96 | annotate("text", x = 20.8, y = 8, hjust = 0, size = 4, 97 | label = "мужчины", family = font_rc, color = "#eec21f") 98 | ) 99 | 100 | ggsave(filename = "figures/cfr-italy.pdf", gg_cfr, width = 5, height = 5) 101 | ggsave(filename = "figures/cfr-italy.svg", gg_cfr, width = 5, height = 5) 102 | 103 | 104 | # calculate --------------------------------------------------------------- 105 | 106 | # filter out only regions 107 | reg_only <- df_reg_10 %>% 108 | filter(nchar(id)==11, 109 | # remove pooled population of Arkhangelk and Tumen 110 | !id %in% c("71000000000", "11000000000")) %>% 111 | mutate(new_age=case_when( 112 | age=="0-9"~ "0-9", 113 | age=="10-19"~ "10-19", 114 | age=="20-29"~"20-29", 115 | age=="30-39"~"30-39", 116 | age=="40-49"~ "40-49", 117 | age=="50-59" ~ "50-59", 118 | age=="60-69" ~ "60-69", 119 | age=="70-79" ~ "70-79" , 120 | age=="80-89" ~ "80+", 121 | age=="90+" ~ "80+", 122 | TRUE~"other")) %>% 123 | group_by(new_age,name,id, sex,year,type) %>% 124 | summarise(value=sum(value)) %>% ungroup() %>% 125 | filter(type=="pooled", !sex=="b", year==2020) %>% 126 | select(-year, -type) 127 | 128 | # add vent 129 | vent <- read.csv2( 130 | "data/vent.csv", colClasses = c("id" = "character") 131 | ) %>% 132 | group_by(id) %>% 133 | mutate(vent = max(vent, vent2, vent3, na.rm = T)) %>% 134 | select(reg, id, vent) %>% 135 | ungroup() %>% 136 | mutate(reg_en = reg %>% stringi::stri_trans_general("ru-ru_Latn/BGN")) 137 | 138 | 139 | # with varying attack rate ------------------------------------------------ 140 | 141 | 142 | calc_attack_rates <- function(rate = 2/3) { 143 | 144 | dfi <- reg_only %>% 145 | left_join(ifr, c("new_age", "sex")) %>% 146 | # assumption on the attack rate 147 | mutate(abs = round ((value*rate) * (adj_prop/100),0)) %>% 148 | group_by(id, name, variable) %>% 149 | summarise( 150 | value = value %>% sum(na.rm = T), 151 | abs = abs %>% sum(na.rm = T) 152 | ) %>% 153 | left_join(vent) %>% 154 | ungroup() %>% 155 | drop_na() %>% 156 | group_by(variable) %>% # to calculate average prop for Russia 157 | mutate( 158 | prop = abs / value * 100, 159 | avg_prop = weighted.mean(prop, value), # average prop for Russia 160 | rel_prop = prop / avg_prop 161 | ) %>% 162 | ungroup() %>% 163 | # discrete 164 | group_by(variable) %>% 165 | mutate( 166 | rel_prop_gr = rel_prop %>% 167 | cut(c(0, .5, 2/3, 4/5, .95, 100/95, 5/4, 3/2, Inf)) 168 | ) %>% 169 | ungroup() %>% 170 | drop_na() 171 | 172 | return(dfi) 173 | 174 | } 175 | 176 | df_calc <- seq(.4, .8, .1) %>% 177 | map_df(calc_attack_rates, .id = "attack_rate") %>% 178 | mutate(attack_rate = attack_rate %>% as_factor %>% 179 | lvls_revalue(seq(40, 80, 10) %>% paste0("%")) %>% 180 | paste) %>% 181 | left_join( 182 | reg_okato, 183 | ., 184 | by = c("okato"="id") 185 | ) 186 | 187 | # map -- RUS labels 188 | p_arates <- df_calc %>% 189 | filter(variable == "icu") %>% 190 | plot_ly() %>% 191 | add_sf( 192 | color = ~ prop, 193 | colors = "RdPu", 194 | midpoint = 1, 195 | split = ~ okato, 196 | alpha = 1, 197 | stroke = I("#ebebeb"), 198 | span = I(.1), 199 | text = ~ paste0( 200 | reg, 201 | "\n", 202 | "Интенсивная терапия понадобится: ", 203 | (abs / 1e3) %>% round(1), 204 | " тыс. чел.", 205 | "\n" 206 | ), 207 | frame = ~ attack_rate, 208 | hoverinfo = "text", 209 | hoveron = "fills" 210 | ) %>% 211 | hide_colorbar() %>% 212 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 213 | animation_slider(currentvalue = list(prefix = "Доля зараженного населения: "), font = list(color="E5E5E5FF")) %>% 214 | animation_button(hide = T) %>% 215 | hide_legend() %>% 216 | layout(plot_bgcolor="#333333") %>% 217 | layout(paper_bgcolor="#333333") 218 | 219 | htmlwidgets::saveWidget(p_arates, file = "map-arates.html", 220 | background = "#333333") 221 | 222 | 223 | # map -- ENG labels 224 | p_arates_en <- df_calc %>% 225 | filter(variable == "icu") %>% 226 | plot_ly() %>% 227 | add_sf( 228 | color = ~ prop, 229 | colors = "RdPu", 230 | midpoint = 1, 231 | split = ~ okato, 232 | alpha = 1, 233 | stroke = I("#ebebeb"), 234 | span = I(.1), 235 | text = ~ paste0( 236 | reg_en, 237 | "\n", 238 | "Demand for intensive care units: ", 239 | (abs / 1e3) %>% round(1), 240 | " thous.", 241 | "\n" 242 | ), 243 | frame = ~ attack_rate, 244 | hoverinfo = "text", 245 | hoveron = "fills" 246 | ) %>% 247 | hide_colorbar() %>% 248 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 249 | animation_slider(currentvalue = list(prefix = "Proportion of the population infected: "), font = list(color="E5E5E5FF")) %>% 250 | animation_button(hide = T) %>% 251 | hide_legend() %>% 252 | layout(plot_bgcolor="#333333") %>% 253 | layout(paper_bgcolor="#333333") 254 | 255 | htmlwidgets::saveWidget(p_arates_en, file = "map-arates-en.html", 256 | background = "#333333") 257 | 258 | 259 | 260 | 261 | # venitlators ------------------------------------------------------------- 262 | 263 | # filter the 40% scenario 264 | df_calc_40 <- df_calc %>% 265 | st_drop_geometry() %>% 266 | filter(attack_rate == "40%", variable == "icu") %>% 267 | transmute(id = okato, reg, reg_en, value, abs, vent) 268 | 269 | # run all the loops script -- output is ru_v df 270 | source("R/vent_analysis.R") # it takes several minutes 271 | 272 | save(ru_v, file = "data/ru_v.rda") 273 | 274 | # # NOT USED in the end 275 | # # interpolate color palete 276 | # pal_func <- colorRamp( 277 | # colors = RColorBrewer::brewer.pal(n = 11, name = "Reds") 278 | # ) 279 | # 280 | # # convert to hex colors 281 | # pal_calc <- function(x) { 282 | # x %>% pal_func() %>% divide_by(255) %>% rgb 283 | # } 284 | # 285 | # 286 | # c(0, .1, .9) %>% pal_calc %>% color 287 | 288 | 289 | # join the data and calculate manual colors 290 | df_vent <- ru_v %>% 291 | mutate( 292 | peak_week = epi_scenario %>% as_factor %>% fct_inorder() %>% 293 | lvls_revalue(c("05", "10", "20")), 294 | log_peak_demand_0_1 = peak_patients_per_vent %>% log %>% scales::rescale(), 295 | log_peak_demand_0_1_rev = 1 - log_peak_demand_0_1 296 | ) %>% 297 | # group_by(id, epi_scenario) %>% 298 | # mutate(manual_color = log_peak_demand_0_1 %>% pal_calc) %>% 299 | # ungroup() %>% 300 | left_join( 301 | reg_okato, 302 | ., 303 | by = c("okato"="id") 304 | ) 305 | 306 | # map -- RUS labels 307 | p_vents <- df_vent %>% 308 | group_by(epi_scenario) %>% 309 | plot_ly() %>% 310 | add_sf( 311 | color = ~ log_peak_demand_0_1_rev, 312 | colors = ~ "BrBG", 313 | split = ~ okato, 314 | alpha = 1, 315 | stroke = I("#ebebeb"), 316 | span = I(.1), 317 | text = ~ paste0( 318 | reg, 319 | "\n", 320 | "При пике эпидемии на ", peak_week %>% str_replace("05", "5"), 321 | " неделе", "\n", 322 | "Пациентов на один аппарат ИВЛ: " , 323 | peak_patients_per_vent %>% round(1), 324 | "\n" 325 | ), 326 | frame = ~ peak_week, 327 | hoverinfo = "text", 328 | hoveron = "fills" 329 | ) %>% 330 | hide_colorbar() %>% 331 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 332 | animation_slider(currentvalue = list(prefix = "Длительность эпидемии в неделях от начала до пика: "), font = list(color="E5E5E5FF")) %>% 333 | animation_button(hide = T) %>% 334 | hide_legend() %>% 335 | layout(plot_bgcolor="#333333") %>% 336 | layout(paper_bgcolor="#333333") 337 | 338 | htmlwidgets::saveWidget(p_vents, file = "map-vents.html", 339 | background = "#333333") 340 | 341 | 342 | # map -- ENG labels 343 | p_vents_en <- df_vent %>% 344 | group_by(epi_scenario) %>% 345 | plot_ly() %>% 346 | add_sf( 347 | color = ~ log_peak_demand_0_1_rev, 348 | colors = ~ "BrBG", 349 | split = ~ okato, 350 | alpha = 1, 351 | stroke = I("#ebebeb"), 352 | span = I(.1), 353 | text = ~ paste0( 354 | reg_en, 355 | "\n", 356 | "Epidemic peaks at the ", peak_week %>% str_replace("05", "5"), 357 | "th week", "\n", 358 | "Peak number of patients per one ICU: " , 359 | peak_patients_per_vent %>% round(1), 360 | "\n" 361 | ), 362 | frame = ~ peak_week, 363 | hoverinfo = "text", 364 | hoveron = "fills" 365 | ) %>% 366 | hide_colorbar() %>% 367 | animation_opts(1000, easing = "elastic", redraw = FALSE) %>% 368 | animation_slider(currentvalue = list(prefix = "Duration of the epidemic form the beginning to the peak, in weeks: "), font = list(color="E5E5E5FF")) %>% 369 | animation_button(hide = T) %>% 370 | hide_legend() %>% 371 | layout(plot_bgcolor="#333333") %>% 372 | layout(paper_bgcolor="#333333") 373 | 374 | htmlwidgets::saveWidget(p_vents_en, file = "map-vents-en.html", 375 | background = "#333333") 376 | 377 | 378 | # export tables in CSV ---------------------------------------------------- 379 | 380 | out_abs_icu <- df_calc %>% 381 | st_drop_geometry() %>% 382 | filter(variable == "icu") %>% 383 | transmute(okato, reg, reg_en, attack_rate, abs) %>% 384 | pivot_wider(names_from = attack_rate, values_from = abs) 385 | 386 | rio::export(out_abs_icu, file = "data/out-abs-icu.csv") 387 | 388 | 389 | out_vent <- df_vent %>% 390 | st_drop_geometry() %>% 391 | transmute(okato, reg, reg_en, epi_scenario, peak_patients_per_vent) %>% 392 | pivot_wider(names_from = epi_scenario, values_from = peak_patients_per_vent) 393 | rio::export(out_vent, file = "data/out-vent.csv") 394 | --------------------------------------------------------------------------------