TP_MIXTE

Fonction AFD FROM SCRATCH

AFD<-function(X,y){

n<-nrow(X)
p <- ncol(X)
K<-length(levels(factor(y)))
nk<-as.vector(table(y))
names(nk) <- levels(y)
pk<-nk/n

Xk <-list()
Xk <- split(X,y)

V<-var(X)*(n-1)/n
R<-cor(X)

g<-matrix(apply(X,2,mean),ncol=1)
rownames(g) <- colnames(X)

Vk<-list()
Rk<-list()
gk<-list()
for (k in 1:K){
    gk[[k]]<-matrix(apply(Xk[[k]],2,mean),ncol=1)
    rownames(gk[[k]]) <- colnames(X)
    Vk[[k]]<-var(Xk[[k]])*(nk[k]-1)/nk[k]
    Rk[[k]]<-cor(Xk[[k]])
}

names(Vk) <- levels(y)
names(Rk) <- levels(y)
names(gk) <- levels(y)

Xcent<-X-matrix(rep(1,n),ncol=1)%*%t(g)
W<-matrix(0,nrow=p,ncol=p)
B<-matrix(0,nrow=p,ncol=p)
for (k in 1:K){
    W<-W+pk[k]*Vk[[k]]
    B<-B+pk[k]*(gk[[k]]-g)%*%t(gk[[k]]-g)
}

# Calcul des FD :

res<-eigen(solve(V)%*%B)

eig <- Re(res$values[1:(K-1)])


UU<-Re(res$vectors[,1:(K-1)])
normes <- sqrt(diag(t(UU)%*%V%*%UU))

if (K>2) {
U <- sweep(UU,2,normes,"/")
} else {
U <- UU/normes
}

if (K>2) {
    rownames(U) <- colnames(X)
    colnames(U)<-paste("u",1:ncol(U),sep="")
} else
{
    names(U) <- colnames(X)

}

# Calcul des VD :
S<-as.matrix(Xcent)%*%U
if (K>2) {
    colnames(S) <-paste("s",1:ncol(S),sep="")
    rownames(S)<-rownames(X)
} else names(S)<-rownames(X)




list(eig=eig,U=U,S=S,nk=nk,K=K,y=y,X=X,Xk=Xk,W=W,B=B,g=data.frame(g=g),gk=data.frame(gk),V=V,R=R,Vk=Vk,Rk=Rk)
}

Fonction qui plot nos resulats AFD

plotAFD<-function(res)
  {
dim = c(1)
nbaxes <- length(res$eig)
if ((length(dim) > 1) && (nbaxes >1)) {
min.x<-min(res$S[,dim[1]])
max.x<-max(res$S[,dim[1]])
min.y<-min(res$S[,dim[2]])
max.y<-max(res$S[,dim[2]])
dim1 <- dim[1]
dim2 <- dim[2]
quali <- as.factor(res$y)
plot(res$S[,dim],xlab=paste("Dim",dim1),ylab=paste("Dim",dim2), xlim=c(min.x,max.x),ylim=c(min.y,max.y),pch=" ",main="Individus")
abline(h = 0, lty = 2,)
abline(v = 0, lty = 2)
legend("topleft",legend = levels(quali), text.col = c(1:length(levels(quali))),cex=0.8)
text(res$S[,dim],labels=rownames(res$S),col=as.numeric(quali))

mat.corr <- res$mat.corr
xlim <- c(-1, 1)*1.3
ylim <- c(-1, 1)*1.3
plot(0, 0, type="n",xlab=paste("Dim",dim1),ylab=paste("Dim",dim2), xlim = xlim, ylim = ylim, main="Variables")
x.cercle <- seq(-1, 1, by = 0.01)
y.cercle <- sqrt(1 - x.cercle^2)
lines(x.cercle, y = y.cercle)
lines(x.cercle, y = -y.cercle)
abline(v = 0, lty = 2)
abline(h = 0, lty = 2)
for (j in 1:nrow(mat.corr)) {
        arrows(0, 0, mat.corr[j,dim1], mat.corr[j,dim2], length = 0.1, angle = 15, code = 2)
        if (abs(mat.corr[j,dim1]) > abs(mat.corr[j,dim2])) {
                        if (mat.corr[j,dim1] >= 0) pos <- 4
                else pos <- 2
             } else {
                        if (mat.corr[j,dim2] >= 0) pos <- 3
                        else pos <- 1
                    }
              text(mat.corr[j,dim1],mat.corr[j,dim2],labels = rownames(mat.corr)[j], pos = pos)
}
} else {
    if (nbaxes==1) {
        quali <- as.factor(res$y)
        plot(res$S,rep(0,length(res$S)),xlab="Axe 1",ylab="",col=as.numeric(quali))
        legend("topleft",legend = levels(quali), text.col = c(1:length(levels(quali))),cex=0.8)
    } else {
        quali <- as.factor(res$y)
        plot(res$S[,dim],rep(0,length(res$S[,dim])),xlab=paste("Axe",dim),ylab="",col=as.numeric(quali))
        legend("topleft",legend = levels(quali), text.col = c(1:length(levels(quali))),cex=0.8)

    }
}   
}

Fonction acp_from_scratch du TD ACP

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)
}

Importer les données

library(readr)
# Importer les données de l'énoncé
data <- read.csv("chienloup.csv", sep=";")

# Il y a t il des NA ? NON
#print(sum(is.na(data)))

head(data)

##                SPE  LCB  LSM LBM  LP  LM LAM GENRE
## 1       BULL-DOG 1 1290  640 950 175 112 138 CHIEN
## 2       BULL-DOG 2 1540  740 760 200 142 165 CHIEN
## 3            BOXER 1580  710 710 167 125 133 CHIEN
## 4    SAINT-BERNARD 2200 1110 880 225 154 180 CHIEN
## 5      BULL-MASSIF 1900  930 780 197 132 140 CHIEN
## 6 DOGUE ALLEMAND 1 2410 1190 870 210 147 183 CHIEN

#print(dim(data))

Question 1

On NORMALISE les DATA

Utilisation de notre fonction AFD déjà utilisé dans le TP MIXTE.

data <- as.data.frame(data)
data_numeric <- data[,2:7]
y <- data[,8]
data_numeric <- as.data.frame(centrer_reduire(as.matrix(data_numeric)))


