Fonction acp_from_scratch calculs matriciellement

acp_from_scratch <- function(X, nombre_composants=NULL, reduire = FALSE) {
  
  n <- nrow(X)
  X <- as.matrix(X)
  
  # Data centree
  data <- centrage(X)
  
  # Data normee
  if (reduire) {
    data <- centrer_reduire(X)
  }

  #calculer la matrice de covariance matriciellement
  matrice_covariance <- (1/n) * t(data) %*% data
  
  # Calcul des valeurs propres et vecteurs propres
  eig_result <- eigen(matrice_covariance)
  valeurs_propres <- eig_result$values
  vecteurs_propres <- eig_result$vectors
  
  # Sélectionner le nombre spécifié de composants principaux
  if (!is.null(nombre_composants)) {
    vecteurs_propres <- vecteurs_propres[, 1:nombre_composants, drop = FALSE]
  }
  
  # Projection des données sur les composants principaux
  nouvelles_coordonnees <- data %*% vecteurs_propres
  
  return(list(matrice_covariance=matrice_covariance,
              nouvelles_coordonnees=nouvelles_coordonnees, 
              valeurs_propres=valeurs_propres, 
              vecteurs_propres=vecteurs_propres))
  
}

Fonction qui centre les données

centrage <- function(data) {
  n <- nrow(data)
  
  # Centrage des données
  # Définir la matrice des poids
  matrice_de_poids <- (1/n) * diag(n)
  
  # Calculer la moyenne pondérée matriciellement
  mat1_n <- matrix(rep(1, n), nrow=1)
  moyenne_ponderee <- mat1_n %*% data / n
  
  #calculer data_centree
  data_centree <- sweep(data, 2, moyenne_ponderee)
  
  return (data_centree)
}

Fonction qui normalise les données

centrer_reduire <- function(donnees) {
  n <- nrow(donnees)  # Nombre d'observations
  p <- ncol(donnees)  # Nombre de variables
  
  # Centrage des données
  donnees_centrees = centrage(donnees)
  
  # Réduction des données (calcul de l'écart-type de façon matricielle avec biais)
  # Calculer la matrice de covariance avec biais (diviser par n!)
  matrice_covariance <- (1 / n) * (t(donnees_centrees) %*% donnees_centrees)
  # Extraire l'écart-type à partir de la diagonale de la matrice de covariance
  ecarts_types <- sqrt(diag(matrice_covariance))
  
  # Réduire les données : diviser par l'écart-type
  donnees_reduites <- sweep(donnees_centrees, 2, ecarts_types, FUN = "/")
  
  return(donnees_reduites)
}

1. et 2. On a le pseudo code dans le rendu du TP1.1, testé et approuvé.

Importer les données

# Données
data_PDE19 <- read.csv("data_PDE20.csv", sep=";", dec=",")
#View(data_PDE19)
data_PDE19$Num <- NULL
data_PDE19$X <- NULL
# Convertir le data.frame en matrice
data_PDE19 <- as.matrix(data_PDE19)

1. visualisation de la matrice des donnees

1.1 afficher la dimension de la matrice

cat("Matrice X des données de dimension (n,p) =",
    "(", paste(dim(data_PDE19), collapse = ", "), ")\n\n")
## Matrice X des données de dimension (n,p) = ( 26, 8 )

1.2 Afficher la matrice avec les noms des colonnes et leurs lignes

data_PDE19_df <- as.data.frame(data_PDE19)
# Ajouter une colonne avec les numéros de ligne
data_PDE19_df$Row <- seq_len(nrow(data_PDE19_df))
# Faire de cette colonne la première colonne
data_PDE19_df <- data_PDE19_df[, c(ncol(data_PDE19_df), 1:(ncol(data_PDE19_df)-1))]

#Pander
pander(data_PDE19_df)
Row X1 X2 X3 X4 X5 X6 X7 X8
1 303.1 24.19 0 3.29 180 8.09 360.9 120.3
2 281.9 38.59 4.29 1.06 192 10.5 353.5 117
3 277.1 34.79 0 6.85 183.8 38.89 344 114.7
4 276.4 32.43 4.14 2.04 190.8 38.53 341.2 113.9
5 253.8 39.5 3.04 1 173.8 19.33 382.1 127.4
6 243.6 34.39 2.79 3.43 166.7 27.59 391.1 130.4
7 277 34.7 0 6.85 183.8 38.8 343.9 114.7
8 294.8 28.29 1.85 1.83 182.3 10.29 360.2 120
9 303 24.2 0 3.3 180 8.1 361 120.3
10 269.4 36.89 2.99 1.03 197.7 12.59 359.5 19.82
11 283.6 28 9.3 0 186.6 13.2 359.4 119.8
12 290.3 23.2 0.8 2.34 172.4 39.4 353.6 117.9
13 285.1 25.9 0.93 7.78 180.1 39 345.7 115.2
14 265.5 40.39 0.95 5.14 184.4 38.83 348.6 116.2
15 261.9 41.49 2.33 2.89 187.3 38.69 349.1 116.3
16 274.4 29.79 6.69 0 183.6 38.89 350 116.7
17 257.9 37.2 2.96 1.1 170.9 18.89 383.3 127.8
18 238.2 29.8 2.6 0.8 166.7 14.14 410.1 136.9
19 236 33.39 5.6 0.39 166.7 15.23 407 135.7
20 247.8 36.69 5.03 1.79 166.7 27.09 386.2 128.8
21 266.6 36.4 0 2.9 166.7 30.68 365.6 121.9
22 264.8 24.19 1.19 5.6 166.7 39.69 391.9 130.7
23 235.7 24.99 0.99 4.29 166.7 39.69 392 130.7
24 239.6 47.89 0.4 4.19 166.7 39.69 376.1 125.3
25 233.1 46.59 2.29 4.83 166.7 39.69 380.1 126.7
26 241.4 34.5 5.15 0.39 166.7 39.69 383.8 127.9

1.3 Calcul des indicateurs stats classiques (mean, sd, median, quartiles etc…) pour l’ensemble des données

#SUPP cette colonne
data_PDE19_df$Row <- NULL
library(pander)

data_PDE19_stats <- data_PDE19_df

# Calculer les statistiques
stats <- sapply(data_PDE19_stats[sapply(data_PDE19_stats, is.numeric)], 
                function(x) 
                  c(Mean = mean(x, na.rm = TRUE), 
                    SD = sd(x, na.rm = TRUE), 
                    Median = median(x, na.rm = TRUE),
                    Min = min(x, na.rm = TRUE),
                    Max = max(x, na.rm = TRUE),
                    Range = diff(range(x, na.rm = TRUE)),
                    Q1 = quantile(x, 0.25, na.rm = TRUE),
                    Q3 = quantile(x, 0.75, na.rm = TRUE),
                    IQR = IQR(x, na.rm = TRUE)))


# Transformer en dataframe pour pander
stats_df <- as.data.frame(t(stats))

# Utiliser pander pour afficher le tableau
pander(stats_df)
  Mean SD Median Min Max Range Q1.25% Q3.75% IQR
X1 265.4 21.51 266 233.1 303.1 70 244.6 280.7 36.06
X2 33.4 6.877 34.45 23.2 47.89 24.69 28.07 37.12 9.05
X3 2.55 2.378 2.31 0 9.3 9.3 0.8325 3.865 3.032
X4 2.889 2.247 2.615 0 7.78 7.78 1.038 4.265 3.228
X5 176.8 9.835 176.9 166.7 197.7 31.03 166.7 183.8 17.1
X6 27.89 12.68 34.61 8.09 39.69 31.6 14.41 38.97 24.56
X7 368.5 20.36 361 341.2 410.1 68.97 350.9 383.6 32.79
X8 119 21.33 120.3 19.82 136.9 117.1 116.4 127.9 11.46

