###---R CODE FOR THREE-LIST CAPTURE-RECAPTURE ANALYSIS-------------------------------###
#--------------------------------------------------------------------------------------#

# Written by Francesco Checchi (October 2008), partly based on code supplied by Patrick Ball (HRDAG)
# Revised by Francesco Checchi (March 2019)

###---PREPARATORY STEPS--------------------------------------------------------------###

  # Set working directory
  setwd("C:/Users/Francesco/Desktop/Sudan")

  # Clear workspace
  rm(list=ls(all=TRUE))

  # Install required packages if not already installed
  if(!require(MASS) ) {install.packages("MASS") }
  if(!require(BMA) ) {install.packages("BMA") }
  if(!require(leaps) ) {install.packages("leaps") }
  
  # Load required packages
  library("MASS")
  library("BMA")
  library("leaps")

  # Import data (one row = one death; columns indicate whether death is included on list 1 2, 3)
  dat <- read.csv("crc_sud_data_23Mar2019.csv", header=TRUE)
  
###---ANALYSE OVERLAP AMONG LISTS----------------------------------------------------###

  # Tabulate overlap among lists
  ol <- as.data.frame(xtabs(~dat[, 1] + dat[, 2]+ dat[, 3], data=dat) )
  colnames(ol)[1:3] <- colnames(dat)

  # Create three-list contingency table as an integer vector: x111, x110, x101, x100, x011, x010, x001
  ol.vector <- c(ol[8,4], ol[4,4], ol[6,4], ol[2,4], ol[7,4], ol[3,4], ol[5,4])

###---SELECT PARAMETERS FOR ANALYSIS-------------------------------------------------###
  
  # Choose plausibility cut-off criteria for models to be included in model averaging procedure
  plausibility.1<-100
    # meaning that if the model predicted x000 (m000) is more than X times the total number of #ascertained deaths,
    # the model is discarded (note: default of 100 essentially means only models that do not converge are discarded

  plausibility.2<-0.6
    # meaning that if the model has a Pearson Chi-square P-value>X it is discarded 
    # on grounds of possible overfitting (note: this is optional; setting it >=1 means no models are discarded)

