################################################################################
#                                                                              #
#   Supplement to Brinks, Toennies, Hoyer (2019): Estimating excess mortality  #
#                                                                              #
#               Script for use with the statistical software R                 #
#                                                                              #
################################################################################


rm(list=ls(all=TRUE))
library(pracma)

#######
#
# data for the illness-death model about dementia in European women
#
#######


# age groups in the surveys
ag.meas   <- seq(67.5, 92.5, by = 5)

# age-specific prevalence of (diagnosed) dementia in women (Lobo 2000, values below Figure 1)
fct_p0 <- function(a){
   p.meas <- log(1e-2*c( 1.0, 3.1, 6.0, 12.6, 20.2, 30.8))
   value_ <- approx(ag.meas, p.meas, a, rule = 2)$y
   return(exp(value_))
}

# incidence of (diagnosed) dementia in women (Fratiglioni 2000, Table 3)
inc.meas  <- 1e-3*c( 2.5, 4.7, 17.5, 34.1, 53.8, 81.7)
mod.i     <- lm(log(inc.meas) ~ ag.meas)

fct_i <- function(t, a){
   value_ <- mod.i$coeff[1] + mod.i$coeff[2]*a
   return(exp(value_))
}

# approximated mortality in women without dementia (Gompertz-Makeham Law)
fct_m0 <- function(t, a){
   return(exp(-9.5 + 0.1*a + t*log(0.99)))
}

# approximated mortality in women WITH dementia (Gompertz-Makeham Law)
fct_m1 <- function(t, a){
   R_ <- exp(approx(c(60, 95), log(c(3, 1.5)), rule = 2, xout = a)$y)
   return(R_ * fct_m0(t, a))
}

#######
#
# routines to calculate prevalence-odds according to Equation (6) of the main text
#
#######

# integrand of phi_{t,a}(x)
fct_integrand_phi <- function(tau, tt, aa, xx){
   return(
            fct_m1(tt - xx + tau, aa - xx + tau) - 
            fct_i (tt - xx + tau, aa - xx + tau) -
            fct_m0(tt - xx + tau, aa - xx + tau)
         )
}

# phi_{t,a}(x)
fct_phi <- function(x_, t_, a_){
   return(romberg(fct_integrand_phi, 0, x_, tt = t_, aa = a_, xx = x_, tol=1e-5)$value)
}

# integrand in Equation (6)
fct_integrand <- function(s_, t_, a_){
   return(fct_i(t_ - s_, a_ - s_) * exp( - fct_phi(s_, t_, a_)))
}

# prevalence odds, Equation (6) of the main text
fct_po <- function(t, a){
  cc_ <- romberg(fct_integrand, 0, a, t_ = t, a_ = a, tol=1e-5)$value
  return(cc_)
}


# Plot simulated prevalence in 1990 (t = 90) and 2010 (t = 110), and compare to surveyed values in 2000
aa  <- seq(65, 93, by = 2)
th1 <- sapply(aa, FUN = fct_po, t =  90) # year 1990
th2 <- sapply(aa, FUN = fct_po, t = 110)

matplot(aa, th2/(1+th2), type = "l", lwd=2, col="black", ylab = expression(paste("Prevalence  ", italic(p))), las = 1, lty = 1, xlab = "Age (years)")
matplot(aa, th1/(1+th1), type = "l", lwd=2, col="black", lty = 2,  add = TRUE)
matplot(ag.meas, fct_p0(ag.meas),  type = "p", lwd=2, pch = 16, col="blue", lty = 2,  add = TRUE)

legend("topleft", legend = c("Simulation year 2010", "Simulation year 1990", "Survey year 2000"),  
                     col = c("black",                 "black",                "blue"), 
                     lty = c(1, 2, NA), pch = c(NA, NA, 16), lwd = c(2, 2, NA))


#######
#
# assess quality of direct estimattion via Equation (4) of the main text
#
#######


ag.est           <- seq(65, 95, by = 5)
list.dT          <- c(0.1, 0.5, 1, 3, 5, 10)
HR.est           <- matrix(data = NA, nrow = length(ag.est), ncol = length(list.dT))
rownames(HR.est) <- as.vector(outer("age  ", as.character(ag.est ), FUN = paste, sep = ""))
colnames(HR.est) <- as.vector(outer("dT = ", as.character(list.dT), FUN = paste, sep = ""))

#true values for comparison
R.true           <- exp(approx(c(60, 95), log(c(3, 1.5)), rule = 2, xout = ag.est)$y)
matR.true        <- as.matrix(R.true) %*% rep(1, length(list.dT))

for(idx.dT in 1:length(list.dT)){
   dT <- list.dT[idx.dT]
   # simulated prevalence-odds in t1 and t2
   po1.ext         <- sapply(ag.est-dT/2, FUN = fct_po, t = 100-dT/2) # t1 = 2000 - dT/2
   po2.ext         <- sapply(ag.est+dT/2, FUN = fct_po, t = 100+dT/2) # t2 = 2000 - dT/2

   #convert back to prevalence
   p1              <- po1.ext/(1+po1.ext)
   p2              <- po2.ext/(1+po2.ext)

   inc             <- fct_i(100, ag.est)
   dp              <- (p2 - p1)/dT 
   pp              <- (p1 + p2)/2

   delta.m         <- (inc - dp/(1-pp))/pp
   m0              <- fct_m0(100, ag.est)
   HR.est[,idx.dT] <- 1 + delta.m/m0
}

cbind(R.true, HR.est)
round(100*(HR.est-matR.true)/matR.true, 2)