Il y a une grosse disparité (variable X1,X7 et X8 par exemple) (Cela permet de donner de l’inertie) et les mediannes sont proches des moyennes : il n’y a pas d’indices de valeurs extremes pour une variable donnée. Et il n’y en a pas quand on regarde les données.

2. Centrage et normalisation des données

données centrées

donnees_centrees <- as.data.frame(centrage(data_PDE19))


# Ajouter une colonne avec les numéros de ligne
donnees_centrees$Row <- seq_len(nrow(donnees_centrees))
# Faire de cette colonne la première colonne
donnees_centrees <- donnees_centrees[, c(ncol(donnees_centrees), 1:(ncol(donnees_centrees)-1))]


# Mettre l'option pour avoir 3 chiffres après la virgule
panderOptions('digits', 3)
pander(donnees_centrees)
Row X1 X2 X3 X4 X5 X6 X7 X8
1 37.6 -9.21 -2.55 0.401 3.21 -19.8 -7.55 1.38
2 16.4 5.19 1.74 -1.83 15.2 -17.4 -15 -1.95
3 11.6 1.39 -2.55 3.96 6.99 11 -24.5 -4.3
4 10.9 -0.969 1.59 -0.849 14 10.6 -27.3 -5.04
5 -11.6 6.1 0.49 -1.89 -2.98 -8.56 13.7 8.42
6 -21.9 0.991 0.24 0.541 -10.1 -0.302 22.7 11.4
7 11.6 1.3 -2.55 3.96 7 10.9 -24.5 -4.3
8 29.4 -5.11 -0.7 -1.06 5.51 -17.6 -8.25 1.05
9 37.6 -9.2 -2.55 0.411 3.22 -19.8 -7.45 1.39
10 3.93 3.49 0.44 -1.86 20.9 -15.3 -8.98 -99.1
11 18.2 -5.4 6.75 -2.89 9.82 -14.7 -9.03 0.853
12 24.9 -10.2 -1.75 -0.549 -4.38 11.5 -14.8 -1.08
13 19.6 -7.5 -1.62 4.89 3.32 11.1 -22.8 -3.72
14 0.0327 6.99 -1.6 2.25 7.61 10.9 -19.9 -2.76
15 -3.58 8.09 -0.22 0.00115 10.5 10.8 -19.4 -2.61
16 8.93 -3.61 4.14 -2.89 6.8 11 -18.5 -2.3
17 -7.55 3.8 0.41 -1.79 -5.88 -9 14.8 8.82
18 -27.2 -3.6 0.0496 -2.09 -10.1 -13.8 41.7 18
19 -29.5 -0.00923 3.05 -2.5 -10.1 -12.7 38.5 16.7
20 -17.7 3.29 2.48 -1.1 -10.1 -0.802 17.8 9.8
21 1.12 3 -2.55 0.0112 -10.1 2.79 -2.85 2.93
22 -0.657 -9.21 -1.36 2.71 -10.1 11.8 23.4 11.7
23 -29.8 -8.41 -1.56 1.4 -10.1 11.8 23.5 11.7
24 -25.9 14.5 -2.15 1.3 -10.1 11.8 7.62 6.4
25 -32.4 13.2 -0.26 1.94 -10.1 11.8 11.6 7.74
26 -24.1 1.1 2.6 -2.5 -10.1 11.8 15.3 8.97

données normés

donnees_normee <- as.data.frame(centrer_reduire(data_PDE19))

# Ajouter une colonne avec les numéros de ligne
donnees_normee$Row <- seq_len(nrow(donnees_normee))
# Faire de cette colonne la première colonne
donnees_normee <- donnees_normee[, c(ncol(donnees_normee), 1:(ncol(donnees_normee)-1))]

pander(donnees_normee)
Row X1 X2 X3 X4 X5 X6 X7 X8
1 1.78 -1.37 -1.09 0.182 0.333 -1.59 -0.378 0.0658
2 0.779 0.77 0.746 -0.83 1.58 -1.4 -0.749 -0.0934
3 0.551 0.206 -1.09 1.8 0.725 0.884 -1.23 -0.206
4 0.518 -0.144 0.682 -0.385 1.45 0.855 -1.37 -0.241
5 -0.552 0.905 0.21 -0.857 -0.309 -0.688 0.684 0.403
6 -1.04 0.147 0.103 0.246 -1.05 -0.0243 1.14 0.546
7 0.548 0.193 -1.09 1.8 0.726 0.877 -1.23 -0.206
8 1.39 -0.758 -0.3 -0.481 0.572 -1.42 -0.413 0.05
9 1.78 -1.36 -1.09 0.187 0.334 -1.59 -0.373 0.0663
10 0.186 0.518 0.189 -0.844 2.17 -1.23 -0.45 -4.74
11 0.861 -0.801 2.89 -1.31 1.02 -1.18 -0.453 0.0408
12 1.18 -1.51 -0.751 -0.249 -0.454 0.925 -0.743 -0.0518
13 0.931 -1.11 -0.695 2.22 0.345 0.893 -1.14 -0.178
14 0.00155 1.04 -0.686 1.02 0.789 0.88 -0.996 -0.132
15 -0.17 1.2 -0.0945 0.000524 1.09 0.868 -0.971 -0.125
16 0.423 -0.535 1.78 -1.31 0.705 0.884 -0.926 -0.11
17 -0.358 0.564 0.176 -0.812 -0.609 -0.724 0.744 0.421
18 -1.29 -0.534 0.0213 -0.948 -1.04 -1.11 2.09 0.859
19 -1.4 -0.00137 1.31 -1.13 -1.05 -1.02 1.93 0.798
20 -0.838 0.488 1.06 -0.499 -1.05 -0.0645 0.892 0.468
21 0.0532 0.445 -1.09 0.00506 -1.05 0.224 -0.143 0.14
22 -0.0312 -1.37 -0.583 1.23 -1.05 0.949 1.17 0.559
23 -1.41 -1.25 -0.669 0.636 -1.05 0.949 1.18 0.559
24 -1.23 2.15 -0.922 0.591 -1.05 0.949 0.382 0.306
25 -1.53 1.96 -0.112 0.881 -1.05 0.949 0.582 0.37
26 -1.14 0.163 1.11 -1.13 -1.05 0.949 0.767 0.429

ACP from scratch CENTREE + NORMEE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=8, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=8, reduire = TRUE)

ACP avec dudi.pca CENTREE + NORMEE

result_dudi_centree <- dudi.pca(data_PDE19,center = TRUE, scale = FALSE, nf = 8, scannf = FALSE)
result_dudi_normee <- dudi.pca(data_PDE19,center = TRUE, scale = TRUE, nf = 8, scannf = FALSE)
library(ggplot2)

# Exécution de l'ACP - centrée et normée
result_centree <- acp_from_scratch(data_PDE19, nombre_composants=8, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=8, reduire = TRUE)

# Créer une fonction pour générer un graphique ggplot pour une paire spécifique de composantes comme demandé
generate_plot <- function(result, x, y, title) {
  data_plot <- as.data.frame(result$nouvelles_coordonnees)
  
  ggplot(data_plot, aes_string(x = paste0("V", x), y = paste0("V", y))) +
    geom_point() +
    labs(title = title, x = paste0("PC", x), y = paste0("PC", y)) +
    theme_minimal()
}

# Générer et afficher les graphiques pour chaque paire de composantes
# Pour données centrées
generate_plot(result_centree, 1, 2, "ACP Centrée: PC1 vs PC2")
## 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.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

generate_plot(result_centree, 1, 3, "ACP Centrée: PC1 vs PC3")