###---FIT CANDIDATE LOG-LINEAR MODELS TO DATA----------------------------------------###

 ##---Preparatory steps---------------------------------------------------------------##
  
  # Attribute names to each model
  model.names<-c("no interactions","l1xl2","l1xl3","l2xl3","l1xl2,l1xl3","l1xl2,l2xl3","l1xl3,l2xl3","l1xl2,l1xl3,l2xl3")

  # Specify indicator values for the coefficients of the 8 different models
  x1 = c(1,1,1,1,0,0,0) # cases that appear on list 1
  x2 = c(1,1,0,0,1,1,0) # cases that appear on list 2
  x3 = c(1,0,1,0,1,0,1) # cases that appear on list 3
  x12 = ifelse(x1==1 & x2==1, 1, 0) # cases that appear on lists 1 and 2
  x13 = ifelse(x1==1 & x3==1, 1, 0) # cases that appear on lists 1 and 3
  x23 = ifelse(x2==1 & x3==1, 1, 0) # cases that appear on lists 2 and 3
  indepvars = cbind(x1, x2, x3, x12, x13, x23)
  rm(x1, x2, x3, x12, x13, x23)

  # Specify formulas for the 8 different models (starting with model without interactions, then adding different interaction terms)
  indep = "x ~ x1+x2+x3"
  formulas = c(
    indep,
    paste(indep, "x12", sep="+"),
    paste(indep, "x13", sep="+"), 
    paste(indep, "x23", sep="+"), 
    paste(indep, "x12", "x13", sep="+"), 
    paste(indep, "x12", "x23", sep="+"),
    paste(indep, "x13", "x23", sep="+"),
    paste(indep, "x12", "x13", "x23", sep="+"))
  rm(indep)

  # Function that fits a log-linear model given each possible formula (model specification)
  crc.models <- function(crc.data, formulas) {
    
    crc.data <- as.data.frame(cbind(indepvars, crc.data)) # associating data to each coefficient
    colnames(crc.data) <- c(colnames(crc.data)[1:6], "x")
    
    crc.glm <- function(formula){
      glm(formula=as.formula(formula), family=poisson(), data=crc.data, maxit=1000)
    } # sub-formula that fits log-linear model based on a given input formula
    
    models <- lapply(formulas, crc.glm) # apply sub-formula to all formulas
    return(models) # return output consisting of each fitted model
  }
  
  # Call the above function so as to fit the 8 models
  models <- crc.models(ol.vector, formulas)

 ##---Compute point estimates of uncaptured deaths for each candidate model------------##
  
  # Function to compute m000, the number of deaths not captured by any list, based on model coefficients
  m000.est<-function(pars){
    m111 <- prod(pars)
    m110 <- prod(pars[1], pars[2], pars[3], pars[5])
    m101 <- prod(pars[1], pars[2], pars[4], pars[6])
    m100 <- prod(pars[1], pars[2])
    m011 <- prod(pars[1], pars[3], pars[4], pars[7])
    m010 <- prod(pars[1], pars[3])
    m001 <- prod(pars[1], pars[4])
    m000 <- (m111 * m100 * m010 * m001) / (m110 * m101 * m011)
    invisible(round(m000))
  }
  
  # Dummy coefficients to denote each candidate model
  dummies <- as.data.frame(cbind(c(1,1,1,1,0,0,0), 
                                 c(1,1,1,1,1,0,0), 
                                 c(1,1,1,1,0,1,0), 
                                 c(1,1,1,1,0,0,1), 
                                 c(1,1,1,1,1,1,0), 
                                 c(1,1,1,1,1,0,1), 
                                 c(1,1,1,1,0,1,1), 
                                 c(1,1,1,1,1,1,1) )
                           )
  
  # Data frame to hold estimated model coefficients
  pars.point <- as.data.frame(array(0 , c(7, length(models))) )
  
  # For each model...
  for (i in 1:length(models)) {
    # For each coefficient...
    for (j in 1:length(dummies[[1]] )) {
          index <- sum(dummies[[i]][1:j])
          # extract exponentiated model coefficient values 
          pars.point[[i]][j] <- ifelse(dummies[[i]][j]==1, exp(models[[i]]$coefficients[index]), 1)
    }
  }

  # Vector to hold m000 point estimates for each model
  point.estimates <- rep(0, times=length(models))
  # For each model, compute m000 based on model coefficient values
  for (i in 1:length(models)) { point.estimates[i] <- m000.est(pars.point[[i]]) }
  

 ##---Compute profile 95% confidence intervals for m000 for each model--------------------##

  # Vector to hold exponentiated model coefficients (upper and lower profile confidence intervals)
  pars.lci <- as.data.frame(array(0, c(7, length(models)) ) )
  pars.uci <- as.data.frame(array(0, c(7, length(models)) ) )

  # Obtain profile CIs for each coefficient value for each model
  cis1 <- confint(models[[1]], level=0.95)
  cis2 <- confint(models[[2]], level=0.95)
  cis3 <- confint(models[[3]], level=0.95)
  cis4 <- confint(models[[4]], level=0.95)
  cis5 <- confint(models[[5]], level=0.95)
  cis6 <- confint(models[[6]], level=0.95)
  cis7 <- confint(models[[7]], level=0.95)
  cis8 <- confint(models[[8]], level=0.95)

  # List holding all the profile CIs for each model's coefficients
  cis<-list(cis1,cis2,cis3,cis4,cis5,cis6,cis7,cis8)

  # For each model...
  for(i in 1:length(models)) {
    
    # For each coefficient...
    for(j in 1:length(dummies[[1]])) {
      index <- sum(dummies[[i]][1:j])
      # exponentiate the lower CI coefficient value
      pars.lci[[i]][j]<-ifelse(dummies[[i]][j]==1, exp(cis[[i]][index]), 1)
    }
    
    # For each coefficient...
    for(j in 1:length(dummies[[1]])) {
      index <- sum(dummies[[i]]) + sum(dummies[[i]][1:j])
      # exponentiate the upper CI coefficient value
      pars.uci[[i]][j]<-ifelse(dummies[[i]][j]==1, exp(cis[[i]][index]), 1)
    }
  }

  # Vector to hold estimated m000 lower CI values for each model
  lcis<-rep(0,times=length(models))
  
  # Compute estimated lower CI values for each model
  for(i in 1:length(models)) {
    lcis[i] <- m000.est(pars.lci[[i]])
  }

  # Vector to hold estimated m000 upper CI values for each model
  ucis<-rep(0,times=length(models))
  
  # Compute estimated upper CI values for each model
  for(i in 1:length(models)) {
    ucis[i] <- m000.est(pars.uci[[i]])
  }  

 ##---Compute other statistics for each model---------------------------------------##
  
  # Degrees of freedom for each model
  dfs <- rep(0,times=length(models))
  for(i in 1:length(models)) {
    dfs[i] <- models[[i]]$df.residual
  }

  # Pearson Chi-square probabilities for each model
  pearson.chi.probs <- rep(0,times=length(models))
  for(i in 1:length(models)) {
    pearson.chi.probs[i] <- round(pchisq(models[[i]]$deviance, models[[i]]$df.residual, lower.tail=FALSE), digits=3)
  }

  for(j in 1:length(pearson.chi.probs)) {
    if (is.nan(pearson.chi.probs[j]) == TRUE) pearson.chi.probs[j]=1
  }

  #Bayesian Information Criterion for each model
  bics <- rep(0, times=length(models))
  for(i in 1:length(models)) {
    bics[i] <- models[[i]]$deviance - models[[i]]$df.residual * log(sum(ol.vector))}
   bics <- round(bics, digits=2)

  #Pearson-adjusted Chi square for each model
  pearsons <- rep(0, times=length(models))
  for(i in 1:length(models)){
  pearsons[i] <- round(models[[i]]$deviance / models[[i]]$df.residual, digits=2)
  }