res <- AFD(data_numeric, y)

##############################################################8

2 groupes donc au plus 1 axes discriminant !

##############################################################8

res$nk #nombre d'individus dans chaque classe

## [1] 30 12

##############################################################8

Il y a 30 individus chien contre 12 individus loup pour les data.

##############################################################8

Afficher les matrices V, B et W obtenues par calcul dans le code du début:

head(res$V)

##           LCB       LSM       LBM        LP        LM       LAM
## LCB 1.0000000 0.9608048 0.3486069 0.6145106 0.7196386 0.5877091
## LSM 0.9608048 1.0000000 0.2001415 0.6605947 0.7356318 0.5948046
## LBM 0.3486069 0.2001415 1.0000000 0.3698780 0.3501861 0.3547371
## LP  0.6145106 0.6605947 0.3698780 1.0000000 0.8933906 0.7628560
## LM  0.7196386 0.7356318 0.3501861 0.8933906 1.0000000 0.7894591
## LAM 0.5877091 0.5948046 0.3547371 0.7628560 0.7894591 1.0000000

head(res$W)

##           LCB       LSM       LBM        LP        LM       LAM
## LCB 0.9399806 0.8820546 0.2998707 0.4101504 0.5486463 0.4321908
## LSM 0.8820546 0.8966734 0.1361957 0.3924578 0.5112761 0.3907520
## LBM 0.2998707 0.1361957 0.9604259 0.2039360 0.2113390 0.2284550
## LP  0.4101504 0.3924578 0.2039360 0.3041730 0.3111779 0.2333309
## LM  0.5486463 0.5112761 0.2113390 0.3111779 0.5128508 0.3463946
## LAM 0.4321908 0.3907520 0.2284550 0.2333309 0.3463946 0.5970308

head(res$B)

##            LCB        LSM        LBM        LP        LM       LAM
## LCB 0.06001935 0.07875020 0.04873617 0.2043602 0.1709923 0.1555183
## LSM 0.07875020 0.10332658 0.06394577 0.2681370 0.2243557 0.2040525
## LBM 0.04873617 0.06394577 0.03957415 0.1659420 0.1388471 0.1262821
## LP  0.20436019 0.26813696 0.16594205 0.6958270 0.5822127 0.5295251
## LM  0.17099234 0.22435566 0.13884710 0.5822127 0.4871492 0.4430645
## LAM 0.15551833 0.20405252 0.12628208 0.5295251 0.4430645 0.4029692

ACP sur matrice des correlations

library(FactoMineR)
data2 <- data_numeric
data2$GENRE <- data$GENRE

pca<-PCA(data2,quali.sup=7,graph=FALSE) 
plot(pca,habillage=7)

plot(pca,choix="var")

plot(pca,invisible="ind")

##############################################################8

On voit bien que nos 2 classes sont sur quasi la même dimension et de signe contraire, on a 1 seul axe discriminant en AFD d’ailleurs. On peut en déduire que pour notre AFD on aura les classes chien d’un côté et celles loup de l’autre sur une droite 1D car 1 seul axe car 2 classes.

##############################################################8

La valeur propres qu’on va utiliser avec son vecteur propre associée en AFD:

res$eig # valeur propre

## [1] 0.8235635

res$U # vecteur propre

##          LCB          LSM          LBM           LP           LM          LAM 
##  0.520342622 -0.006455009  0.079745247 -1.062982533 -0.117579660 -0.126031773

On utilise notre fonction plotAFD pour representer nos 2 classes TRAIN

plotAFD(res)

1er facteurs discriminants

u1<-res$U #1er facteurs discriminants
print(u1)

##          LCB          LSM          LBM           LP           LM          LAM 
##  0.520342622 -0.006455009  0.079745247 -1.062982533 -0.117579660 -0.126031773

Coordonnéees (1D) des centres des groupes H et L en AFD /// DATA TRAIN

gLOUP <- res$gk[,1]
gCHIEN <- res$gk[,2]
t(gLOUP)%*%u1

##           [,1]
## [1,] 0.5739559

t(gCHIEN)%*%u1

##          [,1]
## [1,] -1.43489

Vérification des coordonnées des 2 centres: On obtient bien les mêmes resultats !

S1 <- res$S[,1] # VD
#print(S1)
Sk <- split(S1,y)
lapply(Sk,mean)

## $CHIEN
## [1] 0.5739559
## 
## $LOUP
## [1] -1.43489

On calcul le seuil entre les 2 classes :

on est en 1D donc le seuil entre L et H c’est simplement (gH + gL)/2

S1 <- res$S
#print(dim(S1))
#print(S1)
Sk <- split(S1,y)
#print(dim(Sk))
#print(Sk)
smoy <- lapply(Sk,mean)
#print(smoy)
seuil1 <- (as.numeric(smoy$CHIEN)+as.numeric(smoy$LOUP))/2 #seuil entre L et H
print(seuil1)

## [1] -0.4304669

Prédition de nos DATA avec ce seuil :

predict <- cut(S1,breaks=c(-10,seuil1,10),labels=c("LOUP","CHIEN"))
y <- factor(y, levels = c("LOUP", "CHIEN"))
conf_matrix <- table(y,predict)

pander(conf_matrix)

	LOUP	CHIEN
LOUP	12	0
CHIEN	1	29

Calcul des métriques de performance DATA TEST

accuracy <- sum(diag(conf_matrix)) / sum(conf_matrix)
sensitivity <- diag(conf_matrix) / rowSums(conf_matrix)
specificity <- diag(conf_matrix) / colSums(conf_matrix)
precision <- diag(conf_matrix) / colSums(conf_matrix)
recall <- sensitivity
F1 <- 2 * (precision * recall) / (precision + recall)

# Data frame pour stocker les métriques avec descriptions
performance_metrics <- data.frame(
  Metric = c("Accuracy", "Sensitivity", "Specificity", "Precision", "Recall", "F1 Score"),
  Value = c(accuracy, mean(sensitivity), mean(specificity), mean(precision), mean(recall), mean(F1)),
  Description = c(
    "Proportion de toutes les prédictions correctes",
    "Proportion de positifs réels correctement identifiés",
    "Proportion de négatifs réels correctement identifiés",
    "Proportion de prédictions positives correctes",
    "Identique à la sensibilité",
    "Moyenne harmonique de la précision et du rappel"
  )
)

