#####Chapter 12: Factorial Designs

###Section 12.1: Balanced Factorial Designs
grp <-c(1,1,1,2,2,2,3,3,3,4,4,4)
y <-c(3,4,3,5,3,4,5,6,4,9,9,8)
dum1 <-c(rep(0,3),rep(1,3),rep(0,6))
dum2 <-c(rep(0,6),rep(1,3),rep(0,3))
dum3 <-c(rep(0,9),rep(1,3))
summary(dum.reg <-lm(y~dum1+dum2+dum3))
tapply(y, factor(grp), mean)                 #Calculate Group Means

#Effect coding
eff1 <-c(rep(-.5,6),rep(.5,6));
eff2 <-c(rep(c(rep(-.5,3),rep(.5,3)),2))

#ANOVA
anova.mod <-aov(y~factor(eff1)*factor(eff2))
summary(anova.mod)
barplot(tapply(y,list(eff2,eff1),mean),beside=T,
main = "Exercise and Muscle Tone", col = c("white", "gray"),
xlab = "Weightlifting", names = c("No", "Yes"), 
ylab = "Muscle Tone", legend = c("No Bike", "Bike"), 
args.legend = list(title = "Bike", x = "top", cex =1),ylim = c(0, 10))

#Regression model
reg.mod <-lm(y~eff1*eff2)
summary(reg.mod)
anova(reg.mod)

#Construct S Matrix for Simple Slopes
s0 <-rep(0,4)
s1 <-c(rep(1,2),rep(0,2))
s2 <-c(rep(0,2),rep(1,2))
s3 <-c(-.5,.5,-.5,.5)
S <- rbind(s0,s1,s2,s3)

#Simple Effecs
simp.slope <-t(S)%*%coef(reg.mod)
simp.cov <-t(S)%*%vcov(reg.mod)%*%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=nrow(S),ncol=6),digits=5)
dimnames(simp.table)=list(c("a@b1","a@b2","b@a1","b@a2"),c("slope", "stderr", "t","p","CI.low","CI.high"))
simp.table


###Section 12.2: Unbalanced Factorial Designs
g <-c(1,1,1,2,2,3,3,4,4,4,4,4)
y <-c(62,58,62,42,40,66,64,46,44,42,46,42)
#Effect coding
eff1 <-c(rep(-.5,5),rep(.5,7))
eff2 <-c(rep(-.5,3),rep(.5,2),rep(-.5,2),rep(.5,5))
tapply(y, factor(g), mean)                 #Calculate Group Means

#Plot Means
barplot(tapply(y,list(eff2,eff1),mean),beside=T,
col = c("white", "gray"),
xlab = "Class", names = c("Sophomore", "Senior"), 
ylab = "Study Time", legend = c("Dorm", "Apartment"), 
args.legend = list(title = "Domicile", x = "topright", cex =.9),ylim = c(0, 80))

#Unweighted Means
unweighted.mod <-lm(y~eff1*eff2)
summary(unweighted.mod)
vcov(unweighted.mod)
library(car)                        #Attach car package for unweighted ANOVA
Anova(unweighted.mod,type=3)

#Weighted Means
eff3 <-eff1*eff2
b1.A <-eff1-mean(eff1)
b1.reg <-lm(eff2~eff1+b1.A)
b2.B <-resid(b1.reg)
b2.reg <-lm(eff3~b1.A+b2.B)
b3.AB <-resid(b2.reg)
wgts <-cbind(b1.A,b2.B,b3.AB)
wgts	
weighted.mod <-lm(y~b1.A+b2.B+b3.AB)
summary(weighted.mod)
vcov(weighted.mod)
Anova(weighted.mod)              #No need to specify type with weighted means

###Section 12.3.1:  Multilevel Designs
g <-c(1,1,2,2,3,3,4,4,5,5,6,6)
y=c(48,46,30,35,56,66,76,72,76,68,53,49)
g1 <-c(1,1,1,1,2,2,2,2,3,3,3,3)
g2 <-c(1,1,2,2,1,1,2,2,1,1,2,2)
tapply(y, factor(g), mean)                 #Calculate Group Means

#ANOVA model
anova.mod <-aov(y~factor(g1)*factor(g2))
summary(anova.mod)

barplot(tapply(y,list(g2,g1),mean),beside=T,
main = "Unbalanced ANOVA", col = c("white", "gray"),
xlab = "Class Standing", names = c("Sophomores", "Juniors", "Seniors"), 
ylab = "Study Time", legend = c("Dorm", "Apartment"), 
args.legend = list(title = "Housing", x = "top", cex =1),ylim = c(0, 100))

