Exercice 1

On reprend les trois jeux de données qui posaient problème au TP précédent, et on en ajoute un avec du bruit, susceptible de ne pas être bien classé non plus par les méthodes plus sophistiquées du cours 4.

Note : séparer données et cibles permet d'avoir un code plus lisible je pense.

J'utilise systématiquement hclust - clustering hiérarchique - car elle est nettement plus rapide que PAM pour des résultats comparables.

library(foreign)
data1 <- read.arff("https://raw.githubusercontent.com/deric/clustering-benchmark/master/src/main/resources/datasets/artificial/cluto-t7-10k.arff")
target1 <- as.character(data1[,3]) #0, 1, ..., 8, noise
target1[target1 == "noise"] <- "9" #je préfère un vecteur d'entiers
target1 <- as.factor(target1)
data1 <- data1[,-3]

data2 <- read.arff("https://raw.githubusercontent.com/deric/clustering-benchmark/master/src/main/resources/datasets/artificial/3-spiral.arff")
target2 <- data2[,3] #1, 2, 3
data2 <- data2[,-3]

data3 <- read.arff("https://raw.githubusercontent.com/deric/clustering-benchmark/master/src/main/resources/datasets/artificial/dense-disk-5000.arff")
target3 <- data3[,3] #0, 1
data3 <- data3[,-3]

data4 <- read.arff("https://raw.githubusercontent.com/deric/clustering-benchmark/master/src/main/resources/datasets/artificial/target.arff")
target4 <- data4[,3] #1, 2 (3, 4, 5, 6: points isolés)
data4 <- data4[,-3]

On charge ensuite une petite librairie remplaçant cccd::nng, que je viens d'écrire : version expérimentale...

#git clone https://github.com/yagu0/nngd.git && cd nngd && touch NAMESPACE
#R -e 'library(roxygen2) ; roxygenize(".")' && rm NAMESPACE && R -e 'library(roxygen2) ; roxygenize(".")'
#R CMD INSTALL .
library(nngd)

o10 <- nng(data2, k=10, mutual=TRUE)
o20 <- nng(data2, k=20, mutual=TRUE)
o30 <- nng(data2, k=30, mutual=TRUE)
o40 <- nng(data2, k=40, mutual=TRUE)
options(repr.plot.width=15, repr.plot.height=10)
par(mfrow=c(2,2))
plot(o10$graph)
plot(o20$graph)
plot(o30$graph)
plot(o40$graph)

Pour $k = 10$ le graphe comporte trois composantes connexes, a priori égales aux clusters à retrouver. Si $k \geq 20$ (frontière entre 10 et 20, à déterminer...), alors certaines arêtes de "court-circuit" apparaissent, faussant le résultat. Vérifions :

dists20 <- igraph::distances(o20$graph, weights=o20$distances)
h <- hclust(as.dist(dists20), method="ward.D")
plot(data2, col=cutree(h, 3), pch=19, cex=1.5)

Mauvais car certaines arêtes sont apparues alors qu'elles ne correspondent pas à la géométrie des données.

dists10 = igraph::distances(o10$graph, weights=o10$distances)
dists10[is.infinite(dists10)] <- max(dists10[is.finite(dists10)]) + 1 #avoid Inf in foreign function call...
h <- hclust(as.dist(dists10), method="ward.D")
plot(data2, col=cutree(h, 3), pch=19, cex=1.5)

Parfait ! :-)

Inutile de regarder $k = 30$ et $k = 40$, le résultat ne peut qu'être pire.

# 5000 points : nécessite quelques minutes dans l'implémentation actuelle
o10 <- nng(data3, k=10, mutual=TRUE)
o20 <- nng(data3, k=20, mutual=TRUE)
o30 <- nng(data3, k=30, mutual=TRUE)
o40 <- nng(data3, k=40, mutual=TRUE)
par(mfrow=c(2,2))
plot(o10$graph)
plot(o20$graph)
plot(o30$graph)
plot(o40$graph)

Cette fois il semble que la géométrie soit retrouvée avec un nombre plus important de voisins... Regardons :

dists10 <- igraph::distances(o10$graph, weights=o10$distances)
dists20 <- igraph::distances(o20$graph, weights=o20$distances)
dists30 <- igraph::distances(o30$graphb, weights=o30$distances)
dists40 <- igraph::distances(o40$graph, weights=o40$distances)

plot4 <- function(data, K) {
    par(mfrow=c(2,2))
    h <- hclust(as.dist(dists10), method="ward.D")
    plot(data, col=cutree(h, K), pch=19, cex=1.5)
    h <- hclust(as.dist(dists20), method="ward.D")
    plot(data, col=cutree(h, K), pch=19, cex=1.5)
    h <- hclust(as.dist(dists30), method="ward.D")
    plot(data, col=cutree(h, K), pch=19, cex=1.5)
    h <- hclust(as.dist(dists40), method="ward.D")
    plot(data, col=cutree(h, K), pch=19, cex=1.5)
}
plot4(data3, 2)

Vu la forme des données ça aurait été en effet étrange : la distance de graphe ne permet a priori pas de retrouver le bon clustering.

...C'est le bon moment pour essayer alors la distance "temps moyen d'aller-retour" (?!)

dists10 <- ectd(o10, similarity=function(x) exp(-x^2))
dists20 <- ectd(o20, similarity=function(x) exp(-x^2))
dists30 <- ectd(o30, similarity=function(x) exp(-x^2))
dists40 <- ectd(o40, similarity=function(x) exp(-x^2))

plot4(data3, 2)

Bon... pas mieux. Il faudrait peut-être jouer plus finement sur $k$ et la fonction de similarité... ou plus probablement changer la façon dont le graphe est généré pour accorder plus d'importance aux écarts de densité.