pander(performance_metrics)

Metric	Value	Description
Accuracy	0.9762	Proportion de toutes les prédictions correctes
Sensitivity	0.9833	Proportion de positifs réels correctement identifiés
Specificity	0.9615	Proportion de négatifs réels correctement identifiés
Precision	0.9615	Proportion de prédictions positives correctes
Recall	0.9833	Identique à la sensibilité
F1 Score	0.9715	Moyenne harmonique de la précision et du rappel

Voila pour notre fonction AFD, on peut maintenant continuer la question 2.

CAS CENTREE

data_numeric_centree <- as.data.frame(centrage(as.matrix(data_numeric)))
res_centree <- AFD(data_numeric_centree, y)

V_centree <- res_centree$V
B_centree <- res_centree$B
mat_centree <- solve(V_centree) %*% B_centree
print(dim(mat_centree))

## [1] 6 6

head(mat_centree)

##              LCB          LSM          LBM           LP           LM
## LCB -0.115686741 -0.151790283 -0.093938524 -0.393902367 -0.329586148
## LSM  0.001435129  0.001883005  0.001165336  0.004886479  0.004088616
## LBM -0.017729602 -0.023262660 -0.014396573 -0.060367612 -0.050510813
## LP   0.236330793  0.310084957  0.191902424  0.804683910  0.673295447
## LM   0.026141252  0.034299420  0.021226898  0.089008481  0.074475212
## LAM  0.028020394  0.036765004  0.022752775  0.095406779  0.079828799
##              LAM
## LCB -0.299760138
## LSM  0.003718616
## LBM -0.045939820
## LP   0.612365348
## LM   0.067735553
## LAM  0.072604665

La matrice V-1B est de dimension 6x6.

eig_centree <- eigen(mat_centree)
values_centree <- eig_centree$values
print(values_centree)

## [1]  8.235635e-01  6.208968e-16 -4.689864e-16  5.808309e-17 -5.743591e-17
## [6]  3.608047e-17

vectors_centree <- eig_centree$vectors
print(vectors_centree)

##              [,1]         [,2]        [,3]        [,4]        [,5]        [,6]
## [1,]  0.434101717  0.216034035 -0.17298133  0.81516105  0.64287325 -0.84146247
## [2,] -0.005385164 -0.011968038  0.89970000  0.29790972  0.05658188 -0.23581918
## [3,]  0.066528374 -0.008443295  0.26103446  0.27676360 -0.72804174 -0.34693484
## [4,] -0.886805199 -0.643959906 -0.12701437 -0.40691682 -0.17756615  0.33109279
## [5,] -0.098092161  0.732972781 -0.02605426 -0.05355258  0.03774964  0.06390074
## [6,] -0.105143432 -0.034370263 -0.27507620  0.04141244  0.14322333  0.04754677

CAS NORMEE

data_numeric_normee <- as.data.frame(centrer_reduire(as.matrix(data_numeric)))
res_normee <- AFD(data_numeric_normee, y)

V_normee <- res_normee$V
B_normee <- res_normee$B
mat_normee <- solve(V_normee) %*% B_normee
print(dim(mat_normee))

## [1] 6 6

head(mat_normee)

##              LCB          LSM          LBM           LP           LM
## LCB -0.115686741 -0.151790283 -0.093938524 -0.393902367 -0.329586148
## LSM  0.001435129  0.001883005  0.001165336  0.004886479  0.004088616
## LBM -0.017729602 -0.023262660 -0.014396573 -0.060367612 -0.050510813
## LP   0.236330793  0.310084957  0.191902424  0.804683910  0.673295447
## LM   0.026141252  0.034299420  0.021226898  0.089008481  0.074475212
## LAM  0.028020394  0.036765004  0.022752775  0.095406779  0.079828799
##              LAM
## LCB -0.299760138
## LSM  0.003718616
## LBM -0.045939820
## LP   0.612365348
## LM   0.067735553
## LAM  0.072604665

La matrice V-1B est de dimension 6x6.

eig_normee <- eigen(mat_normee)
values_normee <- eig_normee$values
print(values_normee)

## [1]  8.235635e-01+0.000000e+00i  1.099870e-15+0.000000e+00i
## [3] -2.256959e-16+0.000000e+00i  1.172102e-16+0.000000e+00i
## [5] -6.190151e-17+4.202055e-17i -6.190151e-17-4.202055e-17i

vectors_normee <- eig_normee$vectors
print(vectors_normee)

##                 [,1]           [,2]          [,3]           [,4]
## [1,]  0.434101717+0i  0.83375525+0i  0.2572331+0i  0.03544473+0i
## [2,] -0.005385164+0i -0.46906070+0i  0.6605637+0i  0.58304723+0i
## [3,]  0.066528374+0i -0.07755971+0i  0.4492316+0i -0.34350402+0i
## [4,] -0.886805199+0i  0.18685364+0i  0.1126469+0i -0.01935804+0i
## [5,] -0.098092161+0i -0.17944646+0i -0.5049477+0i -0.57570692+0i
## [6,] -0.105143432+0i -0.10818233+0i -0.1673801+0i  0.45715576+0i
##                       [,5]                  [,6]
## [1,]  0.6983440+0.0000000i  0.6983440+0.0000000i
## [2,]  0.1951932+0.1867490i  0.1951932-0.1867490i
## [3,] -0.2665175+0.3243885i -0.2665175-0.3243885i
## [4,] -0.1349408+0.0073919i -0.1349408-0.0073919i
## [5,] -0.3363387-0.2431549i -0.3363387+0.2431549i
## [6,]  0.2622923+0.0614142i  0.2622923-0.0614142i

CAS CENTRER : on regularise la matrice pour la rendre diagonalisable dans R:

lambda <- 0.01
V_reg <- V_centree + lambda * diag(nrow(V_centree))

# Calcul de V_invB avec la matrice régularisée
V_invB <- solve(V_reg) %*% B_centree

# Diagonalisation
eigen_values <- eigen(V_invB)$values
print(eigen_values)

## [1]  8.122405e-01  7.289952e-16 -3.184714e-16 -2.220446e-16  1.364854e-16
## [6]  1.635272e-18

