#####Chapter 15: Mediation

###Section 15.1: Simple Mediation
X <-c(rep(0,6),rep(1,6))
M <-c(6,5,9,7,8,4,5,2,3,8,2,1)
Y <-c(7,7,9,8,8,6,6,4,4,7,2,3)
summary(mod.1 <-lm(Y~X))
summary(mod.2 <-lm(M~X))
summary(mod.3 <-lm(Y~M+X))
a <-mod.2$coef[2]
b <-mod.3$coef[2]
c <-mod.1$coef[2]
cdir <-mod.3$coef[3]

#Sobel's Test
ab <-a*b
d <-rbind(mod.3$coef[2],mod.2$coef[2])
C <- matrix(c(vcov(mod.2)[2:2,2:2],0,0,vcov(mod.3)[2:2,2:2]), nrow=2) 
SE <-sqrt(t(d)%*%C%*%d)
Z.ab <-ab/SE
pvalue <-2*(1-pnorm(abs(Z.ab)))
CI.low <-ab-(1.96*SE)
CI.high <-ab+(1.96*SE)
Sobel<-round(matrix(c(ab,SE,Z.ab,pvalue,CI.low,CI.high),nrow=1,ncol=6),digits=5)
dimnames(Sobel)=list(c(""),c("ab", "SE", "Z","p","CI.low","CI.high"))
Sobel

#Bootstrap Function 
med.boot <- function(X, M, Y, reps, ci){ 
 ab_vector = NULL 
 for (i in 1:reps){ 
 s = sample(1:length(X), replace=TRUE) 
 Xs = X[s] 
 Ys = Y[s] 
 Ms = M[s] 
 M_Xs = lm(Ms ~ Xs) 
 Y_XMs = lm(Ys ~ Xs + Ms) 
 a = M_Xs$coefficients[2] 
 b = Y_XMs$coefficients[3] 
 ab = a*b 
 ab_vector = c(ab_vector, ab) 
 } 
sorted <-sort(ab_vector)
num=reps*(ci/2)
CI.low <-mean(sorted[1:num])
CI.high <-mean(sorted[(length(sorted)-(num-1)):length(sorted)])
CI <-cbind(CI.low,CI.high)
return=CI
} 
bootstrap <-med.boot(X,M,Y,1000,.05);bootstrap #Specify variables, sample size, and confidence interval

#Effect Size Measures
prop <-ab/c
ratio.1 <-cdir/c
ratio.2 <-ab/cdir
standard <-ab/sd(Y)
effect <-cbind(prop,ratio.1,ratio.2,standard)
effect

#Contrasts
d <-rbind(b,a,-1)
c1 <-c(vcov(mod.2)[2:2,2:2],0,0)
c2 <-c(0,vcov(mod.3)[5],vcov(mod.3)[6])
c3 <-c(0,vcov(mod.3)[8],vcov(mod.3)[9])
CC <-cbind(c1,c2,c3)
se.cont <-sqrt(t(d)%*%CC%*%d)
Z.contrast <-(ab-cdir)/se.cont
Z.contrast
2*(1-pnorm(abs(Z.contrast)))

###Section 15.2.1: Mediation with Three Groups
X1 <-c(rep(0,4),rep(1,4),rep(0,4))
X2 <-c(rep(0,8),rep(1,4))
M <-c(7,9,7,6,5,5,3,7,3,2,1,2)
Y <-c(7,8,7,7,4,4,3,5,4,3,3,2)
summary(mod.1 <-lm(Y~X1+X2))
summary(mod.2 <-lm(M~X1+X2))
summary(mod.3 <-lm(Y~M+X1+X2))
b <-mod.3$coef[2]

