Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

library('readxl')
X <- read_excel("TP_AFC_majeur1718_travail.xlsx", na=" ")
X$id <- NULL
X$`temps travail` <- NULL
X$`Qualite vie` <- NULL
#write_xlsx(X, "AFC_2_var.xlsx")

Faire les transformations de données à partir des données fournies et du cours.

#Tableau de contingence

#Tableau de contingence
contingence <- table(X$Sexe, X$Fonction)

# Renommer les lignes et les colonnes
rownames(contingence) <- c("Non répondu", "H", "F")
colnames(contingence) <- c("Non répondu", "Administratif", "Technicien (OS)",
                           "Ingénieur", "Technicien supérieur", "Direction",
                           "Contractuel S1", "Contractuel S2")
#on prefere le format DF
kij <- as.data.frame.matrix(contingence)
pander(kij)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
Non répondu	8	0	3	7
H	0	15	24	48
F	0	57	9	18

Table continues below
	Technicien supérieur	Direction	Contractuel S1
Non répondu	3	0	0
H	13	6	12
F	7	1	6

	Contractuel S2
Non répondu	4
H	4
F	3

Calculer le tableau des fréquences relatives

# Calculer le nombre total d'observations
kpp <- sum(kij)
# Calculer le tableau des fréquences relatives
fij <- kij / kpp
pander(fij)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
Non répondu	0.03226	0	0.0121	0.02823
H	0	0.06048	0.09677	0.1935
F	0	0.2298	0.03629	0.07258

Table continues below
	Technicien supérieur	Direction	Contractuel S1
Non répondu	0.0121	0	0
H	0.05242	0.02419	0.04839
F	0.02823	0.004032	0.02419

	Contractuel S2
Non répondu	0.01613
H	0.01613
F	0.0121

Ajout des marges au tableau de fréquences relatives

# Conversion du tableau de fréquence en matrice
fij_mat <- as.matrix(fij)
# Ajout des marges au tableau de fréquences relatives
fij_marge <- as.data.frame(addmargins(fij_mat))
pander(fij_marge)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
Non répondu	0.03226	0	0.0121	0.02823
H	0	0.06048	0.09677	0.1935
F	0	0.2298	0.03629	0.07258
Sum	0.03226	0.2903	0.1452	0.2944

Table continues below
	Technicien supérieur	Direction	Contractuel S1
Non répondu	0.0121	0	0
H	0.05242	0.02419	0.04839
F	0.02823	0.004032	0.02419
Sum	0.09274	0.02823	0.07258

	Contractuel S2	Sum
Non répondu	0.01613	0.1008
H	0.01613	0.4919
F	0.0121	0.4073
Sum	0.04435	1

Calcul des profils lignes (version matricielle)

# Calcul des profils lignes (version matricielle)
Dn <- diag(margin.table(fij_mat,1))
L <- solve(Dn) %*% fij_mat
# Calcul des profils lignes autre methode
L <- fij/margin.table(fij_mat,1)
pander(L)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
Non répondu	0.32	0	0.12	0.28
H	0	0.123	0.1967	0.3934
F	0	0.5644	0.08911	0.1782

Table continues below
	Technicien supérieur	Direction	Contractuel S1
Non répondu	0.12	0	0
H	0.1066	0.04918	0.09836
F	0.06931	0.009901	0.05941

	Contractuel S2
Non répondu	0.16
H	0.03279
F	0.0297

Interpretation exemple : 4,9% des personnes en poste de Direction sont des H et 0,99% des F.

Autre exemple : 39% des personnes ingénieurs sont H contre 18% pour les F

Calcul du profil ligne moyen

# Calcul du profil ligne moyen
L_moyen <- t(colSums(fij))
pander(L_moyen)

Table continues below
Non répondu	Administratif	Technicien (OS)	Ingénieur
0.03226	0.2903	0.1452	0.2944

Technicien supérieur	Direction	Contractuel S1	Contractuel S2
0.09274	0.02823	0.07258	0.04435

Interpretation : 3,2% des personnes n’ont pas répondu

29% des personnes sont en poste Administratif

7,3% des personnes sont Contractuel S1

…

Calcul des profils colonnes (matriciel)