eigen_vectors <- eigen(V_invB)$vectors
print(eigen_vectors)

##             [,1]        [,2]         [,3]         [,4]        [,5]         [,6]
## [1,] -0.40783995 -0.27561641  0.971039653 -0.969112366 -0.24648478  0.256097640
## [2,] -0.03451261 -0.01041745 -0.144404982 -0.009322001 -0.33896899 -0.128107398
## [3,] -0.07401006 -0.07866551 -0.002410983 -0.019990431 -0.16922100  0.924840948
## [4,]  0.89355202  0.66771167 -0.186181952  0.241352177  0.65705961 -0.006743752
## [5,]  0.12454878 -0.68680650 -0.020352935  0.033641153  0.05223306 -0.067178843
## [6,]  0.11423813  0.01402739 -0.033844054  0.030856203 -0.60104402 -0.241066879

projected_data <- as.matrix(data_numeric_centree) %*% Re(eigen_vectors)
print(projected_data)

##              [,1]        [,2]        [,3]        [,4]         [,5]        [,6]
##  [1,] -0.60724005  1.24432068 -1.94701941  2.22007251  0.941110502  2.38786707
##  [2,]  0.41369716  0.28089711 -1.41152240  1.70986803  0.931997287  0.19011652
##  [3,] -1.04020267  0.28358958 -0.93275260  1.19140931  0.936255367  0.15277700
##  [4,]  0.28712275 -0.47300692  0.35651561 -0.39926506 -0.409385866  1.49619157
##  [5,] -0.49523755  0.30477783 -0.24463114  0.33257285  0.636070619  0.86329267
##  [6,] -0.60384505 -0.70978721  1.14013171 -1.30012893 -1.241307492  1.53264878
##  [7,] -0.96071739 -1.29570410  1.24606183 -1.42796022 -1.320267140  1.37221440
##  [8,] -0.66932663 -0.89872233  1.54144065 -1.75795559 -1.321218746  1.51606171
##  [9,] -0.40086783 -0.58161252  0.94503543 -1.02523402 -0.571118791  1.23425595
## [10,] -0.39805000 -0.26880078 -0.01703977  0.01299948  0.018017588 -0.18832043
## [11,] -0.98477703  0.32781266 -0.06130957  0.01171482  0.116175381 -0.29347095
## [12,] -0.72321526 -0.47051790  0.54676853 -0.67216162 -0.351505026 -0.08340316
## [13,] -0.95497684  0.44627117  0.22492152 -0.26318304 -0.050072033  0.04373731
## [14,] -0.75200279 -0.36403837  0.45932520 -0.55418302 -0.552650210  0.36592490
## [15,]  0.10348900  0.13446461  0.55837213 -0.70037377 -0.542394417  0.54256932
## [16,] -0.38226984  0.07965061  0.26452643 -0.32856236 -0.289397363  0.12720682
## [17,] -0.32283149 -0.30345025  0.36201257 -0.43826204 -0.593569467 -0.09632245
## [18,] -0.07257447  0.14074714 -0.05558529  0.03803469 -0.001130554 -0.78623558
## [19,] -0.10396827  0.06656273  0.00188606 -0.03332203  0.029388132 -0.43793420
## [20,] -0.54667095  0.30136254 -0.37362435  0.44443470  0.652481936 -0.84842271
## [21,] -0.57682053 -0.31577820  0.31511122 -0.38111133 -0.200342776 -0.65654685
## [22,] -0.44107605 -0.06354563  0.47608932 -0.53307751 -0.358260736 -0.68483434
## [23,] -1.00433039  0.19190665 -0.53000412  0.57232741  0.347080042 -1.41583221
## [24,] -0.31992477 -0.16506405  0.24381260 -0.31172269  0.082914574 -0.63174390
## [25,] -0.05696004 -0.50561247  0.39336550 -0.52364183 -0.300200906 -1.12194710
## [26,] -0.37761319  0.64375176 -0.48498225  0.58441359  1.100284972 -1.80777987
## [27,] -0.74079622  0.57678239 -0.77920256  0.89501756  0.127653763 -0.11918353
## [28,] -0.44963781  0.26958317 -0.32217932  0.40776665  0.482214102  0.24625787
## [29,] -0.89128597  0.68915048 -0.93677184  1.13731667  1.138933626 -1.47859392
## [30,] -0.70914964  0.43400962 -0.97875168  1.09219679  0.562243631 -1.42055069
## [31,]  1.06013866  0.31378560 -0.40174232  0.46973952  0.137911310 -0.26038103
## [32,]  1.13751716  0.24465337  0.36430840 -0.38963983  0.078540162  0.33495501
## [33,]  0.93488146  0.26288664  0.37778617 -0.47581115 -0.199463105  0.83406533
## [34,]  1.09829796 -0.56556306  0.48109284 -0.55742589  0.677170865  1.16695089
## [35,]  0.70112619 -0.79808019  0.54345320 -0.63326511 -0.644000098  0.28591729
## [36,]  1.63519435  0.36970709 -0.13277708  0.12204757  0.314927834 -0.15114122
## [37,]  1.39525246  0.07361899 -0.89877373  1.03183353  0.319687671 -0.86212908
## [38,]  0.91462996  0.34459239 -1.03078915  1.18496239  0.804181964 -0.17266981
## [39,]  1.47042663 -0.59680547  0.58529117 -0.67698227 -2.180366849 -0.50943816
## [40,]  0.96257041  0.26851795 -0.28464426  0.31763169  0.139352896 -0.52182620
## [41,]  1.63676728  0.20278135  0.22715666 -0.22335171  0.242727336 -0.30569289
## [42,]  1.83525726 -0.12009465  0.16963811 -0.16973873  0.309330012  0.16138987

###################################################################8

On voit bien que nos résultats entre notre fonction AFD quo prend la partie réel et la technique de régularisation est identique presque car en effet on a 1 seul axe qui capte totue la variance, les autres sont négligeables !

Donc les 2 approches sont similaires et donnent les mêmes résulats.

###################################################################8

Barplot de l’inertie expliquée et cumulée :

# Préparation pour l'inertie expliquée et cumulée
eigen_values <- Re(eigen_values)
inertie_expliquee <- eigen_values / sum(eigen_values)
cumul_inertie <- cumsum(inertie_expliquee)
ylim_max <- max(as.data.frame(cumul_inertie)) + .1

