Clustering

Description of data set

In this tutorial, we will use the dataset from Wulff et al. (2023), which is part of the moursetrap package. The dataset, as prepared in the following code chunk, contains the mouse movement trajectories of participants in a two-options forced-choice paradigm. The trajectories are normalized using the mt_length_normalize() function from the moursetrap package so that all trajectories consist of 50 points (default is 20) in a 2D space.

library(mousetrap)
library(tidyverse)
dat <- data(KH2017)

# Preprocess trajectory data
dat <- KH2017 %>% mt_length_normalize(n_points = 50)
dat <- dat$ln_trajectories
dat[1:5,1:5,'xpos']; dat[1:5,1:5,'ypos'] #examles
       [,1]      [,2]       [,3]       [,4]       [,5]
id0001    0 -18.06069 -38.967198 -57.753756 -76.540313
id0002    0 -15.60052 -32.227659 -48.262305 -64.296952
id0003    0 -10.02617 -17.001541 -21.124366 -23.588654
id0004    0 -20.06305 -36.929651 -52.368759 -65.752596
id0005    0   0.00000   1.080633   3.535698   5.587012
       [,1]      [,2]      [,3]      [,4]      [,5]
id0001    0  7.695611 13.135988  23.98456  34.83314
id0002    0 11.244849 24.194179  37.87079  51.54740
id0003    0 16.565420 39.008474  62.18148  85.59222
id0004    0 -2.531525  6.049725  20.71095  37.44075
id0005    0 40.034589 80.048229 119.99954 159.97921
dat2 <- data.frame(cbind(dat[,,'xpos'], dat[,,'ypos']))

We can use the mt_heatmap() function from the moursetrap package to visualize the trajectories. The resulting plot contains 1064 mouse movement trajectories of participants. In this tutorial, we want to cluster these trajectories to make sense of this kind of data (i.e., shed light on the processes of information integration and preference formation; Wulff et al., 2023).

mt_heatmap(dat, colors = c('white', 'black'), verbose = FALSE)

Tasks

  1. Cluster the trajectories from dat2 (i.e., treating the x- and y-coordinates as features) into 5 clusters by means of agglomerative hierarchical clustering using the agnes algorithm.
  1. Predict the cluster of each individual trajectory using the model from task 1. Also produce a frequency table for the relative proportion of instances in each cluster.
  1. Redo task 1 and cluster the trajectories into 5 clusters using agglomerative hierarchical clustering and Ward’s method (i.e., define a learner with method = “ward”). Also predict the clusters using the new model. Did the relative frequencies improve (in terms of resulting in a more balanced clustering)?
  1. Plot the trajectories according to the clustering from task 4. For instance, use a for-loop and the mt_heatmap() function from above to produce a separate heatmap for each cluster of movement trajectories.
  1. Redo task 1 and cluster the trajectories into 5 clusters using partitional (i.e., \(k\)-means) clustering. Also redo task 2 and predict the clusters using the new model.
  1. Compare the results from task 5 to the results with the hierarchical clustering by redoing task 4, that is, visualizing the trajectories of the partitional clustering. Do you observe any performance differences?
  1. Bonus: Prior to performing the clustering, do a principal component analysis (PCA). Then, redo task 6 (i.e., compare agglomerative hierarchicalc lustering using Ward’s method and \(k\)-means partitional clustering) with both clusterings specified using only these 5 principal components (PCs) as features that explain the highest amount of variance in the data. (Hint: You can select a subset of PCs that should be used for the modeling by adding a filter pipeline operation after the pca pipeline operation. You can filter for “variance” using the flt() function and set a corresponding fraction for using only these PCs for the clustering that explain the highest amount of variance in the data)

Agnes clustering:

\(k\)-means clustering:

