Added validation script redoing analysis for case clustering for data from 2018
This commit is contained in:
parent
88ac019b93
commit
b08955b2c4
@ -3,12 +3,13 @@
|
|||||||
# content: (1) Load data
|
# content: (1) Load data
|
||||||
# (2) Clustering
|
# (2) Clustering
|
||||||
# (3) Fit tree
|
# (3) Fit tree
|
||||||
# (4) Investigate variants
|
|
||||||
#
|
#
|
||||||
# input: results/haum/event_logfiles_2024-02-21_16-07-33.csv
|
# input: results/haum/dataframes_case_2019.RData
|
||||||
# output: results/haum/eventlogs_pre-corona_case-clusters.csv
|
# output: results/haum/eventlogs_2019_case-clusters.csv
|
||||||
|
# results/haum/tmp_user-navigation.RData
|
||||||
|
# ../../thesis/figures/data/clustering_cases.RData
|
||||||
#
|
#
|
||||||
# last mod: 2024-03-14
|
# last mod: 2024-03-15
|
||||||
|
|
||||||
# setwd("C:/Users/nwickelmaier/Nextcloud/Documents/MDS/2023ss/60100_master_thesis/analysis/code")
|
# setwd("C:/Users/nwickelmaier/Nextcloud/Documents/MDS/2023ss/60100_master_thesis/analysis/code")
|
||||||
|
|
||||||
@ -126,7 +127,7 @@ write.table(res,
|
|||||||
save(res, dist_mat, hcs, acs, coor_2d, coor_3d,
|
save(res, dist_mat, hcs, acs, coor_2d, coor_3d,
|
||||||
file = "results/haum/tmp_user-navigation.RData")
|
file = "results/haum/tmp_user-navigation.RData")
|
||||||
|
|
||||||
save(coor_2d, coor_3d, cluster,
|
save(coor_2d, coor_3d, cluster, dattree,
|
||||||
file = "../../thesis/figures/data/clustering_cases.RData")
|
file = "../../thesis/figures/data/clustering_cases.RData")
|
||||||
|
|
||||||
|
|
||||||
@ -140,9 +141,7 @@ c1 <- rpart::rpart(as.factor(cluster) ~ ., data = dattree[, c("PropMoves",
|
|||||||
"InfocardOnly")],
|
"InfocardOnly")],
|
||||||
method = "class")
|
method = "class")
|
||||||
|
|
||||||
pdf("results/figures/tree_cases_rpart.pdf", height = 5, width = 15, pointsize = 10)
|
|
||||||
plot(partykit::as.party(c1), tp_args = list(fill = mycols, col = mycols))
|
plot(partykit::as.party(c1), tp_args = list(fill = mycols, col = mycols))
|
||||||
dev.off()
|
|
||||||
|
|
||||||
# with conditional tree
|
# with conditional tree
|
||||||
c2 <- partykit::ctree(as.factor(cluster) ~ ., data = dattree[, c("PropMoves",
|
c2 <- partykit::ctree(as.factor(cluster) ~ ., data = dattree[, c("PropMoves",
|
||||||
@ -153,9 +152,7 @@ c2 <- partykit::ctree(as.factor(cluster) ~ ., data = dattree[, c("PropMoves",
|
|||||||
"InfocardOnly")],
|
"InfocardOnly")],
|
||||||
alpha = 0.001)
|
alpha = 0.001)
|
||||||
|
|
||||||
pdf("results/figures/tree_cases_ctree.pdf", height = 7, width = 20, pointsize = 10)
|
|
||||||
plot(c2, tp_args = list(fill = mycols, col = mycols))
|
plot(c2, tp_args = list(fill = mycols, col = mycols))
|
||||||
dev.off()
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -163,7 +160,7 @@ dev.off()
|
|||||||
factoextra::fviz_dend(as.hclust(hc), k = k,
|
factoextra::fviz_dend(as.hclust(hc), k = k,
|
||||||
cex = 0.5,
|
cex = 0.5,
|
||||||
k_colors = mycols,
|
k_colors = mycols,
|
||||||
#type = "phylogenic",
|
type = "phylogenic",
|
||||||
rect = TRUE,
|
rect = TRUE,
|
||||||
main = "",
|
main = "",
|
||||||
ylab = ""
|
ylab = ""
|
||||||
|
|||||||
181
code/11_validation.R
Normal file
181
code/11_validation.R
Normal file
@ -0,0 +1,181 @@
|
|||||||
|
# 11_validation.R
|
||||||
|
#
|
||||||
|
# content: (1) Load data
|
||||||
|
# (2) Extract characteristics for cases
|
||||||
|
# (3) Select features for navigation behavior
|
||||||
|
# (4) Clustering
|
||||||
|
# (5) Fit tree
|
||||||
|
#
|
||||||
|
# input: results/haum/event_logfiles_2024-02-21_16-07-33.csv
|
||||||
|
# output: results/haum/eventlogs_pre-corona_case-clusters.csv
|
||||||
|
#
|
||||||
|
# last mod: 2024-03-15
|
||||||
|
|
||||||
|
# setwd("C:/Users/nwickelmaier/Nextcloud/Documents/MDS/2023ss/60100_master_thesis/analysis/code")
|
||||||
|
|
||||||
|
source("R_helpers.R")
|
||||||
|
|
||||||
|
#--------------- (1) Read data ---------------
|
||||||
|
|
||||||
|
load("results/haum/eventlogs_pre-corona_cleaned.RData")
|
||||||
|
|
||||||
|
# Select one year to handle number of cases
|
||||||
|
dat <- dat[as.Date(dat$date.start) > "2017-12-31" &
|
||||||
|
as.Date(dat$date.start) < "2019-01-01", ]
|
||||||
|
|
||||||
|
#--------------- (2) Extract characteristics for cases ---------------
|
||||||
|
|
||||||
|
datcase <- aggregate(cbind(distance, scaleSize, rotationDegree) ~
|
||||||
|
case, dat, function(x) mean(x, na.rm = TRUE), na.action = NULL)
|
||||||
|
|
||||||
|
datcase$length <- aggregate(item ~ case, dat, length)$item
|
||||||
|
|
||||||
|
eventtab <- aggregate(event ~ case, dat, table)["case"]
|
||||||
|
eventtab$nmove <- aggregate(event ~ case, dat, table)$event[, "move"]
|
||||||
|
eventtab$nflipCard <- aggregate(event ~ case, dat, table)$event[, "flipCard"]
|
||||||
|
eventtab$nopenTopic <- aggregate(event ~ case, dat, table)$event[, "openTopic"]
|
||||||
|
eventtab$nopenPopup <- aggregate(event ~ case, dat, table)$event[, "openPopup"]
|
||||||
|
|
||||||
|
datcase <- datcase |>
|
||||||
|
merge(eventtab, by = "case", all = TRUE)
|
||||||
|
|
||||||
|
rm(eventtab)
|
||||||
|
|
||||||
|
datcase$nitems <- aggregate(item ~ case, dat, function(x)
|
||||||
|
length(unique(x)), na.action = NULL)$item
|
||||||
|
datcase$npaths <- aggregate(path ~ case, dat, function(x)
|
||||||
|
length(unique(x)), na.action = NULL)$path
|
||||||
|
|
||||||
|
dat_split <- split(dat, ~ case)
|
||||||
|
dat_list <- pbapply::pblapply(dat_split, time_minmax_ms)
|
||||||
|
dat_minmax <- dplyr::bind_rows(dat_list)
|
||||||
|
|
||||||
|
datcase$min_time <- aggregate(min_time ~ case, dat_minmax, unique)$min_time
|
||||||
|
datcase$max_time <- aggregate(max_time ~ case, dat_minmax, unique)$max_time
|
||||||
|
|
||||||
|
datcase$duration <- datcase$max_time - datcase$min_time
|
||||||
|
datcase$min_time <- NULL
|
||||||
|
datcase$max_time <- NULL
|
||||||
|
|
||||||
|
artworks <- unique(dat$item)[!unique(dat$item) %in% c("501", "502", "503")]
|
||||||
|
datcase$infocardOnly <- pbapply::pbsapply(dat_split, check_infocards, artworks = artworks)
|
||||||
|
|
||||||
|
# Clean up NAs
|
||||||
|
datcase$distance <- ifelse(is.na(datcase$distance), 0, datcase$distance)
|
||||||
|
datcase$scaleSize <- ifelse(is.na(datcase$scaleSize), 1, datcase$scaleSize)
|
||||||
|
datcase$rotationDegree <- ifelse(is.na(datcase$rotationDegree), 0, datcase$rotationDegree)
|
||||||
|
|
||||||
|
#--------------- (3) Select features for navigation behavior ---------------
|
||||||
|
|
||||||
|
dattree18 <- data.frame(case = datcase$case,
|
||||||
|
PropItems = datcase$nitems / length(unique(dat$item)),
|
||||||
|
SearchInfo = (datcase$nopenTopic +
|
||||||
|
datcase$nopenPopup) / datcase$length,
|
||||||
|
PropMoves = datcase$nmove / datcase$length,
|
||||||
|
PathLinearity = datcase$nitems / datcase$npaths,
|
||||||
|
Singularity = datcase$npaths / datcase$length
|
||||||
|
)
|
||||||
|
|
||||||
|
# centrality <- pbapply::pbsapply(dattree18$case, get_centrality, data = dat)
|
||||||
|
# save(centrality, file = "results/haum/tmp_centrality_2018.RData")
|
||||||
|
load("results/haum/tmp_centrality_2018.RData")
|
||||||
|
|
||||||
|
dattree18$BetweenCentrality <- centrality
|
||||||
|
|
||||||
|
# Average duration per item
|
||||||
|
dat_split <- split(dat[, c("item", "case", "path", "timeMs.start", "timeMs.stop")], ~ path)
|
||||||
|
dat_list <- pbapply::pblapply(dat_split, time_minmax_ms)
|
||||||
|
dat_minmax <- dplyr::bind_rows(dat_list)
|
||||||
|
|
||||||
|
tmp <- aggregate(min_time ~ path, dat_minmax, unique)
|
||||||
|
tmp$max_time <- aggregate(max_time ~ path, dat_minmax, unique, na.action = NULL)$max_time
|
||||||
|
tmp$duration <- tmp$max_time - tmp$min_time
|
||||||
|
tmp$case <- aggregate(case ~ path, dat_minmax, unique)$case
|
||||||
|
|
||||||
|
dattree18$AvDurItem <- aggregate(duration ~ case, tmp, mean)$duration
|
||||||
|
|
||||||
|
rm(tmp)
|
||||||
|
|
||||||
|
# Indicator variable if table was used as info terminal only
|
||||||
|
dattree18$InfocardOnly <- factor(datcase$infocardOnly, levels = 0:1,
|
||||||
|
labels = c("no", "yes"))
|
||||||
|
|
||||||
|
# Add pattern to datcase; loosely based on Bousbia et al. (2009)
|
||||||
|
dattree18$Pattern <- "Dispersion"
|
||||||
|
dattree18$Pattern <- ifelse(dattree18$PathLinearity > 0.8, "Scholar",
|
||||||
|
dattree18$Pattern)
|
||||||
|
dattree18$Pattern <- ifelse(dattree18$PathLinearity <= 0.8 &
|
||||||
|
dattree18$BetweenCentrality >= 0.5, "Star",
|
||||||
|
dattree18$Pattern)
|
||||||
|
dattree18$Pattern <- factor(dattree18$Pattern)
|
||||||
|
|
||||||
|
dattree18$AvDurItemNorm <- normalize(dattree18$AvDurItem)
|
||||||
|
|
||||||
|
#--------------- (4) Clustering ---------------
|
||||||
|
|
||||||
|
df <- dattree18[, c("PropItems", "SearchInfo", "PropMoves", "AvDurItemNorm",
|
||||||
|
"Pattern", "InfocardOnly")]
|
||||||
|
|
||||||
|
dist_mat18 <- cluster::daisy(df, metric = "gower")
|
||||||
|
|
||||||
|
coor_3d <- smacof::mds(dist_mat, ndim = 3, type = "ordinal")$conf
|
||||||
|
coor_2d <- coor_3d[, 1:2]
|
||||||
|
|
||||||
|
plot(coor_2d)
|
||||||
|
rgl::plot3d(coor_3d)
|
||||||
|
|
||||||
|
hc18 <- cluster::agnes(dist_mat, method = "ward")
|
||||||
|
|
||||||
|
k <- 5
|
||||||
|
|
||||||
|
mycols <- c("#91C86E", "#FF6900", "#3CB4DC", "#78004B", "#434F4F")
|
||||||
|
|
||||||
|
cluster18 <- cutree(as.hclust(hc18), k = k)
|
||||||
|
|
||||||
|
table(cluster18)
|
||||||
|
|
||||||
|
plot(coor_2d, col = mycols[cluster18], pch = 16)
|
||||||
|
legend("topleft", c("Searching", "Exploring", "Scanning", "Flitting", "Info"),
|
||||||
|
col = mycols, bty = "n", pch = 16)
|
||||||
|
rgl::plot3d(coor_3d, col = mycols[cluster18])
|
||||||
|
|
||||||
|
print(ftable(xtabs( ~ InfocardOnly + Pattern + cluster18, dattree18)), zero = "-")
|
||||||
|
|
||||||
|
aggregate(. ~ cluster18, df, mean)
|
||||||
|
aggregate(. ~ cluster18, dattree18[, -1], mean)
|
||||||
|
|
||||||
|
save(coor_2d, coor_3d, cluster18, dattree18, dist_mat18, hc18,
|
||||||
|
file = "../../thesis/figures/data/clustering_cases_2018.RData")
|
||||||
|
|
||||||
|
#--------------- (5) Fit tree ---------------
|
||||||
|
|
||||||
|
c1 <- rpart::rpart(as.factor(cluster18) ~ ., data = dattree18[, c("PropMoves",
|
||||||
|
"PropItems",
|
||||||
|
"SearchInfo",
|
||||||
|
"AvDurItem",
|
||||||
|
"Pattern",
|
||||||
|
"InfocardOnly")],
|
||||||
|
method = "class")
|
||||||
|
|
||||||
|
plot(partykit::as.party(c1), tp_args = list(fill = mycols, col = mycols))
|
||||||
|
|
||||||
|
|
||||||
|
## Load data
|
||||||
|
load("../../thesis/figures/data/clustering_cases.RData")
|
||||||
|
|
||||||
|
c19 <- rpart::rpart(as.factor(cluster) ~ ., data = dattree[, c("PropMoves",
|
||||||
|
"PropItems",
|
||||||
|
"SearchInfo",
|
||||||
|
"AvDurItem",
|
||||||
|
"Pattern",
|
||||||
|
"InfocardOnly")],
|
||||||
|
method = "class")
|
||||||
|
|
||||||
|
cl18 <- rpart:::predict.rpart(c1, type = "class", newdata = dattree18)
|
||||||
|
cl18 <- factor(cl18, labels = c("Searching", "Exploring", "Scanning", "Flitting", "Info"))
|
||||||
|
|
||||||
|
cl19 <- rpart:::predict.rpart(c19, type = "class", newdata = dattree18)
|
||||||
|
cl19 <- factor(cl19, labels = c("Scanning", "Exploring", "Flitting", "Searching", "Info"))
|
||||||
|
|
||||||
|
xtabs( ~ cl18 + cl19)
|
||||||
|
|
||||||
@ -48,13 +48,23 @@ vioplot::vioplot(tr$absolute_frequency)
|
|||||||
|
|
||||||
# Power law for frequencies of traces
|
# Power law for frequencies of traces
|
||||||
tab <- table(tr$absolute_frequency)
|
tab <- table(tr$absolute_frequency)
|
||||||
x <- as.numeric(tab)
|
x <- as.numeric(names(tab))
|
||||||
y <- as.numeric(names(tab))
|
y <- as.numeric(tab)
|
||||||
|
|
||||||
plot(x, y, log = "xy")
|
|
||||||
p1 <- lm(log(y) ~ log(x))
|
p1 <- lm(log(y) ~ log(x))
|
||||||
pre <- exp(coef(p1)[1]) * x^coef(p1)[2]
|
pre <- exp(coef(p1)[1]) * x^coef(p1)[2]
|
||||||
lines(x, pre)
|
|
||||||
|
pdf("results/figures/freq-traces_powerlaw.pdf", height = 3.375,
|
||||||
|
width = 3.375, pointsize = 10)
|
||||||
|
par(mai = c(.6,.6,.1,.1), mgp = c(2.4, 1, 0))
|
||||||
|
|
||||||
|
plot(x, y, log = "xy", xlab = "Absolute Frequency of Traces",
|
||||||
|
ylab = "Frequency", pch = 16, col = rgb(0.262, 0.309, 0.309, 0.5))
|
||||||
|
lines(x, pre, col = "#434F4F")
|
||||||
|
legend("topright", paste0("Proportion of traces only occurring once: ",
|
||||||
|
round(tab[1] / nrow(tr), 2)), cex = .7, bty = "n")
|
||||||
|
|
||||||
|
dev.off()
|
||||||
|
|
||||||
# Look at individual traces as examples
|
# Look at individual traces as examples
|
||||||
tr[trace_varied == 5 & trace_length > 50, ]
|
tr[trace_varied == 5 & trace_length > 50, ]
|
||||||
Loading…
Reference in New Issue
Block a user