#Sobel
Sobel <-function(x){
a <-mod.2$coef[1+x];ab <-a*b
d <-rbind(b,a)
C <- matrix(c(vcov(mod.2)[5],0,0,vcov(mod.3)[6]), nrow=2) 
SE <-sqrt(t(d)%*%C%*%d)
Z <-ab/SE
pvalue <-2*(1-pnorm(abs(Z)))
CI.low <-ab-(1.96*SE)
CI.high <-ab+(1.96*SE)
Sobel<-round(matrix(c(ab,SE,Z,pvalue,CI.low,CI.high),nrow=1,ncol=6),digits=5)
dimnames(Sobel)=list(c(""),c("ab", "SE", "Z","p","CI.low","CI.high"))
Sobel
}
sobel.1 <-Sobel(1)
sobel.2 <-Sobel(2)
Sobel.table <-rbind(sobel.1,sobel.2);Sobel.table

#Contrasts
contrast <-function(x){
a <-mod.2$coef[1+x];ab <-a*b;c <-mod.3$coef[2+x];minus <-ab-c
d <-rbind(b,a,-1)
c1 <-c(vcov(mod.2)[2:2,2:2],0,0);
c2 <-c(0,vcov(mod.3)[6],vcov(mod.3)[6+x])
c3 <-c(0,vcov(mod.3)[6+x],vcov(mod.3)[6+x+(4*x)])
CC <-cbind(c1,c2,c3)
SE <-sqrt(t(d)%*%CC%*%d)
Z <-minus/SE
pvalue <-2*(1-pnorm(abs(Z)))
CI.low <-minus-(1.96*SE)
CI.high <-minus+(1.96*SE)
cont<-round(matrix(c(minus,SE,Z,pvalue,CI.low,CI.high),nrow=1,ncol=6),digits=5)
dimnames(cont)=list(c(""),c("ab", "SE", "Z","p","CI.low","CI.high"))
cont
}
cont.1 <-contrast(1)
cont.2 <-contrast(2)
contrasts <-rbind(cont.1,cont.2)
contrasts

###Section 15.2.2:  Multiple Mediators
M1 <-c(9,7,8,1,6,9,2,2,1,8,2,1)
M2 <-c(6,9,7,6,5,6,3,6,7,1,2,1)
X <-c(rep(0,6),rep(1,6))
Y <-c(9,8,6,3,7,9,3,6,5,7,2,1)
summary(mod.1 <-lm(Y~X))
summary(mod.2 <-lm(M1~X))
summary(mod.3 <-lm(M2~X))
summary(mod.4 <-lm(Y~M1+M2+X))
c <-mod.1$coef[2]
a1 <-mod.2$coef[2]
a2 <-mod.3$coef[2]
b1 <-mod.4$coef[2]
b2 <-mod.4$coef[3]
cdir <-mod.4$coef[4]
coef <-rbind(c,a1,a2,b1,b2,cdir)
coef
a1b1 <-a1*b1
a2b2 <-a2*b2

#D matrix
d1 <-c(b1,0,b1,b1,b1,0,b1)
d2 <-c(a1,0,a1,a1,a1,0,a1)
d3 <-c(0,b2,b2,-b2,0,b2,b2)
d4 <-c(0,a2,a2,-a2,0,a2,a2)
d5 <-c(0,0,0,0,-1,-1,-2)
D <-rbind(d1,d2,d3,d4,d5)

c1 <-c(vcov(mod.2)[4],rep(0,4))
c2 <-c(0,vcov(mod.4)[6],0,vcov(mod.4)[7],vcov(mod.4)[8])
c3 <-c(0,0,vcov(mod.3)[4],0,0)
c4 <-c(0,vcov(mod.4)[10],0,vcov(mod.4)[11],vcov(mod.4)[12])
c5 <-c(0,vcov(mod.4)[14],0,vcov(mod.4)[15],vcov(mod.4)[16])
C <-rbind(c1,c2,c3,c4,c5)