# Calcul des profils colonnes (matriciel)
Dp <- diag(margin.table(fij_mat,2))
C <- solve(Dp) %*% t(fij_mat)
rownames(C) <- colnames(fij_mat)
pander(C)

	Non répondu	H	F
Non répondu	1	0	0
Administratif	0	0.2083	0.7917
Technicien (OS)	0.08333	0.6667	0.25
Ingénieur	0.09589	0.6575	0.2466
Technicien supérieur	0.1304	0.5652	0.3043
Direction	0	0.8571	0.1429
Contractuel S1	0	0.6667	0.3333
Contractuel S2	0.3636	0.3636	0.2727

Calcul du profil colonne moyen

# Calcul du profil colonne moyen
C_moyen <- t(rowSums(fij))
pander(C_moyen)

Non répondu	H	F
0.1008	0.4919	0.4073

Interpretation : 1% des personnes n’ont pas répondu, 49% sont des F et 41% des H

Comme on va le voir : la dépendance entre les variables sera fonction de la distance entre les colonnes.

Distance (on choisit de travailler avec la distance du chi2) entre les lignes 1 et 2 et entre les lignes 1 et 3

# Distance du chi2 entre les lignes 1 et 2
L <- as.matrix(L)
x12 <- as.matrix(L[1,] - L[2,])
d_euclidienne_ligne_12 <- t(x12) %*% x12
pander(d_euclidienne_ligne_12)

0.1647

# Distance du chi2 entre les lignes 1 et 3
x13 <- as.matrix(L[1,] - L[3,])
d_euclidienne_ligne_13 <- t(x13) %*% diag(8) %*% x13
d_chi2_ligne_13 <- t(x13) %*% solve(Dp) %*% x13
pander(d_euclidienne_ligne_13)

0.4554

La distance euclidienne entre les lignes 1 “Non répondu” et 2 “H” est de 0.16.

La distance euclidienne entre les lignes 1 “Non répondu” et 3 “F” est de 0.46.

d_chi2_ligne_12 <- t(x12) %*% as.matrix(solve(Dp)) %*% (x12)
pander(d_chi2_ligne_12)

3.897

pander(d_chi2_ligne_13)

4.776

La distance du χ2 est de 3,9 entre les lignes 1 et 2.

La distance du χ2 est de 4.8 entre les lignes 1 et 3.

On peut interpréter ces valeurs ainsi: les personnes qui n’ont pas répondu ont des métier qui ressemblent davantage à ceux des personnes H qu’à ceux F.

Calcul des fréquences attendues sous l’indépendance

# Calcul des fréquences attendues sous l'indépendance
fij_ind <- margin.table(fij_mat,1) %*% t(margin.table(fij_mat,2))
pander(fij_ind)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
Non répondu	0.003252	0.02927	0.01463	0.02967
H	0.01587	0.1428	0.07141	0.1448
F	0.01314	0.1182	0.05912	0.1199

Table continues below
	Technicien supérieur	Direction	Contractuel S1
Non répondu	0.009349	0.002845	0.007317
H	0.04562	0.01389	0.0357
F	0.03777	0.0115	0.02956

	Contractuel S2
Non répondu	0.004471
H	0.02182
F	0.01806

Calcul de la statistique du test et Calcul des degrés de liberté

# Calcul de la statistique du test
Z2 <- kpp*sum((fij-fij_ind)^2/fij_ind)
print(Z2)

## [1] 146.1813

# Calcul des degrés de liberté
n <- ncol(kij)
p <- nrow(kij)
ddl <- (n-1)*(p-1)
print(ddl)

## [1] 14

La valeur de la statistique de test est Z2 = 146.1813 et le nombre de degrés de liberté est de (n-1)(p-1) = 14. Sous l’indépendance, cette statistique suit une distribution du X2 avec 14 ddl.

Calcul de la p-valeur

# Calcul de la p-valeur
pchisq(Z2,ddl, lower.tail = FALSE)

## [1] 4.164989e-24

Puisque la pvalue du test est inférieur au seuil fixée à 5%, on peut conclure que le SEXE et la FONCTION ne sont pas indépendants.

Cependant, ce test permet de supposer qu’il y a un lien entre les 2 variables sans nous en dire d’avantage sur le lien.

Analyse directe