#2df coding for Regression Model
v1 <-c(rep(1,4),rep(0,4),rep(-1,4))
v2 <-c(rep(0,4),rep(1,4),rep(-1,4))
v3 <-c(rep(c(rep(.5,2),rep(-.5,2)),3))
v4 <-v1*v3
v5 <-v2*v3
reg.mod <-lm(y~v1+v2+v3+v4+v5)
summary(reg.mod)

#Get Weighted Sum of Squares Regression for Each Model
ssreg <- sum(anova(reg.mod)[1:5,2] );
dfreg <- sum(anova(reg.mod)[1:5,1] )
ssres <- anova(lm(y~v1+v2+v3+v4+v5))[6,2]
dfres <- anova(lm(y~v1+v2+v3+v4+v5))[6,1]
msres = ssres/dfres

ss.omit.a <- sum(anova(lm(y~v3+v4+v5))[1:3,2])
df.omit.a <- sum(anova(lm(y~v3+v4+v5))[1:3,1])
ss.a <- ssreg-ss.omit.a;ss.a
f.a <-(ss.a/(dfreg-df.omit.a))/msres;f.a

ss.omit.b <- sum(anova(lm(y~v1+v2+v4+v5))[1:4,2])
df.omit.b <- sum(anova(lm(y~v1+v2+v4+v5))[1:4,1])
ss.b <- ssreg-ss.omit.b;ss.b
f.b <-(ss.b/(dfreg-df.omit.b))/msres;f.b

ss.omit.ab <- sum(anova(lm(y~v1+v2+v3))[1:3,2])
df.omit.ab <- sum(anova(lm(y~v1+v2+v3))[1:3,1])
ss.ab <- ssreg-ss.omit.ab;ss.ab
f.ab <-(ss.ab/(dfreg-df.omit.ab))/msres;f.ab


###Section 12.3.2:  Interactions in Multilevel Designs
grp <-c(1,1,2,2,3,3,4,4,5,5,6,6)
y <-c(48,46,30,35,56,66,76,72,76,68,53,49)
tapply(y, factor(grp), mean)                 #Calculate Group Means

#2df coding
v1 <-c(rep(1,4),rep(0,4),rep(-1,4));v2 <-c(rep(0,4),rep(1,4),rep(-1,4))
v3 <-c(rep(c(rep(.5,2),rep(-.5,2)),3));v4 <-v1*v3;v5 <-v2*v3
reg.mod <-lm(y~v1+v2+v3+v4+v5);summary(reg.mod)

#Generate Augmented Coefficients and Covariance Matrix
b <-reg.mod$coef[2: length(reg.mod$coef)]
BB<-c(b [1:2],-(b[1]+b[2]),b[3:5],-(b[4]+b[5]));BB;covar <-vcov(reg.mod)
cov <- covar[2: length(reg.mod$coef),2: length(reg.mod$coef)]
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,5],-(cov[i,4]+cov[i,5]))
aug <-rows(cov)
CC<-rbind(aug[1,],aug[2,],-(aug[1,]+aug[2,]),aug[3,],aug[4,],aug[5,],-(aug[4,]+aug[5,]));CC

#Simple Effects
simple <-function(S){
simp.slope <-t(S)%*%BB;simp.err <-sqrt(diag(t(S)%*%CC%*%S))
df=(length(y)-length(coef(reg.mod)))
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)) 
}

#B at Levels of A
c1 <-c(0,0,0);c2 <-c(0,0,0);c3 <-c(0,0,0);c4 <-c(1,1,1);c5 <-c(1,0,0);c6 <-c(0,1,0);c7 <-c(0,0,1);S <-rbind(c1,c2,c3,c4,c5,c6,c7);simple(S)

SEFF <-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(rep(0,6))
s5 <-c(1*b,1*b,0,2*b,-1*b,-1*b);s6 <-c(-1*b,0,1*b,-1*b,2*b,-1*b)
s7 <-c(0,-1*b,-1*b,-1*b,-1*b,2*b);S <-rbind(s1,s2,s3,s4,s5,s6,s7)
simple(S)}

#Simple Effects Function   #Codes must be specified
SEFF (1,0)                 #A collapsed across B
SEFF (0,1)                 #AxB interactions
SEFF (1,.5)                #Simple effects of A @ b1
SEFF (1,-.5)               #Simple effects of A @ b2

## 2df Simple Effects
dum.a1 <-ifelse(v3 == .5,0,v3);dum.a2 <-dum.a1*v1;dum.a3 <-dum.a2*v2
simpa <-lm(y~ dum.a1+dum.a2+dum.a3);F.A <-anova(simpa,reg.mod);F.A
dum.b1 <-ifelse(v3 == -.5,0,v3);dum.b2 <-dum.b1*v1;dum.b3 <-dum.b2*v2
simpb <-lm(y~ dum.b1+dum.b2+dum.b3);F.B <-anova(simpb,reg.mod);F.B