o10 <- nng(data4, k=10, mutual=TRUE)
o20 <- nng(data4, k=20, mutual=TRUE)
o30 <- nng(data4, k=30, mutual=TRUE)
o40 <- nng(data4, k=40, mutual=TRUE)
par(mfrow=c(2,2))
plot(o10$graph)
plot(o20$graph)
plot(o30$graph)
plot(o40$graph)

# Note : il est nécessaire ici d'ajouter une vraiment grande valeur (+1, +10 échouent).
#        c'est légitime, car la vraie valeur est +infini.
dists10 = igraph::distances(o10$graph, weights=o10$distances)
dists10[is.infinite(dists10)] <- max(dists10[is.finite(dists10)]) + 100000
dists20 = igraph::distances(o20$graph, weights=o20$distances)
dists20[is.infinite(dists20)] <- max(dists20[is.finite(dists20)]) + 100000
dists30 = igraph::distances(o30$graph, weights=o30$distances)
dists30[is.infinite(dists30)] <- max(dists30[is.finite(dists30)]) + 100000
dists40 = igraph::distances(o40$graph, weights=o40$distances)
dists40[is.infinite(dists40)] <- max(dists40[is.finite(dists40)]) + 100000

plot4(data4, 6)

Ok dans tous les cas. Regardons tout de même les composantes connexes :

igraph::components(o10$graph)$csize
igraph::components(o20$graph)$csize
igraph::components(o30$graph)$csize
igraph::components(o40$graph)$csize
# => Structure ok dès k=10

1. 3
2. 3
3. 3
4. 3
5. 395
6. 363

1. 3
2. 3
3. 3
4. 3
5. 395
6. 363

1. 3
2. 3
3. 3
4. 3
5. 395
6. 363

1. 3
2. 3
3. 3
4. 3
5. 395
6. 363

# 10000 points : quelques (longues) minutes... Test seulement avec k=40
o40 <- nng(data1, k=40, mutual=TRUE)

dists40_graph = igraph::distances(o40$graph, weights=o40$distances)
dists40_ect = ectd(o40, similarity=function(x) exp(-x^2)) #TODO: essayer plutôt exp(-x)

h_graph = hclust(as.dist(dists40_graph), method="ward.D")
h_ect = hclust(as.dist(dists40_ect), method="ward.D")

par(mfrow=c(1,2))
plot(data1, col=cutree(h_graph, 10), pch=19, cex=1.5)
plot(data1, col=cutree(h_ect, 10), pch=19, cex=1.5)

Bon et bien ça ne marche pas du tout... En fait sur cet exemple précis un $\varepsilon$-graphe serait adapté (TODO).

On peut conclure que les méthodes proposés dans le cours échouent sur des données à densité variable, les clusters correspondant aux zones plus denses. Il existe certainement diverses façons d'améliorer les choses.

Exercice 2

Il s'agit ici plus d'exploration sur données réelles, les vraies classes n'étant pas connues. De plus les jeux de données étant nettement plus petits, pas de problèmes de temps d'exécution.

Les deux jeux de données suggérés décrivent des relations d'amitié entre humains et entre dauphins. L'idée est de mettre en évidence les communautés ("groupes d'amis" dans un réseau social).

g <- igraph::read.graph("../data/karate/karate.gml", format="gml")
plot(g)

n <- igraph::vcount(g)
dists_graph <- igraph::distances(g) #no weights here
dists_ect <- ectd(list(graph=g, distances=rep(1,n))) #sim = exp(-x) ici n'aurait aucun effet

h_graph <- hclust(as.dist(dists_graph), method="ward.D")
h_ect <- hclust(as.dist(dists_ect), method="ward.D")

clustsToList <- function(h, k) {
    clusts <- cutree(h, k)
    res <- list()
    for (i in seq_len(k)) res[[i]] <- which(clusts == i)
    res
}

par(mfrow=c(2,2))
plot(g, mark.groups = clustsToList(h_graph, 3))
plot(g, mark.groups = clustsToList(h_graph, 5))
plot(g, mark.groups = clustsToList(h_ect, 3))
plot(g, mark.groups = clustsToList(h_ect, 5))

Quand $K = 3$, visuellement le découpage proposé en utilisant les distances de graphe est plus net, plus équilibré. Cela ne signifie pas qu'il soit plus pertinent, mais visuellement l'effet est convainquant.

Côté $K = 5$, la distance ECT semble donner de meilleurs résultats : 12 n'est connecté qu'à 1, et se retrouve logiquement isolé. De même 25 et 26 n'ont chacun que 2 amis hors de leur groupe, donc le regroupement se tient - regrouper 30 et 27 est légèrement plus hasardeux, 30 ayant au moins 3 amis en dehors de 27. Bon ça ne se joue à pas grand chose... mais tout de même.

g <- igraph::read.graph("../data/dolphins/dolphins.gml", format="gml")
plot(g)

n <- igraph::vcount(g)
dists_graph <- igraph::distances(g)
dists_ect <- ectd(list(graph=g, distances=rep(1,n)))

h_graph <- hclust(as.dist(dists_graph), method="ward.D")
h_ect <- hclust(as.dist(dists_ect), method="ward.D")

par(mfrow=c(2,2))
plot(g, mark.groups = clustsToList(h_graph, 2))
plot(g, mark.groups = clustsToList(h_graph, 3))
plot(g, mark.groups = clustsToList(h_ect, 2))
plot(g, mark.groups = clustsToList(h_ect, 3))

Le découpage en 2 groupes est ici encore plus net dans le cas des distances ECT. Partitionner en 3 groupes semble artificiel, on est donc amené à conclure à l'existence de deux principaux groupes de dauphins.