# Barplot de l'inertie expliquée
midpoints <- barplot(inertie_expliquee, main="AFD - Inertie expliquée et cumulée CENTREE", xlab="Composantes", ylab="Inertie", ylim=c(0, ylim_max), col = "blue")
lines(midpoints, cumul_inertie, type="b", col="red")
abline(h = 1, col="grey", lty=2)  # Ligne pointillée pour l'asymptote

############################################################8

Il est évident que nous allons garder qu’une seul composante.

############################################################8

Representation dans les différents plan PC1-PC2, PC1-PC3 PC1-PC4, PC1-PC5, PC2-PC3

library(plotly)

## 
## Attaching package: 'plotly'

## The following object is masked from 'package:MASS':
## 
##     select

## 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

library(FactoMineR)
library(dplyr)
library(stringr)
options(digits=10)



# Assurez-vous que 'data' est défini correctement et contient les colonnes nécessaires
data_numeric_centree <- data[, 2:7]
data_numeric_centree <- as.data.frame(centrage(as.matrix(data_numeric_centree)))

# Supposons que projected_data est déjà calculé et structuré correctement
ind_coords <- projected_data

# S'assurer que la colonne GENRE existe et contient les bonnes catégories
data_numeric_centree$GENRE <- data$GENRE  # Remplacer 'data$GENRE' par la colonne appropriée de votre dataset

# Créer une fonction pour générer un graphique Plotly
generate_plot <- function(x, y, title) {
  data_LOUP <- ind_coords[data_numeric_centree$GENRE == "LOUP", ]
  data_CHIEN <- ind_coords[data_numeric_centree$GENRE == "CHIEN", ]
  
  plot_ly() %>%
    add_trace(x = ~data_LOUP[, x], y = ~data_LOUP[, y], 
              type = 'scatter', mode = 'markers',
              marker = list(size = 6, color = 'red'), name = "L") %>%
    add_trace(x = ~data_CHIEN[, x], y = ~data_CHIEN[, y], 
              type = 'scatter', mode = 'markers',
              marker = list(size = 6, color = 'green'), name = "H") %>%
    layout(title = title,
           xaxis = list(title = paste("PC", x)),
           yaxis = list(title = paste("PC", y)))
}

# Créer et afficher les graphiques pour chaque paire de composantes
generate_plot(1, 2, "ACP: PC1 vs PC2")

generate_plot(1, 3, "ACP: PC1 vs PC3")

generate_plot(1, 4, "ACP: PC1 vs PC4")

generate_plot(1, 5, "ACP: PC1 vs PC5")

generate_plot(2, 3, "ACP: PC2 vs PC3")

data_numeric_centree <- data[,2:7]
data_numeric_centree <- as.data.frame(centrage(as.matrix(data_numeric)))

###########################################################################8

On voit que en augmentant les composantes, la qualité des 2 classes distinctes diminue TRES LARGEMENT sans la PC1 !!!!!! (prenons pour voir PC2 VS PC3) Cela rejoint notre constat précédent : il nous faut PC1 et les autres n’apportent pas grand chose; PC1 VS PC2 est trés similaire à PC1 VS PC3.

###########################################################################8

Question 5

V_centree <- res_centree$V
B_centree <- res_centree$B
W_centree <- res_centree$W
mat_centree1 <- solve(V_centree) %*% B_centree
mat_centree2 <- solve(W_centree) %*% B_centree

head(mat_centree1)

##                 LCB             LSM             LBM              LP
## LCB -0.115686740613 -0.151790282852 -0.093938524317 -0.393902366785
## LSM  0.001435129224  0.001883004653  0.001165335982  0.004886478735
## LBM -0.017729602151 -0.023262660103 -0.014396573488 -0.060367611814
## LP   0.236330793098  0.310084956504  0.191902424051  0.804683909774
## LM   0.026141252134  0.034299419575  0.021226898055  0.089008481281
## LAM  0.028020393583  0.036765003881  0.022752775383  0.095406779481
##                  LM             LAM
## LCB -0.329586147786 -0.299760137970
## LSM  0.004088616465  0.003718615736
## LBM -0.050510812594 -0.045939819540
## LP   0.673295446719  0.612365347752
## LM   0.074475212488  0.067735552967
## LAM  0.079828799148  0.072604664993

head(mat_centree2)

##                 LCB            LSM             LBM             LP
## LCB -0.655684770789 -0.86031101138 -0.532421083510 -2.23254438417
## LSM  0.008133969124  0.01067241991  0.006604845571  0.02769539251
## LBM -0.100487143651 -0.13184719249 -0.081596334527 -0.34214918240
## LP   1.339466399363  1.75748735381  1.087657031923  4.56075590118
## LM   0.148162363490  0.19440090492  0.120308980197  0.50447877897
## LAM  0.158812887686  0.20837524694  0.128957287868  0.54074280254
##                 LM            LAM
## LCB -1.86801544085 -1.69896875230
## LSM  0.02317330003  0.02107622441
## LBM -0.28628320240 -0.26037590726
## LP   3.81607752381  3.47074029878
## LM   0.42210768815  0.38390891027
## LAM  0.45245053663  0.41150587243

###########################################################################8

On voit que les signes sont les mêmes pour les 2 matrices mais les coefficient sont diffénrents pour les 2 matrices Etudions alors les VP des deux matrices :

###########################################################################8

eig1 <- eigen(mat_centree1)
eig2 <- eigen(mat_centree2)
values1 <- eig1$values
values2 <- eig2$values

print(Re(values1))

## [1]  8.235634778e-01  6.208968084e-16 -4.689863849e-16  5.808308622e-17
## [5] -5.743590597e-17  3.608046607e-17

print(Re(values2))

## [1]  4.667760776e+00 -2.526839801e-16 -2.526839801e-16  5.224724950e-16
## [5]  2.306287068e-17  0.000000000e+00

###########################################################################8

Pour comparer les VP on néglige les parties imaginaires, on peut le faire comme on a vu que dans notre cas ils sont négligeables. On voit bien ici aussi que le premier axe qui capte toute les inerties à la fois inertie totale (premiere matrice avec V) et aussi intraclasse (deuxieme matrice avec W).

