class: center, middle, inverse, title-slide # Laboratorio Bio-demografico ## Lezione 14 - Mortalità in eccesso e aspettativa di vita ### Nicola Barban <br> Alma Mater Studiorum Università di Bologna <br> Dipartimento di Scienze Statistiche ### 17 Marzo 2021<br> <img src="../img/UniBo-Universita-di-Bologna.png" style="width:20.0%" /> --- # Mortalità in eccesso  --- # Come si calcola? ## Differenza tra numero di morti in un anno (2020) e media morti in `\(k\)` anni precedenti  --- # Come stimare la mortalità per Covid-19? https://www.nature.com/articles/d41586-020-02497-w ## Tipi di mortalità attribuibili a Covid-19 ### 1. Direct-direct ### 2. Direct-indirect ### 3. Indirect ### 4. Competing risks --- ## **1. Direct-direct** Queste sono le morti che vengono riportate dai vari bollettini COVID. Queste morti, tipicamente in ospedale con test Covid positivo -- ## **2. Direct-indirect** Queste sono morti COVID scambiate per altre patologie, ad esempio polmonite. (ICD-10 J11, J18) Queste morti non sono riportate nei bollettini --- ## **3. Indirect** Queste morti non sono direttamente attrirbuibili a COVID, ma sono indirettamente causate dall'emergenza sanitaria. Ad esempio pronti soccorsi e terapie intasate o rallentamenti nella normale attività ospedaliera -- ## **4. Competing risks** Questo caso implica le morti che si sono evitate a causa del COVID. Ad esempio morti per infarto potrebbero diminuire a casua dell'aumento di altre cause di morte. --- # Short-term Mortality Fluctuations (STMF) data series. ```r library(tidyverse) library(readxl) df<-read_csv("data/STMFinput/ITAstmf.csv") kable(table(df$Year ), type="html") ``` |Var1 | Freq| |:----|----:| |2011 | 3588| |2012 | 3588| |2013 | 3588| |2014 | 3588| |2015 | 3657| |2016 | 3588| |2017 | 3588| |2018 | 3588| |2019 | 3588| |2020 | 3588| --- # Seleziono tutte le fascie di età ```r df_tot<-df %>% filter(Age=="TOT", Sex!="b") plot0<-df_tot %>% ggplot(aes(x=Week, y=Deaths, group=Year))+ geom_line(col="grey", alpha=0.7)+ theme_bw()+ facet_wrap(~Sex) ``` --- ```r plot0 ``` <img src="lezione14_files/figure-html/unnamed-chunk-3-1.png" width="60%" /> --- # Evidenzio anno 2020 ```r plot1<-plot0+ geom_line(data=subset(df_tot,Year==2020), aes(col="2020"), size=1.5, alpha=0.7) ``` --- ```r plot1 ``` <img src="lezione14_files/figure-html/unnamed-chunk-5-1.png" width="60%" /> --- # Calcolo media 2014-2019 ```r media_df_tot <-df_tot %>% filter(Year>=2014 & Year!=2020) %>% group_by(Week, Sex) %>% summarise(Deaths_mean=mean(Deaths)) y2020_df_tot<-df_tot %>% filter(Year==2020) %>% select(Week, Sex, Deaths2020=Deaths) ``` --- ```r DF<-df_tot %>% left_join(media_df_tot, by=c("Week", "Sex") ) %>% left_join(y2020_df_tot, by=c("Week", "Sex") ) %>% mutate( Sex=factor(Sex, levels=c("f", "m"), labels=c("Donne", "Uomini"))) glimpse(DF) ``` ``` ## Rows: 1,042 ## Columns: 12 ## $ PopCode <chr> "ITA", "ITA", "ITA",… ## $ Area <dbl> 1, 1, 1, 1, 1, 1, 1,… ## $ Year <dbl> 2011, 2011, 2011, 20… ## $ Week <dbl> 1, 1, 2, 2, 3, 3, 4,… ## $ Sex <fct> Uomini, Donne, Uomin… ## $ Age <chr> "TOT", "TOT", "TOT",… ## $ AgeInterval <chr> ".", ".", ".", ".", … ## $ Deaths <dbl> 6270, 6848, 6294, 68… ## $ Type <chr> "O", "O", "O", "O", … ## $ Access <chr> "O", "O", "O", "O", … ## $ Deaths_mean <dbl> 7148.500, 7953.500, … ## $ Deaths2020 <dbl> 6585, 6898, 6725, 72… ``` --- # Calculo mortalità in eccesso ```r Excess_mortality<- DF %>% group_by(Sex) %>% filter(Year==2020) %>% select(Sex, Deaths_mean, Deaths2020) %>% summarize(abs_diff=sum(Deaths2020)-sum(Deaths_mean), relative_diff=100*sum(Deaths2020)/sum(Deaths_mean)-100) Excess_mortality ``` ``` ## # A tibble: 2 x 3 ## Sex abs_diff relative_diff ## <fct> <dbl> <dbl> ## 1 Donne 48437. 14.6 ## 2 Uomini 54762. 17.9 ``` --- ```r plot<-DF %>% ggplot(aes(x=Week, y=Deaths, group=Year))+ geom_line(col="grey", alpha=0.7)+ theme_bw()+ facet_wrap(~Sex)+ geom_line(aes(y=Deaths2020, col="2020"), size=1.5, alpha=0.7)+ geom_line(aes(y=Deaths_mean, col="Media 2014-2019"), size=1.5, alpha=0.7)+ scale_color_manual("Anno", labels=c("2020", "Media 2014-2019"), values=c("darkred", "black"))+ labs(x="Settimana", y="", title="Mortalità in eccesso", subtitle="Anno 2020. Italia ", caption="Dati: Human Mortality Database") ``` --- ```r plot ``` <img src="lezione14_files/figure-html/unnamed-chunk-10-1.png" width="60%" /> --- # Seleziona per gruppi di età ```r df_age<-df %>% filter(Age!="TOT", Sex=="b") %>% mutate(Age=as.numeric(Age)) %>% mutate(Age_cat=cut(Age, breaks=c(0,45,65,75,85, Inf) )) %>% arrange(Year, Week, Age) %>% filter(Age_cat!="NA") %>% group_by(Age_cat, Year, Week, Sex) %>% summarise(Deaths=mean(Deaths, na.rm=T)) %>% ungroup() ``` --- ```r media_df_tot <-df_age %>% filter(Year>=2014 & Year!=2020) %>% group_by(Week, Sex, Age_cat) %>% summarise(Deaths_mean=mean(Deaths)) y2020_df_tot<-df_age %>% filter(Year==2020) %>% select(Week, Sex,Age_cat, Deaths2020=Deaths) DF_age<-df_age %>% left_join(media_df_tot, by=c("Week", "Sex","Age_cat") ) %>% left_join(y2020_df_tot, by=c("Week", "Sex","Age_cat") ) ``` --- ```r plot_age<-DF_age %>% ggplot(aes(x=Week, y=Deaths, group=Year))+ geom_line(col="grey", alpha=0.7)+ theme_bw()+ facet_wrap(~Age_cat, scales = "free")+ geom_line(aes(y=Deaths2020, col="2020"), size=1.5, alpha=0.7)+ geom_line(aes(y=Deaths_mean, col="Media 2014-2019"), size=1.5, alpha=0.7)+ scale_color_manual("Anno", labels=c("2020", "Media 2014-2019"), values=c("darkred", "black"))+ labs(x="Settimana", y="", title="Mortalità in eccesso", subtitle="Anno 2020. Italia ", caption="Dati: Human Mortality Database") ``` --- ```r plot_age ``` <img src="lezione14_files/figure-html/unnamed-chunk-14-1.png" width="60%" /> --- ```r exc_mort<-function(data, Y=2020, years_ref=c(2014,2019)){ media_df_tot <-data %>% filter(Year>=years_ref[1] & Year<=years_ref[2] & Year!=Y) %>% group_by(Week, Sex, Age_cat) %>% summarise(Deaths_mean=mean(Deaths, na.rm=T)) y2020_df_tot<-df_age %>% filter(Year==Y) %>% select(Week, Sex,Age_cat, Deaths2020=Deaths) DF_age<-data %>% left_join(media_df_tot, by=c("Week", "Sex", "Age_cat") ) %>% left_join(y2020_df_tot, by=c("Week", "Sex", "Age_cat") ) Excess_mortality<- DF_age %>% group_by(Age_cat, Sex) %>% filter(Year==2020) %>% select(Sex, Deaths_mean, Deaths2020) %>% summarize(abs_diff=sum(Deaths2020, na.rm=T)-sum(Deaths_mean, na.rm=T), relative_diff=100*(abs_diff/sum(Deaths_mean))) return(Excess_mortality) } ``` --- ```r exc_mort(df_age) ``` ``` ## # A tibble: 5 x 4 ## # Groups: Age_cat [5] ## Age_cat Sex abs_diff relative_diff ## <fct> <chr> <dbl> <dbl> ## 1 (0,45] b -162. -8.89 ## 2 (45,65] b 1786. 8.14 ## 3 (65,75] b 8674. 13.5 ## 4 (75,85] b 20692. 16.7 ## 5 (85,Inf] b 13082. 25.5 ``` --- ```r kable(exc_mort(df_age)) ``` |Age_cat |Sex | abs_diff| relative_diff| |:--------|:---|---------:|-------------:| |(0,45] |b | -161.750| -8.886142| |(45,65] |b | 1786.083| 8.143113| |(65,75] |b | 8673.583| 13.544661| |(75,85] |b | 20692.417| 16.668535| |(85,Inf] |b | 13082.167| 25.545535| --- ```r kable(exc_mort(df_age, years_ref=c(2019,2019))) ``` |Age_cat |Sex | abs_diff| relative_diff| |:--------|:---|--------:|-------------:| |(0,45] |b | -11.1| -0.6648299| |(45,65] |b | 2619.0| 12.4118811| |(65,75] |b | 10149.5| 16.2233660| |(75,85] |b | 20107.5| 16.1214026| |(85,Inf] |b | 8915.0| 16.0983537| --- ```r kable(exc_mort(df_age,Y=2019, years_ref=c(2018,2018))) ``` |Age_cat |Sex | abs_diff| relative_diff| |:--------|:---|--------:|-------------:| |(0,45] |b | -96.400| -5.458664| |(45,65] |b | -506.750| -2.345251| |(65,75] |b | -742.500| -1.172921| |(75,85] |b | 1798.500| 1.463063| |(85,Inf] |b | 1732.333| 3.229194| --- # Dati internazionali ```r stmf_df<-read_rds("data/stmf.rds") ``` --- ```r plot_excess_mortality=function(data=stmf_df, age=60, sex="b", country=c("USA"), label="Stati Uniti"){ require(glue) df<- data %>% filter(Sex==sex,Age>=age, PopCode %in% country, Week!="UNK") %>% mutate(PopCode=factor(PopCode, levels=country, labels=label), Week=as.numeric(Week)) media_df_tot <-df %>% filter(Year>=2014 & Year!=2020) %>% group_by(Week, Sex, Age,PopCode) %>% summarise(Deaths_mean=mean(Deaths)) y2020_df_tot<-df %>% filter(Year==2020) %>% select(Week, Sex,Age,PopCode, Deaths2020=Deaths) DF_age<-df %>% left_join(media_df_tot, by=c("Week", "Sex","Age","PopCode") ) %>% left_join(y2020_df_tot, by=c("Week", "Sex","Age","PopCode") ) DF_age %>% ggplot(aes(x=Week, y=Deaths, group=Year))+ geom_line(col="grey", alpha=0.7)+ theme_bw()+ facet_wrap(~Age)+ geom_line(aes(y=Deaths2020, col="2020"), size=1.5, alpha=0.7)+ geom_line(aes(y=Deaths_mean, col="Average"), size=1.5, alpha=0.7)+ scale_color_manual("Anno", labels=c("2020", "Average"), values=c("darkred", "black"))+ labs(x="Settimana", y="", title="Mortalità in eccesso", subtitle=glue('Anno 2020, {label}'), caption="Dati: Human Mortality Database") } ``` --- ```r plot_excess_mortality(country="USA") ``` <img src="lezione14_files/figure-html/unnamed-chunk-22-1.png" width="60%" /> --- ## Recent Gains in Life Expectancy Reversed by the COVID-19 Pandemic ### (Aburto et al. 2021) <img src="images/ex2020_preprint_version_03032021.pdf" alt=""> --- # Carico Dataset ```r df_ex<-read_rds("data/df_ex.rds") glimpse(df_ex) ``` ``` ## Rows: 4,644 ## Columns: 15 ## $ code <chr> "AT", "AT", "AT… ## $ sex <chr> "Female", "Fema… ## $ year <int> 2020, 2020, 202… ## $ age <dbl> 0, 1, 2, 3, 4, … ## $ ex <dbl> 83.64713, 82.76… ## $ ex_diff <dbl> -0.6713147, -0.… ## $ ex_diff_1519 <dbl> 0.4902072, 0.44… ## $ ex_2015 <dbl> 83.82824, 82.96… ## $ ex_2019 <dbl> 84.31844, 83.41… ## $ ex_2020 <dbl> 83.64713, 82.76… ## $ name <chr> "Austria", "Aus… ## $ code_hmd <chr> "AUT", "AUT", "… ## $ rank_e0f19 <int> 18, 18, 18, 18,… ## $ rank_d0m20 <int> 16, 16, 16, 16,… ## $ avg_ex_diff_1519 <dbl> 0.1225518, 0.11… ``` --- # Dati aspettativa di vita ```r df_e0<- df_ex %>% filter(age==0 ) glimpse(df_e0) ``` ``` ## Rows: 54 ## Columns: 15 ## $ code <chr> "AT", "AT", "BE… ## $ sex <chr> "Female", "Male… ## $ year <int> 2020, 2020, 202… ## $ age <dbl> 0, 0, 0, 0, 0, … ## $ ex <dbl> 83.64713, 79.26… ## $ ex_diff <dbl> -0.6713147, -0.… ## $ ex_diff_1519 <dbl> 0.4902072, 0.88… ## $ ex_2015 <dbl> 83.82824, 79.18… ## $ ex_2019 <dbl> 84.31844, 80.07… ## $ ex_2020 <dbl> 83.64713, 79.26… ## $ name <chr> "Austria", "Aus… ## $ code_hmd <chr> "AUT", "AUT", "… ## $ rank_e0f19 <int> 18, 18, 16, 16,… ## $ rank_d0m20 <int> 16, 16, 8, 8, 2… ## $ avg_ex_diff_1519 <dbl> 0.12255179, 0.2… ``` --- ```r # figrue 1 -- absolute levels of life expectancy -------------------------- df_ex0<-df_ex %>% mutate( name = name %>% # asterix for Germany and Chile str_replace("Chile", "Chile*") %>% str_replace("Germany", "Germany*") %>% as_factor() %>% fct_reorder(rank_e0f19)) ``` --- ```r df_ex1<-df_ex0 %>% filter(age %in% c(0, 60)) %>% drop_na(name) %>% transmute( name, sex, age, ex_2015, ex_2019, ex_2020 = ex ) ``` --- ```r df_ex2<-df_ex1%>% pivot_longer( cols = ex_2015:ex_2020, names_to = "year", values_to = "ex", names_prefix = "ex_") %>% mutate(age = age %>% as_factor()) ``` --- ```r fig1<-df_ex2%>% ggplot(aes(ex, name, color = sex, shape = year, size = year))+ geom_hline(yintercept = seq(2, 26, 2), size = 5, color = "#eaeaea")+ geom_point()+ scale_shape_manual(values = c(124, 43, 16))+ scale_size_manual(values = c(4, 4, 1.5))+ scale_color_manual(values = c("#B5223BFF", "#64B6EEFF"))+ scale_y_discrete(position = "right")+ scale_x_continuous(position = "top")+ facet_grid(~age, scales = "free_x")+ theme( legend.position = "none", panel.grid.major.y = element_blank(), panel.grid.minor.y = element_blank(), strip.text = element_blank(), panel.spacing.x = unit(2, "lines"), axis.text.y = element_text(face = 2) )+ labs( x = "Life expectancy, years", y = NULL ) ``` --- ```r fig1 ``` <img src="lezione14_files/figure-html/unnamed-chunk-29-1.png" width="60%" /> ```r ggsave("Life_expectancy_diff.pdf" , width = 6, height = 4.5, device = cairo_pdf) ``` --- <img src="images/fig-1-ann.pdf" alt="">