###---BAYESIAN MODEL AVERAGING-------------------------------------------------------###
  
 ##---Select eligible models for averaging, based on plausibility criteria chosen-----##

  # Data frame of possible models
  possible.models <- data.frame(as.data.frame(rbind(
    c(1,1,1,0,0,0),
    c(1,1,1,1,0,0),
    c(1,1,1,0,1,0),
    c(1,1,1,0,0,1),
    c(1,1,1,1,1,0),
    c(1,1,1,1,0,1),
    c(1,1,1,0,1,1),
    c(1,1,1,1,1,1))),
    point.estimates,
    pearson.chi.probs,
    rep(1,times=length(models))
    )
  colnames(possible.models) <- c("x1", "x2", "x3", "x12", "x13", "x23", "point", "pchi", "eligible")
  
  # For each possible model...
  for(i in 1:length(possible.models$eligible)) {

    # check whether model output meets plausibility criteria
    if (possible.models$point[i] > (plausibility.1 * sum(ol.vector)) | possible.models$pchi[i] > plausibility.2) 
       possible.models$eligible[i] = 0
  }
  
  # Define which models are selected for BMA
  selected.models <- subset(possible.models, eligible==1, select=c(x1, x2, x3, x12, x13, x23))
  
  # Number of eligible models
  n.models <- sum(possible.models$eligible)
  
  
 ##---Re-fit eligible models using BMA package----------------------------------###

  # Call BMA package function to fit models for each eligible model 
  bma.output <- glib(y=ol.vector, x=indepvars, error="poisson", link="log", phi=1, models=selected.models)
  
  # Data.frame of selected models
  bma.dummies <- as.data.frame(rbind(rep(1, times=n.models), t(selected.models)))
  
  # Calculate posterior probabilities of averaged models from their BICs
    # note: not using values given by glib package but rather calculating based on Raftery (1995)
  
    # compute model degrees of freedom
    bma.dfs <- rep(0, times=n.models) 
    for(i in 1:n.models){ bma.dfs[i] <- length(bma.dummies[[i]]) - sum(bma.dummies[[i]]) }

    # calculate model BICs
    bma.bics <- rep(0, times=n.models)
    for(i in 1:n.models) {bma.bics[i] <- bma.output$bf$deviance[i] - bma.dfs[i] * log(sum(ol.vector)) }
    
    # calculate model posterior probabilities
    bma.totprob <- sum(exp(bma.bics*(-0.5)))
    bma.postprobs <- rep(0, times=n.models)
    for(i in 1:n.models) {bma.postprobs[i] <- exp(bma.bics[i]*(-0.5)) / bma.totprob }
    
    
 ##---Recalculate point estimates of m000 for each model eligible for BMA-----------------##
  
  # Obtain coefficients of averaged models
  bma.coefficients <- bma.output$glim.est$coef
  
  # Data frame to hold estimated BMA model coefficients
  bma.pars.point <- as.data.frame(array(0, c(7, n.models)) )
  
  # For each model...
  for(i in 1:n.models){
    # For each coefficient...
    for(j in 1:length(bma.dummies[[1]])){
      index <- sum(bma.dummies[[i]][1:j])
      # Exponentiate estimated coefficient values
      bma.pars.point[[i]][j] <- ifelse(bma.dummies[[i]][j]==1, exp(bma.coefficients[[i]][index]), 1)
    }
  }
  
  # Vector to hold m000 estimated point estimates
  bma.point.estimates <- rep(0, times=n.models)

  # For each model...
  for(i in 1:n.models){
    # Compute m000 estimate
    bma.point.estimates[i]<-m000.est(bma.pars.point[[i]])
  }
  
 ##---Recalculate 95%CIs of m000 for each BMA model, this time in a simpler fashion------##
  # i.e multiplying SEs x 2
  
  # Obtain standard errors of coefficients of re-fitted models
  bma.ses <- bma.output$glim.est$se
  
  # Data frame to hold estimated lower CI values of coefficients, for each eligible model
  bma.pars.lci <- as.data.frame(array(0, c(7, n.models)))
  
  # For each model...
  for(i in 1:n.models){
    # For each coefficient...
    for(j in 1:length(bma.dummies[[1]])) {
      index <- sum(bma.dummies[[i]][1:j])
      # Exponentiate lower confidence interval estimates of coefficients
      bma.pars.lci[[i]][j] <- ifelse(bma.dummies[[i]][j]==1, exp(bma.coefficients[[i]][index] - 2*bma.ses[[i]][index]), 1)
    }
  }
  
  # Vector to hold values of estimated lower confidence intervals of m000 
  bma.lcis<-rep(0,times=n.models)
  
  # For each model, compute lower confidence interval m000 value
  for(i in 1:n.models){ bma.lcis[i]<-m000.est(bma.pars.lci[[i]]) }

  # Data frame to hold estimated upper CI values of coefficients, for each eligible model
  bma.pars.uci <- as.data.frame(array(0, c(7, n.models)))

  # For each model...
  for(i in 1:n.models){
    # For each coefficient...
    for(j in 1:length(bma.dummies[[1]])){
      index <- sum(bma.dummies[[i]][1:j])
      # Exponentiate upper confidence interval estimates of coefficients
      bma.pars.uci[[i]][j] <- ifelse(bma.dummies[[i]][j]==1, exp(bma.coefficients[[i]][index]+2*bma.ses[[i]][index]), 1)
    }
  }

  # Vector to hold values of estimated upper confidence intervals of m000 
  bma.ucis <- rep(0, times=n.models)

  # For each model, compute upper confidence interval m000 value
  for(i in 1:n.models){
    bma.ucis[i] <- m000.est(bma.pars.uci[[i]])
  }
  
  
 ##---Compute BMA estimates of m000--------------------------------------------###
  # (as weighted sum of all eligible models' m000 estimates; weights = model posterior probabilities)
  
  # Point estimate 
  bma.m000.est <- round(sum(bma.point.estimates * bma.postprobs))
  
  # Lower CI
  bma.m000.lci <- round(sum(bma.lcis * bma.postprobs))
  
  # Upper CI
  bma.m000.uci <- round(sum(bma.ucis * bma.postprobs))

  # Data frame to hold results
  results.bma <- data.frame(bma.m000.est, bma.m000.lci, bma.m000.uci)
  colnames(results.bma) <- c("m000_est", "m000_lci", "m000_uci")
  