# Matrice dont on cherche les vecteurs propres dans l'analyse directe
S <- t(fij_mat) %*% solve(Dn) %*% fij_mat %*% solve(Dp)

# Valeurs et vecteurs propres de S (analyse directe) 
vp_S <- eigen(S)

print(vp_S$values)

## [1]  1.000000e+00+0.000000e+00i  3.859159e-01+0.000000e+00i
## [3]  2.035248e-01+0.000000e+00i -4.668173e-17+0.000000e+00i
## [5]  1.229696e-17+2.900943e-17i  1.229696e-17-2.900943e-17i
## [7] -9.531079e-18+0.000000e+00i  9.401319e-18+0.000000e+00i

pb : S non diag dans R

#Alternative : #Transformer en une matrice diagonalisable

#Alternative :
#Transformer en une matrice diagonalisable
A_chapeau = t(fij_mat) %*% solve(Dn) %*% fij_mat
A <- sqrt(solve(Dp)) %*% A_chapeau %*% sqrt(solve(Dp))
pander(A)

0.32	0	0.05657	0.09269	0.07077	0	0	0.1364
0	0.4724	0.1577	0.2215	0.1364	0.058	0.135	0.07764
0.05657	0.1577	0.1634	0.2319	0.1231	0.07997	0.1137	0.0771
0.09269	0.2215	0.2319	0.3295	0.1758	0.1123	0.1597	0.1139
0.07077	0.1364	0.1231	0.1758	0.09697	0.05585	0.08328	0.07005
0	0.058	0.07997	0.1123	0.05585	0.04357	0.05787	0.0258
0	0.135	0.1137	0.1597	0.08328	0.05787	0.08538	0.04063
0.1364	0.07764	0.0771	0.1139	0.07005	0.0258	0.04063	0.07821

Valeurs et vecteurs propres de S (analyse directe)

# Valeurs et vecteurs propres de S (analyse directe) 
vp_A <- eigen(A)

#print(vp_A$values)
#print(vp_A$vectors)
#print(dim(A))
#print(dim(S))

On peut représenter les profils-lignes sur les deux dimensions de l’analyse des correspondances:

varphi_j2 <- solve(Dp) %*% vp_A$vectors[,2]
varphi_j3 <- solve(Dp) %*% vp_A$vectors[,3]

coord_ligne2 <- sqrt(solve(Dn)) %*% fij_mat %*% varphi_j2 
coord_ligne3 <- sqrt(solve(Dn)) %*% fij_mat %*% varphi_j3

dat <- data.frame(dim1 = coord_ligne2, dim2 = coord_ligne3)
ggplot()+
  geom_label(aes(dim1,dim2, label = c("Non répondu", "H", "F")), dat)

# Créer un DataFrame avec les nouvelles coordonnées
dat1 <- data.frame(dim1 = coord_ligne2, dim2 = coord_ligne3)

# Ajouter les libellés aux données
dat1$label <- c("Non répondu", "H", "F")

# Afficher le DataFrame avec les coordonnées et les libellés
print(dat1)

##          dim1       dim2       label
## 1  2.96433550  1.1057725 Non répondu
## 2  0.04788704 -1.0016947           H
## 3 -0.44633734  0.4090943           F

#Représentation de l'inertie expliquée et cumulée
inertie_expliquee <- vp_A$values / sum(vp_A$values)
cumul_inertie <- cumsum(inertie_expliquee)
ylim_max <- max(cumul_inertie) + .1
# Barplot de l'inertie expliquée
midpoints <- barplot(inertie_expliquee, main="Inertie expliquée et cumulée par chaque composante", xlab="Composantes", ylab="Inertie expliquée et cumulée", ylim=c(0, ylim_max), col = "blue")
# Trace l'inertie cumulée
lines(midpoints, cumul_inertie, type="b", col="red")
# Trace l'asymptote horizontale en 1
abline(h = 1, col="grey", lty=2)  # Couleur grise et ligne en pointillés

On a 3 axe non négligeable seulement. Ensuite quasi nul. Coude pour le 3eme axe.

On passe au dessus de 80% d’inertie cumulée pour k=2

On peut prendre k=3 au vue du graphique

Pour la suite on represente en 2D donc k=2.