###########################################################################8

vectors1 <- eig1$vectors
vectors2 <- eig2$vectors

print(Re(vectors1))

##                 [,1]           [,2]           [,3]           [,4]
## [1,]  0.434101716963  0.21603403487 -0.17298132833  0.81516105371
## [2,] -0.005385163907 -0.01196803776  0.89969999614  0.29790971846
## [3,]  0.066528373900 -0.00844329546  0.26103445941  0.27676359534
## [4,] -0.886805199209 -0.64395990609 -0.12701436713 -0.40691682199
## [5,] -0.098092161425  0.73297278051 -0.02605426337 -0.05355257773
## [6,] -0.105143432167 -0.03437026321 -0.27507619652  0.04141243599
##                [,5]           [,6]
## [1,]  0.64287325012 -0.84146247353
## [2,]  0.05658188359 -0.23581917646
## [3,] -0.72804174144 -0.34693484428
## [4,] -0.17756615493  0.33109279052
## [5,]  0.03774964140  0.06390074047
## [6,]  0.14322333140  0.04754676558

print(Re(vectors2))

##                 [,1]           [,2]           [,3]            [,4]
## [1,]  0.434101716963  0.67901817548  0.67901817548 -0.585657694569
## [2,] -0.005385163907 -0.17959846911 -0.17959846911  0.044280329964
## [3,]  0.066528373900 -0.03645136367 -0.03645136367 -0.009781040899
## [4,] -0.886805199209 -0.29634142369 -0.29634142369 -0.329452376044
## [5,] -0.098092161425 -0.03927776457 -0.03927776457  0.722746219723
## [6,] -0.105143432167  0.27290848623  0.27290848623 -0.155073151141
##                 [,5]            [,6]
## [1,] -0.967074192470 -0.968851211342
## [2,]  0.001323680352  0.001480358119
## [3,] -0.052926322276 -0.018288360422
## [4,]  0.244669940628  0.243778889459
## [5,]  0.037385277320  0.026965108231
## [6,]  0.026523946373  0.028903471868

###########################################################################8

Pour comparer les VP on néglige les parties imaginaires, on peut le faire comme on a vu que dans notre cas ils sont négligeables. On voit ici que les coordonnées sur le premier axe est le même pour les 2 vecteurs propres des deux premiers valeurs propres des 2 matrices, ensuite ce n’est plus le cas. Cela souligne encore le rôle primordiale de ce premiere axe par rapport aux autres axes suivant qu’on peut négliger.

###########################################################################8

Question 6

Calcul du rapport de corrélation:

library(MASS)

variance_axes <- apply(projected_data, 2, var)
variance_total <- sum(apply(data_numeric_centree, 2, var))
mu_s <- variance_axes / variance_total

print(mu_s)

## [1] 0.12287982548 0.04028841455 0.08388998164 0.11344328055 0.08069067030
## [6] 0.13805197292

print(eigen_values)

## [1]  8.122405320e-01  7.289952361e-16 -3.184714044e-16 -2.220446049e-16
## [5]  1.364853982e-16  1.635271555e-18

###########################################################################8

Alors qu’une valeur propre écrase les autres, donc qu’un seul axe capte presque toute la variance, on pouvait s’attendre à avoir mu_s avec des valeurs qui écrasent aussi les autres (le premier axe qui écrase les autres), mais ce n’est pas le cas.

###########################################################################8

Question 7 sur LD1

u1 <- res_centree$U
print(u1)

##             LCB             LSM             LBM              LP              LM 
##  0.520342621939 -0.006455008579  0.079745246692 -1.062982532604 -0.117579660418 
##             LAM 
## -0.126031773282

###########################################################################8

́Equation de la combinaison linéaire du premier axe factoriel discriminant correspondant à la première valeur propre : 0.520342622LCB -0.006455009LSM +0.079745247LBM -1.062982533LP. -0.117579660LM. -0.126031773*LAM

###########################################################################8

Question 8

library(MASS)
library(pander)

# Inverse de la matrice V
V_inv <- ginv(V_centree)

# Préparation du tableau pour les résultats
results <- data.frame(
  Axe = integer(),
  Quality_of_Projection = numeric(),
  Absolute_Contribution_LOUP = numeric(),
  Relative_Contribution_LOUP = numeric(),
  Absolute_Contribution_CHIEN = numeric(),
  Relative_Contribution_CHIEN = numeric()
)

# Calcul des indicateurs pour chaque axe (s) et chaque groupe (k)
for (s in 1:length(eigen_values)) {
  # Qualité de la projection pour l'axe s
  quality_projection <- eigen_values[s] / sum(eigen_values)
  
  # Contribution absolue et relative du centre de gravité pour le groupe "Loup"
  absolute_contribution_LOUP <- (t(eigen_vectors[,s]) %*% V_inv %*% gLOUP)^2
  relative_contribution_LOUP <- absolute_contribution_LOUP / eigen_values[s]
  
  # Contribution absolue et relative du centre de gravité pour le groupe "Chien"
  absolute_contribution_CHIEN <- (t(eigen_vectors[,s]) %*% V_inv %*% gCHIEN)^2
  relative_contribution_CHIEN <- absolute_contribution_CHIEN / eigen_values[s]
  
  # Ajouter les résultats dans le tableau
  results <- rbind(results, c(s, quality_projection, absolute_contribution_LOUP, 
                              relative_contribution_LOUP, absolute_contribution_CHIEN, 
                              relative_contribution_CHIEN))
}

# Nommer les colonnes du tableau
colnames(results) <- c("Axe", "Qualité de Projection", "Contribution Absolue (Loup)", 
                       "Contribution Relative (Loup)", "Contribution Absolue (Chien)", 
                       "Contribution Relative (Chien)")

# Afficher le tableau avec pander
pander(results)

Table continues below

Axe	Qualité de Projection	Contribution Absolue (Loup)
1	1	0.4718
2	8.975e-16	0.2006
3	-3.921e-16	0.1663
4	-2.734e-16	0.1954
5	1.68e-16	0.1945
6	2.013e-18	0.02113

Table continues below

Contribution Relative (Loup)	Contribution Absolue (Chien)
0.5809	2.949
2.752e+14	1.254
-5.223e+14	1.04
-8.801e+14	1.221
1.425e+15	1.216
1.292e+16	0.1321