generate_plot(result_centree, 1, 4, "ACP Centrée: PC1 vs PC4")

generate_plot(result_centree, 2, 3, "ACP Centrée: PC2 vs PC3")

# Pour données centrées et normées
generate_plot(result_normee, 1, 2, "ACP Normée: PC1 vs PC2")

generate_plot(result_normee, 1, 3, "ACP Normée: PC1 vs PC3")

generate_plot(result_normee, 1, 4, "ACP Normée: PC1 vs PC4")

generate_plot(result_normee, 2, 3, "ACP Normée: PC2 vs PC3")

on voit qu’il semble il y avoir 2 groupes, que l’on voit de moin en moins bien au fil des CP car l’inertie que l’on capte diminiue avec les CP.

On voit aussi que dans le cas CENTREE des valeurs extremes captent toute la variance quasiment au détrimetn du reste des données, d’ou l’importance de NORMEE si les variances ne sont pas similaires pour les données originales.

D’autres commentaires sur la diffénrence CENTREE VS NORMEE seront fait dans la suite.

library(plotly)
## 
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
## 
##     last_plot
## The following object is masked from 'package:stats':
## 
##     filter
## The following object is masked from 'package:graphics':
## 
##     layout
# Exécution de l'ACP - centrée et normée
result_centree <- acp_from_scratch(data_PDE19, nombre_composants=3, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=3, reduire = TRUE)

# Fonction pour générer un graphique Plotly 3D pour l'ACP
generate_3d_plot <- function(result, title) {
  data_plot <- as.data.frame(result$nouvelles_coordonnees)
  
  plot_ly(data = data_plot, x = ~V1, y = ~V2, z = ~V3, 
          type = 'scatter3d', mode = 'markers',
          marker = list(size = 2, opacity = 0.7)) %>%
    layout(title = title,
           scene = list(xaxis = list(title = 'PC1'),
                        yaxis = list(title = 'PC2'),
                        zaxis = list(title = 'PC3')))
}

# Générer les graphiques 3D pour les données centrées et normées
p3d_centree <- generate_3d_plot(result_centree, "ACP Centrée 3D")
p3d_normee <- generate_3d_plot(result_normee, "ACP Normée 3D")

# Afficher les graphiques
p3d_centree
p3d_normee

Comparaison des résultats DUDI et FROM SCRATCH :

Comparaison des valeurs propres CENTREE

# Mettre l'option pour avoir 5 chiffres après la virgule
panderOptions('digits', 5)
pander(t(as.matrix(result_dudi_centree$eig)))
909.47 351.32 234.58 60.747 18.652 5.2277 3.3892 0.91294 
pander(t(as.matrix(result_centree$valeurs_propres)))
909.47 351.32 234.58 60.747 18.652 5.2277 3.3892 0.91294

On obtient exactement les mêmes valeurs propres entre pca_from_scratch et dudi.pca.

Les valeurs propres dans une ACP reflètent la quantité de variance capturée par chaque composante principale. Dans une ACP centrée, les valeurs propres peuvent varier considérablement, en particulier si les variances des différentes variables sont très différentes. En revanche, dans une ACP normalisée, puisque toutes les variables sont mises à l’échelle pour avoir la même variance unitaire, les valeurs propres tendent à être plus petites et moins dispersées.

Comparaison des valeurs propres NORMEE

pander(t(as.matrix(result_dudi_normee$eig)))
2.8725 2.1191 1.3782 0.79864 0.51113 0.21485 0.090138 0.015465 
pander(t(as.matrix(result_normee$valeurs_propres)))
2.8725 2.1191 1.3782 0.79864 0.51113 0.21485 0.090138 0.015465

On obtient exactement les mêmes valeurs propres entre pca_from_scratch et dudi.pca

En cette ACP NORMEE nos valeurs propres sont bien moins dispersées (ordre de grandeur 1 contre ordre 3)

Comparaison des vecteurs propres CENTREE

# Mettre l'option pour avoir 3 chiffres après la virgule
panderOptions('digits', 3)
pander(as.matrix(result_dudi_centree$c1))
  CS1 CS2 CS3 CS4 CS5 CS6 CS7 CS8
X1 0.605 0.461 -0.359 0.297 0.226 0.00608 -0.391 0.0171
X2 -0.0501 -0.146 0.193 -0.565 0.605 -0.0109 -0.504 0.0326
X3 -0.0104 -0.017 -0.023 -0.101 -0.309 0.641 -0.231 0.656
X4 0.00983 0.0242 0.0689 0.0874 0.141 -0.623 0.151 0.745
X5 0.281 -0.0862 0.0114 -0.386 -0.67 -0.412 -0.369 -0.1
X6 -0.0608 0.049 0.756 0.511 -0.0795 -0.0182 -0.39 -0.0516
X7 -0.591 -0.199 -0.503 0.314 -0.0442 -0.167 -0.478 -0.0103
X8 -0.446 0.846 0.0651 -0.258 -0.103 -0.0546 -0.0101 -0.0215 
pander(as.matrix(result_centree$vecteurs_propres))
0.605 0.461 -0.359
-0.0501 -0.146 0.193
-0.0104 -0.017 -0.023
0.00983 0.0242 0.0689
0.281 -0.0862 0.0114
-0.0608 0.049 0.756
-0.591 -0.199 -0.503
-0.446 0.846 0.0651

On obtient exactement les mêmes vecteurs propres entre pca_from_scratch et dudi.pca

Comparaison des vecteurs propres NORMEE

pander(as.matrix(result_dudi_normee$c1))
  CS1 CS2 CS3 CS4 CS5 CS6 CS7 CS8
X1 0.512 0.0249 0.36 -0.0863 0.241 -0.203 0.434 0.559
X2 -0.154 -0.0609 -0.728 0.196 0.556 -0.0581 0.212 0.217
X3 -0.098 0.535 -0.189 -0.566 -0.122 0.43 0.384 0.0099
X4 0.106 -0.63 0.0505 0.094 -0.0228 0.717 0.258 -0.0185
X5 0.527 0.158 -0.237 -0.0711 0.0639 0.336 -0.669 0.266
X6 -0.095 -0.495 -0.285 -0.554 -0.387 -0.3 -0.0868 0.333
X7 -0.52 0.158 0.164 0.331 -0.227 0.212 -0.112 0.677
X8 -0.368 -0.135 0.371 -0.451 0.642 0.0941 -0.29 0.0172 
pander(as.matrix(result_normee$vecteurs_propres))
0.512 0.0249 0.36
-0.154 -0.0609 -0.728
-0.098 0.535 -0.189
0.106 -0.63 0.0505
0.527 0.158 -0.237
-0.095 -0.495 -0.285
-0.52 0.158 0.164
-0.368 -0.135 0.371

CCL : On obtient exactement les mêmes vecteurs propres entre pca_from_scratch et dudi.pca OUF!

Partie 2 - qualité de l’ACP

3. Représentation de l’inertie expliquée et cumulée CENTREE et NORMEE

# Définissez d'abord vos données pour la centrée
inertie_expliquee_centree <- result_centree$valeurs_propres / sum(result_centree$valeurs_propres)
cumul_inertie_centree <- cumsum(inertie_expliquee_centree)
ylim_max_centree <- max(cumul_inertie_centree) + .1

# Puis pour la normalisée
inertie_expliquee_normee <- result_normee$valeurs_propres / sum(result_normee$valeurs_propres)
cumul_inertie_normee <- cumsum(inertie_expliquee_normee)
ylim_max_normee <- max(cumul_inertie_normee) + .1

# Définir les paramètres de la fenêtre graphique pour les subplots
par(mfrow=c(1, 2))  # 1 ligne, 2 colonnes