# Créer un DataFrame avec les données d'inertie
data <- data.frame(Axe = 1:8, Inertie_Expliquee = inertie_expliquee, Inertie_Cumulee = cumul_inertie)

# Afficher le DataFrame
print(data)

##   Axe Inertie_Expliquee Inertie_Cumulee
## 1   1      6.291521e-01       0.6291521
## 2   2      2.427998e-01       0.8719520
## 3   3      1.280480e-01       1.0000000
## 4   4      2.918491e-17       1.0000000
## 5   5      1.429472e-17       1.0000000
## 6   6      1.224047e-17       1.0000000
## 7   7      2.774642e-18       1.0000000
## 8   8     -2.516395e-20       1.0000000

Matrice dont on cherche les vecteurs propres dans l’analyse directe

# Matrice dont on cherche les vecteurs propres dans l'analyse directe
TT <- fij_mat %*% solve(Dp) %*% t(fij_mat) %*% solve(Dn)

# Vecteurs et valeurs propres de T (analyse duale)
vp_T <- eigen(TT)

phi_2 <- solve(Dn) %*% vp_T$vectors[,2]
phi_3 <- solve(Dn) %*% vp_T$vectors[,3]

coord_col2 <- solve(Dp) %*% t(fij_mat) %*% phi_2
coord_col3 <- solve(Dp) %*% t(fij_mat) %*% phi_3

# Créer un DataFrame avec les nouvelles coordonnées
dat2 <- data.frame(dim1 = coord_col2, dim2 = coord_col3)

# Ajouter les libellés aux données
dat2$label <- c("Non répondu", "Administratif", "Technicien (OS)",
                "Ingénieur", "Technicien supérieur", "Direction",
                "Contractuel S1", "Contractuel S2")

# Afficher le DataFrame avec les coordonnées et les libellés
print(dat2)

##         dim1       dim2                label
## 1 -7.0549005  1.4870320          Non répondu
## 2  1.3699647  0.8793705        Administratif
## 3 -0.1452512 -0.5389528      Technicien (OS)
## 4 -0.2399040 -0.5111996            Ingénieur
## 5 -0.3854328 -0.2273543 Technicien supérieur
## 6  0.2609010 -1.1241770            Direction
## 7  0.5864976 -0.5359796       Contractuel S1
## 8 -2.0885936  0.3868148       Contractuel S2

dat2 <- data.frame(dim1 = coord_col2, dim2 = coord_col3)
ggplot() +
  geom_label(aes(dim1,dim2, label = c("Non répondu", "Administratif", "Technicien (OS)",
                                      "Ingénieur", "Technicien supérieur", "Direction",
                                      "Contractuel S1", "Contractuel S2")),dat2)

#Représentation de l'inertie expliquée et cumulée
inertie_expliquee <- vp_T$values / sum(vp_T$values)
cumul_inertie <- cumsum(inertie_expliquee)
ylim_max <- max(cumul_inertie) + .1
# Barplot de l'inertie expliquée
midpoints <- barplot(inertie_expliquee, main="Inertie expliquée et cumulée par chaque composante", xlab="Composantes", ylab="Inertie expliquée et cumulée", ylim=c(0, ylim_max), col = "blue")
# Trace l'inertie cumulée
lines(midpoints, cumul_inertie, type="b", col="red")
# Trace l'asymptote horizontale en 1
abline(h = 1, col="grey", lty=2)  # Couleur grise et ligne en pointillés

Ici on n’a que 3 au maximum. On peut prendre k=2 comme dans la suite par exemple.

# Créer un DataFrame avec les données d'inertie
data <- data.frame(Axe = 1:3, Inertie_Expliquee = inertie_expliquee, Inertie_Cumulee = cumul_inertie)

# Afficher le DataFrame
print(data)

##   Axe Inertie_Expliquee Inertie_Cumulee
## 1   1         0.6291521       0.6291521
## 2   2         0.2427998       0.8719520
## 3   3         0.1280480       1.0000000

Comparaison avec FactoMineR

afd <- CA(kij)

# Coordonnées des lignes
coo_lignes <- afd$row$coord
# Coordonnées des colonnes
coo_cols <- afd$col$coord

Comparaison des coordonnées Col

