R/mortality_tables.R

In o1i/UWS: Umwandlungssatz in der zweiten Säule

#' Project a life table
#'
#' \code{project_LC} adds additional years to a period life table using a
#' Lee-Carter model with a log-multiplicative scaling factor
#'
#' This function takes a life table in period form (age/years) and the result
#' of a Lee-Carter model and uses linear regression to get the slope of the
#' Kappa (time) parameter. The slope is multiplied by a constant factor and
#' applied as a factor (together with Beta) to the mortality of the last year in
#' the period life table.
#'
#' @param qx A life Table with ages as rows and years as columns. Must have row
#' and column names with the age/year numbers.
#' @param lc Lee-Carter fit (use e.g. the LifeMetrics function to fit). Must
#' have a \code{beta2} and \code{kappa2} component accessible by \code{$}.
#' @param factor A factor that is multiplied with the inferred slope of the
#' Kappas to project the mortality rates.
#' @param n_years The number of years to be projected ahead.
#' @return The Period life table, projected \code{n_years} into the future.
project_LC <- function(qx, lc, factor, n_years){
  stopifnot(nrow(qx) == length(lc$x))
  lastyear <- colnames(qx)[ncol(qx)]
  mx <- qx2mx(qx[, lastyear])
  slope <- lm(lc$kappa2 ~ lc$y)$coef[2] * factor
  add <- mx2qx(mx * exp(pmax(0, lc$beta2) %*% t(1:n_years * slope)))
  colnames(add) <- as.numeric(lastyear) + 1:n_years
  return(cbind(qx, add))
}



#' Period Life Table to Generational Table
#'
#' Transforms a period table to a generational life table. Only takes the
#' complete diagonal from the period table. Mortalities of generations that
#' appear in the period table that are to young or old to have all ages in the
#' table are discarded.
#'
#' @param qx A period life table (Age and Year) that is wider than long.
#' @return The generation life table (Age and Year of birth)
#'
#' @examples
#' per2gen(matrix(1:6/10, 2, 3, dimnames=list(60:61, 2010:2012)))
per2gen <- function(qx){
  stopifnot(ncol(qx) >= nrow(qx))
  n <- ncol(qx) - nrow(qx) + 1
  m <- nrow(qx)
  return(matrix(qx[cbind(rep(1:m, n), rep(0 : (m - 1), n) + rep(1:n, each=m))],
         nrow=m, ncol = n,
         dimnames=list(rownames(qx),
                       as.numeric(colnames(qx)[1:n]) -
                         as.numeric(rownames(qx)[1]))))
}

#' Convert mortality rates to probabilities of death.
#'
#' Converts \eqn{m_x} rates to \eqn{q_x} probabilities.
#'
#' @param mx A number or vector with central mortality rates. Must be
#' in \eqn{[0, Inf)]}
#' @return A number or vector of equal length with probabilities of death.
#'
#' @examples
#' mx2qx(0.2)
#' mx2qx(c(0.5, 2))
mx2qx <- function(mx){
  1-exp(-mx)
}

#' Convert probabilities of death to central mortality rates.
#'
#' Converts \eqn{q_x} probabilities to \eqn{q_x} rates.
#'
#' @param mx A number or vector with probabilities of death. Must be
#' in \eqn{[0, 1)}]}
#' @return A number or vector of equal length with central mortality rates
#'
#' @examples
#' qx2mx(0.2)
#' qx2mx(c(0.5, 0.999))
qx2mx <- function(qx){
  -log(1-qx)
}