# Premier subplot pour la centrée
midpoints_centree <- barplot(inertie_expliquee_centree, main="CENTREE", xlab="Composantes", ylab="Inertie expliquée et cumulée", ylim=c(0, ylim_max_centree), col = "blue")
lines(midpoints_centree, cumul_inertie_centree, type="b", col="red")
abline(h = 1, col="grey", lty=2)  # Ligne pointillée pour l'asymptote

# Second subplot pour la normalisée
midpoints_normee <- barplot(inertie_expliquee_normee, main="NORMEE", xlab="Composantes", ylab="Inertie expliquée et cumulée", ylim=c(0, ylim_max_normee), col = "blue")
lines(midpoints_normee, cumul_inertie_normee, type="b", col="red")
abline(h = 1, col="grey", lty=2)  # Ligne pointillée pour l'asymptote

# Réinitialiser les paramètres de la fenêtre graphique
par(mfrow=c(1, 1))

On voit que la composante 1 est plus elevée en CENTREE qu’en NORMEE:

Interpretation : l’inertie expliqué par cette composante en CENTREE reflete une variance capturé dans les données originales, pondérées selon l’importance relative des différentes variables selon leurs variances et que en NORMEE, la ou toutes les variables sont à la même echelle, cette variance capturé dans les données originales n’est plus presente.

Règle de Karlis - Saporta - Spinaki NORMEE

sueil = mean(VP) + 2sd(VP)

# Seuil calculé à partir de la moyenne et de l'écart-type des valeurs propres
karlis_threshold_value <- mean(result_normee$valeurs_propres) + 2 * sd(result_normee$valeurs_propres)
cat("Valeur de karlis_sueil plus grande que la première VP :", karlis_threshold_value, ">", result_normee$valeurs_propres[1])
## Valeur de karlis_sueil plus grande que la première VP : 3.083225 > 2.872476

La regle de Karlis - Saporta - Spinaki pour NORMEE (selon le cours) nous donne un sueil plus grand que la plus grande des VP: on ne peut pas l’utiliser ici.

Règle de Kaiser - Guttman NORMEE

sueil = 1

# Calcul des inertie expliquées et cumulées
inertie_expliquee_normee <- result_normee$valeurs_propres / sum(result_normee$valeurs_propres)
cumul_inertie_normee <- cumsum(inertie_expliquee_normee)
ylim_max_normee <- max(cumul_inertie_normee) + 0.1

# Barplot de l'inertie expliquée pour la normalisée
midpoints_normee <- barplot(inertie_expliquee_normee, main="ACP NORMEE + règles classiques", xlab="Composantes", ylab="Inertie expliquée", ylim=c(0, ylim_max_normee), col = "blue")
lines(midpoints_normee, cumul_inertie_normee, type="b", pch=19, col="red")

# Ajouter les valeurs des valeurs propres en abscisse, écriture verticale
text(x=midpoints_normee, y=-0.05, labels=round(result_normee$valeurs_propres, 2), srt=90, adj=1, xpd=TRUE, cex=0.8)

# Règle de Kaiser - Guttman
# Identifier la dernière composante avec une valeur propre >= 1 et la position de la barre correspondante
kaiser_comps <- which(result_normee$valeurs_propres >= 1)
if(length(kaiser_comps) > 0) {
  kaiser_limit <- max(kaiser_comps)
  # Utilisez les midpoints pour aligner la ligne verticale avec la barre correspondante
  abline(v=midpoints_normee[kaiser_limit], col="green", lty=2)
}
abline(v=0, col="orange", lty=2)
abline(h = .8, col="grey", lty=2)
# Ajouter une légende pour les seuils
legend("topright",inset=c(0, 0.2), legend=c("Kaiser-Guttman", "Karlis-Saporta-Spinaki"), col=c("green", "orange"), lty=2, cex=0.8)

Selon cette regle de Kaiser - Guttman, on devrait prendre les 3 premieres composantes.

Selon la règle des 80% d’inertei cumulée, 3 est celui a choisir egalement.

On ne voit pas de “Coude” apparaitre sur la courbe des inerties cumuléee.

Il semble que 3 soit un bon choix, mais cela depend de notre but évidemment.

4. Nouvelles coordonnées calculées matriciellement

Comparaison des nouvelles coordonnees CENTREE

# Mettre l'option pour avoir deux chiffres après la virgule
panderOptions('digits', 4)
pander(as.matrix(result_dudi_centree$li))
Axis1 Axis2 Axis3 Axis4 Axis5 Axis6 Axis7 Axis8
29.24 20.15 -26.23 2.579 3.392 -1.333 0.7113 -0.2791
24.7 5.899 -10.63 -17.34 -1.903 -1.054 -1.372 -0.2002
24.73 6.456 16.88 -0.3885 0.7747 -2.807 0.8349 0.602
28.31 5.604 17.4 -3.671 -7.238 0.4854 -0.5048 -0.9967
-19.52 -2.061 -7.613 -8.231 1.843 -0.002059 -1.094 -0.669
-34.63 -4.205 -2.945 0.8816 0.2715 -0.5689 0.9644 0.7654
24.71 6.438 16.82 -0.4085 0.7076 -2.807 0.9399 0.6018
25.05 15.44 -20.59 -2.408 1.57 -0.1851 -0.1289 -0.4921
29.12 20.1 -26.24 2.578 3.366 -1.361 0.6875 -0.2756
58.47 -83.42 -14.13 5.871 0.4236 0.002492 -0.1191 0.001939
19.78 9.921 -14.3 -6.851 -6.756 3.977 0.04525 2.258
22.9 15.93 5.146 16.47 2.703 3.608 -0.04811 -1.444
27.71 11.92 11.53 8.87 -0.6275 -1.458 2.57 2.083
14.16 0.579 19.7 -6.449 0.2354 -2.374 -0.3699 -0.2051
12.35 -1.545 20.72 -9.548 -2.614 -1.394 -1.41 -1.292
18.72 6.181 13.35 1.809 -6.227 4.753 -1.009 -0.4128
-18.59 0.4923 -10.46 -4.535 3.303 0.9167 -0.8359 -0.3595
-50.99 -4.965 -21.38 -0.9477 -4.497 -2.329 1.108 -1.206
-50.18 -6.968 -17.65 -4.07 -3.609 0.3853 0.5246 0.5405
-28.58 -3.109 -2.197 -0.9118 2.11 2.8 -0.05777 1.269
-2.063 4.175 3.852 2.567 9.228 2.757 2.609 -0.7143
-22.53 7.806 -3.566 19.64 -1.33 -3.071 -6.593 0.7255
-40.24 -5.759 6.918 10.48 -7.549 -2.58 4.203 -0.8556
-27.26 -8.609 17.6 -4.864 8.597 -0.1808 -1.08 -0.2255
-34.1 -11.09 17.75 -5.285 5.527 -0.1417 -0.1631 1.266
-31.28 -5.364 10.3 4.163 -1.702 3.964 -0.4117 -0.4847 
pander(as.matrix(result_centree$nouvelles_coordonnees))
29.24 20.15 -26.23
24.7 5.899 -10.63
24.73 6.456 16.88
28.31 5.604 17.4
-19.52 -2.061 -7.613
-34.63 -4.205 -2.945
24.71 6.438 16.82
25.05 15.44 -20.59
29.12 20.1 -26.24
58.47 -83.42 -14.13
19.78 9.921 -14.3
22.9 15.93 5.146
27.71 11.92 11.53
14.16 0.579 19.7
12.35 -1.545 20.72
18.72 6.181 13.35
-18.59 0.4923 -10.46
-50.99 -4.965 -21.38
-50.18 -6.968 -17.65
-28.58 -3.109 -2.197
-2.063 4.175 3.852
-22.53 7.806 -3.566
-40.24 -5.759 6.918
-27.26 -8.609 17.6
-34.1 -11.09 17.75
-31.28 -5.364 10.3