coord_df <- data.frame(x = coord_col2, y = -coord_col3)
names(coord_df) <- c("x", "y")

coo_cols_df <- as.data.frame(coo_cols)
names(coo_cols_df) <- c("x", "y")

# Création du graphique combiné
ggplot() +
  geom_point(data = coord_df, aes(x = x, y = y), color = "blue", shape = 16) + # Points de coord_ligne2 et coord_ligne3
  geom_point(data = coo_cols_df, aes(x = x, y = y), color = "red", shape = 17) + # Points de coo_lignes
  ggtitle("Graphique Combiné des Points") +
  xlab("Axe X") +
  ylab("Axe Y")

Comparaison des coordonnées Ligne

# Conversion en data.frame pour coord_ligne2 et coord_ligne3
coord_df <- data.frame(x = coord_ligne2, y = -coord_ligne3)
names(coord_df) <- c("x", "y")

# Conversion en data.frame pour coo_lignes
coo_lignes_df <- as.data.frame(coo_lignes)
names(coo_lignes_df) <- c("x", "y")

# Création du graphique combiné
ggplot() +
  geom_point(data = coord_df, aes(x = x, y = y), color = "blue", shape = 16) + # Points de coord_ligne2 et coord_ligne3
  geom_point(data = coo_lignes_df, aes(x = x, y = y), color = "red", shape = 17) + # Points de coo_lignes
  ggtitle("Graphique Combiné des Points") +
  xlab("Axe X") +
  ylab("Axe Y")

Nos résultats ne sont pas les mêmes, il nous manque d’appliquer les relations de passage, mais on n’obtient pas les mêmes resultats aussi. Il doit y avoir un problème de code quelque part.

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

nouvelles_coordonnees <- as.matrix(coo_lignes_df)
print(dim(coo_lignes_df))

## [1] 3 2

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

Non répondu	H	F
0.94	8.2e-05	0.48

COMPARAISON avec CA

# Qualité de la représentation des lignes
cos2_ligne <- as.matrix(afd$row$cos2)[,1]
pander(cos2_ligne)

Non répondu	H	F
0.94	8.2e-05	0.48

Ce sont les mêmes résultats entre FROM SCRATCH AFC ET AC

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

nouvelles_coordonnees <- as.matrix(coo_cols_df)
print(dim(coo_cols_df))

## [1] 8 2

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
Non répondu	Administratif	Technicien (OS)	Ingénieur
0.9	0.48	0.027	0.077

Technicien supérieur	Direction	Contractuel S1	Contractuel S2
0.52	0.02	0.31	0.92

# Qualité de la représentation des colonnes
cos2_col <- as.matrix(afd$col$cos2)[,1]
pander(cos2_col)

Table continues below
Non répondu	Administratif	Technicien (OS)	Ingénieur
0.9	0.48	0.027	0.077

Technicien supérieur	Direction	Contractuel S1	Contractuel S2
0.52	0.02	0.31	0.92

Ce sont les mêmes résultats entre FROM SCRATCH AFC ET AC

Heatmap contribution à l’inertie des axes cas LIGNE

# Utilisez les variables données
nouvelles_coordonnees <- as.data.frame(afd$row$coord)
valeurs_propres <- vp_A$values[1:3]

n <- nrow(nouvelles_coordonnees)

#print(n)
#print(valeurs_propres)
print(nouvelles_coordonnees)

##                    Dim 1      Dim 2
## Non répondu  1.755759100 -0.4355323
## H           -0.004157002  0.4584633
## F           -0.429572508 -0.4459823

print(dim(nouvelles_coordonnees))

## [1] 3 2

#print(dim(valeurs_propres))

# 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

## Warning in sweep(nouvelles_coordonnees^2, 2, valeurs_propres, FUN = "/"): STATS
## is longer than the extent of 'dim(x)[MARGIN]'

print(contributions)

##                    Dim 1      Dim 2
## Non répondu 1.027563e+00 0.16384259
## H           2.830231e-05 0.07006287
## F           1.593892e-01 0.32575927

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


# 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 LIGNE")

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

# Contribution des lignes
afd$row$contrib * 1.03/80.524030157

##                    Dim 1     Dim 2
## Non répondu 1.030000e+00 0.1201776
## H           2.817654e-05 0.6498480
## F           2.490931e-01 0.5090957

