Over the course of the pandemic, were countries with lower life expectancies hit harder by COVID-19 than countries with higher life expectancies?

We made 4 graphs to give insight to this relationship.

  1. Time Series
  • Average number of deaths each week over the past year grouped by life expectancy (4 groups)
  1. Diverging bar chart
  • z-scores of life expectancy above/below average per country with Covid-19 deaths per 100k
  1. Bar chart
  • The average cumulative deaths per 100k for each of the 4 life expectancy groups
  1. Animation
  • A comparison of median age to Covid-19 deaths over the past year

Before we started graphing:

  • Import Libraries

  • Import Data

    • World Life Expectancy
    • Country Codes
    • Global Covid-19 Cases
    • Global Covid-19 Deaths
    • Population by age for all countries (UN), Data
    • Population median age for all countries (UN), Data

  • Clean Data

  • Joining the tables

  • Standardize population/cases/deaths

Now for the graphs:

1. Time series and bar chart

Graph A shows the mean cumulative deaths over the weeks for countries split into 4 general life expectancy groups. Graph B shows the average deaths in each life expectancy group on April 12, 2021.

Both graphs show a higher correlation between death from Covid-19 and higher life expectancy.

So, to answer the central question the answer is a preliminary no, countries with lower life expectancy appear to not be more severely impacted by Covid-19.

# PLOT 1:
plot1<- ggplot(average_over_time, aes(x = Date, y = quart_avg)) +
  labs(y="Deaths (per 100k)") +
  geom_col(aes(fill = average_over_time$quart_avg)) +
  ggtitle("Mean Cummulative Deaths vs Life Expectancy by Quartiles") + 
  theme(strip.text = element_text( size = 10, color = "white", hjust = 0.5 ),
    strip.background = element_rect( fill = "#858585", color = NA ),    
    panel.background = element_rect( fill = "#efefef", color = NA ),
    panel.grid.major.x = element_blank(),
    panel.grid.minor.x = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_line( color = "white" ),
    panel.spacing.x = unit( 0.5, "cm" ),
    panel.spacing.y = unit( 0.5, "cm" ),
    legend.position = "none", 
    axis.text.x=element_text(angle=30, hjust=1),
    axis.title.x = element_blank()) +
  facet_wrap(~Quartile, labeller = as_labeller(label_names), ncol=2)


covid_most_recent <- covid_summary_ratios %>%
  filter(Date == "2021-04-12")

m3 <- round(aggregate(covid_most_recent$deaths_per_100k, by=list(LE_group=covid_most_recent$Quartile), FUN = mean),0)
m3 <- as.data.frame(m3)
names(m3) <- c("LE_group", "avg_deaths_100k")

#PLOT 2:
gg <- ggplot(m3, aes(x = factor(LE_group), y = avg_deaths_100k)) + 
geom_col(fill="lightblue") +
geom_text(aes(label = avg_deaths_100k), vjust = -0.5) +
  labs(title= "Average Cummulative Deaths per 100K by Life Expectancy Quartiles",
       x="Life Expectancy Groups", y="Cumulative Deaths (per 100k)") +
  theme(legend.position = "none") + 
  scale_x_discrete(labels=c("1" = "Lowest", "2" = "Lower",
                              "3" = "Higher", "4" = "Highest")) +
  theme_classic()
cowplot::plot_grid(plot1, gg , labels = "AUTO")

2. Diverging bar chart

In order to get a more granular look at the data, this graph shows how individual countries have fared with regard to their Covid-19 deaths and their life expectancy.

The main observation is that countries with higher life expectancy have experienced higher deaths from Covid-19, although there are exceptions.

ggplot(covid_summary_ratios, aes(x=reorder(Country,LE_z), y=LE_z, fill = factor(Quartile), label=LE_z)) + 
  geom_bar(stat='identity') +
  stat_summary(mapping = aes(x = reorder(Country, LE_z), y = deaths_per_100k, alpha = "Deaths Per 100k"),
               fun = max, geom = "col", inherit.aes = FALSE) +
  scale_alpha_manual(name = "Covid Deaths", values= c(.5,.5)) +
  scale_fill_brewer(type = "div", palette = "Pastel2", labels = label_names) +
  labs(title= "Have countries with higher life expectancy fared better with Covid-19 deaths around the world?",
       y = "Normalized life expectancy and Cumulative Deaths per 100K Population",
       x = "Country",
       fill = "Life Expectancy Quartiles") +
  theme_classic() +
  guides(fill = guide_legend(reverse=TRUE))+
  theme(text = element_text(size=8),
        axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank(),
        axis.line.x = element_blank()) +
  theme(plot.title = element_text(hjust = .5, size = 12)) +
   coord_flip()

4. Animation

We wanted to look at this relationship over time. And whether this relationship bears through when looking at median age of countries.

And this graph seems to show this relationship to be the case. An interesting observation from this animation is that you can discern the “waves” of deaths that impacted different parts of the world.

#         Country            Date          Deaths           Cases            Code 
#     "character"          "Date"       "numeric"       "numeric"     "character" 
#        x0_39yrs       x40_65yrs       OVER65yrs              LE        Quartile 
#       "numeric"       "numeric"       "numeric"       "numeric"       "integer" 
#         med_age            LE_z         LE_type    young_to_old       total_pop 
#     "character"       "numeric"     "character"       "numeric"       "numeric" 
# deaths_per_100k  cases_per_100k 
#       "numeric"       "numeric"

# Animated plot
animation <- ggplot(
  covid_summary_ratios, 
  aes(y = deaths_per_100k, 
      x = round(med_age,2), 
      size = total_pop, 
      colour = factor(Quartile))) +
  geom_text(aes(label = Code), hjust= -.4, vjust=.5, angle =90)+
  geom_point(alpha = 0.7, show.legend = TRUE) +
  scale_colour_manual(values = c("#8DD3C7", "#FDCDAC", "#BEBADA", "#FA9FB5"), 
                      name = "Life Expectancy Group",
                      labels = label_names) +
  scale_size(range = c(2, 12)) +
  theme(plot.caption = element_text(size = 18),
        text = element_text(size = 20)) +
  #gg animate specific details
  labs(title = "Week: {frame_time}", 
       x = "Median Age", 
       y = "Deaths per 100K",
       caption = "Bubble size is proportional to population\nBubble colors indicate life expectancy quartile group") +
  guides(size = FALSE) +
  transition_time(Date) +
  ease_aes("linear") +
  theme_classic()
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
animate(animation, nframes = 100, fps = 10, width = 1300, height = 800, end_pause = 30)