On obtient les mêmes nouvelles coordonnées par ACP_from_scratch et par DUDI.ACP

On pouvais savoir cela en avance, car on a vue que les vecteurs propres étaient les mêmes, donc forcement, les nouvelles coordonnées aussi.

Qualité de la projection de l’individu Qik=1 CENTREE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = TRUE)
#On prend toute les composant pour calculer la qualité de projection.

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)

k <- 1

# Calculer la qualité de la projection Qik pour chaque individu
qualite_projections <- apply(nouvelles_coordonnees, 1, function(Ci) sum(Ci[1:k]^2) / sum(Ci^2))

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_projections)))
Table continues below
0.43 0.57 0.65 0.67 0.74 0.98 0.65 0.48 0.43 0.32 0.48
Table continues below
0.48 0.68 0.32 0.22 0.55 0.71 0.84 0.87 0.97 0.03 0.5
0.86 0.61 0.7 0.85

On voit des valeurs avec grande qualité de projection (comme la derniére) et d’autres médiocres (comme la 21 avec 0.03 car plus proche de l’origine notamment)

Qualité de la projection de l’individu Qik=2 CENTREE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = TRUE)
#On prend toute les composant pour calculer la qualité de projection.

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)

k <- 2 

# Calculer la qualité de la projection Qik pour chaque individu
qualite_projections <- apply(nouvelles_coordonnees, 1, function(Ci) sum(Ci[1:k]^2) / sum(Ci^2))

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_projections)))
Table continues below
0.64 0.61 0.69 0.69 0.75 0.99 0.69 0.67 0.64 0.98 0.61
Table continues below
0.71 0.8 0.32 0.23 0.61 0.71 0.84 0.88 0.98 0.15 0.56
0.87 0.67 0.77 0.88

En passant de Qik=1 à Qik=2, la qualité de projection s’ameliore. C’est logique car on a acces a plus de variance et d’inertie comme on l’explique juste apres.

Qualité de la projection de l’individu Qik=3 CENTREE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = TRUE)
#On prend toute les composant pour calculer la qualité de projection.

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)

k <- 3

# Calculer la qualité de la projection Qik pour chaque individu
qualite_projections <- apply(nouvelles_coordonnees, 1, function(Ci) sum(Ci[1:k]^2) / sum(Ci^2))

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_projections)))
Table continues below
0.99 0.71 0.99 0.94 0.86 1 0.99 0.99 0.99 1 0.86 0.73
Table continues below
0.92 0.93 0.85 0.9 0.93 0.99 0.99 0.98 0.26 0.57 0.9
0.92 0.96 0.97

Pour k=3, on a une qualité de projection meileur car beaucoup des individus sont bien plus proche de 1. C’est logique:

Lorsque on augmente le nombre de composantes principales (de k=2 à k=3, ici), on inclut plus d’axes pour représenter nos données. Chaque axe supplémentaire est capable de capturer une partie de la variance qui n’était pas capturée par les axes précédents. En conséquence, la somme des variances capturées par les composantes principales augmente, ce qui conduit à une amélioration de la qualité de projection pour les individus. En effet d’un autre point de vue, plus il y a de dimensions dans l’espace de projection, plus il est probable que les individus soient projetés de façon à conserver leur distance relative, et donc leur variance, par rapport à l’espace original des données.

En calculant le COS2 (ce qui est la même chose mathématiquement) k=2 CENTREE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = TRUE)
#On prend toute les composant pour calculer la qualité de projection.

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)

k <- 2 

# Calculer la qualité de la projection pour chaque individu (cos2)
qualite_cos2 <- apply(nouvelles_coordonnees, 1, function(Ci) {
  cos2_individual_axes <- Ci^2 / sum(Ci^2)
  sum(cos2_individual_axes[1:k])
})

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_cos2)))
Table continues below
0.64 0.61 0.69 0.69 0.75 0.99 0.69 0.67 0.64 0.98 0.61
Table continues below
0.71 0.8 0.32 0.23 0.61 0.71 0.84 0.88 0.98 0.15 0.56
0.87 0.67 0.77 0.88

On obtient les mêmes valeurs de qualitées de projecton qu’avec la formule de définiton

En calculant le COS2 (ce qui est la même chose mathématiquement) k=3

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)
k <- 3

# Calculer la qualité de la projection pour chaque individu (cos2)
qualite_cos2 <- apply(nouvelles_coordonnees, 1, function(Ci) {
  cos2_individual_axes <- Ci^2 / sum(Ci^2)
  sum(cos2_individual_axes[1:k])
})

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_cos2)))
Table continues below
0.99 0.71 0.99 0.94 0.86 1 0.99 0.99 0.99 1 0.86 0.73
Table continues below
0.92 0.93 0.85 0.9 0.93 0.99 0.99 0.98 0.26 0.57 0.9
0.92 0.96 0.97

On obtient les mêmes valeurs de qualitées de projecton qu’avec la formule de définiton

Comparaison des nouvelles coordonnees NORMEE

pander(as.matrix(result_dudi_normee$li))
Axis1 Axis2 Axis3 Axis4 Axis5 Axis6 Axis7 Axis8
1.8 0.2 2.2 0.92 0.57 -0.11 0.05 -0.0089
1.5 1.7 -0.6 0.04 1.3 0.31 -0.25 0.071
1.6 -2.2 -0.36 -0.074 0.19 0.39 -0.039 -0.039
1.7 0.25 -0.76 -1.4 -0.11 -0.16 -0.47 0.014
-1.1 0.93 -0.41 0.47 0.71 -0.18 -0.11 0.065
-1.9 -0.18 0.16 0.3 -0.15 0.37 0.1 -0.059
1.6 -2.2 -0.35 -0.073 0.19 0.4 -0.043 -0.046
1.4 0.94 1.3 0.44 0.67 -0.18 -0.024 0.022
1.7 0.2 2.2 0.92 0.56 -0.1 0.048 -0.0071
3.1 2.1 -2.4 2.4 -2 -0.034 0.12 0.016
1 3.1 0.32 -1.6 0.091 0.78 0.44 -0.067
0.96 -0.76 1.4 -0.7 -0.71 -1.2 0.16 0.012
1.7 -2.2 0.8 -0.51 -0.54 0.76 0.34 -0.16
0.92 -1.5 -1.2 -0.13 0.49 0.15 -0.23 0.026
0.78 -0.52 -1.6 -0.52 0.51 -0.19 -0.51 0.083
0.8 1.4 -0.47 -2.1 -0.54 -0.47 0.00083 0.016
-1.2 0.88 0.016 0.47 0.57 -0.26 0.088 0.047
-2.5 1.2 1.1 0.9 -0.15 0.13 -0.6 -0.037
-2.7 1.9 0.35 0.19 -0.07 0.47 -0.055 -0.044
-1.8 0.78 -0.3 -0.29 0.0075 0.14 0.49 -0.031
-0.48 -0.93 0.11 0.54 0.36 -0.94 0.36 -0.18
-1.1 -1.5 1.5 -0.13 -1.1 0.38 0.11 0.5
-1.9 -1.2 0.94 0.0032 -1.3 0.19 -0.65 -0.23
-1.8 -1.6 -1.6 0.64 0.67 -0.38 0.21 0.061
-2.1 -1.4 -1.7 0.24 0.38 0.3 0.38 -0.013
-2 0.7 -0.53 -1 -0.63 -0.54 0.083 -0.0069 
pander(as.matrix(result_normee$nouvelles_coordonnees))
1.8 0.2 2.2 0.92 0.57 -0.11 0.05 -0.0089
1.5 1.7 -0.6 0.04 1.3 0.31 -0.25 0.071
1.6 -2.2 -0.36 -0.074 0.19 0.39 -0.039 -0.039
1.7 0.25 -0.76 -1.4 -0.11 -0.16 -0.47 0.014
-1.1 0.93 -0.41 0.47 0.71 -0.18 -0.11 0.065
-1.9 -0.18 0.16 0.3 -0.15 0.37 0.1 -0.059
1.6 -2.2 -0.35 -0.073 0.19 0.4 -0.043 -0.046
1.4 0.94 1.3 0.44 0.67 -0.18 -0.024 0.022
1.7 0.2 2.2 0.92 0.56 -0.1 0.048 -0.0071
3.1 2.1 -2.4 2.4 -2 -0.034 0.12 0.016
1 3.1 0.32 -1.6 0.091 0.78 0.44 -0.067
0.96 -0.76 1.4 -0.7 -0.71 -1.2 0.16 0.012
1.7 -2.2 0.8 -0.51 -0.54 0.76 0.34 -0.16
0.92 -1.5 -1.2 -0.13 0.49 0.15 -0.23 0.026
0.78 -0.52 -1.6 -0.52 0.51 -0.19 -0.51 0.083
0.8 1.4 -0.47 -2.1 -0.54 -0.47 0.00083 0.016
-1.2 0.88 0.016 0.47 0.57 -0.26 0.088 0.047
-2.5 1.2 1.1 0.9 -0.15 0.13 -0.6 -0.037
-2.7 1.9 0.35 0.19 -0.07 0.47 -0.055 -0.044
-1.8 0.78 -0.3 -0.29 0.0075 0.14 0.49 -0.031
-0.48 -0.93 0.11 0.54 0.36 -0.94 0.36 -0.18
-1.1 -1.5 1.5 -0.13 -1.1 0.38 0.11 0.5
-1.9 -1.2 0.94 0.0032 -1.3 0.19 -0.65 -0.23
-1.8 -1.6 -1.6 0.64 0.67 -0.38 0.21 0.061
-2.1 -1.4 -1.7 0.24 0.38 0.3 0.38 -0.013
-2 0.7 -0.53 -1 -0.63 -0.54 0.083 -0.0069