Heatmap contribution à l’inertie des axes cas COLONNE

# Utilisez les variables données
nouvelles_coordonnees <- as.data.frame(afd$col$coord)
valeurs_propres <- vp_T$values

n <- nrow(nouvelles_coordonnees)

#print(n)
#print(valeurs_propres)
print(nouvelles_coordonnees)

##                            Dim 1      Dim 2
## Non répondu           2.82630214 -0.9654099
## Administratif        -0.54882902 -0.5709043
## Technicien (OS)       0.05818989  0.3498986
## Ingénieur             0.09610923  0.3318806
## Technicien supérieur  0.15441033  0.1476028
## Direction            -0.10452096  0.7298374
## Contractuel S1       -0.23496002  0.3479683
## Contractuel S2        0.83672288 -0.2511276

print(dim(nouvelles_coordonnees))

## [1] 8 2

#print(dim(valeurs_propres))

# 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

## Warning in sweep(nouvelles_coordonnees^2, 2, valeurs_propres, FUN = "/"): STATS
## is longer than the extent of 'dim(x)[MARGIN]'

print(contributions)

##                            Dim 1       Dim 2
## Non répondu          0.998497974 0.301884487
## Administratif        0.184997927 0.040741462
## Technicien (OS)      0.001096762 0.075192941
## Ingénieur            0.001154623 0.035676414
## Technicien supérieur 0.014643519 0.002723324
## Direction            0.003538540 0.327148491
## Contractuel S1       0.006900776 0.039219007
## Contractuel S2       0.429987691 0.007883134

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


# 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 LIGNE")

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

# Contribution des colonnes
afd$col$contrib * 1./66.77021887

##                            Dim 1      Dim 2
## Non répondu          1.000000000 0.22123900
## Administratif        0.339374701 0.69631754
## Technicien (OS)      0.001907526 0.13077812
## Ingénieur            0.010551784 0.23858051
## Technicien supérieur 0.008581306 0.01486844
## Direction            0.001196679 0.11063651
## Contractuel S1       0.015550104 0.06466957
## Contractuel S2       0.120511589 0.02058400

Les contributions ne sont pas les mêmes, ce qui est bizarre.

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

afd <- CA(kij)

On voit malheureusement que les H sont plus proches de certaines metiers et de même pour les F, respectivement Direction, ingénieur, Contractuel S1, Technicien et technicien supérieur, et Administratif. Contractuel S2 semble étre sur la mediatrice.

pander(afd$col$contrib,
       caption = "Contribution de chaque colonne aux axes factoriels", digit = 2)

Contribution de chaque colonne aux axes factoriels
	Dim 1	Dim 2
Non répondu	67	15
Administratif	23	46
Technicien (OS)	0.13	8.7
Ingénieur	0.7	16
Technicien supérieur	0.57	0.99
Direction	0.08	7.4
Contractuel S1	1	4.3
Contractuel S2	8	1.4

On voit que les non répondu contribuent trés trés fortement aux 1er axe, et Administratif trés fortement à celui du 2eme axe.

Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

library('readxl')
X <- read_excel("TP_AFC_majeur1718_travail.xlsx", na=" ")
X$id <- NULL
X$`Sexe` <- NULL
X$`Qualite vie` <- NULL
#write_xlsx(X, "AFC_2_var.xlsx")

#Tableau de contingence

#Tableau de contingence
contingence <- table(X$'temps travail', X$Fonction)

# Renommer les lignes et les colonnes
rownames(contingence) <- c("égalité", "inferieur", "sous chargé", "sur chargé", "non_repondu")
colnames(contingence) <- c("Non répondu", "Administratif", "Technicien (OS)",
                           "Ingénieur", "Technicien supérieur", "Direction",
                           "Contractuel S1", "Contractuel S2")
#on prefere le format DF
kij <- as.data.frame.matrix(contingence)
pander(kij)

Table continues below
	Non répondu	Administratif	Technicien (OS)	Ingénieur
égalité	0	32	21	15
inferieur	0	10	7	11
sous chargé	0	1	0	1
sur chargé	0	19	7	44
non_repondu	8	10	1	2

Table continues below
	Technicien supérieur	Direction	Contractuel S1
