##########################################################################################
#                                                                                        #
#                                source.R, June 18th 2018                                #
#                                                                                        #
#              This command script generates the results in the manuscript               #
#                        for use with the statistical software R                         #
#                      (The R Foundation for Statistical Software)                       #
#                                                                                        #
#                                                                                        #
#                     Ralph Brinks, University Hospital Duesseldorf                      #
#                         ralph.brinks(at)med.uni-duesseldorf.de                         #
#                                                                                        #
#     This software comes "as is". No warranty of any kind is taken by the authors       #
#                          or any of the affiliated institutes.                         #
#                                                                                        #
##########################################################################################

rm(list=ls(all=TRUE))

##########################################################################################
#
# 1) Surveyed prevalence of hypertension based on NHANES
#
##########################################################################################


## Hypertension data from NHANES
# Trends in Prevalence, Awareness, Management, and Control of Hypertension Among United States Adults, 1999 to 2010
# by Fangjian Guo, Di He, Wei Zhang, R. Grace Walton
# J Am Coll Cardiol. 2012 Aug 14;60(7):599-606. doi: 10.1016/j.jacc.2012.04.026

# Years of NHANES surveys (midpoint of periods)
years   <- c(2000.0, 2002.0, 2004.0, 2006.0, 2008.0, 2010.0)
nYears  <- length(years)

# Ages of NHANES surveys (midpoint of age-groups)
ages    <- c(15, 30, 50, 70)
nAges   <- length(ages)

# Data: Hypertension (p1+p2) in percent, Tab. 3 in Guo et al
hyp     <- c(   rep(0, 6),                        # 15y
               7.6,  6.7,  7.2,  7.3,  8.2,  7.0, #20-39y
              30.2, 29.3, 33.1, 31.2, 32.2, 30.3, #40-59y
              66.1, 66.9, 67.2, 66.5, 66.5, 66.7) #60+

# Data: Awareness (w1) in percent, Tab. 4 in Guo et al
awa     <- c(   rep(0, 6),                        # 15y
              51.4, 50.0, 54.0, 52.4, 65.5, 58.8, #20-39y
              73.1, 72.1, 75.1, 79.2, 79.1, 84.1, #40-59y
              70.0, 73.4, 79.3, 81.9, 83.2, 84.0) #60+

hMat    <- matrix(data = 1e-2*hyp, nrow = nAges, ncol = nYears, byrow = TRUE) #p1+p2
aMat    <- matrix(data = 1e-2*awa, nrow = nAges, ncol = nYears, byrow = TRUE) #w1 = p2/(p1+p2)

p2      <- aMat * hMat # p2 = w1 * (p1 + p2)
p1      <- hMat - p2

set_splines <- function(p1_, p2_){
   sp1a <<- splinefun(ages,  p1_[,1], method="natural")
   sp1b <<- splinefun(ages,  p1_[,2], method="natural")
   sp1c <<- splinefun(ages,  p1_[,3], method="natural")
   sp1d <<- splinefun(ages,  p1_[,4], method="natural")
   sp1e <<- splinefun(ages,  p1_[,5], method="natural")
   sp1f <<- splinefun(ages,  p1_[,6], method="natural")

   sp2a <<- splinefun(ages,  p2_[,1], method="natural")
   sp2b <<- splinefun(ages,  p2_[,2], method="natural")
   sp2c <<- splinefun(ages,  p2_[,3], method="natural")
   sp2d <<- splinefun(ages,  p2_[,4], method="natural")
   sp2e <<- splinefun(ages,  p2_[,5], method="natural")
   sp2f <<- splinefun(ages,  p2_[,6], method="natural")
}

get_p1  <- function(time, age){
   y    <- numeric(6)
   y[1] <- sp1a(age)
   y[2] <- sp1b(age)
   y[3] <- sp1c(age)
   y[4] <- sp1d(age)
   y[5] <- sp1e(age)
   y[6] <- sp1f(age)
   sp   <- smooth.spline(years, y, df = 4)
   return(predict(sp, time)$y)
}

get_p2  <- function(time, age){
   y    <- numeric(6)
   y[1] <- sp2a(age)
   y[2] <- sp2b(age)
   y[3] <- sp2c(age)
   y[4] <- sp2d(age)
   y[5] <- sp2e(age)
   y[6] <- sp2f(age)
   sp   <- smooth.spline(years, y, df = 4)
   return(predict(sp, time)$y)
}

a.hd    <- 15:70
t.hd    <- seq(from = 1999, to = 2010, by = 1)

p1.hd   <- matrix(NA, nrow=length(t.hd), ncol = length(a.hd))
p2.hd   <- matrix(NA, nrow=length(t.hd), ncol = length(a.hd))

set_splines(p1, p2)

for(jj in 1:length(a.hd)){
    p1.hd[, jj] <-  get_p1(t.hd, a.hd[jj])
    p2.hd[, jj] <-  get_p2(t.hd, a.hd[jj])
}

# Figure 3 of the manuscript
#png("Figure3.png", width = 960, height = 960, pointsize=28) 
  par(mfrow = c(1, 2), las=1)
  image(x = t.hd, y = a.hd, z = 1e2*p1.hd, main="Undiagnosed",
        col = rainbow(255, start=.7, end=.1), xlab = "Year", ylab = "Age (years)", las=1)
  contour(x = t.hd, y = a.hd, z = 1e2*p1.hd, add = TRUE, labcex = 0.8)

  image(x = t.hd, y = a.hd, z = 1e2*p2.hd, main="Diagnosed",
        col = rainbow(255, start=.7, end=.1), xlab = "Year", ylab = "Age (years)", las=1)
  contour(x = t.hd, y = a.hd, z = 1e2*p2.hd, add = TRUE, labcex = 0.8)