###---ESTIMATE THE SENSITIVITY OF EACH LIST------------------------------------###
  
  # Compute the number of deaths captured by any list or all lists combined
  list.1 <- ol.vector[1] + ol.vector[2] + ol.vector[3] + ol.vector[4]
  list.2 <- ol.vector[1] + ol.vector[2] + ol.vector[5] + ol.vector[6]
  list.3 <- ol.vector[1] + ol.vector[3] + ol.vector[5] + ol.vector[7]
  all.lists <- sum(ol.vector)

  # Compute the estimated total number of events, with 95%CI
  all.est <- results.bma + all.lists

  # Compute the estimated sensitivities, with 95%CI
  sens.list.1 <- round(100 * list.1 / all.est, digits=1)
  sens.list.2 <- round(100 * list.2 / all.est, digits=1)
  sens.list.3 <- round(100 * list.3 / all.est, digits=1)
  sens.all.lists <- round(100 * all.lists / all.est, digits=1)

  sensitivities <- data.frame("List.1_n" = list.1,
                              "List.1_sens     " = paste("   ",sens.list.1[[1]], "% (",sens.list.1[[3]],"-",sens.list.1[[2]],")",sep=""),
                              "List.2_n" = list.2,
                              "List.2_sens     " = paste("   ",sens.list.2[[1]], "% (",sens.list.2[[3]],"-",sens.list.2[[2]],")",sep=""),
                              "List.3_n" = list.3,
                              "List.3_sens     " = paste("   ",sens.list.3[[1]], "% (",sens.list.3[[3]],"-",sens.list.3[[2]],")",sep=""),
                              "All.Lists_n" = all.lists,
                              "All.Lists_sens     " = paste("   ",sens.all.lists[[1]], "% (",sens.all.lists[[3]],"-",sens.all.lists[[2]],")",sep="")
                              )