#Function for Simple Slopes
simple.slope <-function(D,C){
simp.slope <-c(a1*b1,a2*b2,a1*b1+a2*b2,a1*b1-a2*b2,a1*b1-cdir,a2*b2-cdir,(a1*b1+a2*b2)-2*cdir)
simp.cov <-t(D)%*%C%*%D
simp.err <-sqrt(diag(simp.cov))
simples <-simp.slope/sqrt(diag(simp.cov))
zvalues <-2*(1-pnorm(abs(simples)))
CI.low <-simp.slope-(1.96*simp.err)
CI.high <-simp.slope+(1.96*simp.err)
simp.table<-round(matrix(c(simp.slope,simp.err,simples,zvalues,CI.low,CI.high),nrow=length(simp.slope),ncol=6),digits=5)
dimnames(simp.table)=list(c("a1b1","a2b2","a1b2+a2b2","a1b1-a2b2","a1b1-cdir","a2b2-cdir","a1b1+a2b2-2*cdir"),c("slope","stderr","Z","p","CI.low","CI.high"))
return(list(D,simp.table))
}
simple <-simple.slope(D,C)
simple

###Section 15.2.3:  Mediation and Moderation
Z <-c(62,40,22,65,43,32,56,63,33,62,27,25)
M <-c(8,4,1,9,5,7,2,1,1,5,5,9);
X <-c(rep(.5,6),rep(-.5,6))
Y <-c(3,8,9,1,7,8,6,7,6,4,5,2)
devZ <-Z-mean(Z);devM <-M-mean(M);XZ <-X*devZ;MZ <-devM*devZ
summary(mod.1 <-lm(Y~X*devZ))
summary(mod.2 <-lm(M~X*devZ))
summary(mod.3 <-lm(Y~X+devZ+XZ+devM+MZ))

#Simple slopes for predicting Y and M, respectively, from GRP, AGE, GRP*AGE
simp.mod <-function(model){
s0 <-c(0,0,0);s1 <-c(1,1,1);s2 <-c(0,0,0);s3 <-c(-sd(Z),0,sd(Z))
S <-rbind(s0,s1,s2,s3)
simp.slope <-t(S)%*%model$coef
simp.err <-sqrt(diag(t(S)%*%vcov(model)%*%S))
simple <-simp.slope/simp.err
tvalues <-2*pt(-abs(simple),df=(length(X)-nrow(S)))
crit <-abs(qt(0.025, 8))
CI.low <-simp.slope-(crit*simp.err)
CI.high <-simp.slope+(crit*simp.err)
simp.table<-round(matrix(c(simp.slope,simp.err,simple,tvalues,CI.low,CI.high),nrow=length(simp.slope),ncol=6),digits=5)
dimnames(simp.table)=list(c("group", "age", "group*age"),c("slope", "stderr", "t","p","CI.low","CI.high"))
simp.table
}
simp.c <-simp.mod(mod.1);simp.c
simp.a <-simp.mod(mod.2);simp.a

#Simple slopes for predicting Y from GRP, AGE, GRP*AGE, ANXIETY, GRP*ANXIETY
simp.med <-function(a,b){ # enter 0,1 for b values; 1,0 for cdirect
s0 <-c(0,0,0);s1 <-c(1*a,1*a,1*a);s2 <-c(0,0,0);s3 <-c(-sd(Z)*a,0,sd(Z)*a)
s4 <-c(1*b,1*b,1*b);s5 <-c(-sd(Z)*b,0,sd(Z)*b)
S <-rbind(s0,s1,s2,s3,s4,s5)
simp.slope <-t(S)%*%mod.3$coef
simp.err <-sqrt(diag(t(S)%*%vcov(mod.3)%*%S))
simple <-simp.slope/simp.err
tvalues <-2*pt(-abs(simple),df=(length(X)-nrow(S)))
crit <-abs(qt(0.025, 6))
CI.low <-simp.slope-(crit*simp.err);CI.high <-simp.slope+(crit*simp.err)
simp.table<-round(matrix(c(simp.slope,simp.err,simple,tvalues,CI.low,CI.high),nrow=length(simp.slope),ncol=6),digits=5)
dimnames(simp.table)=list(c("group", "age", "group*age"),c("slope", "stderr", "t","p","CI.low","CI.high"))
simp.table
}
simp.b <-simp.med(0,1)
simp.b
simp.cdir <-simp.med(1,0)
simp.cdir