égalité	7	0	8
inferieur	5	2	3
sous chargé	1	0	0
sur chargé	9	5	6
non_repondu	1	0	1

	Contractuel S2
égalité	2
inferieur	0
sous chargé	0
sur chargé	6
non_repondu	3

Avant de faire ACF : test du khi2 pour vérifier si il y a un lien significatif entre les deux variables catégorielles :

chisq.test(kij)

## Warning in chisq.test(kij): Chi-squared approximation may be incorrect

## 
##  Pearson's Chi-squared test
## 
## data:  kij
## X-squared = 120.62, df = 28, p-value = 1.824e-13

Le test est significatif, on peut continuer l’analyse.

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

afd <- CA(kij)

On voit malheureusement comme on s’y attend que les métier de direction, ingenieur sont proche de sur chargé. Celui de technicien supérieur plutot vers sous chargé et inférieur.

pander(afd$col$contrib,
       caption = "Contribution de chaque colonne aux axes factoriels", digit = 2)

Contribution de chaque colonne aux axes factoriels ### On voit que les non répondu contribuent trés trés fortement aux 1er axe, et technicien et ingénieur fortement à celui du 2eme axe, technciicen supérieur au 3eme (axe des sous chargé) et Directeur aux 4eme (axe des sur chargé)
	Dim 1	Dim 2	Dim 3	Dim 4
Non répondu	82	1.4	2.3	4.7
Administratif	1.6	13	0.0012	8.9
Technicien (OS)	1.9	32	2	14
Ingénieur	7.2	33	2.2	0.36
Technicien supérieur	1.3	0.11	60	9.9
Direction	1.5	11	3.6	48
Contractuel S1	0.45	2.3	3.4	4.5
Contractuel S2	3.7	6.4	27	9.7

Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

library('readxl')
X <- read_excel("TP_AFC_majeur1718_travail.xlsx", na=" ")
X$id <- NULL
X$`Sexe` <- NULL
X$`Fonction` <- NULL
#write_xlsx(X, "AFC_2_var.xlsx")

Faire les transformations de données à partir des données fournies et du cours.

#Tableau de contingence

#Tableau de contingence
contingence <- table(X$`temps travail`, X$`Qualite vie`)

# Renommer les lignes et les colonnes
rownames(contingence) <- c("égalité", "inferieur", "sous chargé", "sur chargé", "non_repondu")
colnames(contingence) <- c("a été améliorée", "a été maintenue", "a été dégradée", "non_répondu")
#on prefere le format DF
kij <- as.data.frame.matrix(contingence)
pander(kij)

Table continues below
	a été améliorée	a été maintenue	a été dégradée
égalité	14	41	18
inferieur	6	16	14
sous chargé	0	1	2
sur chargé	7	47	37
non_repondu	0	5	5

	non_répondu
égalité	12
inferieur	2
sous chargé	0
sur chargé	5
non_repondu	16

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

afd <- CA(kij)

On voit malheureusement que les travailleurs sur chargés jugent que la qualité de vie au travail a été degradée comme on peut s’y attendre.

pander(afd$col$contrib,
       caption = "Contribution de chaque colonne aux axes factoriels", digit = 2)

Contribution de chaque colonne aux axes factoriels ## On voit que les non répondu contribuent trés trés fortement aux 1er axe, et “a été degradée” et “a été amelioré” trés fortement à celui du 2eme axe (axe des changement de qualité de vie) et le 3eme par “mainntenue” (axe des qualité de vie non changées)
	Dim 1	Dim 2	Dim 3
a été améliorée	3.2	53	32
a été maintenue	6.4	2.8	46
a été dégradée	4.7	44	21
non_répondu	86	0.11	0.1

Peut on traiter plusieurs modalités ?

oui mais il faudrait faire donc de l’ACM.

TP_AFC_R_MARKDOWN

2023-11-04

Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

Faire les transformations de données à partir des données fournies et du cours.

Calculer le tableau des fréquences relatives

Ajout des marges au tableau de fréquences relatives

Calcul des profils lignes (version matricielle)

Interpretation exemple : 4,9% des personnes en poste de Direction sont des H et 0,99% des F.

Autre exemple : 39% des personnes ingénieurs sont H contre 18% pour les F

