#####Chapter 14: Moderated Regression

###Section 14.1: Simple Slopes
grp <-c(rep(1,4),rep(2,4),rep(3,4))
age <-c(29,27,39,53,57,32,45,21,47,55,29,22)
y  <-c(7,9,5,2,5,7,6,5,4,3,3,4)
eff1 <-c(rep(1,4),rep(0,4),rep(-1,4));eff2 <-c(rep(0,4),rep(1,4),rep(-1,4))
devage <-age-mean(age)

summary(mod.a <-lm(y~devage+eff1+eff2+eff1*devage+eff2*devage))
summary(mod.b <-lm(y~devage+eff1+eff2))
summary(mod.c <-update(mod.a, .~. -devage))  #Use update function to delete continuous variable but retain cross-products
summary(mod.d <-update(mod.a, .~. -eff1-eff2))    #Use update function to delete categorical terms but retain cross-products
anova(mod.b,mod.a)              #test interaction
anova(mod.c,mod.a)              #test continuous variable
anova(mod.d,mod.a)              #test categorical variable

##Plot Regression Lines Using Separate Coefficients for Each Group
#Predicted Values and Simple Slopes
i0 <-c(rep(1,3));i1 <-c(rep(0,3));i2 <-c(1,0,-1);i3 <-c(0,1,-1)
i4 <-c(rep(0,3));i5 <-c(rep(0,3))
II <-round(rbind(i0,i1,i2,i3,i4,i5),digits=5);intercept <-t(II)%*%coef(mod.a)

s0 <-c(rep(0,3));s1 <-c(rep(1,3));s2 <-c(rep(0,3));s3 <-c(rep(0,3))
s4 <-c(1,0,-1);s5 <-c(0,1,-1);SS <-round(rbind(s0,s1,s2,s3,s4,s5),digits=5)
slope <-t(SS)%*%coef(mod.a);both <-cbind(intercept,slope);both
mean(both[,1])            #average intercept = intercept in mod.a
mean(both[,2])            #average slope = slope in mod.a

#Predicted Values for Ss one standard deviation above and below the mean
p0 <-c(rep(1,9))
p1 <-c(rep(-sd(age),3),rep(0,3),rep(sd(age),3))
p2 <-c(rep(c(1,0,-1),3))
p3 <-c(rep(c(0,1,-1),3))
p4 <-c(-sd(age),0,sd(age),rep(0,3),sd(age),0,-sd(age))
p5 <-c(0,-sd(age),sd(age),rep(0,3),0,sd(age),-sd(age))
P <-rbind(p0,p1,p2,p3,p4,p5)
pred.val <-t(P)%*%coef(mod.a); pred.val

#Plotting Predicted Values 1
byrow <-rbind(c(pred.val[1:3]),c(pred.val[4:6]),c(pred.val[7:9]))
matplot((byrow), main = "Simple Slopes Relating Age to Reasoning Across Three Conditions", type="l",ylab = 'Reasoning Ability', xlab = "DEV_age",lwd=2)
legend("topright",legend=c("New","Traditional","Control"),
lty=1,lwd=2,pch=21,col=c("black","red","darkgreen"),
ncol=1,bty="n",cex=0.8,
text.col=c("black","red","darkgreen"),
inset=0.01)

#Crossing Points
cross.12 <-(intercept[1]-intercept[2])/(slope[2]-slope[1]);cross.12
cross.13 <-(intercept[1]-intercept[3])/(slope[3]-slope[1]);cross.13
cross.23 <-(intercept[2]-intercept[3])/(slope[3]-slope[2]);cross.23