Qualité de la projection de l’individu Qik=2 NORMEE

result_centree <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = FALSE)
result_normee <- acp_from_scratch(data_PDE19, nombre_composants=NULL, reduire = TRUE)
#On prend toute les composant pour calculer la qualité de projection.

nouvelles_coordonnees <- as.matrix(result_normee$nouvelles_coordonnees)


k <- 2 

# Calculer la qualité de la projection Qik pour chaque individu
qualite_projections <- apply(nouvelles_coordonnees, 1, function(Ci) sum(Ci[1:k]^2) / sum(Ci^2))

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_projections)))
Table continues below
0.34 0.71 0.96 0.5 0.69 0.93 0.96 0.55 0.34 0.48 0.76
Table continues below
0.25 0.8 0.63 0.2 0.33 0.78 0.77 0.97 0.9 0.43 0.47 0.62
0.61 0.65 0.7

Qualité de la projection de l’individu Qik=3 NORMEE

nouvelles_coordonnees <- as.matrix(result_normee$nouvelles_coordonnees)

k <- 3

# Calculer la qualité de la projection Qik pour chaque individu
qualite_projections <- apply(nouvelles_coordonnees, 1, function(Ci) sum(Ci[1:k]^2) / sum(Ci^2))

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_projections)))
Table continues below
0.87 0.75 0.97 0.6 0.75 0.93 0.97 0.87 0.87 0.67 0.77
Table continues below
0.57 0.87 0.93 0.81 0.36 0.78 0.88 0.98 0.92 0.43 0.79
0.73 0.89 0.95 0.74

Même commentaire que pour CENTREE

En calculant le COS2 (ce qui est la même chose mathématiquement) k=2 NORMEE

nouvelles_coordonnees <- as.matrix(result_normee$nouvelles_coordonnees)
k <- 2 

# Calculer la qualité de la projection pour chaque individu (cos2)
qualite_cos2 <- apply(nouvelles_coordonnees, 1, function(Ci) {
  cos2_individual_axes <- Ci^2 / sum(Ci^2)
  sum(cos2_individual_axes[1:k])
})

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_cos2)))
Table continues below
0.34 0.71 0.96 0.5 0.69 0.93 0.96 0.55 0.34 0.48 0.76
Table continues below
0.25 0.8 0.63 0.2 0.33 0.78 0.77 0.97 0.9 0.43 0.47 0.62
0.61 0.65 0.7

En calculant le COS2 (ce qui est la même chose mathématiquement) k=3 NORMEE

nouvelles_coordonnees <- as.matrix(result_normee$nouvelles_coordonnees)
k <- 3

# Calculer la qualité de la projection pour chaque individu (cos2)
qualite_cos2 <- apply(nouvelles_coordonnees, 1, function(Ci) {
  cos2_individual_axes <- Ci^2 / sum(Ci^2)
  sum(cos2_individual_axes[1:k])
})

# Afficher les résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(t(as.matrix(qualite_cos2)))
Table continues below
0.87 0.75 0.97 0.6 0.75 0.93 0.97 0.87 0.87 0.67 0.77
Table continues below
0.57 0.87 0.93 0.81 0.36 0.78 0.88 0.98 0.92 0.43 0.79
0.73 0.89 0.95 0.74

Meme resultat entre fomule du COS2 et celle du cours pour les diffenrents k

Même commentaire que précédemment pour CENTREE

5. Contribution de l’individu i à l’inertie de l’axe factoriel j CENTREE et NORMEE

Contribution cas CENTREE

nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)

valeurs_propres <- result_centree$valeurs_propres 

# Nombre total d'individus
n <- nrow(nouvelles_coordonnees)

# Calculer la contribution de chaque individu à l'inertie de chaque axe
contributions <- sweep(nouvelles_coordonnees^2, 2, valeurs_propres, FUN="/") / n

# Affichage des résultats avec deux chiffres après la virgule
panderOptions('digits', 2)
pander(contributions)
0.036 0.044 0.11 0.0042 0.024 0.013 0.0057 0.0033
## On revi endra sur ses contri butions ap rés.
# Contribu tion cas N ORMEE
```r nouvelles_ coordonnee s <- as.ma trix(resul t_normee$n ouvelles_c oordonnees )
valeurs_pr opres <- r esult_norm ee$valeurs _propres
# Nombre t n <- nrow( otal d’ind nouvelles_ ividus coordonnee s)
# Calculer contributi la contri ons <- swe bution de ep(nouvell chaque ind es_coordon ividu à l’ nees^2, 2, inertie de valeurs_p chaque ax ropres, FU e N=“/”) / n
# Affichag panderOpti pander(con ``` e des résu ons(’digit tributions ltats avec s’, 2) ) deux chif fres après la virgul e

0.041 0.00072 0.13 0.041 0.024 0.002 0.0011 2e-04

0.03 0.054 0.0099 7.6e-05 0.13 0.017 0.027 0.013

0.033 0.088 0.0036 0.00026 0.0027 0.028 0.00066 0.0039

0.037 0.0011 0.016 0.097 0.00094 0.0046 0.093 0.00049

0.017 0.016 0.0047 0.011 0.038 0.0057 0.0056 0.01

0.047 6e-04 0.00069 0.0044 0.0017 0.024 0.0044 0.0088

0.033 0.088 0.0034 0.00025 0.0026 0.028 8e-04 0.0053

