# NOT RUN {
# Additive model
bg.add <- mlcm(BumpyGlossy)
plot(bg.add, type = "b")
# Independence model for Bumpiness
bg.ind <- mlcm(BumpyGlossy, model = "ind", whichdim = 2)
anova(bg.ind, bg.add, test = "Chisq")
# Full model
bg.full <- mlcm(BumpyGlossy, model = "full")
anova(bg.add, bg.full, test = "Chisq")
opar <- par(mfrow = c(1, 2), pty = "s")
# Compare additive and full model graphically
plot(bg.full, standard.scale = TRUE, type = "b",
lty = 2, ylim = c(0, 1.05),
xlab = "Gloss Level",
ylab = "Bumpiness Model Estimates")
# additive prediction
bg.pr <- with(bg.add, outer(pscale[, 1], pscale[, 2], "+"))
# predictions are same for arbitrary scaling,
# so we adjust additive predictions to best fit
# those from the full model by a scale factor.
cf <- coef(lm(as.vector(bg.full$pscale/bg.full$pscale[5, 5]) ~
as.vector(bg.pr) - 1))
matplot(cf * bg.pr, type = "b", add = TRUE, lty = 1)
#### Now make image of residuals between 2 models
bg.full.sc <- bg.full$pscale/bg.full$pscale[5, 5]
bg.add.adj <- cf * bg.pr
bg.res <- (bg.add.adj - bg.full.sc) + 0.5
image(1:5, 1:5, bg.res,
col = grey.colors(100, min(bg.res), max(bg.res)),
xlab = "Gloss Level", ylab = "Bumpiness Level"
)
#### Example with formula
# additive model
bg.frm <- mlcm(~ p[1] * (x - 1)^p[2] + p[3] * (y - 1)^p[4],
p = c(0.1, 1.3, 1.6, 0.8), data = BumpyGlossy)
summary(bg.frm)
# independence model
bg.frm1 <- mlcm(~ p[1] * (x - 1)^p[2], p = c(1.6, 0.8),
data = BumpyGlossy, model = "ind", whichdim = 2)
summary(bg.frm1)
### Test additive against independent fits
ddev <- -2 * (logLik(bg.frm1) - logLik(bg.frm))
df <- attr(logLik(bg.frm), "df") - attr(logLik(bg.frm1), "df")
pchisq(as.vector(ddev), df, lower = FALSE)
# Compare additive power law and nonparametric models
xx <- seq(1, 5, len = 100)
par(mfrow = c(1, 1))
plot(bg.add, pch = 21, bg = c("red", "blue"))
lines(xx, predict(bg.frm, newdata = xx)[seq_along(xx)])
lines(xx, predict(bg.frm, newdata = xx)[-seq_along(xx)])
AIC(bg.frm, bg.add)
par(opar)
#### Analysis of 3-way MLCM data set
# additive model
T.mlcm <- mlcm(Texture)
summary(T.mlcm)
plot(T.mlcm, type = "b")
# independent models
lapply(seq(1, 3), function(wh){
m0 <- mlcm(Texture, model = "ind", which = wh)
anova(m0, T.mlcm, test = "Chisq")
})
# Deviance differences for 2-way interactions vs 2-way additive models
mlcm(Texture[, -c(4, 5)])$obj$deviance -
mlcm(Texture[, -c(4, 5)], model = "full")$obj$deviance
mlcm(Texture[, -c(2, 3)])$obj$deviance -
mlcm(Texture[, -c(2, 3)], model = "full")$obj$deviance
mlcm(Texture[, -c(6, 7)])$obj$deviance -
mlcm(Texture[, -c(6, 7)], model = "full")$obj$deviance
# deviance differences for 3-way interaction tested against 3 2-way interactions
T3way.mlcm <- mlcm(Texture, model = "full")
## construct model matrix from 3 2-way interactions
T3_2way.mf <- cbind(model.frame(mlcm(Texture[, -c(4, 5)], model = "full")$obj),
model.matrix(mlcm(Texture[, -c(2, 3)], model = "full")$obj),
model.matrix(mlcm(Texture[, -c(6, 7)], model = "full")$obj)
)
T3_2way.mlcm <- glm(Resp ~ . + 0, family = binomial(probit), data = T3_2way.mf)
Chi2 <- T3_2way.mlcm$deviance - T3way.mlcm$obj$deviance
degfr <- T3_2way.mlcm$df.residual - T3way.mlcm$obj$df.residual
pchisq(Chi2, degfr, lower.tail = FALSE)
# }
Run the code above in your browser using DataLab