#Test Simple Slopes
simple.slope <-function(S,B,C){
simp.slope <-t(S)%*%B
simp.cov <-t(S)%*%C%*%S
simp.err <-sqrt(diag(simp.cov))
simples <-simp.slope/sqrt(diag(simp.cov))
df <-length(y)-nrow(S)
tvalues <-2*pt(-abs(simples),df=df)
crit <-abs(qt(0.025,df))
CI.low <-simp.slope-(crit*simp.err)
CI.high <-simp.slope+(crit*simp.err)
simp.table<-round(matrix(c(simp.slope,simp.err,simples,tvalues,CI.low,CI.high),nrow=ncol(S),ncol=6),digits=5)
dimnames(simp.table)=list(c(),c("slope","stderr","t","p","CI.low","CI.high"))
return(list(S,simp.table))
}
simple <-simple.slope(SS,coef(mod.a),vcov(mod.a))
simple

###Section 14.2.  Simple Effects
grp <-c(rep(1,4),rep(2,4),rep(3,4))
age <-c(29,27,39,53,57,32,45,21,47,55,29,22)
y  <-c(7,9,5,2,5,7,6,5,4,3,3,4)
eff1 <-c(rep(1,4),rep(0,4),rep(-1,4))
eff2 <-c(rep(0,4),rep(1,4),rep(-1,4))
devage <-age-mean(age)
summary(mod.a <-lm(y~devage+eff1+eff2+eff1*devage+eff2*devage))

#Predicted Values for Ss one standard deviation above and below the mean
p0 <-c(rep(1,9))
p1 <-c(rep(-sd(age),3),rep(0,3),rep(sd(age),3))
p2 <-c(rep(c(1,0,-1),3))
p3 <-c(rep(c(0,1,-1),3))
p4 <-c(-sd(age),0,sd(age),rep(0,3),sd(age),0,-sd(age))
p5 <-c(0,-sd(age),sd(age),rep(0,3),0,sd(age),-sd(age))
P <-rbind(p0,p1,p2,p3,p4,p5)
pred.val <-t(P)%*%coef(mod.a); pred.val

#Create Bar Graph
bar.graph<-c(pred.val[1],pred.val[7],pred.val[2],pred.val[8],pred.val[3],pred.val[9])
mat1 <- matrix(bar.graph, 2)
barplot(mat1,beside=T,
main = "Moderated Regression", col = c("white", "gray"),
xlab = "Treatment", names = c("New", "Traditional", "Control"), 
ylab = "Reasoning Ability", legend = c("Younger", "Older"), 
args.legend = list(title = "Age", x = "top", cex =1),ylim = c(0, 10))

#Create Augmented Matrices
aug.b <-function(mod,start){
coef <-coef(mod)
BB<-c(coef[start],coef[start+1],-(coef[start]+coef[start+1]),coef[start+2],coef[start+3],-(coef[start+2]+coef[start+3]))
}
BB <-aug.b(mod.a,3)

aug.c <-function(mod,start){
covar <-vcov(mod)
cov <-covar[start:(start+3),start:(start+3)]
rows<-function(cov,i,j)cbind(cov[i,1],cov[i,2],-(cov[i,1]+cov[i,2]),cov[i,3],cov[i,4],-(cov[i,3]+cov[i,4]))
aug <-rows(cov)
CC<-rbind(aug[1,],aug[2,],-(aug[1,]+aug[2,]),aug[3,],aug[4,],-(aug[3,]+aug[4,]))
}
CC <-aug.c(mod.a,3) 

#Simple Slopes
simple <-function(S){
simp.slope <-t(S)%*%BB;simp.err <-sqrt(diag(t(S)%*%CC%*%S))
df=(length(y)-length(coef(mod.a)))
ttests <-simp.slope/simp.err;pvalues <-2*pt(-abs(ttests),df=df)
crit <-abs(qt(0.025,df))
CI.low <-simp.slope-(crit*simp.err);CI.high <-simp.slope+(crit*simp.err)
simp.table<-round(matrix(c(simp.slope,simp.err,ttests,pvalues,CI.low,CI.high),nrow=ncol(S),ncol=6),digits=5)
dimnames(simp.table)=list(c(),c("slope","stderr","t","p","CI.low","CI.high"))
return(list(S,simp.table)) 
}