Calcul du profil ligne moyen

Interpretation : 3,2% des personnes n’ont pas répondu

29% des personnes sont en poste Administratif

7,3% des personnes sont Contractuel S1

Calcul des profils colonnes (matriciel)

Calcul du profil colonne moyen

Interpretation : 1% des personnes n’ont pas répondu, 49% sont des F et 41% des H

Comme on va le voir : la dépendance entre les variables sera fonction de la distance entre les colonnes.

Distance (on choisit de travailler avec la distance du chi2) entre les lignes 1 et 2 et entre les lignes 1 et 3

La distance euclidienne entre les lignes 1 “Non répondu” et 2 “H” est de 0.16.

La distance euclidienne entre les lignes 1 “Non répondu” et 3 “F” est de 0.46.

La distance du χ2 est de 3,9 entre les lignes 1 et 2.

La distance du χ2 est de 4.8 entre les lignes 1 et 3.

On peut interpréter ces valeurs ainsi: les personnes qui n’ont pas répondu ont des métier qui ressemblent davantage à ceux des personnes H qu’à ceux F.

Calcul des fréquences attendues sous l’indépendance

Calcul de la statistique du test et Calcul des degrés de liberté

La valeur de la statistique de test est Z2 = 146.1813 et le nombre de degrés de liberté est de (n-1)(p-1) = 14. Sous l’indépendance, cette statistique suit une distribution du X2 avec 14 ddl.

Calcul de la p-valeur

Puisque la pvalue du test est inférieur au seuil fixée à 5%, on peut conclure que le SEXE et la FONCTION ne sont pas indépendants.

Cependant, ce test permet de supposer qu’il y a un lien entre les 2 variables sans nous en dire d’avantage sur le lien.

Analyse directe

pb : S non diag dans R

Valeurs et vecteurs propres de S (analyse directe)

On peut représenter les profils-lignes sur les deux dimensions de l’analyse des correspondances:

On a 3 axe non négligeable seulement. Ensuite quasi nul. Coude pour le 3eme axe.

On passe au dessus de 80% d’inertie cumulée pour k=2

On peut prendre k=3 au vue du graphique

Pour la suite on represente en 2D donc k=2.

Matrice dont on cherche les vecteurs propres dans l’analyse directe

Ici on n’a que 3 au maximum. On peut prendre k=2 comme dans la suite par exemple.

Comparaison avec FactoMineR

Comparaison des coordonnées Col

Comparaison des coordonnées Ligne

Nos résultats ne sont pas les mêmes, il nous manque d’appliquer les relations de passage, mais on n’obtient pas les mêmes resultats aussi. Il doit y avoir un problème de code quelque part.

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

COMPARAISON avec CA

Ce sont les mêmes résultats entre FROM SCRATCH AFC ET AC

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

Ce sont les mêmes résultats entre FROM SCRATCH AFC ET AC

Heatmap contribution à l’inertie des axes cas LIGNE

Heatmap contribution à l’inertie des axes cas COLONNE

Les contributions ne sont pas les mêmes, ce qui est bizarre.

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

On voit malheureusement que les H sont plus proches de certaines metiers et de même pour les F, respectivement Direction, ingénieur, Contractuel S1, Technicien et technicien supérieur, et Administratif. Contractuel S2 semble étre sur la mediatrice.

On voit que les non répondu contribuent trés trés fortement aux 1er axe, et Administratif trés fortement à celui du 2eme axe.

Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

Avant de faire ACF : test du khi2 pour vérifier si il y a un lien significatif entre les deux variables catégorielles :

Le test est significatif, on peut continuer l’analyse.

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

On voit malheureusement comme on s’y attend que les métier de direction, ingenieur sont proche de sur chargé. Celui de technicien supérieur plutot vers sous chargé et inférieur.

Importer les données

On s’interesse aux 2 premieres colonne : SEXE et FONCTION

Faire les transformations de données à partir des données fournies et du cours.

Utilsation de FactoMineR pour aller plus loin que avec FROM SCRATCH

On voit malheureusement que les travailleurs sur chargés jugent que la qualité de vie au travail a été degradée comme on peut s’y attendre.

Peut on traiter plusieurs modalités ?

oui mais il faudrait faire donc de l’ACM.