# 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)Run the code above in your browser using DataLab