Skip to content

Instantly share code, notes, and snippets.

@dreidpath
Last active June 19, 2023 06:03
Show Gist options
  • Save dreidpath/3f61613e1f0e6a4af1eec84d05c10fa0 to your computer and use it in GitHub Desktop.
Save dreidpath/3f61613e1f0e6a4af1eec84d05c10fa0 to your computer and use it in GitHub Desktop.
Use life tables to calculate the probability of dying between two ages (e.g., 76.5 and 88.2).
################################################################################
# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment