# NOT RUN {
requireNamespace("psychotools")
data(soundquality)
######### Replication code for Choisel and Wickelmaier (2007) ######
### A. Scaling overall preference
## Participants
summary(subset(SQsubjects, status == "selected"))
## Transitivity violations
aggregate(preference ~ progmat + time,
data = SQpreference,
function(x) unlist(strans(summary(x, pcmatrix = TRUE))[
c("weak", "moderate", "strong")]))
## BTL modeling
prefdf <- aggregate(preference ~ progmat + time,
data = SQpreference,
function(x) uscale(eba(summary(x, pcmatrix = TRUE))))
## Preference scale
p <- t(prefdf[prefdf$time == "before", 3])
colnames(p) <- levels(prefdf$progmat)
dotchart(p, main = "Quality of multichannel reproduced sound",
xlab = "Estimated preference (BTL model)", log = "x",
panel.first = abline(v = 1/8, col = "gray"))
points(x = t(prefdf[prefdf$time == "after", 3]),
y = c(31:38, 21:28, 11:18, 1:8), pch = 3)
legend("topleft", c("before", "after"), pch = c(1, 3))
mtext("(Choisel and Wickelmaier, 2007)", line = 0.5)
### B. Scaling specific auditory attributes
## Transitivity violations
aggregate(
x = SQattributes[-(1:2)],
by = list(progmat = SQattributes$progmat),
FUN = function(x) strans(summary(x, pcmatrix = TRUE))[
c("weak", "moderate", "strong")],
simplify = FALSE
)
## BTL modeling
uscal <- aggregate(
x = SQattributes[-(1:2)],
by = list(progmat = SQattributes$progmat),
FUN = function(x) uscale(eba(summary(x, pcmatrix = TRUE)))
)
uscal <- data.frame(
progmat = rep(levels(SQattributes$progmat), each = 8),
repmod = factor(1:8, labels = labels(SQattributes$width)),
as.data.frame(sapply(uscal[-1], t))
)
## EBA modeling: envelopment, width
uscal$envelopment[uscal$progmat == "SteelyDan"] <-
uscale(eba(summary(SQattributes[SQattributes$progmat == "SteelyDan",
"envelopment"], pcmatrix = TRUE),
A = list(c(1,9), c(2,9), c(3,9), c(4,9), 5, 6, c(7,9), 8)))
uscal$width[uscal$progmat == "SteelyDan"] <-
uscale(eba(summary(SQattributes[SQattributes$progmat == "SteelyDan",
"width"], pcmatrix = TRUE),
A = list(1, 2, c(3,9), c(4,9), c(5,9), 6, 7, c(8,9))))
### C. Relating overall preference to specific attributes
## Principal components: classical music
pca1 <- princomp(
~ width + spaciousness + envelopment + distance +
clarity + brightness + elevation,
data = uscal,
subset = progmat %in% c("Beethoven", "Rachmaninov"),
cor = TRUE
)
## Loadings on first two components
L <- varimax(loadings(pca1) %*% diag(pca1$sdev)[, 1:2])
## Factor scores
f <- scale(predict(pca1)[, 1:2]) %*% L$rotmat
dimnames(f) <- list(
abbreviate(rep(labels(SQattributes$width), 2), 2),
names(pca1$sdev)[1:2]
)
biplot(f, 2*L$loadings, cex = 0.8, expand = 1.5,
main = "Preference and auditory attributes: classical music",
xlim = c(-1.5, 2), ylim = c(-2, 2))
## Predicting preference
classdf <- cbind(
pref = as.vector(t(prefdf[prefdf$time == "after" &
prefdf$progmat %in% c("Beethoven", "Rachmaninov"), 3])),
as.data.frame(f)
)
m1 <- lm(pref ~ Comp.1 + Comp.2 + I(Comp.1^2), classdf)
c1 <- seq(-1.5, 2.0, length.out = 101)
c2 <- seq(-2.0, 2.0, length.out = 101)
z <- matrix(predict(m1, expand.grid(Comp.1 = c1, Comp.2 = c2)), 101, 101)
contour(c1, c2, z, add = TRUE, col = "darkblue")
## Principal components: pop music
pca2 <- princomp(
~ width + spaciousness + envelopment + distance +
clarity + brightness + elevation,
data = uscal,
subset = progmat %in% c("SteelyDan", "Sting"),
cor = TRUE
)
L <- varimax(loadings(pca2) %*% diag(pca2$sdev)[, 1:2])
f[] <- scale(predict(pca2)[, 1:2]) %*% L$rotmat
biplot(f, 2*L$loadings, cex = 0.8,
main = "Preference and auditory attributes: pop music",
xlim = c(-1.5, 2), ylim = c(-2.5, 1.5))
popdf <- cbind(
pref = as.vector(t(prefdf[prefdf$time == "after" &
prefdf$progmat %in% c("SteelyDan", "Sting"), 3])),
as.data.frame(f)
)
m2 <- lm(pref ~ Comp.1 + Comp.2 + I(Comp.2^2), popdf)
c1 <- seq(-1.5, 2.0, length.out = 101)
c2 <- seq(-2.5, 1.5, length.out = 101)
z <- matrix(predict(m2, expand.grid(Comp.1 = c1, Comp.2 = c2)), 101, 101)
contour(c1, c2, z, add = TRUE, col = "darkblue")
# }
Run the code above in your browser using DataLab