Contribution Relative (Chien)
3.631
1.72e+15
-3.264e+15
-5.501e+15
8.907e+15
8.077e+16

###########################################################################8

La qualité de projection par nuage voit celui numéro 1 écraser les autres, car on a une VP qui écrase les autres.

###########################################################################8

Question 9: on modifie notre fonction AFD selon ce qui est demandé:

• Centrée et réduire nos données initiales (attention à réduire avec l’écart type intra classes)

Fonction pour calculer l’écart-type intra-classe et standardiser les données

X <- data_numeric
y <- data$GENRE

# Fonction pour calculer l'écart-type intra-classe et standardiser les données
standardize_intra_class <- function(X, y) {

  X_standardized <- as.data.frame(matrix(nrow = nrow(X), ncol = ncol(X)))
  colnames(X_standardized) <- colnames(X)
  
  # Calculer l'écart-type pour chaque groupe et standardiser les variables
  for (group in unique(y)) {

    indices <- which(y == group)
    
    X_group <- X[indices, ]
    
    mean_group <- colMeans(X_group)
    sd_group <- apply(X_group, 2, sd)
    
    X_group_centered <- sweep(X_group, 2, mean_group, FUN = "-")
    X_group_scaled <- sweep(X_group_centered, 2, sd_group, FUN = "/")
    
    X_standardized[indices, ] <- X_group_scaled
  }
  
  return(X_standardized)
}

X_standardized <- standardize_intra_class(X, y)
head(X_standardized)

##             LCB           LSM           LBM            LP            LM
## 1 -2.4466857377 -2.4724995592  2.2661406875 -1.4497678760 -2.3671687543
## 2 -1.5923960248 -1.8465503037  0.4417053882  0.1976956195  0.4658789570
## 3 -1.4557096708 -2.0343350803 -0.0384091642 -1.9769561945 -1.1395147461
## 4  0.6629288172  0.4694619416  1.5939803141  1.8451591149  1.5990980415
## 5 -0.3622188383 -0.6572467183  0.6337512092  0.0000000000 -0.4784702801
## 6  1.3805321760  0.9702213460  1.4979574036  0.8566810176  0.9380535755
##             LAM
## 1 -1.2918998195
## 2  0.4320521637
## 3 -1.6111501868
## 4  1.3898032655
## 5 -1.1641996726
## 6  1.5813534858

Fonction AFD2 FROM SCRATCH

library(dplyr)
AFD2<-function(X,y, centrerReduire = False){

  

if (centrerReduire) {
  
# Fonction pour calculer l'écart-type intra-classe et standardiser les données
standardize_intra_class(X, y)

}
  
  
  
n<-nrow(X)
p <- ncol(X)
K<-length(levels(factor(y)))
nk<-as.vector(table(y))
names(nk) <- levels(y)
pk<-nk/n

Xk <-list()
Xk <- split(X,y)

V<-var(X)*(n-1)/n
R<-cor(X)

g<-matrix(apply(X,2,mean),ncol=1)
rownames(g) <- colnames(X)

Vk<-list()
Rk<-list()
gk<-list()
for (k in 1:K){
    gk[[k]]<-matrix(apply(Xk[[k]],2,mean),ncol=1)
    rownames(gk[[k]]) <- colnames(X)
    Vk[[k]]<-var(Xk[[k]])*(nk[k]-1)/nk[k]
    Rk[[k]]<-cor(Xk[[k]])
}

names(Vk) <- levels(y)
names(Rk) <- levels(y)
names(gk) <- levels(y)

Xcent<-X-matrix(rep(1,n),ncol=1)%*%t(g)
W<-matrix(0,nrow=p,ncol=p)
B<-matrix(0,nrow=p,ncol=p)
for (k in 1:K){
    W<-W+pk[k]*Vk[[k]]
    B<-B+pk[k]*(gk[[k]]-g)%*%t(gk[[k]]-g)
}

# Calcul des FD :

res<-eigen(solve(V)%*%B)

eig <- Re(res$values[1:(K-1)])


UU<-Re(res$vectors[,1:(K-1)])
normes <- sqrt(diag(t(UU)%*%V%*%UU))

if (K>2) {
U <- sweep(UU,2,normes,"/")
} else {
U <- UU/normes
}

if (K>2) {
    rownames(U) <- colnames(X)
    colnames(U)<-paste("u",1:ncol(U),sep="")
} else
{
    names(U) <- colnames(X)

}

# Calcul des VD :
S<-as.matrix(Xcent)%*%U
if (K>2) {
    colnames(S) <-paste("s",1:ncol(S),sep="")
    rownames(S)<-rownames(X)
} else names(S)<-rownames(X)



lambda <- 0.05
V_reg <- V + lambda * diag(nrow(V))
V_invB <- solve(V_reg) %*% B
eigen_values <- eigen(V_invB)$values
eigen_vectors <- eigen(V_invB)$vectors
gLOUP <- data.frame(gk)[,1]
gCHIEN <- data.frame(gk)[,2]



V_inv <- ginv(V)


results <- data.frame(
  Axe = integer(),
  Quality_of_Projection = numeric(),
  Absolute_Contribution_LOUP = numeric(),
  Relative_Contribution_LOUP = numeric(),
  Absolute_Contribution_CHIEN = numeric(),
  Relative_Contribution_CHIEN = numeric()
)

# Calcul des indicateurs pour chaque axe (s) et chaque groupe (k)
for (s in 1:length(eigen_values)) {
  # Qualité de la projection pour l'axe s
  quality_projection <- eigen_values[s] / sum(eigen_values)
  
  # Contribution absolue et relative du centre de gravité pour le groupe "Loup"
  absolute_contribution_LOUP <- (t(eigen_vectors[,s]) %*% V_inv %*% gLOUP)^2
  relative_contribution_LOUP <- absolute_contribution_LOUP / eigen_values[s]
  
  # Contribution absolue et relative du centre de gravité pour le groupe "Chien"
  absolute_contribution_CHIEN <- (t(eigen_vectors[,s]) %*% V_inv %*% gCHIEN)^2
  relative_contribution_CHIEN <- absolute_contribution_CHIEN / eigen_values[s]
  
  # Ajouter les résultats dans le tableau
  results <- rbind(results, c(s, quality_projection, absolute_contribution_LOUP, 
                              relative_contribution_LOUP, absolute_contribution_CHIEN, 
                              relative_contribution_CHIEN))
}


colnames(results) <- c("Axe", "Qualité de Projection", "Contribution Absolue (Loup)", 
                       "Contribution Relative (Loup)", "Contribution Absolue (Chien)", 
                       "Contribution Relative (Chien)")






list(eig=eig,U=U,S=S,nk=nk,K=K,y=y,X=X,Xk=Xk,W=W,B=B,g=data.frame(g=g),gk=data.frame(gk),V=V,R=R,Vk=Vk,Rk=Rk,results=results)
}

