# Supplementary file 1
# R code for methods and analyses.
# (R version 3.3.2 (2016-10-31))
# Code can be run to reproduce Table 3 and Table 4.
# Figure 3 calibration plots can be reproduced by setting n = 1e6, n.sim = 1 and
# appraisal(..., plots=TRUE).

#########################################################################################
library(rms)
library(boot)
# Function to return performance measures (discrimination and calibration)
appraisal <- function(obs, LP, N, plots = TRUE, title = "", w=rep(1,length(obs))){
  
  sum.tab<- matrix(rep(NA, 2), nrow = 1, dimnames=list(NULL, c("O/E ratio", "C index")))
  pred <- 1 / (1 + exp(-LP))
  sum.tab[1] <- (sum(obs * w)/ sum(w)) / (sum(pred * w) / sum(w)) # O:E ratio
  sum.tab[2] <- somers2(LP,obs, weights = w)[1] #c-index
  if(plots){ #calibration plot
    predw <- rep(pred, round(w))
    obsw <- rep(obs, round(w))
    minidf<- data.frame(cbind(obsw, predw))
    minidf<- minidf[with(minidf, order(predw)),]
    dec.pred <- dec.obs <- c()
    for (i in 1:10) { # create deciles for calibration plot
      dec.obs[i] <- mean(minidf[(1+(i-1)*(sum(round(w))/10)):((sum(round(w))/10)*i), 1])
      dec.pred[i] <- mean(minidf[(1+(i-1)*(sum(round(w))/10)):((sum(round(w))/10)*i), 2])
    }
    plot(dec.pred,dec.obs, pch = 18, cex=1.5, main= paste(title),
         col = "darkgreen", bg= "darkgreen", xlim = c(0,0.4), ylim = c(0,0.4),
         ylab = "Observed risk", xlab = "Predicted risk", cex.lab = 1.25, las=1)
    abline(a=0,b=1)
  }
  return(round(sum.tab,4))  
}
#########################################################################################
n = 1000
n.sim = 10000
mu = 0
s = sqrt(0.2)
b0U <- -1.5 # For scenarios 14-16, choose from the following (-1.55, -1.7, -2.15) 
bU <- 0 # For scenarios 14-16, choose from the following: (1, 2, 4)
Z <- -1.95 # For scenarios 5-13, choose from the following (-3.3 (25% treated),-1.95 (50%), -0.7 (75%))
# For scenarios 14-16, choose from the following (-1.9, -1.8, -1.55)
tr.effect <- 0.5 # For scnearios 5-13, choose from the following: (0.3, 0.5, 0.8)

untreated <- ignore <- restrict <- ipw <- ipw.restrict <- ipw.trunc.restrict <- matrix(NA,n.sim, ncol=2)
method.names<-c("Untreated", "Ignore", "Exclude treated", "IPW", "IPW, exclude", 
                 "IPW trunc., exclude")