smat <-function(a,b){
s1 <-c(1*a,1*a,0,2*a,-1*a,-1*a);s2 <-c(-1*a,0,1*a,-1*a,2*a,-1*a)
s3 <-c(0,-1*a,-1*a,-1*a,-1*a,2*a);s4 <-c(1*b,1*b,0,2*b,-1*b,-1*b)
s5 <-c(-1*b,0,1*b,-1*b,2*b,-1*b);s6 <-c(0,-1*b,-1*b,-1*b,-1*b,2*b)
S <-rbind(s1,s2,s3,s4,s5,s6);simple(S)
}

simple.grp <-smat(1,0);simple.grp
simple.inter <-smat(0,1);simple.inter
simple.young <-smat(1,-sd(age));simple.young
simple.old <-smat(1,sd(age));simple.old

#2df Tests
dum.lo <-devage+sd(age)
eff1.lo <-eff1*dum.lo
eff2.lo <-eff2*dum.lo
summary(atlow <-lm(y~dum.lo+eff1.lo+eff2.lo))
anova(atlow,mod.a)

dum.hi <-devage-sd(age)
eff1.hi <-eff1*dum.hi
eff2.hi <-eff2*dum.hi
summary(athigh <-lm(y~dum.hi+eff1.hi+eff2.hi))
anova(athigh,mod.a)

###Section 14.3:  Regions of Significance
grp <-c(rep(1,4),rep(2,4),rep(3,4))
age <-c(29,27,39,53,57,32,45,21,47,55,29,22)
y  <-c(7,9,5,2,5,7,6,5,4,3,3,4)
eff1 <-c(rep(1,4),rep(0,4),rep(-1,4))
eff2 <-c(rep(0,4),rep(1,4),rep(-1,4))
devage <-age-mean(age)
summary(mod.a <-lm(y~devage+eff1+eff2+eff1*devage+eff2*devage))

#Create function for augmented vector
aug.b <-function(mod,start){
coef <-coef(mod)
BB<-c(coef[start],coef[start+1],-(coef[start]+coef[start+1]),coef[start+2],coef[start+3],-(coef[start+2]+coef[start+3]))
}
BB <-aug.b(mod.a,3)  #Enter model and first categorical coefficient

#Create function for augmented covariance matrix
aug.c <-function(mod,start){
covar <-vcov(mod)
cov <-covar[start:(start+3),start:(start+3)]
rows<-function(cov,i,j)cbind(cov[i,1],cov[i,2],-(cov[i,1]+cov[i,2]),cov[i,3],cov[i,4],-(cov[i,3]+cov[i,4]))
aug <-rows(cov)
CC<-rbind(aug[1,],aug[2,],-(aug[1,]+aug[2,]),aug[3,],aug[4,],-(aug[3,]+aug[4,]))
}
CC <-aug.c(mod.a,3) #Enter model and first categorical coefficient

#Create Johnson-Neyman Function  -- specify group comparisons
jnfunc <-function(a,b){
c = -(a+b)
j1 <-c(a,b,c,0,0,0)
j2 <-c(0,0,0,-a,-b,-c)
bg <-(-(t(j1)%*%BB))
bp <-t(j2)%*%BB
cgg <-t(j1)%*%CC%*%j1
cgp <-(-(t(j1)%*%CC%*%j2))
cpp <-t(j2)%*%CC%*%j2
df <-length(y)- length(coef(mod.a))
t.crit <-abs(qt(.025,df))
A <-(t.crit^2*cpp)-bp^2
B <-2*((t.crit^2*cgp-(bg*bp)))
C <-(t.crit^2*cgg)-bg^2
lower <-(-B+sqrt(B^2-4*A*C))/(2*A)
upper <-(-B-sqrt(B^2-4*A*C))/(2*A)
return <-cbind(lower,upper)
}

comp1 <-jnfunc(1,-1);comp2 <-jnfunc(1,0);comp3 <-jnfunc(0,1)
comp4 <-jnfunc(2,-1);comp5 <-jnfunc(-1,2);comp6 <-jnfunc(-1,-1)

regions <-rbind(comp1,comp2,comp3,comp4,comp5,comp6)
regions
raw.regions <-regions+mean(age);raw.regions
