Excess Deaths
by : Chris at Savvy Analytics
Background : Yes, this is yet another Covid dashboard. However, while there are many Covid dashboards, many of them fail to put the scale of the pandemic in perspective over time and across countries.
Goal : Positive cases can be skewed by the availability of testing. Likewise the success of the vaccines are muted when you have a positive test with benign symptoms.
Therefore as depressing as it is to report on deaths, I think they present the best insight as to where we are with coping with the current pandemic.
Note : This article, like most of mine on R-Pubs, is both instructional and investigative. You can re-create any of these charts and tables from the embedded R code. Click the “Code” button to view.
The source for the data in this analysis is through the The Human Mortality Database who in turn directly source their data from the respective health organizations in each country. Those primary sources are cited at the bottom of this article.
# Load libraries
QuietLoad <- function(library) {
suppressWarnings(suppressPackageStartupMessages(
library(library, character.only=TRUE)))
}
# Load libraries
# Load libraries
QuietLoad('tidyverse')
QuietLoad('readxl')
QuietLoad('lubridate')
QuietLoad('scales')
QuietLoad('kableExtra')
QuietLoad('DBI')
QuietLoad('bigrquery')
# Load Human Mortality Data
MortalityRaw <- readr::read_csv("https://www.mortality.org/Public/STMF/Outputs/stmf.csv", skip=1,
col_types = "cddcddddddddddddddd")
CountryNames = tibble(
Country = c("AUS2", "AUT", "BEL", "BGR", "CAN", "CHE", "CHL", "CZE", "DEUTNP", "DNK", "ESP", "EST", "FIN", "FRATNP", "GBRTENW", "GBR_NIR", "GBR_SCO", "GRC", "HRV", "HUN", "ISL", "ISR", "ITA", "KOR", "LTU", "LUX", "LVA", "NLD", "NOR", "NZL_NP", "POL", "PRT", "RUS", "SVK", "SVN", "SWE", "TWN", "USA"),
CountryName = c("Australia", "Austria", "Belgium", "Bulgaria", "Canada", "Switzerland", "Chile", "Czech Republic", "Germany", "Denmark", "Spain", "Estonia", "Finland", "France", "England and Wales", "Northern Ireland", "Scotland", "Greece", "Croatia", "Hungary", "Iceland", "Israel", "Italy", "S. Korea", "Lithuania", "Luxembourg", "Latvia", "Netherlands", "Norway", "New Zealand", "Poland", "Portugal", "Russia", "Slovakia", "Slovenia", "Sweden", "Taiwan ", "USA"),
CountrySource = c("Australian Bureau of Statistics", "Statistik Austria", "STATBEL and Eurostat", "National Statistical Institute", "Statistics Canada", "Eurostat and Swiss Federal Statistical Office", "National Statistical Office", "Statistical Office and Eurostat", "Statistisches Bundesamt", "Statistics Denmark", "National Statistical Office", "Eurostat", "Statistics Finland", "INSERM", "Office for National Statistics, https://www.ons.gov.uk", "Eurostat", "National Statistical Office", "Eurostat", "Eurostat", "Eurostat", "Statistics Iceland", "Stat Office", "ISTAT", "Statistics Korea", "Statistics Lithuania", "Eurostat", "Statistical Bureau of Latvia", "Statistics Netherlands", "Statistics Norway", "Statistics New Zealand", "Eurostat", "Statistics Portugal (INE)", "ILPH", "Eurostat", "Eurostat", "Statistics Sweden", "Department of Statistics of the Ministry of the Interior", "Centers for Disease Control and Prevention, CDC, Influenza Division")
)
CountryNames = CountryNames%>%
mutate(RowID = row_number(),
GroupID = trunc(RowID / round(nrow(CountryNames) / 4)) + 1)
# Wrangle
MortalityDF <- MortalityRaw %>%
select(CountryCode:DTotal) %>%
pivot_longer(5:10,
names_to = "Age", values_to = "Deaths",
names_pattern = "[D_]*([a-z0-9_p]*)"
) %>%
rename(Country = CountryCode) %>%
filter(Age == "", Sex == "b") %>%
select(Year, Week, Country, Deaths) %>%
group_by(Country, Year) %>%
filter(!(Year==2020 & Week==max(Week))) %>%
left_join(CountryNames, by = c("Country"))
MortalityDF_Detailed <- MortalityRaw %>%
select(CountryCode:DTotal) %>%
pivot_longer(5:10,
names_to = "Age", values_to = "Deaths",
names_pattern = "[D_]*([a-z0-9_p]*)"
) %>%
rename(Country = CountryCode) %>%
filter(Age != "", Sex != "b") %>%
select(Year, Week, Country, Sex, Age, Deaths) %>%
filter(!(Year==2020 & Week==max(Week))) %>%
left_join(CountryNames, by = c("Country"))
BeforeCovid_Deaths <- MortalityDF %>%
filter(Year >= 2015 & Year <= 2019) %>%
group_by(Country, Week) %>%
summarise(Median_Deaths = median(Deaths), .groups = "drop")
BeforeCovid_Deaths_Detailed <- MortalityDF_Detailed %>%
filter(Year >= 2015 & Year <= 2019) %>%
group_by(Country, Week, Sex, Age) %>%
summarise(Median_Deaths = median(Deaths), .groups = "drop")
Excess_Deaths <- MortalityDF %>%
filter(Year >= 2015) %>%
left_join(BeforeCovid_Deaths, by = c("Week", "Country")) %>%
mutate(Excess = Deaths - Median_Deaths)
Excess_Deaths_Detailed <- MortalityDF_Detailed %>%
filter(Year >= 2015) %>%
left_join(BeforeCovid_Deaths_Detailed, by = c("Week", "Country", "Sex", "Age")) %>%
mutate(Excess = Deaths - Median_Deaths) %>%
select(Year, Week, Country, CountryName, CountrySource, Sex, Age, Median_Deaths, Deaths, Excess)
LastRefresh = paste0(year(Sys.Date()), " wk ", week(Sys.Date()), " at ",
Sys.time() %>% format("%m-%d %H:%M UDT"))
LatestData = max(paste0(MortalityDF$Year, " wk ", str_pad(MortalityDF$Week, 2, pad = "0")))The key to perspective is comparing to prior years and then normalizing.
In the chart below you can see the individual years from 2015 through 2019 charted in gray along with the mean value of those years expressed as the flat line through the middle of them. That mean value was scaled to zero and all other years are expressed as a +/- variance to that mean.
Using this method, we can see the absolute variance in deaths in 2020 and beyond. First, a look at the USA.
Excess_Deaths %>%
filter(Country %in% c("USA")) %>%
mutate(`2015-2019` = if_else(Year < 2020, Excess, as.numeric(NA)),
`2020` = if_else(Year == 2020, Excess, as.numeric(NA)),
`2021` = if_else(Year == 2021, Excess, as.numeric(NA))) %>%
ggplot(aes(Week, `2015-2019`, group=Year), color = "grey") +
geom_line(color = "gray", size = 2, na.rm = TRUE) +
geom_hline(yintercept=0, col='black') +
geom_line(aes(Week, `2020`), color = "red", size = 2, na.rm = TRUE) +
geom_line(aes(Week, `2021`), color = "blue", size = 2, na.rm = TRUE) +
facet_wrap(~ Country, scales='free_y') +
scale_y_continuous(label = comma) +
scale_x_continuous(breaks = c(seq(0,52, 3))) +
guides(col="none") +
theme_classic() +
labs(title = "Excess Deaths vs Median Deaths 2015-2019",
subtitle = "2021 (blue), 2020 (red), 2015-2019 (grey)",
x = "Week", y = "Deaths",
caption = paste0("Sources : US - CDC & NIH Other Countries - https://www.mortality.org/Public/STMF_DOC/STMFNote.pdf"))
Now we will look at the other countries with data reporting sufficiency.
Excess_Deaths %>%
filter(GroupID == 1) %>%
mutate(`2015-2019` = if_else(Year < 2020, Excess, as.numeric(NA)),
`2020` = if_else(Year == 2020, Excess, as.numeric(NA)),
`2021` = if_else(Year == 2021, Excess, as.numeric(NA))) %>%
ggplot(aes(Week, `2015-2019`, group=Year), color = "grey") +
geom_line(color = "gray", na.rm = TRUE) +
geom_hline(yintercept=0, col='black') +
geom_line(aes(Week, `2020`), color = "red", na.rm = TRUE) +
geom_line(aes(Week, `2021`), color = "blue", na.rm = TRUE) +
facet_wrap(~ CountryName, scales='free_y', ncol = 3) +
scale_y_continuous(label = comma) +
scale_x_continuous(breaks = c(seq(0,52, 3))) +
guides(col="none") +
theme_classic() +
labs(title = "Excess Deaths vs Median Deaths 2015-2019",
subtitle = "2021 (blue), 2020 (red), 2015-2019 (grey)",
x = "Week", y = "Deaths",
caption = paste0("Sources : US - CDC & NIH Other Countries - https://www.mortality.org/Public/STMF_DOC/STMFNote.pdf"))
Excess_Deaths %>%
filter(GroupID == 2) %>%
mutate(`2015-2019` = if_else(Year < 2020, Excess, as.numeric(NA)),
`2020` = if_else(Year == 2020, Excess, as.numeric(NA)),
`2021` = if_else(Year == 2021, Excess, as.numeric(NA))) %>%
ggplot(aes(Week, `2015-2019`, group=Year), color = "grey") +
geom_line(color = "gray", na.rm = TRUE) +
geom_hline(yintercept=0, col='black') +
geom_line(aes(Week, `2020`), color = "red", na.rm = TRUE) +
geom_line(aes(Week, `2021`), color = "blue", na.rm = TRUE) +
facet_wrap(~ CountryName, scales='free_y', ncol = 3) +
scale_y_continuous(label = comma) +
scale_x_continuous(breaks = c(seq(0,52, 3))) +
guides(col="none") +
theme_classic() +
labs(title = "Excess Deaths vs Median Deaths 2015-2019",
subtitle = "2021 (blue), 2020 (red), 2015-2019 (grey)",
x = "Week", y = "Deaths",
caption = paste0("Sources : US - CDC & NIH Other Countries - https://www.mortality.org/Public/STMF_DOC/STMFNote.pdf"))
Excess_Deaths %>%
filter(GroupID == 3) %>%
mutate(`2015-2019` = if_else(Year < 2020, Excess, as.numeric(NA)),
`2020` = if_else(Year == 2020, Excess, as.numeric(NA)),
`2021` = if_else(Year == 2021, Excess, as.numeric(NA))) %>%
ggplot(aes(Week, `2015-2019`, group=Year), color = "grey") +
geom_line(color = "gray", na.rm = TRUE) +
geom_hline(yintercept=0, col='black') +
geom_line(aes(Week, `2020`), color = "red", na.rm = TRUE) +
geom_line(aes(Week, `2021`), color = "blue", na.rm = TRUE) +
facet_wrap(~ CountryName, scales='free_y', ncol = 3) +
scale_y_continuous(label = comma) +
scale_x_continuous(breaks = c(seq(0,52, 3))) +
guides(col="none") +
theme_classic() +
labs(title = "Excess Deaths vs Median Deaths 2015-2019",
subtitle = "2021 (blue), 2020 (red), 2015-2019 (grey)",
x = "Week", y = "Deaths",
caption = paste0("Sources : US - CDC & NIH Other Countries - https://www.mortality.org/Public/STMF_DOC/STMFNote.pdf"))
Excess_Deaths %>%
filter(GroupID == 4) %>%
mutate(`2015-2019` = if_else(Year < 2020, Excess, as.numeric(NA)),
`2020` = if_else(Year == 2020, Excess, as.numeric(NA)),
`2021` = if_else(Year == 2021, Excess, as.numeric(NA))) %>%
ggplot(aes(Week, `2015-2019`, group=Year), color = "grey") +
geom_line(color = "gray", na.rm = TRUE) +
geom_hline(yintercept=0, col='black') +
geom_line(aes(Week, `2020`), color = "red", na.rm = TRUE) +
geom_line(aes(Week, `2021`), color = "blue", na.rm = TRUE) +
facet_wrap(~ CountryName, scales='free_y', ncol = 3) +
scale_y_continuous(label = comma) +
scale_x_continuous(breaks = c(seq(0,52, 3))) +
guides(col="none") +
theme_classic() +
labs(title = "Excess Deaths vs Median Deaths 2015-2019",
subtitle = "2021 (blue), 2020 (red), 2015-2019 (grey)",
x = "Week", y = "Deaths",
caption = paste0("Sources : US - CDC & NIH Other Countries - https://www.mortality.org/Public/STMF_DOC/STMFNote.pdf"))
Were you surprised at the fluctuations in some countries?
Will we see continued drops now that vaccines are widely available in much of the world?
CountryNames %>%
dplyr::select(-RowID, -GroupID) %>%
kable("html", escape = FALSE,
caption = '<p style="color:black; font-size:18px">Countries & Sources</p>') %>%
kable_styling("striped", font_size = 14,
bootstrap_options = c("striped", "hover", "condensed")) %>%
row_spec(0, color = "white", background = "black") | Country | CountryName | CountrySource |
|---|---|---|
| AUS2 | Australia | Australian Bureau of Statistics |
| AUT | Austria | Statistik Austria |
| BEL | Belgium | STATBEL and Eurostat |
| BGR | Bulgaria | National Statistical Institute |
| CAN | Canada | Statistics Canada |
| CHE | Switzerland | Eurostat and Swiss Federal Statistical Office |
| CHL | Chile | National Statistical Office |
| CZE | Czech Republic | Statistical Office and Eurostat |
| DEUTNP | Germany | Statistisches Bundesamt |
| DNK | Denmark | Statistics Denmark |
| ESP | Spain | National Statistical Office |
| EST | Estonia | Eurostat |
| FIN | Finland | Statistics Finland |
| FRATNP | France | INSERM |
| GBRTENW | England and Wales | Office for National Statistics, https://www.ons.gov.uk |
| GBR_NIR | Northern Ireland | Eurostat |
| GBR_SCO | Scotland | National Statistical Office |
| GRC | Greece | Eurostat |
| HRV | Croatia | Eurostat |
| HUN | Hungary | Eurostat |
| ISL | Iceland | Statistics Iceland |
| ISR | Israel | Stat Office |
| ITA | Italy | ISTAT |
| KOR | S. Korea | Statistics Korea |
| LTU | Lithuania | Statistics Lithuania |
| LUX | Luxembourg | Eurostat |
| LVA | Latvia | Statistical Bureau of Latvia |
| NLD | Netherlands | Statistics Netherlands |
| NOR | Norway | Statistics Norway |
| NZL_NP | New Zealand | Statistics New Zealand |
| POL | Poland | Eurostat |
| PRT | Portugal | Statistics Portugal (INE) |
| RUS | Russia | ILPH |
| SVK | Slovakia | Eurostat |
| SVN | Slovenia | Eurostat |
| SWE | Sweden | Statistics Sweden |
| TWN | Taiwan | Department of Statistics of the Ministry of the Interior |
| USA | USA | Centers for Disease Control and Prevention, CDC, Influenza Division |
Covid is a somber subject so in closing:
Protect yourself, live your life to its’ fullest and
Be savvy
Note : Data is automatically refreshed.
Source last checked on 2022 wk 24 at 06-15 10:22 UDT and the latest available data is 2022 wk 21