0.0.1 TD n°2 – Classification automatique
## Le chargement a nécessité le package : ggplot2## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa##
## Attachement du package : 'dplyr'## Les objets suivants sont masqués depuis 'package:data.table':
##
## between, first, last## Les objets suivants sont masqués depuis 'package:stats':
##
## filter, lag## Les objets suivants sont masqués depuis 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(ggplot2)
# Lecture du fichier CSV
my_data <- fread("C:/Users/USER/Desktop/Cours/Data/travail.csv", encoding = "UTF-8")
# Correction des problèmes d'encodage pour les noms de pays
if("Pays" %in% colnames(my_data)) {
my_data$Pays <- iconv(my_data$Pays, from = "latin1", to = "UTF-8")
}
# Inspection des données
head(my_data)## Pays salmoyPPP ecart d9_d1 tx_chom tx_inact heures
## <char> <num> <num> <num> <num> <num> <num>
## 1: Australie 49125.87 14.286311 3.324824 5.759536 22.55099 1675.9
## 2: Autriche 50348.94 15.670900 3.271053 5.578426 23.57500 1487.0
## 3: Belgique 49675.00 3.701299 2.409763 7.147249 31.97500 1546.0
## 4: Canada 47621.84 18.221154 3.605346 6.394011 21.54332 1695.0
## 5: Chili 25878.95 21.052632 4.318182 7.008574 32.59680 1954.0
## 6: Républiquetchèque 25372.04 15.614011 3.453708 2.940991 24.10000 1776.0
## tx_syndic empl_jeunes empl_age protec UE
## <num> <num> <num> <num> <int>
## 1: 14.62790 43.652034 12.810401 1.6666666 0
## 2: 26.92521 31.817148 4.799532 2.3690476 1
## 3: 54.23405 5.996652 2.519975 1.8928572 1
## 4: 26.29624 41.623341 13.491795 0.9206349 0
## 5: 17.69605 10.410969 24.130476 2.6269841 0
## 6: 10.47115 4.978073 6.347621 2.9246032 1## Classes 'data.table' and 'data.frame': 32 obs. of 12 variables:
## $ Pays : chr "Australie" "Autriche" "Belgique" "Canada" ...
## $ salmoyPPP : num 49126 50349 49675 47622 25879 ...
## $ ecart : num 14.3 15.7 3.7 18.2 21.1 ...
## $ d9_d1 : num 3.32 3.27 2.41 3.61 4.32 ...
## $ tx_chom : num 5.76 5.58 7.15 6.39 7.01 ...
## $ tx_inact : num 22.6 23.6 32 21.5 32.6 ...
## $ heures : num 1676 1487 1546 1695 1954 ...
## $ tx_syndic : num 14.6 26.9 54.2 26.3 17.7 ...
## $ empl_jeunes: num 43.7 31.8 6 41.6 10.4 ...
## $ empl_age : num 12.81 4.8 2.52 13.49 24.13 ...
## $ protec : num 1.667 2.369 1.893 0.921 2.627 ...
## $ UE : int 0 1 1 0 0 1 1 1 0 1 ...
## - attr(*, ".internal.selfref")=<externalptr>## Pays salmoyPPP ecart d9_d1
## Length:32 Min. :15314 Min. : 3.403 Min. :2.250
## Class :character 1st Qu.:26801 1st Qu.: 8.811 1st Qu.:2.817
## Mode :character Median :42678 Median :13.768 Median :3.298
## Mean :40955 Mean :13.270 Mean :3.273
## 3rd Qu.:49843 3rd Qu.:15.871 3rd Qu.:3.637
## Max. :63062 Max. :34.617 Max. :5.066
## tx_chom tx_inact heures tx_syndic
## Min. : 2.910 Min. :11.35 Min. :1356 Min. : 4.487
## 1st Qu.: 4.386 1st Qu.:21.68 1st Qu.:1514 1st Qu.:12.446
## Median : 5.669 Median :24.71 Median :1691 Median :17.494
## Mean : 6.641 Mean :25.18 Mean :1667 Mean :26.319
## 3rd Qu.: 7.057 3rd Qu.:29.07 3rd Qu.:1759 3rd Qu.:28.922
## Max. :21.653 Max. :36.61 Max. :2257 Max. :85.518
## empl_jeunes empl_age protec UE
## Min. : 2.640 Min. : 2.048 Min. :0.2567 Min. :0.0000
## 1st Qu.: 6.646 1st Qu.: 4.530 1st Qu.:1.6488 1st Qu.:0.0000
## Median :17.438 Median : 9.952 Median :2.1389 Median :1.0000
## Mean :22.572 Mean :12.308 Mean :2.0227 Mean :0.5938
## 3rd Qu.:33.427 3rd Qu.:18.470 3rd Qu.:2.3730 3rd Qu.:1.0000
## Max. :68.621 Max. :38.177 Max. :3.1845 Max. :1.0000# Les variables quantitatives pour la classification (colonnes 2 à 11)
# La colonne 1 est "Pays", colonne 12 est "UE" (binaire)
data_clust <- my_data[, 2:11]
rownames(data_clust) <- my_data$Pays
# Normalisation (centrer-réduire)
data_clust_norm <- scale(data_clust)# La différence entre les deux formules de "linkage"
cat("
AVERAGE LINKAGE (lien moyen) :
- La distance entre deux clusters est la moyenne des distances entre toutes les paires d'individus (un de chaque cluster).
- Tend à créer des groupes de variance relativement égale.
- Moins sensible aux outliers que le lien simple.
WARD LINKAGE (critère de Ward) :
- La distance entre deux clusters est l'augmentation de l'inertie intra-classe (somme des carrés des écarts) lors de leur fusion.
- Minimise la variance intra-classe à chaque étape.
- Tend à créer des groupes de taille similaire et sphériques.
")##
## AVERAGE LINKAGE (lien moyen) :
## - La distance entre deux clusters est la moyenne des distances entre toutes les paires d'individus (un de chaque cluster).
## - Tend à créer des groupes de variance relativement égale.
## - Moins sensible aux outliers que le lien simple.
##
## WARD LINKAGE (critère de Ward) :
## - La distance entre deux clusters est l'augmentation de l'inertie intra-classe (somme des carrés des écarts) lors de leur fusion.
## - Minimise la variance intra-classe à chaque étape.
## - Tend à créer des groupes de taille similaire et sphériques.1 Dans un premier temps, on effectue la classification ascendante hiérarchique à partir des 10 variables quantitatives brutes, après les avoir normées (ou centrées réduites), pour donner à toutes les variables de départ des poids équivalents dans l’analyse.
2 On effectuera d’abord la classification avec une distance euclidienne et un ‘average linkage’, puis avec la même distance mais un linkage de Ward.
2.1 1.2 CAH avec average linkage
# Classification avec average linkage
cah_avg <- hclust(dist_eucl, method = "average")
# S'assurer que les noms des pays sont utilisés comme labels
cah_avg$labels <- my_data$Pays
# Dendrogramme avec les noms des pays
fviz_dend(cah_avg, k = 4, rect = TRUE, show_labels = TRUE,
labels_track_height = 0.5, # Ajuste l'espace pour les labels
main = "CAH - Average linkage (données brutes normalisées)")## Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
## ℹ Please use tidy evaluation idioms with `aes()`.
## ℹ See also `vignette("ggplot2-in-packages")` for more information.
## ℹ The deprecated feature was likely used in the factoextra package.
## Please report the issue at <https://github.com/kassambara/factoextra/issues>.
## This warning is displayed once per session.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## ℹ The deprecated feature was likely used in the factoextra package.
## Please report the issue at <https://github.com/kassambara/factoextra/issues>.
## This warning is displayed once per session.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: The `<scale>` argument of `guides()` cannot be `FALSE`. Use "none" instead as
## of ggplot2 3.3.4.
## ℹ The deprecated feature was likely used in the factoextra package.
## Please report the issue at <https://github.com/kassambara/factoextra/issues>.
## This warning is displayed once per session.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## 1.3 CAH avec Ward
# Classification avec Ward
cah_ward <- hclust(dist_eucl, method = "ward.D2")
# S'assurer que les noms des pays sont utilisés comme labels
cah_ward$labels <- my_data$Pays
# Dendrogramme
fviz_dend(cah_ward, k = 4, rect = TRUE, show_labels = TRUE, labels_track_height = 0.5,
main = "CAH - Ward linkage (données brutes normalisées)")
3 Expliquer la différence entre les deux formules de ‘linkage’ utilisés
3.1 1.4 Explication des linkages
cat("
RÉPONSE - Différence entre average linkage et Ward :
AVERAGE LINKAGE (lien moyen) :
- La distance entre deux clusters est calculée comme la MOYENNE des distances entre toutes les paires d'individus (un de chaque cluster).
- Formule : d(A,B) = (1/(|A|·|B|)) * Σ Σ d(x,y) pour x∈A, y∈B
- Propriétés :
• Tend à créer des groupes de variance relativement égale
• Moins sensible aux valeurs aberrantes que le lien simple
• Donne souvent des dendrogrammes plus équilibrés
WARD LINKAGE (critère de Ward) :
- La distance entre deux clusters est l'AUGMENTATION de l'inertie intra-classe (somme des carrés des écarts) lors de leur fusion.
- Formule : d(A,B) = (|A|·|B|)/(|A|+|B|) * ||centroid_A - centroid_B||²
- Propriétés :
• Minimise la variance intra-classe à chaque étape
• Tend à créer des groupes de taille similaire et de forme sphérique
• Souvent préféré en analyse de données car optimise l'homogénéité interne
")##
## RÉPONSE - Différence entre average linkage et Ward :
##
## AVERAGE LINKAGE (lien moyen) :
## - La distance entre deux clusters est calculée comme la MOYENNE des distances entre toutes les paires d'individus (un de chaque cluster).
## - Formule : d(A,B) = (1/(|A|·|B|)) * Σ Σ d(x,y) pour x∈A, y∈B
## - Propriétés :
## • Tend à créer des groupes de variance relativement égale
## • Moins sensible aux valeurs aberrantes que le lien simple
## • Donne souvent des dendrogrammes plus équilibrés
##
## WARD LINKAGE (critère de Ward) :
## - La distance entre deux clusters est l'AUGMENTATION de l'inertie intra-classe (somme des carrés des écarts) lors de leur fusion.
## - Formule : d(A,B) = (|A|·|B|)/(|A|+|B|) * ||centroid_A - centroid_B||²
## - Propriétés :
## • Minimise la variance intra-classe à chaque étape
## • Tend à créer des groupes de taille similaire et de forme sphérique
## • Souvent préféré en analyse de données car optimise l'homogénéité interne4 “Représenter graphiquement les groupes obtenus par les deux méthodes, et comparer les résultats.
4.1 1.5 Comparaison des groupes
# Découpage en 4 groupes (nombre à justifier par la hauteur du dendrogramme)
groups_avg <- cutree(cah_avg, k = 4)
groups_ward <- cutree(cah_ward, k = 4)
# Ajout aux données
my_data$groupe_avg <- groups_avg
my_data$groupe_ward <- groups_ward
# Tableau de contingence pour comparer
table_comparaison <- table(groups_avg, groups_ward)
print("Table de contingence entre les deux classifications:")## [1] "Table de contingence entre les deux classifications:"## groups_ward
## groups_avg 1 2 3 4
## 1 6 7 12 0
## 2 0 0 0 5
## 3 0 1 0 0
## 4 1 0 0 0# Visualisation des groupes dans un plan factoriel (ACP préliminaire)
acp_comp <- PCA(data_clust_norm, graph = FALSE)
# Plot avec couleurs selon groupes_avg
p_avg <- fviz_pca_ind(acp_comp, geom.ind = "point",
col.ind = as.factor(groups_avg),
palette = "Set1", addEllipses = TRUE,
title = "Plan factoriel - Groupes Average linkage")
# Plot avec couleurs selon groupes_ward
p_ward <- fviz_pca_ind(acp_comp, geom.ind = "point",
col.ind = as.factor(groups_ward),
palette = "Set2", addEllipses = TRUE,
title = "Plan factoriel - Groupes Ward")
# Affichage côte à côte
library(gridExtra)##
## Attachement du package : 'gridExtra'## L'objet suivant est masqué depuis 'package:dplyr':
##
## combine## Too few points to calculate an ellipse## Too few points to calculate an ellipse
# Commentaire sur les différences
cat("
Comparaison des résultats :
- Les groupes sont-ils identiques ?", ifelse(identical(groups_avg, groups_ward), "Oui", "Non"), "
- Taux de concordance :", sum(diag(table_comparaison)) / sum(table_comparaison) * 100, "%
Interprétation :
- Si forte concordance : les deux méthodes détectent la même structure
- Si différences : Ward tend à créer des groupes plus compacts, Average linkage plus souple
")##
## Comparaison des résultats :
## - Les groupes sont-ils identiques ? Non
## - Taux de concordance : 18.75 %
##
## Interprétation :
## - Si forte concordance : les deux méthodes détectent la même structure
## - Si différences : Ward tend à créer des groupes plus compacts, Average linkage plus souple#-----------------Attention à vérifier-------
# Découpage en 4 groupes (nombre à justifier par la hauteur du dendrogramme)
groups_avg <- cutree(cah_avg, k = 4)
groups_ward <- cutree(cah_ward, k = 4)
# Ajout aux données
my_data$groupe_avg <- groups_avg
my_data$groupe_ward <- groups_ward
# Tableau de contingence pour comparer
table_comparaison <- table(groups_avg, groups_ward)
print("Table de contingence entre les deux classifications:")## [1] "Table de contingence entre les deux classifications:"## groups_ward
## groups_avg 1 2 3 4
## 1 6 7 12 0
## 2 0 0 0 5
## 3 0 1 0 0
## 4 1 0 0 0# Visualisation des groupes dans un plan factoriel (ACP préliminaire)
acp_comp <- PCA(data_clust_norm, graph = FALSE)
# Création d'un data frame avec les coordonnées et les noms des pays
plot_data <- as.data.frame(acp_comp$ind$coord[, 1:2])
colnames(plot_data) <- c("Dim1", "Dim2")
plot_data$Pays <- my_data$Pays
plot_data$groupe_avg <- as.factor(groups_avg)
plot_data$groupe_ward <- as.factor(groups_ward)
# Plot avec couleurs selon groupes_avg (avec noms des pays)
p_avg <- ggplot(plot_data, aes(x = Dim1, y = Dim2, color = groupe_avg, label = Pays)) +
geom_point(size = 3) +
geom_text(vjust = -0.5, size = 3, check_overlap = TRUE) +
scale_color_brewer(palette = "Set1") +
stat_ellipse(level = 0.95) +
labs(title = "Plan factoriel - Groupes Average linkage",
x = paste0("Dim1 (", round(acp_comp$eig[1, 2], 1), "%)"),
y = paste0("Dim2 (", round(acp_comp$eig[2, 2], 1), "%)"),
color = "Groupe") +
theme_minimal()
# Plot avec couleurs selon groupes_ward (avec noms des pays)
p_ward <- ggplot(plot_data, aes(x = Dim1, y = Dim2, color = groupe_ward, label = Pays)) +
geom_point(size = 3) +
geom_text(vjust = -0.5, size = 3, check_overlap = TRUE) +
scale_color_brewer(palette = "Set2") +
stat_ellipse(level = 0.95) +
labs(title = "Plan factoriel - Groupes Ward",
x = paste0("Dim1 (", round(acp_comp$eig[1, 2], 1), "%)"),
y = paste0("Dim2 (", round(acp_comp$eig[2, 2], 1), "%)"),
color = "Groupe") +
theme_minimal()
# Affichage côte à côte
library(gridExtra)
grid.arrange(p_avg, p_ward, ncol = 2)## Too few points to calculate an ellipse
## Too few points to calculate an ellipse## Warning: The following aesthetics were dropped during statistical transformation: label.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
## the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
## variable into a factor?## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_path()`).## Warning in MASS::cov.trob(data[, vars], wt = weight * nrow(data)): Absence
## probable de convergence## Warning: The following aesthetics were dropped during statistical transformation: label.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
## the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
## variable into a factor?
# Commentaire sur les différences avec liste des pays par groupe
cat("
Comparaison des résultats :
- Les groupes sont-ils identiques ?", ifelse(identical(groups_avg, groups_ward), "Oui", "Non"), "
- Taux de concordance :", sum(diag(table_comparaison)) / sum(table_comparaison) * 100, "%
Liste des pays par groupe (Ward) :
")##
## Comparaison des résultats :
## - Les groupes sont-ils identiques ? Non
## - Taux de concordance : 18.75 %
##
## Liste des pays par groupe (Ward) :for (g in 1:4) {
pays_g <- my_data$Pays[my_data$groupe_ward == g]
cat("Groupe", g, ":", paste(pays_g, collapse = ", "), "\n")
}## Groupe 1 : Australie, Canada, Irlande, Nouvelle-Zélande, Suisse, Royaume-Uni, États-Unis
## Groupe 2 : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède
## Groupe 3 : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe 4 : Chili, Estonie, Japon, Corée, Mexiquecat("
Interprétation :
- Si forte concordance : les deux méthodes détectent la même structure
- Si différences : Ward tend à créer des groupes plus compacts, Average linkage plus souple
")##
## Interprétation :
## - Si forte concordance : les deux méthodes détectent la même structure
## - Si différences : Ward tend à créer des groupes plus compacts, Average linkage plus souple5 Choisir une des deux représentations, et décrire les groupes par rapport aux variables de départ.”
5.1 1.6 Description des groupes (choix de Ward)
# Je choisis la classification avec Ward (souvent plus robuste)
# Ajout des groupes au dataframe
#my_data$groupe_ward <- groups_ward
# Moyennes des variables par groupe
library(dplyr)
desc_groupes_ward <- my_data %>%
group_by(groupe_ward) %>%
summarise(across(salmoyPPP:protec, mean, na.rm = TRUE))## Warning: There was 1 warning in `summarise()`.
## ℹ In argument: `across(salmoyPPP:protec, mean, na.rm = TRUE)`.
## ℹ In group 1: `groupe_ward = 1`.
## Caused by warning:
## ! The `...` argument of `across()` is deprecated as of dplyr 1.1.0.
## Supply arguments directly to `.fns` through an anonymous function instead.
##
## # Previously
## across(a:b, mean, na.rm = TRUE)
##
## # Now
## across(a:b, \(x) mean(x, na.rm = TRUE))## # A tibble: 4 × 11
## groupe_ward salmoyPPP ecart d9_d1 tx_chom tx_inact heures tx_syndic
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 50145. 14.2 3.53 5.42 22.2 1675. 19.3
## 2 2 50079. 12.2 2.81 5.37 20.2 1444. 49.7
## 3 3 34779. 8.94 3.23 9.03 28.8 1692. 20.6
## 4 4 28317. 23.9 3.76 4.64 28.7 1952. 12.4
## # ℹ 3 more variables: empl_jeunes <dbl>, empl_age <dbl>, protec <dbl>## [1] "Moyennes des variables par groupe (Ward):"## # A tibble: 4 × 11
## groupe_ward salmoyPPP ecart d9_d1 tx_chom tx_inact heures tx_syndic
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 50145. 14.2 3.53 5.42 22.2 1675. 19.3
## 2 2 50079. 12.2 2.81 5.37 20.2 1444. 49.7
## 3 3 34779. 8.94 3.23 9.03 28.8 1692. 20.6
## 4 4 28317. 23.9 3.76 4.64 28.7 1952. 12.4
## # ℹ 3 more variables: empl_jeunes <dbl>, empl_age <dbl>, protec <dbl># Profil détaillé de chaque groupe
for (g in 1:4) {
cat("\n", paste(rep("=", 50), collapse = ""))
cat("\nGROUPE", g, ":\n")
cat("Pays:", paste(my_data$Pays[my_data$groupe_ward == g], collapse = ", "), "\n")
cat("Nombre de pays:", sum(my_data$groupe_ward == g), "\n")
cat("Caractéristiques principales:\n")
# Moyennes globales
moy_globale <- colMeans(my_data[, 2:11])
# Écarts-types globaux pour le seuil
sd_globale <- apply(my_data[, 2:11], 2, sd)
# Récupération des valeurs du groupe
groupe_data <- desc_groupes_ward[desc_groupes_ward$groupe_ward == g, ]
for (var in names(my_data)[2:11]) {
val_groupe <- groupe_data[[var]]
diff <- val_groupe - moy_globale[var]
# Seuil à 0.5 écart-type
if (abs(diff) > 0.5 * sd_globale[var]) {
direction <- ifelse(diff > 0, "▲ supérieur à", "▼ inférieur à")
cat(sprintf(" %s %s : %.2f (moy=%.2f, diff=%.2f)\n",
direction, var, val_groupe, moy_globale[var], diff))
}
}
}##
## ==================================================
## GROUPE 1 :
## Pays: Australie, Canada, Irlande, Nouvelle-Zélande, Suisse, Royaume-Uni, États-Unis
## Nombre de pays: 7
## Caractéristiques principales:
## ▲ supérieur à salmoyPPP : 50145.11 (moy=40955.47, diff=9189.64)
## ▼ inférieur à tx_inact : 22.24 (moy=25.18, diff=-2.93)
## ▲ supérieur à empl_jeunes : 36.82 (moy=22.57, diff=14.25)
## ▼ inférieur à protec : 1.19 (moy=2.02, diff=-0.83)
##
## ==================================================
## GROUPE 2 :
## Pays: Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède
## Nombre de pays: 8
## Caractéristiques principales:
## ▲ supérieur à salmoyPPP : 50079.07 (moy=40955.47, diff=9123.61)
## ▼ inférieur à d9_d1 : 2.81 (moy=3.27, diff=-0.46)
## ▼ inférieur à tx_inact : 20.18 (moy=25.18, diff=-5.00)
## ▼ inférieur à heures : 1443.51 (moy=1666.91, diff=-223.39)
## ▲ supérieur à tx_syndic : 49.73 (moy=26.32, diff=23.41)
## ▲ supérieur à empl_jeunes : 38.97 (moy=22.57, diff=16.40)
## ▲ supérieur à protec : 2.36 (moy=2.02, diff=0.34)
##
## ==================================================
## GROUPE 3 :
## Pays: Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Nombre de pays: 12
## Caractéristiques principales:
## ▼ inférieur à ecart : 8.94 (moy=13.27, diff=-4.33)
## ▲ supérieur à tx_chom : 9.03 (moy=6.64, diff=2.39)
## ▲ supérieur à tx_inact : 28.76 (moy=25.18, diff=3.58)
## ▼ inférieur à empl_jeunes : 6.36 (moy=22.57, diff=-16.21)
## ▼ inférieur à empl_age : 4.36 (moy=12.31, diff=-7.95)
##
## ==================================================
## GROUPE 4 :
## Pays: Chili, Estonie, Japon, Corée, Mexique
## Nombre de pays: 5
## Caractéristiques principales:
## ▼ inférieur à salmoyPPP : 28316.51 (moy=40955.47, diff=-12638.95)
## ▲ supérieur à ecart : 23.93 (moy=13.27, diff=10.66)
## ▲ supérieur à d9_d1 : 3.76 (moy=3.27, diff=0.49)
## ▼ inférieur à tx_chom : 4.64 (moy=6.64, diff=-2.00)
## ▲ supérieur à tx_inact : 28.70 (moy=25.18, diff=3.52)
## ▲ supérieur à heures : 1951.68 (moy=1666.91, diff=284.77)
## ▼ inférieur à tx_syndic : 12.36 (moy=26.32, diff=-13.96)
## ▲ supérieur à empl_age : 26.00 (moy=12.31, diff=13.69)# Visualisation des profils (radar chart ou boxplots)
# Boxplots comparatifs
par(mfrow = c(2, 5))
for (var in names(my_data)[2:11]) {
boxplot(my_data[[var]] ~ my_data$groupe_ward,
main = var, xlab = "Groupe", col = 2:5)
}
5.2 2eme méthode
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats 1.0.1 ✔ stringr 1.6.0
## ✔ lubridate 1.9.5 ✔ tibble 3.3.1
## ✔ purrr 1.2.1 ✔ tidyr 1.3.2
## ✔ readr 2.2.0
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::between() masks data.table::between()
## ✖ gridExtra::combine() masks dplyr::combine()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::first() masks data.table::first()
## ✖ lubridate::hour() masks data.table::hour()
## ✖ lubridate::isoweek() masks data.table::isoweek()
## ✖ lubridate::isoyear() masks data.table::isoyear()
## ✖ dplyr::lag() masks stats::lag()
## ✖ dplyr::last() masks data.table::last()
## ✖ lubridate::mday() masks data.table::mday()
## ✖ lubridate::minute() masks data.table::minute()
## ✖ lubridate::month() masks data.table::month()
## ✖ lubridate::quarter() masks data.table::quarter()
## ✖ lubridate::second() masks data.table::second()
## ✖ purrr::transpose() masks data.table::transpose()
## ✖ lubridate::wday() masks data.table::wday()
## ✖ lubridate::week() masks data.table::week()
## ✖ lubridate::yday() masks data.table::yday()
## ✖ lubridate::year() masks data.table::year()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors# Profilage complet
profil_groupes <- my_data %>%
group_by(groupe_ward) %>%
summarise(across(salmoyPPP:protec,
list(moy = ~mean(., na.rm = TRUE),
sd = ~sd(., na.rm = TRUE))))
# Identification des caractéristiques distinctives
moyennes_globales <- my_data %>%
summarise(across(salmoyPPP:protec, mean, na.rm = TRUE)) %>%
pivot_longer(everything(), names_to = "variable", values_to = "moy_globale")
ecarts_types_globaux <- my_data %>%
summarise(across(salmoyPPP:protec, sd, na.rm = TRUE)) %>%
pivot_longer(everything(), names_to = "variable", values_to = "sd_globale")
# Fusion et calcul des écarts
comparaison <- profil_groupes %>%
pivot_longer(cols = -groupe_ward,
names_to = c("variable", ".value"),
names_pattern = "(.*)_(.*)") %>%
left_join(moyennes_globales, by = "variable") %>%
left_join(ecarts_types_globaux, by = "variable") %>%
mutate(ecart_type_standardise = (moy - moy_globale) / sd_globale,
significatif = abs(ecart_type_standardise) > 0.5)
# Affichage des résultats
print(comparaison %>% filter(significatif))## # A tibble: 24 × 8
## groupe_ward variable moy sd moy_globale sd_globale
## <int> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 1 salmoyPPP 50145. 8292. 40955. 13047.
## 2 1 tx_inact 22.2 3.96 25.2 5.60
## 3 1 empl_jeunes 36.8 10.4 22.6 17.8
## 4 1 protec 1.19 0.488 2.02 0.625
## 5 2 salmoyPPP 50079. 6142. 40955. 13047.
## 6 2 d9_d1 2.81 0.389 3.27 0.640
## 7 2 tx_inact 20.2 4.07 25.2 5.60
## 8 2 heures 1444. 52.9 1667. 199.
## 9 2 tx_syndic 49.7 26.0 26.3 20.8
## 10 2 empl_jeunes 39.0 16.1 22.6 17.8
## # ℹ 14 more rows
## # ℹ 2 more variables: ecart_type_standardise <dbl>, significatif <lgl>6 Récupérer les résultats de l’ACP sur 10 variables effectuée lors du premier TD.
6.1 2.1 ACP sur les données normalisées
## [1] "Valeurs propres:"## eigenvalue percentage of variance cumulative percentage of variance
## comp 1 3.4965438 36.0933554 36.09336
## comp 2 2.4801335 25.6013785 61.69473
## comp 3 1.0451232 10.7883682 72.48310
## comp 4 0.8258227 8.5246216 81.00772
## comp 5 0.6057488 6.2528907 87.26061
## comp 6 0.4187208 4.3222791 91.58289
## comp 7 0.3606969 3.7233225 95.30622
## comp 8 0.2626895 2.7116334 98.01785
## comp 9 0.1377596 1.4220351 99.43988
## comp 10 0.0542612 0.5601156 100.00000# Détermination du nombre d'axes à retenir (coude ou variance > 70%)
fviz_eig(acp, addlabels = TRUE, main = "Valeurs propres de l'ACP")## Warning in geom_bar(stat = "identity", fill = barfill, color = barcolor, :
## Ignoring empty aesthetic: `width`.
# Choix du nombre d'axes (par exemple, ceux avec variance > 10% ou cumul > 70%)
# Ici, on prend les 3 premiers axes (à ajuster selon le graphique)
nb_axes <- 3
cat("Nombre d'axes retenus:", nb_axes, "\n")## Nombre d'axes retenus: 3## Variance expliquée cumulée: 72.4831 %7 Effectuer la classification ascendante hiérarchique avec ‘average linkage’, à partir des ‘scores’ des individus-pays sur les axes retenus pour la description.
7.1 2.2 CAH sur les scores ACP
# Récupération des scores sur les axes retenus
scores_ind <- acp$ind$coord[, 1:nb_axes]
rownames(scores_ind) <- my_data$Pays
# CAH avec average linkage sur les scores
dist_scores <- dist(scores_ind, method = "euclidean")
cah_scores_avg <- hclust(dist_scores, method = "average")
# Dendrogramme
fviz_dend(cah_scores_avg, k = 4, rect = TRUE, show_labels = TRUE,
main = paste0("CAH sur scores ACP (", nb_axes, " axes) - Average linkage"))
8 La classification obtenue est-elle la même que précédemment ? Pourquoi ?
8.1 2.3 Comparaison avec classification sur données brutes
# Table de contingence
table_comp_acp_brut <- table(groups_avg, groups_scores_avg)
print("Comparaison groupes bruts vs groupes sur scores ACP:")## [1] "Comparaison groupes bruts vs groupes sur scores ACP:"## groups_scores_avg
## groups_avg 1 2 3 4
## 1 25 0 0 0
## 2 1 4 0 0
## 3 0 0 1 0
## 4 0 0 0 1# Taux de concordance
concordance <- sum(diag(table_comp_acp_brut)) / sum(table_comp_acp_brut) * 100
cat("Taux de concordance:", round(concordance, 2), "%\n")## Taux de concordance: 96.88 %## Warning in chisq.test(table_comp_acp_brut): L’approximation du Chi-2 est
## peut-être incorrecte##
## Pearson's Chi-squared test
##
## data: table_comp_acp_brut
## X-squared = 88.615, df = 9, p-value = 3.085e-15cat("
RÉPONSE - La classification est-elle la même ?
", ifelse(concordance > 80, "Oui, les classifications sont très similaires",
"Non, les classifications diffèrent"), " avec un taux de concordance de ",
round(concordance, 2), "%.
EXPLICATION :
- Si identique : Les ", nb_axes, " premiers axes de l'ACP capturent suffisamment d'information
pour retrouver la structure de groupe présente dans les données brutes.
- Si différente : Une partie de l'information discriminante pour la classification
se trouve sur les axes non retenus (axes ", nb_axes+1, " et suivants).
La perte d'information (", round(100 - sum(acp$eig[1:nb_axes, 2]), 2), "%)
a modifié la structure des proximités entre pays.
Remarque de l'énoncé :
'Une rotation des composantes principales retenues est inutile si l'objectif
est la classification automatique. Elle n'est utile qu'en termes de facilité
d'interprétation des axes.'
")##
## RÉPONSE - La classification est-elle la même ?
##
## Oui, les classifications sont très similaires avec un taux de concordance de 96.88 %.
##
## EXPLICATION :
## - Si identique : Les 3 premiers axes de l'ACP capturent suffisamment d'information
## pour retrouver la structure de groupe présente dans les données brutes.
## - Si différente : Une partie de l'information discriminante pour la classification
## se trouve sur les axes non retenus (axes 4 et suivants).
## La perte d'information ( 27.52 %)
## a modifié la structure des proximités entre pays.
##
## Remarque de l'énoncé :
## 'Une rotation des composantes principales retenues est inutile si l'objectif
## est la classification automatique. Elle n'est utile qu'en termes de facilité
## d'interprétation des axes.'9 On remarque après l’ACP que 2 pays sont très différents des autres.
9.1 3.1 Identification des outliers
# Visualisation du plan factoriel avec labels
fviz_pca_ind(acp, col.ind = "blue", repel = TRUE,
title = "Plan factoriel - Identification des outliers")
# Identification manuelle des outliers (à ajuster selon le graphique)
# Généralement Mexique et parfois Japon ou Corée
outliers <- c("Mexique", "Japon") # À MODIFIER selon votre analyse
cat("Pays outliers identifiés:", paste(outliers, collapse = ", "), "\n")## Pays outliers identifiés: Mexique, Japon# Vérification graphique
#acp_ind <- as.data.frame(acp$ind$coord[, 1:2])
#acp_ind$Pays <- rownames(acp_ind)
#acp_ind$outlier <- acp_ind$Pays %in% outliers
#ggplot(acp_ind, aes(x = Dim.1, y = Dim.2, label = Pays)) +
# geom_point(aes(color = outlier), size = 3) +
# geom_text(vjust = -0.5, size = 3) +
# scale_color_manual(values = c("FALSE" = "blue", "TRUE" = "red")) +
# labs(title = "Identification des outliers dans le plan factoriel")
acp_ind <- as.data.frame(acp$ind$coord[, 1:2])
acp_ind$Pays <- my_data$Pays # Utiliser les vrais noms des pays
acp_ind$outlier <- acp_ind$Pays %in% outliers
ggplot(acp_ind, aes(x = Dim.1, y = Dim.2, label = Pays)) +
geom_point(aes(color = outlier), size = 3) +
geom_text(vjust = -0.5, size = 3, check_overlap = TRUE) +
scale_color_manual(values = c("FALSE" = "blue", "TRUE" = "red")) +
labs(title = "Identification des outliers dans le plan factoriel")
10 Recommencer la procédure complète sans ces deux pays (toujours avec ‘average linkage’), en replaçant les deux pays écartés comme individus supplémentaires dans l’ACP.
10.1 3.2 ACP sans les outliers
# Indices des outliers
indices_out <- which(my_data$Pays %in% outliers)
indices_in <- setdiff(1:nrow(my_data), indices_out)
# ACP sans outliers (individus actifs = sans outliers, supplémentaires = outliers)
acp_sans_out <- PCA(data_clust_norm,
scale.unit = FALSE,
ind.sup = indices_out,
graph = FALSE)
# Scores des individus actifs (sans outliers)
scores_sans_out <- acp_sans_out$ind$coord[, 1:nb_axes]10.2 3.3 CAH sur scores sans outliers
rownames(scores_sans_out) <- my_data$Pays[indices_in]
# CAH sur les scores des individus actifs
dist_sans_out <- dist(scores_sans_out, method = "euclidean")
cah_sans_out <- hclust(dist_sans_out, method = "average")
# Dendrogramme avec noms des pays
fviz_dend(cah_sans_out, k = 4, rect = TRUE, show_labels = TRUE,
labels_track_height = 0.5,
main = "CAH sans outliers - Average linkage")
11 Sauvegarder ensuite la classification obtenue. Cette classification correspond-elle à celle obtenue sur l’ensemble des individus ? Pourquoi ?”
11.1 3.4 Comparaison des classifications
# Comparaison uniquement sur les pays communs (sans outliers)
commun <- setdiff(my_data$Pays, outliers)
idx_commun <- which(my_data$Pays %in% commun)
table_comp_outliers <- table(groups_avg[idx_commun], groups_sans_out)
print("Comparaison avec/sans outliers:")## [1] "Comparaison avec/sans outliers:"## groups_sans_out
## 1 2 3 4
## 1 25 0 0 0
## 2 0 3 0 0
## 3 0 0 1 0
## 4 0 0 0 1concordance_out <- sum(diag(table_comp_outliers)) / sum(table_comp_outliers) * 100
cat("Taux de concordance (hors outliers):", round(concordance_out, 2), "%\n")## Taux de concordance (hors outliers): 100 %# Identification des pays qui changent de groupe
for (i in 1:nrow(table_comp_outliers)) {
for (j in 1:ncol(table_comp_outliers)) {
if (i != j && table_comp_outliers[i, j] > 0) {
pays_concernes <- my_data$Pays[idx_commun][groups_avg[idx_commun] == i & groups_sans_out == j]
cat("Pays du groupe", i, "(avec outliers) reclassés en groupe", j, "(sans outliers) :",
paste(pays_concernes, collapse = ", "), "\n")
}
}
}
cat("
RÉPONSE - La classification correspond-elle ?
", ifelse(concordance_out > 80, "Oui, elle correspond", "Non, elle diffère"), " avec un taux de
concordance de ", round(concordance_out, 2), "%.
EXPLICATION :
- Si identique : Les outliers (", paste(outliers, collapse = " et "), ") n'influençaient pas la structure des groupes.
- Si différente : Les outliers avaient un effet d'attraction/répulsion sur certains pays,
modifiant les distances et donc la formation des groupes. Leur suppression permet
de révéler la structure 'vraie' des autres pays, sans distorsion.
")##
## RÉPONSE - La classification correspond-elle ?
##
## Oui, elle correspond avec un taux de
## concordance de 100 %.
##
## EXPLICATION :
## - Si identique : Les outliers ( Mexique et Japon ) n'influençaient pas la structure des groupes.
## - Si différente : Les outliers avaient un effet d'attraction/répulsion sur certains pays,
## modifiant les distances et donc la formation des groupes. Leur suppression permet
## de révéler la structure 'vraie' des autres pays, sans distorsion.12 Refaire l’analyse des étapes 2 et 3 avec ‘ward linkage’ au lieu de ‘average linkage’.”
12.1 4.1 CAH avec Ward sur scores ACP (tous pays)
# CAH avec Ward sur tous les pays
cah_scores_ward <- hclust(dist_scores, method = "ward.D2")
# Dendrogramme
fviz_dend(cah_scores_ward, k = 4, rect = TRUE, show_labels = TRUE,
labels_track_height = 0.5,
main = "CAH sur scores ACP - Ward linkage")
13 Les groupes obtenus sont-ils les mêmes ?
13.1 4.3 Comparaison Ward vs Average (sur scores)
# Comparaison des deux linkages sur scores
table_ward_avg_scores <- table(groups_scores_avg, groups_scores_ward)
print("Comparaison Average vs Ward sur scores ACP:")## [1] "Comparaison Average vs Ward sur scores ACP:"## groups_scores_ward
## groups_scores_avg 1 2 3 4
## 1 6 8 12 0
## 2 0 0 0 4
## 3 0 1 0 0
## 4 1 0 0 0concordance_ward_avg <- sum(diag(table_ward_avg_scores)) / sum(table_ward_avg_scores) * 100
cat("Taux de concordance Average vs Ward sur scores:",
round(concordance_ward_avg, 2), "%\n")## Taux de concordance Average vs Ward sur scores: 18.75 %# Identification des pays qui changent selon la méthode de linkage
for (i in 1:nrow(table_ward_avg_scores)) {
for (j in 1:ncol(table_ward_avg_scores)) {
if (i != j && table_ward_avg_scores[i, j] > 0) {
pays_concernes <- my_data$Pays[groups_scores_avg == i & groups_scores_ward == j]
cat("Pays du groupe", i, "(Average) reclassés en groupe", j, "(Ward) :",
paste(pays_concernes, collapse = ", "), "\n")
}
}
}## Pays du groupe 1 (Average) reclassés en groupe 2 (Ward) : Autriche, Danemark, Finlande, Allemagne, Pays-Bas, Norvège, Suède, Suisse
## Pays du groupe 1 (Average) reclassés en groupe 3 (Ward) : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Pays du groupe 2 (Average) reclassés en groupe 4 (Ward) : Chili, Estonie, Corée, Mexique
## Pays du groupe 3 (Average) reclassés en groupe 2 (Ward) : Islande
## Pays du groupe 4 (Average) reclassés en groupe 1 (Ward) : États-Unis14 Représenter graphiquement les groupes obtenus dans le premier plan factoriel.”
14.1 4.4 Visualisation dans le plan factoriel
# Visualisation des groupes Ward dans le plan factoriel
#p_ward_plan <- fviz_pca_ind(acp, geom.ind = "point",
# col.ind = as.factor(groups_scores_ward),
# palette = "Set3", addEllipses = TRUE,
# ellipse.type = "confidence",
# repel = TRUE,
# title = "Groupes Ward dans le plan factoriel")
#print(p_ward_plan)
# Avec labels
#fviz_pca_ind(acp, geom.ind = c("point", "text"),
# col.ind = as.factor(groups_scores_ward),
# palette = "Set3", addEllipses = TRUE,
# repel = TRUE,
# title = "Groupes Ward dans le plan factoriel (avec labels)")
# Visualisation des groupes Ward dans le plan factoriel
p_ward_plan <- fviz_pca_ind(acp, geom.ind = "point",
col.ind = as.factor(groups_scores_ward),
palette = "Set3", addEllipses = TRUE,
ellipse.type = "confidence",
repel = TRUE,
title = "Groupes Ward dans le plan factoriel")
print(p_ward_plan)
# Avec labels (les noms des pays apparaîtront automatiquement)
fviz_pca_ind(acp, geom.ind = c("point", "text"),
col.ind = as.factor(groups_scores_ward),
palette = "Set3", addEllipses = TRUE,
repel = TRUE,
title = "Groupes Ward dans le plan factoriel (avec labels)")
15 Décrire précisément les groupes et donner leurs parangons (= individus typiques)
15.1 4.5 Description des groupes et parangons
# Ajout des groupes aux données
my_data$groupe_ward_acp <- groups_scores_ward
# Parangons : individus les plus proches du centre de leur groupe
centers <- aggregate(scores_ind, by = list(groups_scores_ward), FUN = mean)
colnames(centers)[1] <- "groupe"
parangons <- data.frame(groupe = integer(), pays = character())
for (g in 1:4) {
# Individus du groupe g
indices_g <- which(groups_scores_ward == g)
scores_g <- scores_ind[indices_g, ]
# Centre du groupe
center_g <- as.numeric(centers[centers$groupe == g, -1])
# Distances au centre
dist_center <- rowSums((scores_g - matrix(center_g,
nrow = nrow(scores_g),
ncol = nb_axes,
byrow = TRUE))^2)
# Parangon (individu le plus proche)
idx_parangon <- indices_g[which.min(dist_center)]
parangons <- rbind(parangons,
data.frame(groupe = g,
pays = my_data$Pays[idx_parangon]))
}
print("Parangons de chaque groupe (Ward sur scores ACP):")## [1] "Parangons de chaque groupe (Ward sur scores ACP):"## groupe pays
## 1 1 Canada
## 2 2 Pays-Bas
## 3 3 Slovenie
## 4 4 Chili# Description détaillée des groupes avec les noms des pays
cat("\n", paste(rep("=", 70), collapse = ""))##
## ======================================================================##
## DESCRIPTION DES GROUPES (Ward sur scores ACP)## ======================================================================for (g in 1:4) {
pays_du_groupe <- my_data$Pays[groups_scores_ward == g]
parangon <- parangons$pays[parangons$groupe == g]
cat("\n", paste(rep("-", 70), collapse = ""))
cat("\nGROUPE", g, "- Parangon:", parangon)
cat("\n", paste(rep("-", 70), collapse = ""))
cat("\nPays:", paste(pays_du_groupe, collapse = ", "))
cat("\nEffectif:", length(pays_du_groupe), "pays\n")
# Caractéristiques moyennes
moy_g <- colMeans(my_data[groups_scores_ward == g, 2:11])
moy_tot <- colMeans(my_data[, 2:11])
cat("\nProfil moyen (comparé à la moyenne générale):\n")
for (var in names(moy_g)) {
diff <- moy_g[var] - moy_tot[var]
if (abs(diff) > 0.3 * sd(my_data[[var]])) {
direction <- ifelse(diff > 0, "▲ supérieur", "▼ inférieur")
cat(sprintf(" %s: %.2f %s (moy=%.2f)\n",
var, moy_g[var], direction, moy_tot[var]))
}
}
}##
## ----------------------------------------------------------------------
## GROUPE 1 - Parangon: Canada
## ----------------------------------------------------------------------
## Pays: Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis
## Effectif: 7 pays
##
## Profil moyen (comparé à la moyenne générale):
## salmoyPPP: 47085.11 ▲ supérieur (moy=40955.47)
## ecart: 15.64 ▲ supérieur (moy=13.27)
## d9_d1: 3.55 ▲ supérieur (moy=3.27)
## tx_chom: 5.13 ▼ inférieur (moy=6.64)
## tx_inact: 23.15 ▼ inférieur (moy=25.18)
## tx_syndic: 19.55 ▼ inférieur (moy=26.32)
## empl_jeunes: 31.81 ▲ supérieur (moy=22.57)
## empl_age: 15.98 ▲ supérieur (moy=12.31)
## protec: 1.16 ▼ inférieur (moy=2.02)
##
## ----------------------------------------------------------------------
## GROUPE 2 - Parangon: Pays-Bas
## ----------------------------------------------------------------------
## Pays: Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse
## Effectif: 9 pays
##
## Profil moyen (comparé à la moyenne générale):
## salmoyPPP: 51435.02 ▲ supérieur (moy=40955.47)
## d9_d1: 2.80 ▼ inférieur (moy=3.27)
## tx_chom: 5.33 ▼ inférieur (moy=6.64)
## tx_inact: 19.72 ▼ inférieur (moy=25.18)
## heures: 1457.57 ▼ inférieur (moy=1666.91)
## tx_syndic: 45.95 ▲ supérieur (moy=26.32)
## empl_jeunes: 40.33 ▲ supérieur (moy=22.57)
## protec: 2.28 ▲ supérieur (moy=2.02)
##
## ----------------------------------------------------------------------
## GROUPE 3 - Parangon: Slovenie
## ----------------------------------------------------------------------
## Pays: Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Effectif: 12 pays
##
## Profil moyen (comparé à la moyenne générale):
## salmoyPPP: 34778.67 ▼ inférieur (moy=40955.47)
## ecart: 8.94 ▼ inférieur (moy=13.27)
## tx_chom: 9.03 ▲ supérieur (moy=6.64)
## tx_inact: 28.76 ▲ supérieur (moy=25.18)
## empl_jeunes: 6.36 ▼ inférieur (moy=22.57)
## empl_age: 4.36 ▼ inférieur (moy=12.31)
## protec: 2.27 ▲ supérieur (moy=2.02)
##
## ----------------------------------------------------------------------
## GROUPE 4 - Parangon: Chili
## ----------------------------------------------------------------------
## Pays: Chili, Estonie, Corée, Mexique
## Effectif: 4 pays
##
## Profil moyen (comparé à la moyenne générale):
## salmoyPPP: 25179.99 ▼ inférieur (moy=40955.47)
## ecart: 23.78 ▲ supérieur (moy=13.27)
## d9_d1: 3.99 ▲ supérieur (moy=3.27)
## tx_chom: 5.07 ▼ inférieur (moy=6.64)
## tx_inact: 30.29 ▲ supérieur (moy=25.18)
## heures: 2012.10 ▲ supérieur (moy=1666.91)
## tx_syndic: 11.18 ▼ inférieur (moy=26.32)
## empl_jeunes: 15.08 ▼ inférieur (moy=22.57)
## empl_age: 26.74 ▲ supérieur (moy=12.31)16 Refaire l’analyse à partir des données brutes et à partir des résultats d’ACP, en utilisant la méthode k-means.”
16.1 5.1 k-means sur données brutes
set.seed(123) # Pour reproductibilité
# k-means avec k=4 sur données brutes normalisées
kmeans_brut <- kmeans(data_clust_norm, centers = 4, nstart = 25)
print("k-means sur données brutes (k=4):")## [1] "k-means sur données brutes (k=4):"## [1] 7 4 12 9##
## 1 2 3 4
## 7 4 12 9inertie_brut <- kmeans_brut$betweenss / kmeans_brut$totss * 100
cat("Inertie interclasse / inertie totale:", round(inertie_brut, 2), "%\n")## Inertie interclasse / inertie totale: 50.9 %# Ajout des groupes
my_data$groupe_kmeans_brut <- kmeans_brut$cluster
# Pays par groupe k-means
for (g in 1:4) {
cat("\nGroupe k-means brut", g, ":",
paste(my_data$Pays[my_data$groupe_kmeans_brut == g], collapse = ", "))
}##
## Groupe k-means brut 1 : Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis
## Groupe k-means brut 2 : Chili, Estonie, Corée, Mexique
## Groupe k-means brut 3 : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe k-means brut 4 : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse16.2 5.2 k-means sur scores ACP
set.seed(123)
kmeans_scores <- kmeans(scores_ind, centers = 4, nstart = 25)
print("k-means sur scores ACP (k=4):")## [1] "k-means sur scores ACP (k=4):"## [1] 9 12 4 7inertie_scores <- kmeans_scores$betweenss / kmeans_scores$totss * 100
cat("Inertie interclasse / inertie totale:", round(inertie_scores, 2), "%\n")## Inertie interclasse / inertie totale: 68.52 %my_data$groupe_kmeans_acp <- kmeans_scores$cluster
# Pays par groupe k-means ACP
for (g in 1:4) {
cat("\nGroupe k-means ACP", g, ":",
paste(my_data$Pays[my_data$groupe_kmeans_acp == g], collapse = ", "))
}##
## Groupe k-means ACP 1 : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse
## Groupe k-means ACP 2 : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe k-means ACP 3 : Chili, Estonie, Corée, Mexique
## Groupe k-means ACP 4 : Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis17 Faire varier le nombre de groupes et constater que l’inertie expliquée augmente si on augmente le nombre de groupes.
17.1 5.3 Variation du nombre de groupes
# Test de 2 à 10 groupes
k_values <- 2:10
inertie_brut_evol <- sapply(k_values, function(k) {
set.seed(123)
km <- kmeans(data_clust_norm, centers = k, nstart = 25)
km$betweenss / km$totss * 100
})
inertie_scores_evol <- sapply(k_values, function(k) {
set.seed(123)
km <- kmeans(scores_ind, centers = k, nstart = 25)
km$betweenss / km$totss * 100
})
# DataFrame pour ggplot
df_evol <- data.frame(
k = rep(k_values, 2),
inertie = c(inertie_brut_evol, inertie_scores_evol),
methode = rep(c("Données brutes", "Scores ACP"), each = length(k_values))
)
# Graphique d'évolution
ggplot(df_evol, aes(x = k, y = inertie, color = methode)) +
geom_line(size = 1) +
geom_point(size = 3) +
labs(title = "Évolution de l'inertie expliquée avec k-means",
x = "Nombre de groupes (k)",
y = "Inertie interclasse / inertie totale (%)") +
theme_minimal()
## [1] "Inertie expliquée (%) selon k:"print(data.frame(
k = k_values,
Donnees_brutes = round(inertie_brut_evol, 2),
Scores_ACP = round(inertie_scores_evol, 2)
))## k Donnees_brutes Scores_ACP
## 1 2 25.87 35.42
## 2 3 41.60 55.91
## 3 4 50.90 68.52
## 4 5 57.84 74.83
## 5 6 64.03 80.62
## 6 7 69.22 84.79
## 7 8 73.46 87.49
## 8 9 77.13 89.21
## 9 10 80.45 90.74cat("
RÉPONSE - Variation de l'inertie expliquée :
L'inertie expliquée augmente mécaniquement avec le nombre de groupes car :
- Avec plus de groupes, les individus sont plus proches de leur centre
- À la limite, avec k = n (nombre d'individus), l'inertie interclasse = 100%
Le choix du nombre de groupes se fait par la méthode du 'coude' :
- On cherche le point où l'augmentation d'inertie ralentit
- Au-delà de ce point, ajouter des groupes n'apporte plus beaucoup de gain
Comparaison brutes vs ACP :
- L'inertie est généralement plus faible sur scores ACP car on a réduit la dimension
- La forme de la courbe peut être différente selon la qualité de la réduction
")##
## RÉPONSE - Variation de l'inertie expliquée :
##
## L'inertie expliquée augmente mécaniquement avec le nombre de groupes car :
## - Avec plus de groupes, les individus sont plus proches de leur centre
## - À la limite, avec k = n (nombre d'individus), l'inertie interclasse = 100%
##
## Le choix du nombre de groupes se fait par la méthode du 'coude' :
## - On cherche le point où l'augmentation d'inertie ralentit
## - Au-delà de ce point, ajouter des groupes n'apporte plus beaucoup de gain
##
## Comparaison brutes vs ACP :
## - L'inertie est généralement plus faible sur scores ACP car on a réduit la dimension
## - La forme de la courbe peut être différente selon la qualité de la réduction17.1.1 Synthèse finale
# Tableau récapitulatif des différentes classifications
resultats <- data.frame(
Pays = my_data$Pays,
CAH_brut_avg = groups_avg,
CAH_brut_ward = groups_ward,
CAH_acp_avg = groups_scores_avg,
CAH_acp_ward = groups_scores_ward,
Kmeans_brut = my_data$groupe_kmeans_brut,
Kmeans_acp = my_data$groupe_kmeans_acp
)
print("Récapitulatif des classifications:")## [1] "Récapitulatif des classifications:"## Pays CAH_brut_avg CAH_brut_ward CAH_acp_avg
## Australie Australie 1 1 1
## Autriche Autriche 1 2 1
## Belgique Belgique 1 3 1
## Canada Canada 1 1 1
## Chili Chili 2 4 2
## Républiquetchèque Républiquetchèque 1 3 1
## Danemark Danemark 1 2 1
## Estonie Estonie 2 4 2
## Finlande Finlande 1 2 1
## France France 1 3 1
## CAH_acp_ward Kmeans_brut Kmeans_acp
## Australie 1 1 4
## Autriche 2 4 1
## Belgique 3 3 2
## Canada 1 1 4
## Chili 4 2 3
## Républiquetchèque 3 3 2
## Danemark 2 4 1
## Estonie 4 2 3
## Finlande 2 4 1
## France 3 3 2# Sauvegarde des résultats
write.csv(resultats, "classifications_pays.csv", row.names = FALSE)
#cat("Résultats sauvegardés dans 'classifications_pays.csv'\n")
# Affichage des pays par groupe pour chaque méthode
cat("\n", paste(rep("=", 80), collapse = ""))##
## ================================================================================##
## RÉCAPITULATIF COMPLET DES CLASSIFICATIONS## ================================================================================for (methode in c("CAH_brut_ward", "CAH_acp_ward", "Kmeans_brut", "Kmeans_acp")) {
cat("\n", paste(rep("-", 60), collapse = ""))
cat("\n", methode, "\n")
cat(paste(rep("-", 60), collapse = ""), "\n")
for (g in 1:4) {
pays_groupe <- resultats$Pays[resultats[[methode]] == g]
if (length(pays_groupe) > 0) {
cat("Groupe", g, "(", length(pays_groupe), "pays) :",
paste(pays_groupe, collapse = ", "), "\n")
}
}
}##
## ------------------------------------------------------------
## CAH_brut_ward
## ------------------------------------------------------------
## Groupe 1 ( 7 pays) : Australie, Canada, Irlande, Nouvelle-Zélande, Suisse, Royaume-Uni, États-Unis
## Groupe 2 ( 8 pays) : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède
## Groupe 3 ( 12 pays) : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe 4 ( 5 pays) : Chili, Estonie, Japon, Corée, Mexique
##
## ------------------------------------------------------------
## CAH_acp_ward
## ------------------------------------------------------------
## Groupe 1 ( 7 pays) : Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis
## Groupe 2 ( 9 pays) : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse
## Groupe 3 ( 12 pays) : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe 4 ( 4 pays) : Chili, Estonie, Corée, Mexique
##
## ------------------------------------------------------------
## Kmeans_brut
## ------------------------------------------------------------
## Groupe 1 ( 7 pays) : Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis
## Groupe 2 ( 4 pays) : Chili, Estonie, Corée, Mexique
## Groupe 3 ( 12 pays) : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe 4 ( 9 pays) : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse
##
## ------------------------------------------------------------
## Kmeans_acp
## ------------------------------------------------------------
## Groupe 1 ( 9 pays) : Autriche, Danemark, Finlande, Allemagne, Islande, Pays-Bas, Norvège, Suède, Suisse
## Groupe 2 ( 12 pays) : Belgique, Républiquetchèque, France, Grèce, Hongrie, Italie, Luxembourg, Pologne, Portugal, Républiqueslovaque, Slovenie, Espagne
## Groupe 3 ( 4 pays) : Chili, Estonie, Corée, Mexique
## Groupe 4 ( 7 pays) : Australie, Canada, Irlande, Japon, Nouvelle-Zélande, Royaume-Uni, États-Unis# Sauvegarde des résultats
write.csv(resultats, "classifications_pays.csv", row.names = FALSE)
cat("\nRésultats sauvegardés dans 'classifications_pays.csv'\n")##
## Résultats sauvegardés dans 'classifications_pays.csv'