0.028 0.016 0.047 0.0094 0.034 0.0056 0.00024 0.0012

0.041 7e-04 0.13 0.041 0.024 0.0018 0.001 0.00013

0.13 0.082 0.16 0.28 0.3 2e-04 0.0066 0.00064

0.014 0.18 0.0028 0.12 0.00062 0.11 0.082 0.011

0.012 0.011 0.051 0.024 0.038 0.28 0.011 0.00033

0.039 0.09 0.018 0.013 0.022 0.1 0.051 0.06

0.011 0.042 0.042 0.00077 0.018 0.0042 0.024 0.0017

0.0082 0.005 0.074 0.013 0.02 0.0064 0.11 0.017

0.0085 0.034 0.0062 0.21 0.022 0.039 2.9e-07 6e-04

0.018 0.014 7.5e-06 0.01 0.024 0.012 0.0033 0.0055

0.086 0.026 0.034 0.039 0.0017 0.0029 0.15 0.0033

0.099 0.067 0.0033 0.0018 0.00037 0.04 0.0013 0.0048

0.046 0.011 0.0024 0.004 4.2e-06 0.0036 0.1 0.0024

0.0031 0.016 0.00037 0.014 0.0099 0.16 0.054 0.084

0.016 0.042 0.066 0.00085 0.085 0.026 0.0056 0.62

0.046 0.028 0.025 5e-07 0.13 0.0066 0.18 0.13

0.041 0.049 0.076 0.02 0.034 0.026 0.019 0.0092

0.057 0.034 0.081 0.0027 0.011 0.016 0.061 0.00041

0.056 0.0089 0.008 0.048 0.03 0.053 0.0029 0.00012 ——– ——— ——— ——— ——— ——– ——— ———

Heatmap qui affiche les individus rangés par leur contribution globale à l’inertie des axes cas CENTREE puis cas NORMEE

# Utilisez les variables données
nouvelles_coordonnees <- as.matrix(result_centree$nouvelles_coordonnees)
valeurs_propres <- result_centree$valeurs_propres
n <- nrow(nouvelles_coordonnees)

# Calculer la contribution de chaque individu à l'inertie de chaque axe
# Nous nous assurons que le résultat est une matrice
contributions <- sweep(nouvelles_coordonnees^2, 2, valeurs_propres, FUN="/") / n

# Transformer en data frame pour le traitement
contributions_df <- as.data.frame(contributions)

# Calculer la contribution totale pour chaque individu
contributions_df$Total <- rowSums(contributions_df)

# Trier le data frame par la contribution totale de manière décroissante
contributions_df <- contributions_df[order(-contributions_df$Total), ]

# Préparer les données pour la heatmap (sans la colonne Total)
contributions_for_heatmap <- contributions_df[, -ncol(contributions_df)]


# Utilisez les variables données
nouvelles_coordonnees <- as.matrix(result_normee$nouvelles_coordonnees)
valeurs_propres <- result_normee$valeurs_propres
n <- nrow(nouvelles_coordonnees)

# Calculer la contribution de chaque individu à l'inertie de chaque axe
# Nous nous assurons que le résultat est une matrice
contributions <- sweep(nouvelles_coordonnees^2, 2, valeurs_propres, FUN="/") / n

# Transformer en data frame pour le traitement
contributions_df <- as.data.frame(contributions)

# Calculer la contribution totale pour chaque individu
contributions_df$Total <- rowSums(contributions_df)

# Trier le data frame par la contribution totale de manière décroissante
contributions_df <- contributions_df[order(-contributions_df$Total), ]

# Préparer les données pour la heatmap (sans la colonne Total)
contributions_normee_for_heatmap <- contributions_df[, -ncol(contributions_df)]





# Charger la librairie 'pheatmap'
if (!requireNamespace("pheatmap", quietly = TRUE)) {
  install.packages("pheatmap")
}
library(pheatmap)


# Créer la heatmap pour les données CENTRÉES
pheatmap(contributions_for_heatmap, cluster_rows = FALSE, show_rownames = TRUE,
         cluster_cols = FALSE, display_numbers = TRUE,
         color = colorRampPalette(c("blue", "white", "red"))(100),
         main = "Contributions (Centrées)")

# La heatmap est affichée sans regroupement des lignes ou des colonnes,
# avec les noms des lignes et les nombres affichés.

La CP 2 capture la variance de l’individu 10 principalement pour son inertie.

ici, la somme des colonnes ne vaut pas 1 a causes des arrondis (2 chiffres) mais sinon en vrai si ( on le calcul plus tard)

# Créer la heatmap pour les données NORMALISÉES
pheatmap(contributions_normee_for_heatmap, cluster_rows = FALSE, show_rownames = TRUE,
         cluster_cols = FALSE, display_numbers = TRUE,
         color = colorRampPalette(c("blue", "white", "red"))(100),
         main = "Contributions (Normalisées)")

En NORMEE, la CP 2 ne capture plus la variance du 10 autant, car la variance du 10 est mise a la meme echelle que les autres individus.

En NORMEE, la variance du 22, mise au meme niveau que les autres, est capturé grandement par le CP8, ce qui n’était pas le cas en CENTREE :

Calculer la somme des contributions pour chaque axe (Est ce egale à 1 ?) CENTREE

# Calculer la somme des contributions pour chaque axe
sum_contributions <- colSums(contributions)

# Afficher les sommes des contributions, cela devrait être égal ou très proche de 1 pour chaque axe
pander(sum_contributions)

1, 1, 1, 1, 1, 1, 1 and 1

Calculer la somme des contributions pour chaque axe (Est ce egale à 1 ?) NORMEE

# Calculer la somme des contributions pour chaque axe
sum_contributions <- colSums(contributions)

# Afficher les sommes des contributions, cela devrait être égal ou très proche de 1 pour chaque axe
pander(sum_contributions)

1, 1, 1, 1, 1, 1, 1 and 1

6. Vérification avec la fonction dudi.pca CENTREE

result_dudi_centree <- dudi.pca(data_PDE19,center = TRUE, scale = FALSE, nf = 8, scannf = FALSE)
pander(as.matrix(result_dudi_centree$c1))
  CS1 CS2 CS3 CS4 CS5 CS6 CS7 CS8
X1 0.61 0.46 -0.36 0.3 0.23 0.0061 -0.39 0.017
X2 -0.05 -0.15 0.19 -0.56 0.6 -0.011 -0.5 0.033
X3 -0.01 -0.017 -0.023 -0.1 -0.31 0.64 -0.23 0.66
X4 0.0098 0.024 0.069 0.087 0.14 -0.62 0.15 0.75
X5 0.28 -0.086 0.011 -0.39 -0.67 -0.41 -0.37 -0.1
X6 -0.061 0.049 0.76 0.51 -0.079 -0.018 -0.39 -0.052
X7 -0.59 -0.2 -0.5 0.31 -0.044 -0.17 -0.48 -0.01
X8 -0.45 0.85 0.065 -0.26 -0.1 -0.055 -0.01 -0.021 
pander(as.matrix(result_centree$vecteurs_propres))
0.61 0.46 -0.36 0.3 0.23 0.0061 -0.39 0.017
-0.05 -0.15 0.19 -0.56 0.6 -0.011 -0.5 0.033
-0.01 -0.017 -0.023 -0.1 -0.31 0.64 -0.23 0.66
0.0098 0.024 0.069 0.087 0.14 -0.62 0.15 0.75
0.28 -0.086 0.011 -0.39 -0.67 -0.41 -0.37 -0.1
-0.061 0.049 0.76 0.51 -0.079 -0.018 -0.39 -0.052
-0.59 -0.2 -0.5 0.31 -0.044 -0.17 -0.48 -0.01
-0.45 0.85 0.065 -0.26 -0.1 -0.055 -0.01 -0.021

