R/fit_CBD_M5.R

In BayesMoFo: Bayesian Mortality Forecasting

#' A function to fit the stochastic mortality model "M5".
#'
#' Carry out Bayesian estimation of the stochastic mortality model referred to as \bold{"M5"} under the formulation of Cairns et al. (2009).
#' 
#' The model can be described mathematically as follows:
#' If \code{family="poisson"}, then
#' \deqn{d_{x,t,p} \sim \text{Poisson}(E^c_{x,t,p} m_{x,t,p}) , }
#' \deqn{\log(m_{x,t,p})=k^1_{t,p} + k^2_{t,p}(x-\bar{x}) , }
#' where \eqn{\bar{x}} is the mean of \eqn{x},
#' \eqn{d_{x,t,p}} represents the number of deaths at age \eqn{x} in year \eqn{t} of stratum \eqn{p},
#' while \eqn{E^c_{x,t,p}} and \eqn{m_{x,t,p}} represents respectively the corresponding central exposed to risk and central mortality rate at age \eqn{x} in year \eqn{t} of stratum \eqn{p}.
#' Similarly, if \code{family="nb"}, then a negative binomial distribution is fitted, i.e.
#' \deqn{d_{x,t,p} \sim \text{Negative-Binomial}(\phi,\frac{\phi}{\phi+E^c_{x,t,p} m_{x,t,p}}) , }
#' \deqn{\log(m_{x,t,p})=k^1_{t,p} + k^2_{t,p}(x-\bar{x}) , }
#' where \eqn{\phi} is the overdispersion parameter. See Wong et al. (2018).
#' But if \code{family="binomial"}, then 
#' \deqn{d_{x,t,p} \sim \text{Binomial}(E^0_{x,t,p} , q_{x,t,p}) , }
#' \deqn{\text{logit}(q_{x,t,p})=k^1_{t,p} + k^2_{t,p}(x-\bar{x}) , }
#' where \eqn{q_{x,t,p}} represents the initial mortality rate at age \eqn{x} in year \eqn{t} of stratum \eqn{p},
#' while \eqn{E^0_{x,t,p}\approx E^c_{x,t,p}+\frac{1}{2}d_{x,t,p}} is the corresponding initial exposed to risk.
#' No constraints are needed.
#' If \code{forecast=TRUE}, then the following time series models are fitted on \eqn{k^1_{t,p}} as follows:
#' \deqn{k^1_{t,p} = \eta^1_1+\eta^1_2 t +\rho (k^1_{t-1,p}-(\eta^1_1+\eta^1_2 (t-1))) + \epsilon^1_{t,p} \text{ for }p=1,\ldots,P \text{ and } t=1,\ldots,T,}
#' where \eqn{\epsilon^1_{t,p}\sim N(0,(\sigma^1)_k^2)} for \eqn{t=1,\ldots,T}, while \eqn{\eta^1_1,\eta^1_2,\rho^1,(\sigma^1)_k^2} are additional parameters to be estimated.
#' Similarly for \eqn{k^2_{t,p}}. Note that the forecasting models are inspired by Wong et al. (2023).
#' 
#' @references Cairns, A. J. G., Blake, D., Dowd, K., Coughlan, G. D., Epstein, D., Ong, A., and Balevich, I. (2009). A Quantitative Comparison of Stochastic Mortality Models Using Data From England and Wales and the United States. North American Actuarial Journal, 13(1), 1–35. \doi{https://doi.org/10.1080/10920277.2009.10597538}
#' @references Jackie S. T. Wong, Jonathan J. Forster, and Peter W. F. Smith. (2018). Bayesian mortality forecasting with overdispersion, Insurance: Mathematics and Economics, Volume 2018, Issue 3, 206-221. \doi{https://doi.org/10.1016/j.insmatheco.2017.09.023}
#' @references Jackie S. T. Wong, Jonathan J. Forster, and Peter W. F. Smith. (2023). Bayesian model comparison for mortality forecasting, Journal of the Royal Statistical Society Series C: Applied Statistics, Volume 72, Issue 3, 566–586. \doi{https://doi.org/10.1093/jrsssc/qlad021}
#' 
#' @param death death data that has been formatted through the function \code{preparedata_fn}.
#' @param expo expo data that has been formatted through the function \code{preparedata_fn}.
#' @param n_iter number of iterations to run. Default is \code{n_iter=10000}. 
#' @param family a string of characters that defines the family function associated with the mortality model. "poisson" would assume that deaths follow a Poisson distribution and use a log link; "binomial" would assume that deaths follow a Binomial distribution and a logit link; "nb" (default) would assume that deaths follow a Negative-Binomial distribution and a log link.
#' @param n.chain number of parallel chains for the model.
#' @param thin thinning interval for monitoring purposes.
#' @param n.adapt the number of iterations for adaptation. See \code{?rjags::adapt} for details.
#' @param forecast a logical value indicating if forecast is to be performed (default is \code{FALSE}). See below for details.
#' @param h a numeric value giving the number of years to forecast. Default is \code{h=5}.
#' @param quiet if TRUE then messages generated during compilation will be suppressed, as well as the progress bar during adaptation.
#' @return A list with components:
#' \describe{
#'   \item{\code{post_sample}}{An \code{mcmc.list} object containing the posterior samples generated.}
#'   \item{\code{param}}{A vector of character strings describing the names of model parameters.}
#'   \item{\code{death}}{The death data that was used.}
#'   \item{\code{expo}}{The expo data that was used.}
#'   \item{\code{family}}{The family function used.}
#'   \item{\code{forecast}}{A logical value indicating if forecast has been performed.}
#'   \item{\code{h}}{The forecast horizon used.}
#' }
#' @keywords bayesian estimation models
#' @concept stochastic mortality models
#' @concept parameter estimation
#' @concept CBD_M5
#' @importFrom stats dnbinom dbinom dpois quantile sd
#' @export
#' @examples
#' #load and prepare mortality data
#' data("dxt_array_product");data("Ext_array_product")
#' death<-preparedata_fn(dxt_array_product,strat_name = c("ACI","DB","SCI"),ages=35:65)
#' expo<-preparedata_fn(Ext_array_product,strat_name = c("ACI","DB","SCI"),ages=35:65)
#' 
#' #fit the model (poisson family)
#' #NOTE: This is a toy example, please run it longer in practice.
#' fit_CBD_M5_result<-fit_CBD_M5(death=death,expo=expo,n_iter=50,n.adapt=50,family="poisson")
#' head(fit_CBD_M5_result)