#dev.off()

##########################################################################################
#
# 2) Modelled prevalence of hypertension
#
##########################################################################################

## Auxiliary functions: 
# rates for the four-state model
lambda_0 <- function(t, a){
    #fictious incidence rate of undiagnosed hypertension
    thisT  <- c(2000, 2003, 2010)
    Tvals  <- c(0.9,    1,   0.9)
    thisA  <- c(15,    20,    35,    50,    65,   75)
    Avals  <- c( 0, 0.003, 0.008, 0.022, 0.052, 0.09)
    value_ <- approx(thisA, Avals, a, rule = 2)$y * approx(thisT, Tvals, t, rule = 2)$y
    return(value_)
}

lambda_1 <- function(t, a){
    #fictious rate of diagnosing hypertension
    thisT  <- c(2000, 2003, 2008, 2012)
    Tvals  <- c( 0.5,    1,    1, 0.75)
    thisA  <- c(15,   20, 47,  75)
    Avals  <- c( 0, 0.25,  1, 0.65)
    value_ <- 0.30 * approx(thisA, Avals, a, rule = 2)$y * approx(thisT, Tvals, t, rule = 2)$y
    return(value_)
}

# fictious prevalence of undiagnosed (p1) and diagnosed (p2) hypertension in 1999
get_p0  <- function(a){
   # fictious prevalence of hypertension in 1999
   thisA  <- c(15,    30,    50,   70)
   p1Vals <- c( 0, 0.039, 0.081,  0.2)
   p2Vals <- c( 0, 0.045, 0.23 ,  0.44)
   p1_ <- approx(thisA, p1Vals, a, rule = 2)$y #undiagnosed
   p2_ <- approx(thisA, p2Vals, a, rule = 2)$y #diagnosed
   return(c(p1_, p2_))
}

mort <- function(t, a){
   # general mortality total population 1990-2012 in US, t = 2000 means year 2000
   # Source: Human Mortality Database. University of California, Berkeley (USA), 
   # and Max Planck Institute for Demographic Research (Germany). 
   # Available at www.mortality.org or www.humanmortality.de, data downloaded on Mar 29, 2017

   alpha_ <- 14.47584906
   beta_  <-  0.07281751 
   gamma_ <- -0.01171214
   return(exp(alpha_ + beta_ * a + gamma_ * t))
}

rhs <- function(t_, y, parms) 
{
   # right hand side of the differential equation
   with(as.list(parms), 
   {
      t  <- ts + t_
      a  <- as + t_
      l0 <- lambda_0(t, a) 
      l1 <- lambda_1(t, a)
      m  <- mort(t, a)
      m1 <- 1.1 * m 
      m2 <- 1.2 * m

      # next line is the differential equation
      dy <- c( -((l1+l0)+(m1-m))*y[1] -     l0*y[2] + l0,
                              l1*y[1] - (m2-m)*y[2])
      list(dy)
   }   
       )
}
#end: auxiliary functions


# start solving system of PDEs
require(deSolve)

age   <- 0:70
years <- 1999 + 0:11
prev1 <- matrix(data = 0, nrow = length(age), ncol = length(years))
prev2 <- matrix(data = 0, nrow = length(age), ncol = length(years))


#needs about five seconds
for(a0 in age){
   parms <- c(ts = 1999, as = a0)
   t_    <- seq(0, 11, by = 0.5)
   y_    <- get_p0(a0)
   x     <- c(p = y_)
   out   <- as.data.frame(deSolve::rk4(x, t_, rhs, parms))
   for(ii in 1:12){
      if(a0+ii > nrow(prev1)) break
      prev1[a0+ii, ii] <- out$p1[1+(ii-1)*2]
      prev2[a0+ii, ii] <- out$p2[1+(ii-1)*2]
   }
}

# Figure 4 of the manuscript
#png("Figure4.png", width = 960, height = 960, pointsize=28) 
  par(mfrow = c(1, 2), las=1)
  image(x = years, y = age[-(1:15)], z = 1e2*t(prev1[-(1:15), ]), main="Undiagnosed",
        col = rainbow(255, start=.7, end=.1), xlab = "Year", ylab = "Age (years)", las=1)
  contour(x = years, y = age[-(1:15)], z = 1e2*t(prev1[-(1:15), ]), add = TRUE, labcex = 0.8)

  image(x = years, y = age[-(1:15)], z = 1e2*t(prev2[-(1:15), ]), main="Diagnosed",
        col = rainbow(255, start=.7, end=.1), xlab = "Year", ylab = "Age (years)", las=1)
  contour(x = years, y = age[-(1:15)], z = 1e2*t(prev2[-(1:15), ]), add = TRUE, labcex = 0.8)
#dev.off()



# Figure 5 of the manuscript
#png("Figure5.png", width = 960, height = 960, pointsize=28)
  par(mfrow = c(1, 2), las=1)

  matplot(15:70, 1e2*prev1[-(1:15), 11], type="l", xlab="Age (years)", 
           ylab = "Prevalence (%)", main = "Undiagnosed", ylim=c(0, 12), lty = 2)
  matplot(15:70, 1e2*p1.hd[12, ], type="l", lty=1, col="blue", add = TRUE)
  legend("topleft", legend=c("Model", "Survey"), lty = c(2, 1), col=c("black", "blue"))

  matplot(15:70, 1e2*prev2[-(1:15), 11], type="l", xlab="Age (years)", 
           ylab = "Prevalence (%)", main = "Diagnosed", ylim=c(0, 60), lty = 2)
  matplot(15:70, 1e2*p2.hd[12, ], type="l", lty=1, col="blue", add = TRUE)
  legend("topleft", legend=c("Model", "Survey"), lty = c(2, 1), col=c("black", "blue"))
#dev.off()