d.lo <-rbind(simp.b[1],simp.a[1])
d.md <-rbind(simp.b[2],simp.a[2])
d.hi <-rbind(simp.b[3],simp.a[3])
ab.lo <-simp.b[1]*simp.a[1]
ab.md <-simp.b[2]*simp.a[2]
ab.hi <-simp.b[3]*simp.a[3]

s0 <-c(0,0,0);s1 <-c(1,1,1);s2 <-c(0,0,0);s3 <-c(-sd(Z),0,sd(Z))
S <-rbind(s0,s1,s2,s3)

cov.a <-diag(t(S)%*%vcov(mod.2)%*%S)
s.lo <-c(1,-sd(Z));s.md <-c(1,0);s.hi <-c(1,sd(Z))
SS <-cbind(s.lo,s.md,s.hi)
cov.b <-t(SS)%*%vcov(mod.3)[5:6,5:6]%*%SS
cov.lo <-matrix(c(cov.a[1],0,0,cov.b[1]),nrow=2)
cov.md <-matrix(c(cov.a[2],0,0,cov.b[5]),nrow=2)
cov.hi <-matrix(c(cov.a[3],0,0,cov.b[9]),nrow=2)
std.lo <- sqrt(t(d.lo)%*%cov.lo%*%d.lo)
Z.lo <-ab.lo/std.lo
Z.lo.p <-2*(1-pnorm(abs(Z.lo)))
std.md <- sqrt(t(d.md)%*%cov.md%*%d.md)
Z.md <-ab.md/std.md
Z.md.p <-2*(1-pnorm(abs(Z.md)))
std.hi <- sqrt(t(d.hi)%*%cov.hi%*%d.hi)
Z.hi <-ab.hi/std.hi
Z.hi.p <-2*(1-pnorm(abs(Z.hi)))

med.mod <-matrix(c(ab.lo, std.lo, Z.lo,Z.lo.p,ab.md, std.md, Z.md,Z.md.p,ab.hi, std.hi, Z.hi,Z.hi.p ),nrow=3,byrow=TRUE)
dimnames(med.mod)=list(c("young", "medium", "old"),c("ab", "std.err", "Z","p"))
med.mod


###Section 15.3:  Johnson-Neyman Regions of Significance Using Uniroot Function
JN <-function(q){
 S.2<-c(0,1,0,q)
 slope.2 <-t(S.2)%*%mod.2$coef
 std.err.2 <-sqrt(t(S.2)%*%vcov(mod.2)%*%S.2)
 S.3 <-c(0,0,0,0,1,q)
 slope.3 <-t(S.3)%*%mod.3$coef
 std.err.3 <-sqrt(t(S.3)%*%vcov(mod.3)%*%S.3) 
 ab <-slope.2*slope.3
 D <-rbind(slope.3,slope.2)
 S.4 <-c(0,1,0,q)
 cov.a <-diag(t(S.4)%*%vcov(mod.2)%*%S.4)
 S.5 <-c(1,q)
 cov.b <-t(S.5)%*%vcov(mod.3)[5:6,5:6]%*%S.5
 cov.m <-matrix(c(cov.a,0,0,cov.b),nrow=2)
 std.m <- sqrt(t(D)%*%cov.m%*%D)
 Z <-ab/std.m
 P <-2*(1-pnorm(abs(Z)))
 JN <-1.96-abs(Z)
}

jn.lo <-uniroot(JN,c(-100,100));jn.lo$root+mean(Z) #Use low starting values
jn.hi <-uniroot(JN,c(100,500));jn.hi$root+mean(Z)   #Use high starting values