metrics <- c("O/E ratio", "O/E ratio S.E.", "C index", "C index S.E.")
#----------------------------------------------------------------------------------------
for(i in 1:n.sim) {
# Data generation  

# Scenarios 1-12
# Generate development set (untreated outcomes)
  df1 <- data.frame(X1=rnorm(n, mu, s), X2=rnorm(n, mu, s))
  drisk <- 1/(1+exp(-(-1.5 + 1*df1$X1 + 1*df1$X2))) 
  dY <- rbinom(n, 1, drisk)
# Generate validation set (untreated outcomes)
  df2 <- data.frame(X1=rnorm(n, mu, s), X2=rnorm(n, mu, s))
  vrisk <- 1/(1+exp(-(-1.5 + 1*df2$X1 + 1*df2$X2)))
  vY <- rbinom(n, 1, vrisk)

# Scenarios 13-15
# Generate development set (untreated outcomes)
#  df1 <- data.frame(X1=rnorm(n, mu, s), X2=rnorm(n, mu, s), U=rnorm(n, mu, s))
#  drisk <- 1/(1+exp(-(b0U + 1*df1$X1 + 1*df1$X2 + bU*df1$U))) 
#  dY <- rbinom(n, 1, drisk)
# Generate validation set (untreated outcomes)
#  df2 <- data.frame(X1=rnorm(n, mu, s), X2=rnorm(n, mu, s), U=rnorm(n, mu, s))
#  vrisk <- 1/(1+exp(-(b0U + 1*df2$X1 + 1*df2$X2 + bU*df2$U)))
#  vY <- rbinom(n, 1, vrisk)
#----------------------------------------------------------------------------------------
# Generate treated outcomes
# Scenario 1, 5-15
 pt   <- 1/(1+exp(-(Z + 10*vrisk)))
 treated	<- rbinom(n,1,pt)
 odds.treated <- log(vrisk/(1-vrisk))
 odds.treated[treated == 1] <- odds.treated[treated == 1] + log(tr.effect)
 odds.treated <- inv.logit(odds.treated)
 Y.treated <- rbinom(n, 1, odds.treated)

# Scenario 2 (for other scenarios, see options below)
#   treated	<- rbinom(n, 1, 0.5)
#   odds.treated <- log(vrisk/(1 - vrisk))
#   odds.treated[treated == 1] <- odds.treated[treated == 1] + log(0.5)
#   odds.treated <- inv.logit(odds.treated)
#   Y.treated <- rbinom(n, 1, odds.treated)

# Scenario 3
#  treatment.OR <-1 / (1+exp(-(1-5*vrisk)))
#  pt <- 1/(1+exp(-(Z + 10*vrisk)))
#  treated	<- rbinom(n,1,pt)
#  odds.treated <- log(vrisk/(1-vrisk))
#  odds.treated[treated == 1] <- odds.treated[treated == 1] + log(treatment.OR)[treated==1]
#  odds.treated <- inv.logit(odds.treated)
#  Y.treated <- rbinom(n, 1, odds.treated)

# Scenario 4
#  pt   <- 1/(1+exp(-(-18 + 100*vrisk)))
#  treated  <- rbinom(n,1,pt)
#  odds.treated <- log(vrisk/(1-vrisk))
#  odds.treated[treated == 1] <- odds.treated[treated == 1] + log(0.5)
#  odds.treated <- inv.logit(odds.treated)
#  Y.treated <- rbinom(n, 1, odds.treated) 
#----------------------------------------------------------------------------------------
# Develop model (untreated)
# Note for Scenarios 13-15, unobserved predictor U is not included in the prediction model
  model1 <- glm(dY ~ df1$X1 + df1$X2, family=binomial)
  vLP <- model1$coef[1] + model1$coef[2]*df2$X1 + model1$coef[3]*df2$X2
  vpredrisk <- 1/(1+exp(-(vLP)))

#Inverse probability weighting
# Note for Scenarios 13-15, unobserved predictor U is not included in the propensity model  
  psm<-glm(treated~vpredrisk, family="binomial")$fitted.values
  df2$ps <- 0
  df2[treated==0,]$ps <- 1/(1 - psm[treated==0])
  df2[treated==1,]$ps <- 1/psm[treated==1]
# truncation (98%, upper end of weight distribution truncated)
  pstrunc<-df2[treated==0,]$ps
  pstrunc[pstrunc > quantile(pstrunc, 0.98)] <- quantile(pstrunc, 0.98)
#----------------------------------------------------------------------------------------  
# Assess model performance following each analytical approach
#  Note for "restrict" and "ipw.restrict", only the untreated subset is included.
#  Note for "ipw", "ipw.restrict" and "ipw.trunc.restrict", performance measures are weighted.
  untreated[i,] <- appraisal(vY, vLP, n, plots=F)
  ignore[i,] <- appraisal(Y.treated, vLP, n, plots=F)
  restrict[i,] <- appraisal(Y.treated[treated==0], vLP[treated==0], length(vLP[treated==0]), plots=F)
  ipw[i,] <- appraisal(Y.treated, vLP, n, plots=F, w=df2$ps)
  ipw.restrict[i,] <- appraisal(Y.treated[treated==0], vLP[treated==0], 
                                length(vY[treated==0]), plots=F, w=df2[treated==0,]$ps)
  ipw.trunc.restrict[i,] <- appraisal(Y.treated[treated==0], vLP[treated==0], 
                                      length(vY[treated==0]), plots=F, w=pstrunc)
}
#########################################################################################  
# Generate output tables
full.output <- cbind(untreated, ignore, restrict, ipw, ipw.restrict, ipw.trunc.restrict)
output.est<-matrix(apply(full.output, 2, mean),ncol=2, byrow=T)
output.SE <- matrix(apply(full.output, 2, sd), ncol=2, byrow=T)
output <- cbind(output.est[,1],output.SE[,1],output.est[,2],output.SE[,2]) 
rownames(output) <- method.names
colnames(output) <- metrics
print(output)