# 09_user_navigation.R # # content: (1) Read data # (1.1) Read log event data # (1.2) Extract additional infos for clustering # (2) Clustering # (3) Fit tree # (3) Investigate variants # # input: results/haum/event_logfiles_2024-02-21_16-07-33.csv # output: results/haum/event_logfiles_pre-corona_with-clusters_cases.csv # results/haum/dattree.csv # # last mod: 2024-02-27 # setwd("C:/Users/nwickelmaier/Nextcloud/Documents/MDS/2023ss/60100_master_thesis/analysis/code") library(bupaverse) library(factoextra) #--------------- (1) Read data --------------- #--------------- (1.1) Read log event data --------------- dat0 <- read.table("results/haum/event_logfiles_2024-02-21_16-07-33.csv", colClasses = c("character", "character", "POSIXct", "POSIXct", "character", "integer", "numeric", "character", "character", rep("numeric", 3), "character", "character", rep("numeric", 11), "character", "character"), sep = ";", header = TRUE) dat0$event <- factor(dat0$event, levels = c("move", "flipCard", "openTopic", "openPopup")) dat0$topic <- factor(dat0$topic) dat0$weekdays <- factor(weekdays(dat0$date.start), levels = c("Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag"), labels = c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")) # Select data pre Corona dat <- dat0[as.Date(dat0$date.start) < "2020-03-13", ] dat <- dat[dat$path != 106098, ] rm(dat0) #--------------- (1.2) Extract additional infos for clustering --------------- 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"] topictab <- aggregate(topic ~ case, dat, table)["case"] topictab$artist <- aggregate(topic ~ case, dat, table)$topic[, 1] topictab$details <- aggregate(topic ~ case, dat, table)$topic[, 2] topictab$extra_info <- aggregate(topic ~ case, dat, table)$topic[, 3] topictab$komposition <- aggregate(topic ~ case, dat, table)$topic[, 4] topictab$leben_des_kunstwerks <- aggregate(topic ~ case, dat, table)$topic[, 5] topictab$licht_und_farbe <- aggregate(topic ~ case, dat, table)$topic[, 6] topictab$technik <- aggregate(topic ~ case, dat, table)$topic[, 7] topictab$thema <- aggregate(topic ~ case, dat, table)$topic[, 8] datcase <- datcase |> merge(eventtab, by = "case", all = TRUE) |> merge(topictab, by = "case", all = TRUE) datcase$ntopiccards <- aggregate(topic ~ case, dat, function(x) ifelse(all(is.na(x)), NA, length(na.omit(x))), na.action = NULL)$topic datcase$ntopics <- aggregate(topic ~ case, dat, function(x) ifelse(all(is.na(x)), NA, length(unique(na.omit(x)))), na.action = NULL)$topic 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 datcase$vacation <- aggregate(vacation ~ case, dat, function(x) ifelse(all(is.na(x)), 0, 1), na.action = NULL)$vacation datcase$holiday <- aggregate(holiday ~ case, dat, function(x) ifelse(all(is.na(x)), 0, 1), na.action = NULL)$holiday datcase$weekend <- aggregate(weekdays ~ case, dat, function(x) ifelse(any(x %in% c("Saturday", "Sunday")), 1, 0), na.action = NULL)$weekdays datcase$morning <- aggregate(date.start ~ case, dat, function(x) ifelse(lubridate::hour(x[1]) > 13, 0, 1), na.action = NULL)$date.start dat_split <- split(dat, ~ case) time_minmax <- function(subdata) { subdata$min_time <- min(subdata$timeMs.start) if (all(is.na(subdata$timeMs.stop))) { subdata$max_time <- NA } else { subdata$max_time <- max(subdata$timeMs.stop, na.rm = TRUE) } subdata } # TODO: Export from package mtt dat_list <- pbapply::pblapply(dat_split, time_minmax) 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 cor_mat <- cor(datcase[, -1], use = "pairwise") diag(cor_mat) <- NA heatmap(cor_mat) # TODO: Add info if all items of a case are information cards?? # Navigation types by Bousbia et al. (2010): # - Overviewing: this value is close to the Canter “scanning” value. It # implies that the learner is covering a large proportion of course pages. # Through this phase of fast-reading, the user seeks to acquire an # overall view of the course. # - Flitting: close to “wandering”. It reflects a browsing activity without a # strategy or a particular goal. The main difference with the overviewing # type is the lack of focus on the course. # - Studying: corresponds to a partial or complete reading of the course # pages where the learner spends time on each page. # - Deepening: This describes a learner who spends relatively long time on a # course, checking details, and seeking Web documents related to the course # topics. The main difference with studying is the Web search part that the # learner uses to obtain a deeper understanding of the course. # Taxonomy defined by Canter et al. (1985): # - Scanning: seeking an overview of a theme (i.e. subpart of the hypermedia) # by requesting an important proportion of its pages but without spending # much time on them. # - Browsing: going wherever the data leads the navigator until catching an # interest. # - Exploring: reading the viewed pages thoroughly. # - Searching: seeking for a particular document or information. # - Wandering: navigating in an unstructured fashion without any particular # goal or strategy. # Features for navigation types for MTT: # - Scanning / Overviewing: # * Proportion of artworks looked at is high: datcase$nitems / 70 # * Duration per artwork is low: "ave_duration_item" / datcase$duration # - Exploring: # * Looking at additional information for most items touched (high value): # harmonic mean of datcase$nopenTopic / datcase$nflipCard and # datcase$nopenPopup / datcase$nopenTopic # - Searching / Studying: # * Looking only at a few items # datcase$nitems / 70 is low # * Opening few cards # datcase$nflipCard / mean(datcase$nflipCard) or median(datcase$nflipCard) is low # * but for most cards popups are opened: # datcase$nopenPopup / datcase$nflipCard is high # - Wandering / Flitting: # * Items are mostly just moved: # datcase$nmove / datcase$length is high # * Duration per case is low: # datcase$duration / mean(datcase$duration) or median(datcase$duration) # * Duration per artwork is low: "ave_duration_item" / datcase$duration dattree <- data.frame(case = datcase$case, Duration = datcase$duration, PropItems = datcase$nitems / length(unique(dat$item)), PropTopic = datcase$nopenTopic / datcase$nflipCard, PropPopup = datcase$nopenPopup / datcase$nopenTopic, # SearchInfo = # 2*(((datcase$nopenPopup / datcase$nopenTopic) * # (datcase$nopenTopic / datcase$nflipCard)) / # ((datcase$nopenPopup / datcase$nopenTopic) + # (datcase$nopenTopic / datcase$nflipCard)) # ), PropMoves = datcase$nmove / datcase$length, PathLinearity = datcase$nitems / datcase$npaths, Singularity = datcase$npaths / datcase$length ) #dattree$SearchInfo <- ifelse(dattree$SearchInfo %in% 0, 0.1, dattree$SearchInfo) #dattree$SearchInfo <- ifelse(is.na(dattree$SearchInfo), 0, dattree$SearchInfo) dattree$PropTopic <- ifelse(is.na(dattree$PropTopic), 0, dattree$PropTopic) dattree$PropPopup <- ifelse(is.na(dattree$PropPopup), 0, dattree$PropPopup) get_centrality <- function(case, data) { data$start <- data$date.start data$complete <- data$date.stop alog <- activitylog(data[data$case == case, ], case_id = "case", activity_id = "item", resource_id = "path", timestamps = c("start", "complete")) net <- process_map(alog, render = FALSE) inet <- DiagrammeR::to_igraph(net) c(igraph::centr_degree(inet, loops = FALSE)$centralization, igraph::centr_degree(inet, loops = TRUE)$centralization, igraph::centr_betw(inet)$centralization) } centrality <- lapply(dattree$case, get_centrality, data = dat) centrality <- do.call(rbind, centrality) save(centrality, file = "results/haum/tmp_centrality.RData") dattree$centr_degree <- centrality[, 1] dattree$centr_degree_loops <- centrality[, 2] dattree$centr_between <- centrality[, 3] ## Add 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) 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 dattree$AvDurItem <- aggregate(duration ~ case, tmp, mean)$duration rm(tmp) par(mfrow = c(3,3)) hist(dattree$Duration, breaks = 50, main = "") hist(dattree$SearchInfo, breaks = 50, main = "") hist(dattree$PropItems, breaks = 50, main = "") hist(dattree$PropMoves, breaks = 50, main = "") hist(dattree$PathLinearity, breaks = 50, main = "") hist(dattree$Singularity, breaks = 50, main = "") hist(dattree$centr_degree, breaks = 50, main = "") hist(dattree$centr_degree_loops, breaks = 50, main = "") hist(dattree$centr_between, breaks = 50, main = "") cor_mat <- cor(dattree[, -1], use = "pairwise") diag(cor_mat) <- NA heatmap(cor_mat) dattree$Pattern <- "Dispersion" dattree$Pattern <- ifelse(dattree$PathLinearity > 0.8 & dattree$Singularity > 0.8, "Scholar", dattree$Pattern) dattree$Pattern <- ifelse(dattree$PathLinearity <= 0.8 & dattree$centr_between > 0.5, "Star", dattree$Pattern) write.table(dattree, file = "results/haum/dattree.csv", sep = ";", quote = FALSE, row.names = FALSE) #--------------- (2) Clustering --------------- df <- dattree[, c("AvDurItem", "PropItems", "PropTopic", "PropPopup", "PropMoves")] #df <- dattree[, c("AvDurItem", "PropItems", "SearchInfo", "PropMoves")] # TODO: With or without duration? Why is it relevant? df$Scholar <- ifelse(dattree$Pattern == "Scholar", 1, 0) df$Star <- ifelse(dattree$Pattern == "Star", 1, 0) df$Dispersion <- ifelse(dattree$Pattern == "Dispersion", 1, 0) # scale Duration and min/max SearchInfo df$AvDurItem <- as.numeric(scale(df$AvDurItem)) #df$SearchInfo <- (df$SearchInfo - min(df$SearchInfo)) / # (max(df$SearchInfo) - min(df$SearchInfo)) df$PropTopic <- (df$PropTopic - min(df$PropTopic, na.rm = TRUE)) / (max(df$PropTopic, na.rm = TRUE) - min(df$PropTopic, na.rm = TRUE)) df$PropPopup <- (df$PropPopup - min(df$PropPopup, na.rm = TRUE)) / (max(df$PropPopup, na.rm = TRUE) - min(df$PropPopup, na.rm = TRUE)) mat <- dist(df) # TODO: Do I need to scale all variables? h1 <- hclust(mat, method = "average") h2 <- hclust(mat, method = "complete") h3 <- hclust(mat, method = "ward.D") h4 <- hclust(mat, method = "ward.D2") h5 <- hclust(mat, method = "single") # Cophenetic Distances, for each linkage (runs quite some time!) c1 <- cophenetic(h1) c2 <- cophenetic(h2) c3 <- cophenetic(h3) c4 <- cophenetic(h4) c5 <- cophenetic(h5) # Correlations cor(mat, c1) cor(mat, c2) cor(mat, c3) cor(mat, c4) cor(mat, c5) # https://en.wikipedia.org/wiki/Cophenetic_correlation # https://stats.stackexchange.com/questions/195446/choosing-the-right-linkage-method-for-hierarchical-clustering hc <- h4 # Something like a scree plot (??) plot(rev(hc$height)[1:100], type = "b", pch = 16, cex = .5) k <- 4 grp_hclust <- cutree(hc, k = k) table(grp_hclust) fviz_cluster(list(data = df, cluster = grp_hclust), palette = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E", "black"), ellipse.type = "convex", show.clust.cent = FALSE, ggtheme = theme_bw()) table(dattree[grp_hclust == 1, "Pattern"]) table(dattree[grp_hclust == 2, "Pattern"]) table(dattree[grp_hclust == 3, "Pattern"]) table(dattree[grp_hclust == 4, "Pattern"]) # Look at 3d plot to see if clusters are actually separate pc <- prcomp(df) coor <- as.data.frame(pc$x[, c(1, 2, 3)]) rgl::plot3d(coor, col = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E")[grp_hclust]) aggregate(cbind(Duration, PropItems, SearchInfo, PropMoves, PathLinearity, Singularity, centr_degree, centr_degree_loops, centr_between) ~ grp_hclust, dattree, mean) aggregate(cbind(duration, distance, scaleSize, rotationDegree, length, nmove, nflipCard, nopenTopic, nopenPopup) ~ grp_hclust, datcase, mean) ### DBSCAN clustering library(dbscan) d1 <- dbscan(df, eps = .5, minPts = 9) hullplot(df, d1) grp_db <- d1$cluster table(grp_db) kNNdistplot(df, k = 6) abline(h = 0.5, col = "red") fviz_cluster(list(data = df[grp_db != 0, ], cluster = grp_db[grp_db != 0]), palette = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E"), ellipse.type = "convex", show.clust.cent = FALSE, ggtheme = theme_bw()) rgl::plot3d(coor, col = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E")[grp_db + 1]) aggregate(. ~ grp_db, df, mean) table(dattree[grp_db == 0, "Pattern"]) table(dattree[grp_db == 1, "Pattern"]) table(dattree[grp_db == 2, "Pattern"]) table(dattree[grp_db == 3, "Pattern"]) ### K-Means clustering k1 <- kmeans(df, 4) grp_km <- k1$cluster table(grp_km) fviz_cluster(list(data = df, cluster = grp_km), palette = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E"), ellipse.type = "convex", show.clust.cent = FALSE, ggtheme = theme_bw()) rgl::plot3d(coor, col = c("#78004B", "#FF6900", "#3CB4DC", "#91C86E")[grp_km]) ### Look at selected cases ########################################### tmp <- res tmp$start <- tmp$date.start tmp$complete <- tmp$date.stop alog <- activitylog(tmp[tmp$case == 30855, ], case_id = "case", activity_id = "item", resource_id = "path", timestamps = c("start", "complete")) process_map(alog) ###################################################################### res <- merge(dat, dattree[, c("case", "grp")], by = "case", all.x = TRUE) res <- res[order(res$fileId.start, res$date.start, res$timeMs.start), ] rm(dat) xtabs( ~ item + grp, res) aggregate(event ~ grp, res, table) # Look at clusters par(mfrow = c(2, 2)) vioplot::vioplot(duration ~ grp, res) vioplot::vioplot(distance ~ grp, res) vioplot::vioplot(scaleSize ~ grp, res) vioplot::vioplot(rotationDegree ~ grp, res) aggregate(cbind(duration, distance, scaleSize, rotationDegree) ~ grp, res, mean) aggregate(cbind(duration, distance, scaleSize, rotationDegree) ~ grp, res, median) write.table(res, file = "results/haum/event_logfiles_pre-corona_with-clusters_cases.csv", sep = ";", quote = FALSE, row.names = FALSE) save(res, mat, h1, h2, h3, h4, h5, c1, c2, c3, c4, c5, datcase, dattree, df, file = "results/haum/tmp_user-navigation.RData") #--------------- (3) Fit tree --------------- library(rpart) library(partykit) ## dbscan dattree_db <- dattree[grp_db != 0, ] dattree_db$grp <- factor(grp_db[grp_db != 0]) dattree_db$Pattern <- factor(dattree_db$Pattern) c1 <- rpart(grp ~ AvDurItem + PropItems + SearchInfo + PropMoves + Pattern, data = dattree_db, method = "class") c1 <- rpart(grp_db ~ AvDurItem + PropItems + PropTopic + PropPopup + PropMoves + Pattern, data = dattree, method = "class") plot(as.party(c1)) c1a <- rpart(grp_db ~ AvDurItem + PropItems + SearchInfo + PropMoves + Pattern, data = dattree, method = "class") plot(as.party(c1a)) c2 <- rpart(grp ~ PropItems + SearchInfo + PropMoves + Pattern, data = dattree_db, method = "class") plot(as.party(c2)) # with conditional tree function c3 <- ctree(as.factor(grp_db) ~ AvDurItem + PropItems + PropTopic + PropPopup + PropMoves + as.factor(Pattern), data = dattree, alpha = 1) plot(c3) cluster <- as.factor(grp_db[grp_db != 0]) c4 <- ctree(cluster ~ nmove + nflipCard + nopenTopic + nopenPopup, data = datcase[grp_db != 0, ], alpha = .001) plot(c4) c5 <- ctree(cluster ~ duration, data = datcase[grp_db != 0, ], alpha = .001) plot(c5) ## hclust c1 <- rpart(as.factor(grp_hclust) ~ AvDurItem + PropItems + SearchInfo + PropMoves + Pattern, data = dattree, method = "class") plot(as.party(c1)) c3 <- ctree(as.factor(grp_hclust) ~ AvDurItem + PropItems + SearchInfo + PropMoves + as.factor(Pattern), data = dattree, alpha = 0) plot(c3) c4 <- ctree(as.factor(grp_hclust) ~ nmove + nflipCard + nopenTopic + nopenPopup, data = datcase, alpha = .001) plot(c4) #--------------- (4) Investigate variants --------------- res$start <- res$date.start res$complete <- res$date.stop alog <- activitylog(res, case_id = "case", activity_id = "item", resource_id = "path", timestamps = c("start", "complete")) trace_explorer(alog, n_traces = 25) # --> sequences of artworks are just too rare tr <- traces(alog) trace_length <- sapply(strsplit(tr$trace, ","), length) tr[trace_length > 10, ] trace_varied <- sapply(strsplit(tr$trace, ","), function(x) length(unique(x))) tr[trace_varied > 1, ] table(tr[trace_varied > 2, "absolute_frequency"]) table(tr[trace_varied > 3, "absolute_frequency"]) summary(tr$absolute_frequency) 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)) plot(x, y, log = "xy") p1 <- lm(log(y) ~ log(x)) pre <- exp(coef(p1)[1]) * x^coef(p1)[2] lines(x, pre) # Look at individual traces as examples tr[trace_varied == 5 & trace_length > 50, ] # --> every variant exists only once, of course datcase[datcase$nitems == 5 & datcase$length > 50,] sapply(datcase[, -c(1, 9)], median) #ex <- datcase[datcase$nitems == 4 & datcase$length == 15,] ex <- datcase[datcase$nitems == 5,] ex <- ex[sample(1:nrow(ex), 20), ] # --> pretty randomly chosen... TODO: case_ids <- NULL for (case in ex$case) { if ("080" %in% res$item[res$case == case] | "503" %in% res$item[res$case == case]) { case_ids <- c(case_ids, TRUE) } else { case_ids <- c(case_ids, FALSE) } } cases <- ex$case[case_ids] for (case in cases) { alog <- activitylog(res[res$case == case, ], case_id = "case", activity_id = "item", resource_id = "path", timestamps = c("start", "complete")) dfg <- process_map(alog, type_nodes = frequency("absolute", color_scale = "Greys"), type_edges = frequency("absolute", color_edges = "#FF6900"), rankdir = "LR", render = FALSE) export_map(dfg, file_name = paste0("results/processmaps/dfg_example_cases_", case, "_R.pdf"), file_type = "pdf", title = paste("Case", case)) } ########################### TODO: Still need it? net <- process_map(alog, render = FALSE) #DiagrammeR::get_node_df(net) DiagrammeR::get_node_info(net) DiagrammeR::get_degree_distribution(net) DiagrammeR::get_degree_in(net) DiagrammeR::get_degree_out(net) DiagrammeR::get_degree_total(net) N <- DiagrammeR::count_nodes(net) - 2 # Do not count start and stop nodes dc <- DiagrammeR::get_degree_total(net)[1:N, "total_degree"] / (N - 1) inet <- DiagrammeR::to_igraph(net) igraph::centr_degree(inet, loops = FALSE) igraph::centr_betw(inet) igraph::centr_clo(inet)