nwickelmaier/mtt_haum
nwickelmaier/mtt_haum
0
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Some variable name and plot size adjustments

Browse Source
This commit is contained in:
Nora Wickelmaier 2024-03-18 15:32:09 +01:00
parent b08955b2c4
commit 26f90a7fec
2 changed files with 46 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
code/07_item-clustering.R
View File

@ -97,6 +97,7 @@ mycols <- c("#434F4F", "#78004B", "#FF6900", "#3CB4DC", "#91C86E", "Black")
cluster <- cutree(hc, k = k) cluster <- cutree(hc, k = k)
pdf("results/figures/dendrogram_items.pdf", width = 6.5, height = 5.5, pointsize = 10) pdf("results/figures/dendrogram_items.pdf", width = 6.5, height = 5.5, pointsize = 10)
# TODO: Move code for plots to /thesis/
factoextra::fviz_dend(hc, k = k, factoextra::fviz_dend(hc, k = k,
cex = 0.5, cex = 0.5,
@ -182,10 +183,10 @@ coor_2d <- cmdscale(dist_mat, k = 2)
items <- sprintf("%03d", as.numeric(rownames(datitem))) items <- sprintf("%03d", as.numeric(rownames(datitem)))
#pdf("results/figures/clustering_artworks.pdf", height = 8, width = 8, pointsize = 10) pdf("results/figures/clustering_artworks.pdf", height = 8, width = 8, pointsize = 16)
png("results/figures/clustering_artworks.png", units = "in", height = 8, width = 8, pointsize = 10, res = 300) #png("results/figures/clustering_artworks.png", units = "in", height = 8, width = 8, pointsize = 16, res = 300)
par(mai = c(.4,.4,.1,.1), mgp = c(2.4, 1, 0)) par(mai = c(.6,.6,.1,.1), mgp = c(2.4, 1, 0))
plot(coor_2d, type = "n", ylim = c(-3.7, 2.6), xlim = c(-5, 10.5), plot(coor_2d, type = "n", ylim = c(-3.7, 2.6), xlim = c(-5, 10.5),
xlab = "", ylab = "") xlab = "", ylab = "")
@ -208,7 +209,7 @@ for (item in items) {
points(x, y, points(x, y,
col = mycols[cluster[items == item]], col = mycols[cluster[items == item]],
cex = 9, cex = 6,
pch = 15) pch = 15)
rasterImage(img, rasterImage(img,

62
code/11_validation.R
View File

@ -25,10 +25,10 @@ dat <- dat[as.Date(dat$date.start) > "2017-12-31" &
#--------------- (2) Extract characteristics for cases --------------- #--------------- (2) Extract characteristics for cases ---------------
datcase <- aggregate(cbind(distance, scaleSize, rotationDegree) ~ datcase18 <- aggregate(cbind(distance, scaleSize, rotationDegree) ~
case, dat, function(x) mean(x, na.rm = TRUE), na.action = NULL) case, dat, function(x) mean(x, na.rm = TRUE), na.action = NULL)
datcase$length <- aggregate(item ~ case, dat, length)$item datcase18$length <- aggregate(item ~ case, dat, length)$item
eventtab <- aggregate(event ~ case, dat, table)["case"] eventtab <- aggregate(event ~ case, dat, table)["case"]
eventtab$nmove <- aggregate(event ~ case, dat, table)$event[, "move"] eventtab$nmove <- aggregate(event ~ case, dat, table)$event[, "move"]
@ -36,44 +36,44 @@ eventtab$nflipCard <- aggregate(event ~ case, dat, table)$event[, "flipCard"]
eventtab$nopenTopic <- aggregate(event ~ case, dat, table)$event[, "openTopic"] eventtab$nopenTopic <- aggregate(event ~ case, dat, table)$event[, "openTopic"]
eventtab$nopenPopup <- aggregate(event ~ case, dat, table)$event[, "openPopup"] eventtab$nopenPopup <- aggregate(event ~ case, dat, table)$event[, "openPopup"]
datcase <- datcase |> datcase18 <- datcase18 |>
merge(eventtab, by = "case", all = TRUE) merge(eventtab, by = "case", all = TRUE)
rm(eventtab) rm(eventtab)
datcase$nitems <- aggregate(item ~ case, dat, function(x) datcase18$nitems <- aggregate(item ~ case, dat, function(x)
length(unique(x)), na.action = NULL)$item length(unique(x)), na.action = NULL)$item
datcase$npaths <- aggregate(path ~ case, dat, function(x) datcase18$npaths <- aggregate(path ~ case, dat, function(x)
length(unique(x)), na.action = NULL)$path length(unique(x)), na.action = NULL)$path
dat_split <- split(dat, ~ case) dat_split <- split(dat, ~ case)
dat_list <- pbapply::pblapply(dat_split, time_minmax_ms) dat_list <- pbapply::pblapply(dat_split, time_minmax_ms)
dat_minmax <- dplyr::bind_rows(dat_list) dat_minmax <- dplyr::bind_rows(dat_list)
datcase$min_time <- aggregate(min_time ~ case, dat_minmax, unique)$min_time datcase18$min_time <- aggregate(min_time ~ case, dat_minmax, unique)$min_time
datcase$max_time <- aggregate(max_time ~ case, dat_minmax, unique)$max_time datcase18$max_time <- aggregate(max_time ~ case, dat_minmax, unique)$max_time
datcase$duration <- datcase$max_time - datcase$min_time datcase18$duration <- datcase18$max_time - datcase18$min_time
datcase$min_time <- NULL datcase18$min_time <- NULL
datcase$max_time <- NULL datcase18$max_time <- NULL
artworks <- unique(dat$item)[!unique(dat$item) %in% c("501", "502", "503")] artworks <- unique(dat$item)[!unique(dat$item) %in% c("501", "502", "503")]
datcase$infocardOnly <- pbapply::pbsapply(dat_split, check_infocards, artworks = artworks) datcase18$infocardOnly <- pbapply::pbsapply(dat_split, check_infocards, artworks = artworks)
# Clean up NAs # Clean up NAs
datcase$distance <- ifelse(is.na(datcase$distance), 0, datcase$distance) datcase18$distance <- ifelse(is.na(datcase18$distance), 0, datcase18$distance)
datcase$scaleSize <- ifelse(is.na(datcase$scaleSize), 1, datcase$scaleSize) datcase18$scaleSize <- ifelse(is.na(datcase18$scaleSize), 1, datcase18$scaleSize)
datcase$rotationDegree <- ifelse(is.na(datcase$rotationDegree), 0, datcase$rotationDegree) datcase18$rotationDegree <- ifelse(is.na(datcase18$rotationDegree), 0, datcase18$rotationDegree)
#--------------- (3) Select features for navigation behavior --------------- #--------------- (3) Select features for navigation behavior ---------------
dattree18 <- data.frame(case = datcase$case, dattree18 <- data.frame(case = datcase18$case,
PropItems = datcase$nitems / length(unique(dat$item)), PropItems = datcase18$nitems / length(unique(dat$item)),
SearchInfo = (datcase$nopenTopic + SearchInfo = (datcase18$nopenTopic +
datcase$nopenPopup) / datcase$length, datcase18$nopenPopup) / datcase18$length,
PropMoves = datcase$nmove / datcase$length, PropMoves = datcase18$nmove / datcase18$length,
PathLinearity = datcase$nitems / datcase$npaths, PathLinearity = datcase18$nitems / datcase18$npaths,
Singularity = datcase$npaths / datcase$length Singularity = datcase18$npaths / datcase18$length
) )
# centrality <- pbapply::pbsapply(dattree18$case, get_centrality, data = dat) # centrality <- pbapply::pbsapply(dattree18$case, get_centrality, data = dat)
@ -97,10 +97,10 @@ dattree18$AvDurItem <- aggregate(duration ~ case, tmp, mean)$duration
rm(tmp) rm(tmp)
# Indicator variable if table was used as info terminal only # Indicator variable if table was used as info terminal only
dattree18$InfocardOnly <- factor(datcase$infocardOnly, levels = 0:1, dattree18$InfocardOnly <- factor(datcase18$infocardOnly, levels = 0:1,
labels = c("no", "yes")) labels = c("no", "yes"))
# Add pattern to datcase; loosely based on Bousbia et al. (2009) # Add pattern
dattree18$Pattern <- "Dispersion" dattree18$Pattern <- "Dispersion"
dattree18$Pattern <- ifelse(dattree18$PathLinearity > 0.8, "Scholar", dattree18$Pattern <- ifelse(dattree18$PathLinearity > 0.8, "Scholar",
dattree18$Pattern) dattree18$Pattern)
@ -118,13 +118,13 @@ df <- dattree18[, c("PropItems", "SearchInfo", "PropMoves", "AvDurItemNorm",
dist_mat18 <- cluster::daisy(df, metric = "gower") dist_mat18 <- cluster::daisy(df, metric = "gower")
coor_3d <- smacof::mds(dist_mat, ndim = 3, type = "ordinal")$conf coor_3d_18 <- smacof::mds(dist_mat18, ndim = 3, type = "ordinal")$conf
coor_2d <- coor_3d[, 1:2] coor_2d_18 <- coor_3d_18[, 1:2]
plot(coor_2d) plot(coor_2d_18)
rgl::plot3d(coor_3d) rgl::plot3d(coor_3d_18)
hc18 <- cluster::agnes(dist_mat, method = "ward") hc18 <- cluster::agnes(dist_mat18, method = "ward")
k <- 5 k <- 5
@ -134,17 +134,17 @@ cluster18 <- cutree(as.hclust(hc18), k = k)
table(cluster18) table(cluster18)
plot(coor_2d, col = mycols[cluster18], pch = 16) plot(coor_2d_18, col = mycols[cluster18], pch = 16)
legend("topleft", c("Searching", "Exploring", "Scanning", "Flitting", "Info"), legend("topleft", c("Searching", "Exploring", "Scanning", "Flitting", "Info"),
col = mycols, bty = "n", pch = 16) col = mycols, bty = "n", pch = 16)
rgl::plot3d(coor_3d, col = mycols[cluster18]) rgl::plot3d(coor_3d_18, col = mycols[cluster18])
print(ftable(xtabs( ~ InfocardOnly + Pattern + cluster18, dattree18)), zero = "-") print(ftable(xtabs( ~ InfocardOnly + Pattern + cluster18, dattree18)), zero = "-")
aggregate(. ~ cluster18, df, mean) aggregate(. ~ cluster18, df, mean)
aggregate(. ~ cluster18, dattree18[, -1], mean) aggregate(. ~ cluster18, dattree18[, -1], mean)
save(coor_2d, coor_3d, cluster18, dattree18, dist_mat18, hc18, save(coor_2d_18, coor_3d_18, cluster18, dattree18, dist_mat18, hc18,
file = "../../thesis/figures/data/clustering_cases_2018.RData") file = "../../thesis/figures/data/clustering_cases_2018.RData")
#--------------- (5) Fit tree --------------- #--------------- (5) Fit tree ---------------