From b08955b2c4bafd6b125c0a4bae3d661ac786e07e Mon Sep 17 00:00:00 2001 From: nwickel Date: Fri, 15 Mar 2024 16:29:50 +0100 Subject: [PATCH] Added validation script redoing analysis for case clustering for data from 2018 --- code/10_user-navigation.R | 17 +- code/11_validation.R | 181 ++++++++++++++++++ ...e-variants.R => 12_investigate-variants.R} | 18 +- ...ase-clusters.py => 13_pm-case-clusters.py} | 0 4 files changed, 202 insertions(+), 14 deletions(-) create mode 100644 code/11_validation.R rename code/{11_investigate-variants.R => 12_investigate-variants.R} (75%) rename code/{12_pm-case-clusters.py => 13_pm-case-clusters.py} (100%) diff --git a/code/10_user-navigation.R b/code/10_user-navigation.R index 118e0c1..d603201 100644 --- a/code/10_user-navigation.R +++ b/code/10_user-navigation.R @@ -3,12 +3,13 @@ # content: (1) Load data # (2) Clustering # (3) Fit tree -# (4) Investigate variants # -# input: results/haum/event_logfiles_2024-02-21_16-07-33.csv -# output: results/haum/eventlogs_pre-corona_case-clusters.csv +# input: results/haum/dataframes_case_2019.RData +# 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") @@ -126,7 +127,7 @@ write.table(res, save(res, dist_mat, hcs, acs, coor_2d, coor_3d, 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") @@ -140,9 +141,7 @@ c1 <- rpart::rpart(as.factor(cluster) ~ ., data = dattree[, c("PropMoves", "InfocardOnly")], 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)) -dev.off() # with conditional tree 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")], 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)) -dev.off() @@ -163,7 +160,7 @@ dev.off() factoextra::fviz_dend(as.hclust(hc), k = k, cex = 0.5, k_colors = mycols, - #type = "phylogenic", + type = "phylogenic", rect = TRUE, main = "", ylab = "" diff --git a/code/11_validation.R b/code/11_validation.R new file mode 100644 index 0000000..8561ec4 --- /dev/null +++ b/code/11_validation.R @@ -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) + diff --git a/code/11_investigate-variants.R b/code/12_investigate-variants.R similarity index 75% rename from code/11_investigate-variants.R rename to code/12_investigate-variants.R index 8a12322..6f0d650 100644 --- a/code/11_investigate-variants.R +++ b/code/12_investigate-variants.R @@ -48,13 +48,23 @@ vioplot::vioplot(tr$absolute_frequency) # Power law for frequencies of traces tab <- table(tr$absolute_frequency) -x <- as.numeric(tab) -y <- as.numeric(names(tab)) +x <- as.numeric(names(tab)) +y <- as.numeric(tab) -plot(x, y, log = "xy") p1 <- lm(log(y) ~ log(x)) 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 tr[trace_varied == 5 & trace_length > 50, ] diff --git a/code/12_pm-case-clusters.py b/code/13_pm-case-clusters.py similarity index 100% rename from code/12_pm-case-clusters.py rename to code/13_pm-case-clusters.py