Use life tables to calculate the probability of dying between two ages (e.g., 76.5 and 88.2).

probability_of_death.R

################################################################################
# Using the US CDC life tables for White Males (2020), I wanted to estimate the 
# Probability that if Joe Biden or Donald Trump became the next US president
# They would die in office. The general approach could be used for any interval.
# The life tables can be found here: https://stacks.cdc.gov/view/cdc/118055
################################################################################

library(tidyverse)
library(lubridate)


#### Functions to estimate the probability of death over and arbitrary interval of years ####

## The functions low_prob() and high_prob() take the proportion of the part of a whole  
## year at age X to work out the probability of dying during that remaining period of the year.
## For example if the probability of dying at age 10-11 is .1 and the person is already
## 10 years and 6 months, then the probability of dying in the remaining 6 months is
## estimated as .05

# Calculate the probability of dying between age x.n and (x+1).0
lower_prob <- function(prob, start_age){
  (1-(start_age - floor(start_age))) * prob
}

# Calculate the probability of dying between age y.0 and y.n
upper_prob <- function(prob, end_age){
  (end_age - floor(end_age)) * prob
}

# Calculate the probability of dying between age x.n and y.n 
interval_death <- function(start_age, end_age, df){
  whole_years <- ceiling(start_age): floor(end_age-1)
  probabilities <- c(lower_prob(df$qx[floor(start_age)], start_age),
                     df$qx[whole_years],
                     upper_prob(df$qx[floor(end_age)], end_age))
  survival_probabilities <- 1 - probabilities
  interval_survival_probability <- prod(survival_probabilities)
  interval_death_probability <- 1 - interval_survival_probability
  return(interval_death_probability)
}



#### Setup the life tables ####

# Read in the white male life table data
url <- "https://ftp.cdc.gov/pub/Health_Statistics/NCHS/Publications/NVSR/71-01/Table17.xlsx"
destfile <- "Table17.xlsx"
curl::curl_download(url, destfile)
ltDF <- readxl::read_excel(destfile, skip = 2) %>%
  drop_na() %>%  # Drop the notes in the last two rows
  rename("age_cat" = `...1`) %>%
  mutate(age = 0:(nrow(ltDF) - 1))



#### Example Comparing Donald Trump and Joe Biden and their probabilities of
#### Dying between the start of the next presidential term and the end of the 
#### next presidential term

# Beginning and end of the next presidential term
term_start <- as_date("2025-01-20")
term_end <- as_date("2029-01-20")

# Birth dates of Biden and Trump
biden_dob <- as_date("1942-11-20")
trump_dob <- as_date("1946-06-14")

# Age of Biden and Trump at the beginning and end of the next presidential term
biden_start <- as.numeric(term_start - biden_dob)/365.25
biden_end <- as.numeric(term_end - biden_dob)/365.25
trump_start <- as.numeric(term_start - trump_dob)/365.25
trump_end <- as.numeric(term_end - trump_dob)/365.25


#### Calculate the probabilities of dying in office using the life tables ####
interval_death(trump_start, trump_end, ltDF)
interval_death(biden_start, biden_end, ltDF)