Les Vecteurs propres pour les 2 fonctions sont les mêmes, donc les plans factoriels sont aussi les mêmes: notre premier plan factoriel est donc correct en comparant avec la fonction R qui résout l’ACP dudi.pca()

6. Vérification avec la fonction dudi.pca NORMEE

result_dudi_normee <- dudi.pca(data_PDE19,center = TRUE, scale = TRUE, nf = 8, scannf = FALSE)
pander(as.matrix(result_dudi_normee$c1))
  CS1 CS2 CS3 CS4 CS5 CS6 CS7 CS8
X1 0.51 0.025 0.36 -0.086 0.24 -0.2 0.43 0.56
X2 -0.15 -0.061 -0.73 0.2 0.56 -0.058 0.21 0.22
X3 -0.098 0.54 -0.19 -0.57 -0.12 0.43 0.38 0.0099
X4 0.11 -0.63 0.051 0.094 -0.023 0.72 0.26 -0.018
X5 0.53 0.16 -0.24 -0.071 0.064 0.34 -0.67 0.27
X6 -0.095 -0.49 -0.29 -0.55 -0.39 -0.3 -0.087 0.33
X7 -0.52 0.16 0.16 0.33 -0.23 0.21 -0.11 0.68
X8 -0.37 -0.14 0.37 -0.45 0.64 0.094 -0.29 0.017 
pander(as.matrix(result_normee$vecteurs_propres))
0.51 0.025 0.36 -0.086 0.24 -0.2 0.43 0.56
-0.15 -0.061 -0.73 0.2 0.56 -0.058 0.21 0.22
-0.098 0.54 -0.19 -0.57 -0.12 0.43 0.38 0.0099
0.11 -0.63 0.051 0.094 -0.023 0.72 0.26 -0.018
0.53 0.16 -0.24 -0.071 0.064 0.34 -0.67 0.27
-0.095 -0.49 -0.29 -0.55 -0.39 -0.3 -0.087 0.33
-0.52 0.16 0.16 0.33 -0.23 0.21 -0.11 0.68
-0.37 -0.14 0.37 -0.45 0.64 0.094 -0.29 0.017

Même commentaire : Les Vecteurs propres pour les 2 fonctions sont les mêmes, donc les plans factoriels sont aussi les mêmes: notre premier plan factoriel est donc correct en comparant avec la fonction R qui résout l’ACP dudi.pca()

7. Représentation graphique CP1 vs CP2 CENTREE

# Graphique pour CP1 vs CP2
plot(result_centree$nouvelles_coordonnees[,1], result_centree$nouvelles_coordonnees[,2], 
     xlab="CP1", ylab="CP2", main="Premier vs Deuxième axe principal CENTREE",
     type="n", xlim=c(min(c(result_centree$nouvelles_coordonnees[,1], result_dudi_centree$li[,1])),
                      max(c(result_centree$nouvelles_coordonnees[,1], result_dudi_centree$li[,1]))),
     ylim=c(min(c(result_centree$nouvelles_coordonnees[,2], result_dudi_centree$li[,2])),
            max(c(result_centree$nouvelles_coordonnees[,2], result_dudi_centree$li[,2]))))
points(result_centree$nouvelles_coordonnees[,1], result_centree$nouvelles_coordonnees[,2], col="blue", pch=16)
points(result_dudi_centree$li[,1], result_dudi_centree$li[,2], col="red", pch=17)
legend(x = 0.6, y = 0.5, legend=c("pca_from_scratch", "dudi.pca"),
       col=c("blue", "red"), pch=c(16, 17), cex=0.8, bty="n")

Les individus se superposent exactement entre ACP FROM SCRATCH et DUDI.APC, on obtient les memes résultats pour l’ACP

Représentation graphique CP1 vs CP3 CENTREE

# Graphique pour CP1 vs CP3
plot(result_centree$nouvelles_coordonnees[,1], result_centree$nouvelles_coordonnees[,3], 
     xlab="CP1", ylab="CP3", main="Premier vs Troisième axe principal CENTREE",
     type="n", xlim=c(min(c(result_centree$nouvelles_coordonnees[,1], result_dudi_centree$li[,1])),
                      max(c(result_centree$nouvelles_coordonnees[,1], result_dudi_centree$li[,1]))),
     ylim=c(min(c(result_centree$nouvelles_coordonnees[,3], result_dudi_centree$li[,3])),
            max(c(result_centree$nouvelles_coordonnees[,3], result_dudi_centree$li[,3]))))
points(result_centree$nouvelles_coordonnees[,1], result_centree$nouvelles_coordonnees[,3], col="blue", pch=16)
points(result_dudi_centree$li[,1], result_dudi_centree$li[,3], col="red", pch=17)
legend(x = 0.6, y = 0.5, legend=c("pca_from_scratch", "dudi.pca"),
       col=c("blue", "red"), pch=c(16, 17), cex=0.8, bty="n")

Représentation graphique CP1 vs CP2 NORMEE

# Graphique pour CP1 vs CP2
plot(result_normee$nouvelles_coordonnees[,1], result_normee$nouvelles_coordonnees[,2], 
     xlab="CP1", ylab="CP2", main="Premier vs Deuxième axe principal NORMEE",
     type="n", xlim=c(min(c(result_normee$nouvelles_coordonnees[,1], result_dudi_normee$li[,1])),
                      max(c(result_normee$nouvelles_coordonnees[,1], result_dudi_normee$li[,1]))),
     ylim=c(min(c(result_normee$nouvelles_coordonnees[,2], result_dudi_normee$li[,2])),
            max(c(result_normee$nouvelles_coordonnees[,2], result_dudi_normee$li[,2]))))
points(result_normee$nouvelles_coordonnees[,1], result_normee$nouvelles_coordonnees[,2], col="blue", pch=16)
points(result_dudi_normee$li[,1], result_dudi_normee$li[,2], col="red", pch=17)
legend(x = 0.6, y = 0.5, legend=c("pca_from_scratch", "dudi.pca"),
       col=c("blue", "red"), pch=c(16, 17), cex=0.8, bty="n")

7. Représentation graphique CP1 vs CP3 NORMEE

# Graphique pour CP1 vs CP3
plot(result_normee$nouvelles_coordonnees[,1], result_normee$nouvelles_coordonnees[,3], 
     xlab="CP1", ylab="CP3", main="Premier vs Troisième axe principal NORMEE",
     type="n", xlim=c(min(c(result_normee$nouvelles_coordonnees[,1], result_dudi_normee$li[,1])),
                      max(c(result_normee$nouvelles_coordonnees[,1], result_dudi_normee$li[,1]))),
     ylim=c(min(c(result_normee$nouvelles_coordonnees[,3], result_dudi_normee$li[,3])),
            max(c(result_normee$nouvelles_coordonnees[,3], result_dudi_normee$li[,3]))))
points(result_normee$nouvelles_coordonnees[,1], result_normee$nouvelles_coordonnees[,3], col="blue", pch=16)
points(result_dudi_normee$li[,1], result_dudi_normee$li[,3], col="red", pch=17)
legend(x = 0.6, y = 0.5, legend=c("pca_from_scratch", "dudi.pca"),
       col=c("blue", "red"), pch=c(16, 17), cex=0.8, bty="n")

#CCL PARTIE 2 - QUALITE DE ACP

Il semble que pour nos données k=3 semble être la meilleur solution (Regle de Kaiser - Guttman + les qualites des projections des individus proche de 1 pour k=3, bine plus que k=2). Mais cela dependra de notre but : representation graphique, reduction de dimension…