Question 9.2

data <- as.data.frame(data)
data_numeric <- data[,2:7]
y <- data[,8]
res3 = AFD2(X,y,centrerReduire = TRUE)

head(res3$results)

##   Axe Qualité de Projection Contribution Absolue (Loup)
## 1   1       1.000000000e+00               0.46080241880
## 2   2       3.524455466e-16               0.03128179755
## 3   3      -3.111227065e-16               0.06090065317
## 4   4       1.434705176e-16               0.18964205618
## 5   5      -3.817216460e-17               0.09683025685
## 6   6       1.788391896e-17               0.04328993358
##   Contribution Relative (Loup) Contribution Absolue (Chien)
## 1              5.954800078e-01                 2.8800151175
## 2              1.146970133e+14                 0.1955112347
## 3             -2.529546560e+14                 0.3806290823
## 4              1.708143787e+15                 1.1852628511
## 5             -3.278058738e+15                 0.6051891053
## 6              3.128071428e+15                 0.2705620849
##   Contribution Relative (Chien)
## 1               3.721750049e+00
## 2               7.168563330e+14
## 3              -1.580966600e+15
## 4               1.067589867e+16
## 5              -2.048786712e+16
## 6               1.955044643e+16

head(results)

##   Axe Qualité de Projection Contribution Absolue (Loup)
## 1   1       1.000000000e+00               0.47182064600
## 2   2       8.975115220e-16               0.20062811863
## 3   3      -3.920900175e-16               0.16633470430
## 4   4      -2.733729680e-16               0.19541878698
## 5   5       1.680356900e-16               0.19450385772
## 6   6       2.013284846e-18               0.02113398396
##   Contribution Relative (Loup) Contribution Absolue (Chien)
## 1              5.808878373e-01                 2.9488790375
## 2              2.752118377e+14                 1.2539257414
## 3             -5.222908619e+14                 1.0395919019
## 4             -8.800879762e+14                 1.2213674186
## 5              1.425089132e+15                 1.2156491107
## 6              1.292383757e+16                 0.1320873998
##   Contribution Relative (Chien)
## 1               3.630548983e+00
## 2               1.720073986e+15
## 3              -3.264317887e+15
## 4              -5.500549851e+15
## 5               8.906807075e+15
## 6               8.077398483e+16

print(res3$eig)

## [1] 0.8235634778

print(res_centree$eig)

## [1] 0.8235634778

print(res3$U)

##             LCB             LSM             LBM              LP              LM 
##  0.520342621939 -0.006455008579  0.079745246692 -1.062982532604 -0.117579660418 
##             LAM 
## -0.126031773282

print(res_centree$U)

##             LCB             LSM             LBM              LP              LM 
##  0.520342621939 -0.006455008579  0.079745246692 -1.062982532604 -0.117579660418 
##             LAM 
## -0.126031773282

Question 9.3

###########################################################################8

On observe que pour l’axe 1, les résultat entre CENTREE ET CENTREE REDUITS sont les mêmes : car on a la même valeur propres entre les 2 et le même LD1.

En effet, on divise les donnees selon les classes et non selon la méthode classique comme en ACP.

###########################################################################8

Question 9.4 : Calculer les coefficients de corrélation avec les différentes variables.

calculate_correlations <- function(eigen_vectors, eigen_values) {
  eigen_vectors <- eigen_vectors[,1:2]
  eigen_values <- eigen_values[1:2]
  correlations <- sweep(eigen_vectors, 2, sqrt(eigen_values), FUN = "*")
  return(correlations)
}

correlations <- calculate_correlations(eigen_vectors, eigen_values)

variable_names <- c('Var1', 'Var2', 'Var3', 'Var4', 'Var5', 'Var6')
correlation_df <- data.frame(Variable = variable_names, correlations)
pander(correlation_df)

Variable	X1	X2
Var1	-0.3676	-7.442e-09
Var2	-0.0311	-2.813e-10
Var3	-0.0667	-2.124e-09
Var4	0.8053	1.803e-08
Var5	0.1122	-1.854e-08
Var6	0.103	3.787e-10

###########################################################################8

On voit que les coefficients de corrélation avec les différentes variables sont non négligeable seulement dans le cas du premier axe factorielle. Ceci est en cohérence avec nos résultats précédents sur les différents axes factorielles et que le premier écrase les autres.

###########################################################################8

Question 9.5 : Projeter les p variables Zj pour j [1..p] dans le nouvel espace des k axes retenus et tracer les p variables dans le plan factoriel retenu (axe factoriel1,axe factoriel 2) sur le cercle de corrélation.

project_on_factors <- function(variables, correlations) {
  projection <- variables %*% correlations[, 1:2]
  return(projection)
}

projection <- project_on_factors(as.matrix(X_standardized), correlations)

# Cercle de corrélation
plot_correlation_circle <- function(correlations) {
  plot(correlations[,1], correlations[,2], type = 'n') 
  text(correlations[,1], correlations[,2], labels = colnames(X_standardized), cex = 0.7)
  abline(h = 0, v = 0, col = "gray") 
  circle_radius <- sqrt(max(correlations[,1]^2 + correlations[,2]^2))
  symbols(0, 0, circles = circle_radius, add = TRUE, inches = FALSE, lty = 2) # fait un circle
}

plot_correlation_circle(correlations)

###########################################################################8

On voit ici que c’est la variable LP qui est la plus discriminante, les variables LBM et LSM sont celles qui le sont le moins. (On raisonne uniquement en 1D selon le premiere axe)

###########################################################################8