LS0tDQp0aXRsZTogIk1vZHVsZSAzOiBUdXRvcmlhbDogQ2x1c3RlcmluZyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KZWRpdG9yX29wdGlvbnM6IA0KICBjaHVua19vdXRwdXRfdHlwZTogaW5saW5lDQotLS0NCg0KIyBDbHVzdGVyaW5nDQoNCiMjIERlc2NyaXB0aW9uIG9mIGRhdGEgc2V0DQoNCkluIHRoaXMgdHV0b3JpYWwsIHdlIHdpbGwgdXNlIHRoZSBkYXRhc2V0IGZyb20gV3VsZmYgZXQgYWwuICgyMDIzKSwgd2hpY2ggaXMgcGFydCBvZiB0aGUgYG1vdXJzZXRyYXBgIHBhY2thZ2UuIFRoZSBkYXRhc2V0LCBhcyBwcmVwYXJlZCBpbiB0aGUgZm9sbG93aW5nIGNvZGUgY2h1bmssIGNvbnRhaW5zIHRoZSBtb3VzZSBtb3ZlbWVudCB0cmFqZWN0b3JpZXMgb2YgcGFydGljaXBhbnRzIGluIGEgdHdvLW9wdGlvbnMgZm9yY2VkLWNob2ljZSBwYXJhZGlnbS4gVGhlIHRyYWplY3RvcmllcyBhcmUgbm9ybWFsaXplZCB1c2luZyB0aGUgYG10X2xlbmd0aF9ub3JtYWxpemUoKWAgZnVuY3Rpb24gZnJvbSB0aGUgYG1vdXJzZXRyYXBgIHBhY2thZ2Ugc28gdGhhdCBhbGwgdHJhamVjdG9yaWVzIGNvbnNpc3Qgb2YgNTAgcG9pbnRzIChkZWZhdWx0IGlzIDIwKSBpbiBhIDJEIHNwYWNlLg0KDQpgYGB7cn0NCmxpYnJhcnkobW91c2V0cmFwKQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpkYXQgPC0gZGF0YShLSDIwMTcpDQoNCiMgUHJlcHJvY2VzcyB0cmFqZWN0b3J5IGRhdGENCmRhdCA8LSBLSDIwMTcgJT4lIG10X2xlbmd0aF9ub3JtYWxpemUobl9wb2ludHMgPSA1MCkNCmRhdCA8LSBkYXQkbG5fdHJhamVjdG9yaWVzDQpkYXRbMTo1LDE6NSwneHBvcyddOyBkYXRbMTo1LDE6NSwneXBvcyddICNleGFtbGVzDQpkYXQyIDwtIGRhdGEuZnJhbWUoY2JpbmQoZGF0WywsJ3hwb3MnXSwgZGF0WywsJ3lwb3MnXSkpDQpgYGANCg0KV2UgY2FuIHVzZSB0aGUgYG10X2hlYXRtYXAoKWAgZnVuY3Rpb24gZnJvbSB0aGUgYG1vdXJzZXRyYXBgIHBhY2thZ2UgdG8gdmlzdWFsaXplIHRoZSB0cmFqZWN0b3JpZXMuIFRoZSByZXN1bHRpbmcgcGxvdCBjb250YWlucyAxMDY0IG1vdXNlIG1vdmVtZW50IHRyYWplY3RvcmllcyBvZiBwYXJ0aWNpcGFudHMuIEluIHRoaXMgdHV0b3JpYWwsIHdlIHdhbnQgdG8gY2x1c3RlciB0aGVzZSB0cmFqZWN0b3JpZXMgdG8gbWFrZSBzZW5zZSBvZiB0aGlzIGtpbmQgb2YgZGF0YSAoaS5lLiwgc2hlZCBsaWdodCBvbiB0aGUgcHJvY2Vzc2VzIG9mIGluZm9ybWF0aW9uIGludGVncmF0aW9uIGFuZCBwcmVmZXJlbmNlIGZvcm1hdGlvbjsgV3VsZmYgZXQgYWwuLCAyMDIzKS4NCg0KYGBge3J9DQptdF9oZWF0bWFwKGRhdCwgY29sb3JzID0gYygnd2hpdGUnLCAnYmxhY2snKSwgdmVyYm9zZSA9IEZBTFNFKQ0KYGBgDQoNCiMjIFRhc2tzDQoNCjEuICBDbHVzdGVyIHRoZSB0cmFqZWN0b3JpZXMgZnJvbSBgZGF0MmAgKGkuZS4sIHRyZWF0aW5nIHRoZSB4LSBhbmQgeS1jb29yZGluYXRlcyBhcyBmZWF0dXJlcykgaW50byA1IGNsdXN0ZXJzIGJ5IG1lYW5zIG9mIGFnZ2xvbWVyYXRpdmUgaGllcmFyY2hpY2FsIGNsdXN0ZXJpbmcgdXNpbmcgdGhlIGBhZ25lc2AgYWxnb3JpdGhtLg0KDQpgYGB7cn0NCg0KYGBgDQoNCjIuICBQcmVkaWN0IHRoZSBjbHVzdGVyIG9mIGVhY2ggaW5kaXZpZHVhbCB0cmFqZWN0b3J5IHVzaW5nIHRoZSBtb2RlbCBmcm9tIHRhc2sgMS4gQWxzbyBwcm9kdWNlIGEgZnJlcXVlbmN5IHRhYmxlIGZvciB0aGUgcmVsYXRpdmUgcHJvcG9ydGlvbiBvZiBpbnN0YW5jZXMgaW4gZWFjaCBjbHVzdGVyLg0KDQpgYGB7cn0NCg0KYGBgDQoNCjMuICBSZWRvIHRhc2sgMSBhbmQgY2x1c3RlciB0aGUgdHJhamVjdG9yaWVzIGludG8gNSBjbHVzdGVycyB1c2luZyBhZ2dsb21lcmF0aXZlIGhpZXJhcmNoaWNhbCBjbHVzdGVyaW5nIGFuZCBXYXJkJ3MgbWV0aG9kIChpLmUuLCBkZWZpbmUgYSBsZWFybmVyIHdpdGggbWV0aG9kID0gIndhcmQiKS4gQWxzbyBwcmVkaWN0IHRoZSBjbHVzdGVycyB1c2luZyB0aGUgbmV3IG1vZGVsLiBEaWQgdGhlIHJlbGF0aXZlIGZyZXF1ZW5jaWVzIGltcHJvdmUgKGluIHRlcm1zIG9mIHJlc3VsdGluZyBpbiBhIG1vcmUgYmFsYW5jZWQgY2x1c3RlcmluZyk/DQoNCmBgYHtyfQ0KDQpgYGANCg0KNC4gIFBsb3QgdGhlIHRyYWplY3RvcmllcyBhY2NvcmRpbmcgdG8gdGhlIGNsdXN0ZXJpbmcgZnJvbSB0YXNrIDQuIEZvciBpbnN0YW5jZSwgdXNlIGEgYGZvcmAtbG9vcCBhbmQgdGhlIGBtdF9oZWF0bWFwKClgIGZ1bmN0aW9uIGZyb20gYWJvdmUgdG8gcHJvZHVjZSBhIHNlcGFyYXRlIGhlYXRtYXAgZm9yIGVhY2ggY2x1c3RlciBvZiBtb3ZlbWVudCB0cmFqZWN0b3JpZXMuDQoNCmBgYHtyfQ0KDQpgYGANCg0KNS4gIFJlZG8gdGFzayAxIGFuZCBjbHVzdGVyIHRoZSB0cmFqZWN0b3JpZXMgaW50byA1IGNsdXN0ZXJzIHVzaW5nIHBhcnRpdGlvbmFsIChpLmUuLCAkayQtbWVhbnMpIGNsdXN0ZXJpbmcuIEFsc28gcmVkbyB0YXNrIDIgYW5kIHByZWRpY3QgdGhlIGNsdXN0ZXJzIHVzaW5nIHRoZSBuZXcgbW9kZWwuDQoNCmBgYHtyfQ0KDQpgYGANCg0KNi4gIENvbXBhcmUgdGhlIHJlc3VsdHMgZnJvbSB0YXNrIDUgdG8gdGhlIHJlc3VsdHMgd2l0aCB0aGUgaGllcmFyY2hpY2FsIGNsdXN0ZXJpbmcgYnkgcmVkb2luZyB0YXNrIDQsIHRoYXQgaXMsIHZpc3VhbGl6aW5nIHRoZSB0cmFqZWN0b3JpZXMgb2YgdGhlIHBhcnRpdGlvbmFsIGNsdXN0ZXJpbmcuIERvIHlvdSBvYnNlcnZlIGFueSBwZXJmb3JtYW5jZSBkaWZmZXJlbmNlcz8NCg0KYGBge3J9DQoNCmBgYA0KDQo3LiAgQm9udXM6IFByaW9yIHRvIHBlcmZvcm1pbmcgdGhlIGNsdXN0ZXJpbmcsIGRvIGEgcHJpbmNpcGFsIGNvbXBvbmVudCBhbmFseXNpcyAoUENBKS4gVGhlbiwgcmVkbyB0YXNrIDYgKGkuZS4sIGNvbXBhcmUgYWdnbG9tZXJhdGl2ZSBoaWVyYXJjaGljYWxjIGx1c3RlcmluZyB1c2luZyBXYXJkJ3MgbWV0aG9kIGFuZCAkayQtbWVhbnMgcGFydGl0aW9uYWwgY2x1c3RlcmluZykgd2l0aCBib3RoIGNsdXN0ZXJpbmdzIHNwZWNpZmllZCB1c2luZyBvbmx5IHRoZXNlIDUgcHJpbmNpcGFsIGNvbXBvbmVudHMgKFBDcykgYXMgZmVhdHVyZXMgdGhhdCBleHBsYWluIHRoZSBoaWdoZXN0IGFtb3VudCBvZiB2YXJpYW5jZSBpbiB0aGUgZGF0YS4gKEhpbnQ6IFlvdSBjYW4gc2VsZWN0IGEgc3Vic2V0IG9mIFBDcyB0aGF0IHNob3VsZCBiZSB1c2VkIGZvciB0aGUgbW9kZWxpbmcgYnkgYWRkaW5nIGEgYGZpbHRlcmAgcGlwZWxpbmUgb3BlcmF0aW9uIGFmdGVyIHRoZSBgcGNhYCBwaXBlbGluZSBvcGVyYXRpb24uIFlvdSBjYW4gZmlsdGVyIGZvciAidmFyaWFuY2UiIHVzaW5nIHRoZSBgZmx0KClgIGZ1bmN0aW9uIGFuZCBzZXQgYSBjb3JyZXNwb25kaW5nIGZyYWN0aW9uIGZvciB1c2luZyBvbmx5IHRoZXNlIFBDcyBmb3IgdGhlIGNsdXN0ZXJpbmcgdGhhdCBleHBsYWluIHRoZSBoaWdoZXN0IGFtb3VudCBvZiB2YXJpYW5jZSBpbiB0aGUgZGF0YSkNCg0KQWduZXMgY2x1c3RlcmluZzoNCg0KYGBge3J9DQoNCmBgYA0KDQokayQtbWVhbnMgY2x1c3RlcmluZzoNCg0KYGBge3J9DQoNCmBgYA0K