##################Supplemental Materials 2###################
#R code to conduct Bayesian analysis with prior on 
#joint distribution of intensity of exposure and its duration
#and to generate results shown in Figures 4 to 5
##############################################################

############################start definition of functions#####
##############################################################
#Function to set scaled beta distribution 
#for prior on correlation of log(D) and log(I)
#mn=mean
#sd-standard deviation

rscbeta <- function(n, mn, sd) {
  if (sd==0) {
    opt <- rep(mn,n)
  } else {
    sd.b <- sd/2
    mn.b <- (1+mn)/2
    tmp <- mn.b*(1-mn.b)/sd.b^2 - 1
    opt <- -1 + 2*rbeta(n, tmp*mn.b, tmp*(1-mn.b))
  }
opt
}
##############################################################

##############################################################
### simple Bayesian linear regression, adapated from Hoff's book
Hoff <- function(dsm,y, n.mc=25000) {

  n <- length(y)
  
  ### hyperparameters
  g <- n; nu0 <- 1; s20 <- 1
  
  Hg <- (g/(g+1)) * dsm %*% solve(t(dsm)%*%dsm)%*%t(dsm)
  SSRg <- t(y)%*%(diag(1, nrow=n) - Hg) %*% y
  Vb <- g * solve(t(dsm)%*%dsm)/(g+1)
  Eb <- Vb%*%t(dsm)%*%y

  s2 <- 1/rgamma(n.mc, (nu0+n)/2, (nu0*s20+SSRg)/2)

  E <- matrix(rnorm(n.mc*2, 0, sqrt(s2)), n.mc,2)
  bt.smp <- t( t(E%*%chol(Vb)) +c(Eb))

list(s2=s2, bt=bt.smp)
}

fitmod <- function(d, y, lgk.mn, lgk.sd, rho.mn, rho.sd, n.mc=25000) {
  
  ### fit y|d regression
  ftA <- Hoff(cbind(1,d), y, n.mc=n.mc)

  ### fit d (just variance)
  var.d.smp <- 0.5*sum(y^2)/(n+1)/rgamma(n.mc, 0.5*(n+1))

  ### sample from rho,k prior
  rho.smp <- rscbeta(n.mc, rho.mn, rho.sd)
  k.smp <-   exp(rnorm(n.mc, lgk.mn, lgk.sd))

  ### extract the posterior samples we need
  b1.smp <- ftA$bt[,2]/(1+rho.smp*k.smp)
  var.y.d.smp <- ftA$s2

  ### which Monte Carlo draws satisfy constaint?
  ind <- b1.smp^2 < ( var.y.d.smp / ( (1-rho.smp)^2 * k.smp^2 * var.d.smp ) )

  ### output
  list(b1=b1.smp[ind], b1.excld=b1.smp[!ind], prop.out=mean(!ind))
}  
############################end definition of functions###############


#######################################################################
### Synthetic data for Figures 4 and 5
###based on the report  
### "Saw filers exposed to cobalt and other metals: determinants of exposure
	# and respiratory health evaluation." by Teschke, Kay; Kennedy, Susan M.; Marion, 
	#Stephen A.; Chan Yeung, Moira; van Zuylen, Marielle; Lea, John; Switzer, Teresa; 
	#Thompson, Kent; Oja, Juri Apr 30, 1993
	#https://open.library.ubc.ca/media/download/pdf/52383/1.0048206/2
#and subsequet "OEM paper": https://www.ncbi.nlm.nih.gov/pmc/articles/PMC1128185/
#######################################################################

### settings
n <- 500 #about 5 times the original study (N=118), 
		#to mimic large follow-up investigation
		# that may not be able to affort to measure exposure 
		# as precisely as the orginal (typical), e.g. missing intensity for all

b0 <- 4 #based on Table 18a, with FEV1 (L) that is typically about 4 L.

### true value of target, beta1
			#OEM paper Table 4
			#-0.055 L /(0.001 mg/m3 cobalat)
			#-0.012 L/year
b1 <- -0.2 #true value of target to get 10% (-5 to -6) of observed slope with intensity
sg <- 1

#intentisity of exposure to Cobalt, Table 4 of the report
# 278 measurements, 59 detected above 0.0007 mg/m3
# among detected: average (sd) 0.0098  0.021, maximum 0.11
#  suppose that when not truncated mean would be smaller and sd larger
mu.i <- log(0.005)
sg.i <- 1.3

#duration -- "yrs in saw filing trade 15.5 (8.6)" (Table 13)
mu.d <- 2.65
sg.d <- 0.5
rho <- 0.5 #change to -0.5 as required
k <- sg.i/sg.d

### data generation
set.seed(13)
require(mvtnorm)

  tmp <- rmvnorm(n, mean=c(mu.d,mu.i), 
                sigma=matrix(c(sg.d^2, rep(rho*sg.d*sg.i,2), sg.i^2),2,2))
  d <- tmp[,1]; i <- tmp[,2]
  y <- rnorm(n, b0+b1*(d+i), sg)