###---DISPLAY ANALYSIS RESULTS---------------------------------------------------###

  # Prepare data frame with essential results from each log-linear model
  results.glm <- data.frame(model.names, point.estimates, lcis, ucis,
                            dfs, pearson.chi.probs, bics, pearsons, possible.models$eligible)
  colnames(results.glm) <- c("model", "m000_point", "m000_lci", "m000_uci",
                             "df", "Chi2 P-value", "BIC", "Pearson adj Chi2", "eligible?")
  #m000_est is the estimated number of uncaptured cases, m000_lci and m000_uci are the lower and upper 95%CIs
  #other parameters: residual degrees of freedom, P-value for model, Bayesian Information Criterion,
    # adjusted Chi2 (Chi2/df), whether model is eligible for BMA

  # Results of log-linear modelling approach
  results.glm

  # Results of Bayesian Model Averaging
  summary(bma.output, n.models=n.models)

  # Re-calculated (Raftery) BICs of the averaged models:
  round(bma.bics, digits=2)

  # Re-calculated (Raftery) posterior probabilities of the averaged models:
  round(bma.postprobs, digits=3)

  # Estimated m000 based on Bayesian Model Averaging
  results.bma

  # Total estimated number of events:
  all.est
  
  # Sensitivity of the different lists and all lists combined:
  sensitivities
  
  
###---ENDS-----------------------------------------------------------------------------------###