fit_CBD_M5<-function(death,expo,n_iter=10000,family="nb",n.chain=1,thin=1,n.adapt=1000,forecast=FALSE,h=5,quiet=FALSE){
  
  p<-death$n_strat
  A<-death$n_ages
  T<-death$n_years
  
  ages<-death$ages
  
  if (forecast){
    t<-(1:T)-mean(1:T)
    matrix_kappa_X<-matrix(c(rep(1,T+h),c(t,t[T]+1:h)),byrow=F,ncol=2)
    
    prior_prec_eta1<-solve(matrix(c(400,0,0,2),nrow=2));prior_mean_eta1<-c(0,0)
    prior_prec_eta2<-solve(matrix(c(400,0,0,2),nrow=2));prior_mean_eta2<-c(0,0)
    
    sigma2_kappa1<-100;sigma2_kappa2<-100
    
    death_forecast<-array(dim=c(p,A,T+h));expo_forecast<-array(dim=c(p,A,T+h))
    death_forecast[,,1:T]<-death$data
    death_forecast[,,(T+1):(T+h)]<-NA
    expo_forecast[,,1:T]<-expo$data
    expo_forecast[,,(T+1):(T+h)]<-expo$data[,,T]
    
    if (family=="binomial"){
      expo_forecast_initial<-expo_forecast
      expo_forecast_initial[,,1:T]<-round(expo_forecast[,,1:T,drop=FALSE]+0.5*death$data)
      expo_forecast_initial[,,(T+1):(T+h)]<-round(expo$data[,,T]+0.5*death$data[,,T])
      
      data<-list(dxt=death_forecast,ext=expo_forecast_initial,A=A,T=T,p=p,h=h,matrix_kappa_X=matrix_kappa_X,prior_mean_eta1=prior_mean_eta1,prior_prec_eta1=prior_prec_eta1,prior_mean_eta2=prior_mean_eta2,prior_prec_eta2=prior_prec_eta2,x=ages,xbar=mean(ages))
      inits<-function() (list(kappa1_rest_mat=matrix(0,nrow=p,ncol=T),kappa2_rest_mat=matrix(0,nrow=p,ncol=T),rho1=0.5,eta1=c(0,0),i_sigma2_kappa1=0.1,rho2=0.5,eta2=c(0,0),i_sigma2_kappa2=0.1))
      vars<-c("q","kappa1","kappa2","eta1","rho1","sigma2_kappa1","eta2","rho2","sigma2_kappa2")
      logit_CBD_M5_alt_forecast_jags<-rjags::jags.model(system.file("models/logit_CBD_M5_alt_forecast.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
      result_jags<-rjags::coda.samples(logit_CBD_M5_alt_forecast_jags,vars,n.iter=n_iter,thin=thin)
      
    }
    if (family=="poisson"){
      data<-list(dxt=death_forecast,ext=expo_forecast,A=A,T=T,p=p,h=h,matrix_kappa_X=matrix_kappa_X,prior_mean_eta1=prior_mean_eta1,prior_prec_eta1=prior_prec_eta1,prior_mean_eta2=prior_mean_eta2,prior_prec_eta2=prior_prec_eta2,x=ages,xbar=mean(ages))
      inits<-function() (list(kappa1_rest_mat=matrix(0,nrow=p,ncol=T),kappa2_rest_mat=matrix(0,nrow=p,ncol=T),rho1=0.5,eta1=c(0,0),i_sigma2_kappa1=0.1,rho2=0.5,eta2=c(0,0),i_sigma2_kappa2=0.1))
      vars<-c("q","kappa1","kappa2","eta1","rho1","sigma2_kappa1","eta2","rho2","sigma2_kappa2")
      log_CBD_M5_alt_forecast_jags<-rjags::jags.model(system.file("models/log_CBD_M5_alt_forecast.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
      result_jags<-rjags::coda.samples(log_CBD_M5_alt_forecast_jags,vars,n.iter=n_iter,thin=thin)
    }
    if (family=="nb"){
      data<-list(dxt=death_forecast,ext=expo_forecast,A=A,T=T,p=p,h=h,matrix_kappa_X=matrix_kappa_X,prior_mean_eta1=prior_mean_eta1,prior_prec_eta1=prior_prec_eta1,prior_mean_eta2=prior_mean_eta2,prior_prec_eta2=prior_prec_eta2,x=ages,xbar=mean(ages))
      inits<-function() (list(kappa1_rest_mat=matrix(0,nrow=p,ncol=T),kappa2_rest_mat=matrix(0,nrow=p,ncol=T),rho1=0.5,eta1=c(0,0),i_sigma2_kappa1=0.1,rho2=0.5,eta2=c(0,0),i_sigma2_kappa2=0.1,phi=100))
      vars<-c("q","kappa1","kappa2","eta1","rho1","sigma2_kappa1","eta2","rho2","sigma2_kappa2","phi")
      nb_CBD_M5_alt_forecast_jags<-rjags::jags.model(system.file("models/nb_CBD_M5_alt_forecast.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
      result_jags<-rjags::coda.samples(nb_CBD_M5_alt_forecast_jags,vars,n.iter=n_iter,thin=thin)
    }
  }
  
  if (!forecast){
    
    t<-(1:T)-mean(1:T)
    matrix_kappa_X<-matrix(c(rep(1,T),t),byrow=F,ncol=2)
    
    prior_prec_eta1<-solve(matrix(c(400,0,0,2),nrow=2));prior_mean_eta1<-c(0,0)
    prior_prec_eta2<-solve(matrix(c(400,0,0,2),nrow=2));prior_mean_eta2<-c(0,0)
    
    sigma2_kappa1<-100;sigma2_kappa2<-100
  
  data<-list(dxt=death$data,ext=expo$data,A=A,T=T,p=p,matrix_kappa_X=matrix_kappa_X,prior_mean_eta1=prior_mean_eta1,prior_prec_eta1=prior_prec_eta1,prior_mean_eta2=prior_mean_eta2,prior_prec_eta2=prior_prec_eta2,x=ages,xbar=mean(ages))
  inits<-function() (list(kappa1=matrix(0,nrow=p,ncol=T),kappa2=matrix(0,nrow=p,ncol=T),rho1=0.5,eta1=c(0,0),i_sigma2_kappa1=0.1,rho2=0.5,eta2=c(0,0),i_sigma2_kappa2=0.1))
  vars<-c("q","kappa1","kappa2","eta1","rho1","sigma2_kappa1","eta2","rho2","sigma2_kappa2")
  
  if (family=="binomial"){
    expo_initial<-round(expo$data+0.5*death$data)
    data<-list(dxt=death$data,ext=expo_initial,A=A,T=T,p=p,matrix_kappa_X=matrix_kappa_X,prior_mean_eta1=prior_mean_eta1,prior_prec_eta1=prior_prec_eta1,prior_mean_eta2=prior_mean_eta2,prior_prec_eta2=prior_prec_eta2,x=ages,xbar=mean(ages))
    logit_CBD_M5_jags<-rjags::jags.model(system.file("models/logit_CBD_M5.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
    result_jags<-rjags::coda.samples(logit_CBD_M5_jags,vars,n.iter=n_iter,thin=thin)
  }
  if (family=="poisson"){
    log_CBD_M5_jags<-rjags::jags.model(system.file("models/log_CBD_M5.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
    result_jags<-rjags::coda.samples(log_CBD_M5_jags,vars,n.iter=n_iter,thin=thin)
  }
  if (family=="nb"){
    inits<-function() (list(kappa1=matrix(0,nrow=p,ncol=T),kappa2=matrix(0,nrow=p,ncol=T),rho1=0.5,eta1=c(0,0),i_sigma2_kappa1=0.1,rho2=0.5,eta2=c(0,0),i_sigma2_kappa2=0.1,phi=100))
    vars<-c("q","kappa1","kappa2","eta1","rho1","sigma2_kappa1","eta2","rho2","sigma2_kappa2","phi")
    nb_CBD_M5_jags<-rjags::jags.model(system.file("models/nb_CBD_M5.jags",package="BayesMoFo"),data=data,inits=inits,n.chain=n.chain,n.adapt = n.adapt,quiet=quiet)
    result_jags<-rjags::coda.samples(nb_CBD_M5_jags,vars,n.iter=n_iter,thin=thin)
  }
  }
  
  list(post_sample=result_jags,param=vars[-1],death=death,expo=expo,family=family,forecast=forecast,h=h)
  
}