#######################################################################
#priors on correlation and k
#######################################################################

### wide priors (Priors 1)
rho.sd.wide <- .2
lgk.sd.wide <- .125

## narrow priors (Prior 2)
rho.sd.nrw <- rho.sd.wide/3
lgk.sd.nrw <- lgk.sd.wide/3

#######################################################################
#Analysis that is reflected in Figures 4 and 5
#mechanics of how figures are generated is ommited for clarity
#######################################################################

  ### complete data answer when both log(D) and log(I) are observed
  ans.cmplt <- Hoff(cbind(1,d+i), y)$bt[,2]

  ### naive answer when only log(D) is known
  ans.naive <- Hoff(cbind(1,d), y)$bt[,2]

  ### known rho,k answer
  tmp <- fitmod(d, y, 
              lgk.mn=log(k), lgk.sd=0,
              rho.mn=rho, rho.sd=0)

  ans.known <- tmp$b1; pro.known <- tmp$prop.out

  ### first set of priors (#1, wider)
  rho.sd <-  rho.sd.wide; lgk.sd <- lgk.sd.wide
  ans.1 <- list(); pro.1 <- rep(NA,4)

  tmp  <- fitmod(d,y,
                 rho.mn=rho+rho.sd, rho.sd=rho.sd, 
                 lgk.mn=log(k)+lgk.sd, lgk.sd=lgk.sd)   
  ans.1[[1]] <- tmp$b1; pro.1[1] <- tmp$prop.out
                  
  tmp <- fitmod(d,y,
                rho.mn=rho-rho.sd, rho.sd=rho.sd, 
                lgk.mn=log(k)-lgk.sd, lgk.sd=lgk.sd)   
  ans.1[[2]] <- tmp$b1; pro.1[2] <- tmp$prop.out

  tmp <- fitmod(d,y,
               rho.mn=rho+rho.sd, rho.sd=rho.sd, 
              lgk.mn=log(k)-lgk.sd, lgk.sd=lgk.sd)   
  ans.1[[3]] <- tmp$b1; pro.1[3] <- tmp$prop.out

  tmp <- fitmod(d,y,
                rho.mn=rho-rho.sd, rho.sd=rho.sd, 
                lgk.mn=log(k)+lgk.sd, lgk.sd=lgk.sd)   
  ans.1[[4]] <- tmp$b1; pro.1[4] <- tmp$prop.out

  ### second set of priors (#2, narrower)
  rho.sd <-  rho.sd.nrw; lgk.sd <- lgk.sd.nrw
  ans.2 <- list(); pro.2 <- rep(NA,4)

  tmp  <- fitmod(d,y,
                 rho.mn=rho+rho.sd, rho.sd=rho.sd, 
                lgk.mn=log(k)+lgk.sd, lgk.sd=lgk.sd)   
  ans.2[[1]] <- tmp$b1; pro.2[1] <- tmp$prop.out
                  
  tmp <- fitmod(d,y,
                rho.mn=rho-rho.sd, rho.sd=rho.sd, 
                lgk.mn=log(k)-lgk.sd, lgk.sd=lgk.sd)   
  ans.2[[2]] <- tmp$b1; pro.2[2] <- tmp$prop.out

  tmp <- fitmod(d,y,
               rho.mn=rho+rho.sd, rho.sd=rho.sd, 
               lgk.mn=log(k)-lgk.sd, lgk.sd=lgk.sd)   
  ans.2[[3]] <- tmp$b1; pro.2[3] <- tmp$prop.out

  tmp <- fitmod(d,y,
                rho.mn=rho-rho.sd, rho.sd=rho.sd, 
                lgk.mn=log(k)+lgk.sd, lgk.sd=lgk.sd)   
  ans.2[[4]] <- tmp$b1; pro.2[4] <- tmp$prop.out

########################################################################
### what proportion of sampled points discarded due to constraint?
  print(pro.1)
  print(pro.2)
  print(pro.known)

##########################################################################
### Examine distribution of samples from posterior distribition of beta 1
###estimates interms of 95% Credible Interval and Median
#Only log(D), naive
quantile(ans.naive, c(.025,0.5, .975))

#Priors 1
quantile(ans.1[[1]], c(.025,0.5, .975))
quantile(ans.1[[2]], c(.025,0.5, .975))
quantile(ans.1[[3]], c(.025,0.5, .975))
quantile(ans.1[[4]], c(.025,0.5, .975))

#Priors 2
quantile(ans.2[[1]], c(.025,0.5, .975))
quantile(ans.2[[2]], c(.025,0.5, .975))
quantile(ans.2[[3]], c(.025,0.5, .975))
quantile(ans.2[[4]], c(.025,0.5, .975))

#known (rho, k)
quantile(ans.known, c(.025, 0.5, .975))

#complete data on D and I
quantile(ans.cmplt, c(.025, 0.5, .975))

#################################################end Appendix 3##########################




