Série3 Masters S3 20-21 USMBA

Les packages requis

> require(FactoMineR)
> require(factoextra)
> require(LeLogicielR) # je crois que ce package n'existe plus sur le CRAN. On peut s'en passer.

Exercice 0

Enoncé :

Soit la base de données suivante :

Individu	Revenu	Habitat
1	RM	VILLE
2	RM	AGGLOM
3	RPF	CAMPAGNE
4	RPE	VILLE
5	RM	AGGLOM
6	RM	VILLE
7	RPF	AGGLOM
8	RPE	AGGLOM
9	RPF	VILLE
10	RPF	CAMPAGNE
11	RPE	CAMPAGNE
12	RPE	VILLE
13	RPE	VILLE
14	RPF	CAMPAGNE
15	RM	CAMPAGNE

1. Saisir la base de données sous Excel sous le nom : bd.xlsx
2. Convertir le fichier « bd.xlsx » en « bd.csv ».
3. Importer « bd.csv » sous R et nommer le « bd ».
4. Utiliser la fonction «table» de R pour convertir «bd» en un Tableau de contingence et nommer le «TC».
5. Vérifier, par une fonction de R, que l’effectif de TC est bien 15.
6. Convertir TC en un Tableau de fréquence que vous nommerez « TCF ».
7. Ajouter les marges (qu’on nommera « poids ») à TCF et nommer le tableau résultant « TCFM ».

Réponse 0 :

Questions 1-2-3

Importation des Données

> (bd <- read.csv2("C:/Users/serie3-FCA-MAC-21-22/EX0-Ser-3.csv",row.names=1))# ex0-ser-3.csv

Question 4

Tableau de contingence

> (TC <- table(bd))

##       Habitat
## Revenu AGGLOM CAMPAGNE VILLE
##    RM       2        1     2
##    RPE      1        1     3
##    RPF      1        3     1

Question 5

Effectif Total de l’échantillon

> (n <- sum(TC))

## [1] 15

Question 6

Tableau des fréquences

> (TCF <- TC/n)

##       Habitat
## Revenu     AGGLOM   CAMPAGNE      VILLE
##    RM  0.13333333 0.06666667 0.13333333
##    RPE 0.06666667 0.06666667 0.20000000
##    RPF 0.06666667 0.20000000 0.06666667

Question 7

Tableau des fréquences avec marges poids

> poids <- sum
> (TCFM <- addmargins(TCF,FUN=poids))

## Margins computed over dimensions
## in the following order:
## 1: Revenu
## 2: Habitat

##        Habitat
## Revenu      AGGLOM   CAMPAGNE      VILLE      poids
##   RM    0.13333333 0.06666667 0.13333333 0.33333333
##   RPE   0.06666667 0.06666667 0.20000000 0.33333333
##   RPF   0.06666667 0.20000000 0.06666667 0.33333333
##   poids 0.26666667 0.33333333 0.40000000 1.00000000

Exercice 1

Enoncé :

Soit le tableau suivant croisant les variables REVENU et HABITAT (où les modalités RPE, RM et RPF désignent respectivement Revenu Plutôt Elevé, Revenu Moyen et Revenu Plutôt Faible) :

	CAMPAGNE	AGGLOMERATION	VILLES
RPE	80	120	200
RM	100	300	100
RPF	300	220	180

1. Qu’appelle-t-on ce type de tableau ?

2. Combien d’axes proposez-vous de retenir pour résumer ces données ? Justifier.

3. Calculer les inerties associées aux 2 premiers axes. Peut-on dire que l’un des axes est l’axe des REVENUS ? Justifier

4. Calculer l’inertie Totale \(\phi ^2\). En déduire la statistique de khi-deux \(\chi ^2\)

5. Quels sont les individus(modalités revenus) qui contribuent le plus à la formation de l’axe \(F^2\) ?

6. Interpréter globalement le mapping de la Question 3.

Réponse 1 :

Question 1

Ce tableau croisant deux variables qualitatives est un Tableau de Contingence.

Question 2

> rev=read.csv2("C:/Users/serie3-FCA-MAC-21-22/ex1-ser-3.csv",row.names=1) # ex1-ser-3.csv
> rev

> (n <- sum(rev)) # effectif total

## [1] 1600

> (nr <- dim(rev)[1]) # nb de modalités lignes

## [1] 3

> (nc <- dim(rev)[2]) # nb de modalités colonnes

## [1] 3

1. Le nombre Total d’axes d’inerties non nulles est dans le cas d’un TC égal à \(inf(nr-1,nc-1)=inf(3-1,3-1)=\) \(2\).

2. Le nombre d’axes à retenir :

Nous avons besoin d’abord de lancer l’afc sur les données rev :

> rev.afc=CA(rev)

> summary(rev.afc)

## 
## Call:
## CA(X = rev) 
## 
## The chi square of independence between the two variables is equal to 215.7143 (p-value =  1.567094e-45 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2
## Variance               0.076   0.058
## % of var.             56.631  43.369
## Cumulative % of var.  56.631 100.000
## 
## Rows
##                 Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2  
## RPE           |    47.917 |  0.263 22.727  0.362 | -0.350 52.273  0.638 |
## RM            |    52.083 | -0.403 66.470  0.974 | -0.065  2.280  0.026 |
## RPF           |    34.821 |  0.137 10.803  0.237 |  0.246 45.447  0.763 |
## 
## Columns
##                 Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2  
## CAMPAGNE      |    42.857 |  0.166 10.780  0.192 |  0.340 59.220  0.808 |
## AGGLOMERATION |    45.536 | -0.334 58.464  0.980 | -0.047  1.536  0.020 |
## VILLES        |    46.429 |  0.280 30.755  0.506 | -0.277 39.245  0.494 |

> M <- rbind(rev,apply(rev,2,sum))  # la somme de chaque ligne
> rownames(M)[4] <- "profil moyen"  # ajouter un nom à cette ligne
> round(prop.table(as.matrix(M),margin=1),3)

##              CAMPAGNE AGGLOMERATION VILLES
## RPE             0.200         0.300  0.500
## RM              0.200         0.600  0.200
## RPF             0.429         0.314  0.257
## profil moyen    0.300         0.400  0.300

Axes	\(F^1\)	\(F^2\)
Inertie	\(\lambda_1=0.0763504\)	\(\lambda_2=0.058471\)

Mais on ne retient qu’un seul axe vu que seulement \(\lambda_1 \geq\bar{\lambda}\). Dans ce cas on est obligé de prendre le deuxième axe pour former un plan.

Autre Méthode pour le choix des axes :

> seuil <- mean(rev.afc$eig[,1])
> i0 <- which(rev.afc$eig[,1]>=seuil) # les n° des axes dont les val-propres >= seuil
> if(length(i0)==1) {
+ lambda <- data.frame(rev.afc$eig[1:2,1]) # réecrire comme data.frame pour pouvoir ajouter les noms (lignes et colonnes)
+ print("Kaiser nous permet de retenir le 1er axe, mais on sera contraint de prendre le 2 ème :")  
+ 
+ names(lambda) <- " Les axes à retenir" # ajout nom de la colonne 
+ row.names(lambda) <- paste("F",c(i0,2),sep="") # ajout noms des lignes (les components)
+ lambda
+ } else {
+ lambda <- data.frame(rev.afc$eig[i0,1])
+ names(lambda) <- paste("Kaiser nous a permis de retenir les",length(i0),"axes suivants :")
+ row.names(lambda) <- paste("F",i0,sep="")
+ lambda}    

## [1] "Kaiser nous permet de retenir le 1er axe, mais on sera contraint de prendre le 2 ème :"

Il y a une autre méthode dite méthode de l’ebouli des valeurs propres. Dans notre cas, cette méthode ne donne pas grand chose vu que l=k=3 :

> fviz_eig(rev.afc, addlabels = TRUE, ylim = c(0, rev.afc$eig[1,2]))

Question 3

Oui en effet, les modalités Revenu s’échelonnent (en les projettant) selon l’axe \(F^2\) de la modalité RPF à la modalité RPEen transitant par RM.

Question 4

L’inertie totale est la somme des valeurs propres : \[\phi^2=I_T=\sum_{k=1}^2 I(F^k)=0.1348214\] ce qui implique que le chi-deux est égal à \[\chi ^2 = n\times\phi^2=1600\times 0.1348214=215.7142857\], ou directement par le test de chi-deux : 215.7142857.

Question 5

On peut présenter plusieurs méthodes :
1. Les modalités les plus contributives, dans le cas de l’afc sont celles dont la contribution dépasse le poids :

\(C_i^k\geq f_{i\,\bullet}\;\) ce qui est equivaut à \(\frac{f_{i\,\bullet}\times (F_{i}^{k})^2}{\lambda_k}\geq f_{i\,\bullet}\Rightarrow\) \(|F_i^k|=|coord_i^k|\geq \sqrt{\lambda_k}\).

> tab <- data.frame(cbind(rev.afc$call$marge.row*100,rev.afc$row$coord[,2],rev.afc$row$contrib[,2]))
> names(tab) <- c("Poids", "Coord","Ctr2")
> tab

2. La modalité RPE est sélectionnée négativement et la modalité RPF positivement; en effet, d’une part \(\sqrt{\lambda_2}=0.2418078\) :

> (seuil2 <- rev.afc$svd$vs[2]) # racine de lambda 2

## [1] 0.2418078

D’autre part on a les coordonnées :

> rev.afc$row$coord[,2]

##         RPE          RM         RPF 
## -0.34965505 -0.06531033  0.24645313

> (val.coord2 <- abs(rev.afc$row$coord[,2]))

##        RPE         RM        RPF 
## 0.34965505 0.06531033 0.24645313

> (ordr.decroi <- sort(val.coord2,decreasing=TRUE))

##        RPE        RPF         RM 
## 0.34965505 0.24645313 0.06531033

> barplot(ordr.decroi,col="cyan",las=2,main="La Contribution des profils-lignes à F2")
> abline(h=seuil2,lty=2,lwd=1.3,col=2)
> fleches()

Contribution des lignes à la Dim 2

sign-Contrib	Négatif	Psitif
\(F^2\)	RPE	RPF

On peut aussi trouver la même chose avec factoextra mais en comparant à la moyenne des contributions soit \(1/3\times 100=33\%\) :

require(factoextra)
fviz_contrib(rev.afc, choice="row",axes=c(2,2))

Question 6

Tous les points lignes et colonnes sont dans le plan. Les RMsont attirés par les agglomérations et ont tendance à fuire la campagneet la Ville, alors que les RPFpréfèrent la campagne et les RPEfréquentent les villes.

Remarque

On a une variable ordinale (ou d’échelle) qui peut créer un effet Guttman. C’est le cas ici, puisqu’on a une forme parabolique du nuage :

> plot(rev.afc$col$coord[,1:2],xlim=c(-.5,.5),ylim=c(-.5,.5))
> text(rev.afc$col$coord[,1:2],pos=3,paste(row.names(rev.afc$col$coord)),cex=.7,col=2)
> text(rev.afc$col$coord[,1:2],pos=1,paste(round(rev.afc$col$contrib[,1],1)),cex=.7,col=2)
> text(rev.afc$row$coord[,1:2],pos=2,paste(row.names(rev.afc$row$coord)),cex=.7,col=4)
> text(rev.afc$row$coord[,1:2],pos=1,paste(round(rev.afc$row$contrib[,1],1)),cex=.7,col=4)
> abline(h=0,v=0, col=3)
> text(0,0,"G",col="magenta",pos=4)
> lines(rev.afc$col$coord[,1:2],type="h",lty=2,col="gray")
> lines(rev.afc$row$coord[,1:2],type="l",col="blue",lwd=2)

D’après le graphique ci-dessus, l’axe \(F^1\) oppose la classe des extrêmes (riches et pauvres) à la classe des moyens. Par contre, l’axe \(F^2\) oppose les extrêmes entre eux (les riches aux pauvres).

Exercice 2

Enoncé¹ :

Un chirurgien a effectué des opérations de la main sur 698 patients âgés de 20 à 90 ans et a noté par MAUVAIS, MOYEN, BON ou EXCELLENT le résultat de l’opération sur chacun des patients. On convient de désigner les classes d’âges d’une largeur de \(10\,ans\) par leur centre, on aura \(7\,centres\) (\(C_i\)) :

	EXCELLENT	BON	MOYEN	MAUVAIS
C25	16	6	0	1
C35	59	27	4	4
C45	63	39	10	3
C55	150	52	11	6
C65	89	33	7	5
C75	54	16	7	5
C85	20	6	4	1

1) Compléter le tableau ci-dessus par ses marges. Vérifier l’effectif total. Ecrire le tableau des fréquences (au cent-millième près), calculer les fréquences marginales, la matrice centrée des fréquences, le tableau des profils-lignes du \(N_I\) et celui des profils-colonnes du \(N_j\). Indiquer les poids des points des deux nuages.

2) Calculer les inerties associées aux 3 axes. Peut-on dire que l’un des axes est l’axe des âges ?

3) Les 3 points EXCELLENT, C55 et C65 sont voisins sur l’axe 1, peut-on dire qu’il ya une bonne corrélation entre l’âge moyen des 50 à 70 ans et la qualité excellente de résultat de l’opération ? Ecrire l’équation des coordonnées barycentriques de EXCELLENT par rapport aux 7 classes d’âges. Cette équation confirme-t-elle le résultat précèdent ?

4) Même question pour MOYEN.

Réponse 2 :

Question 1

On commence par importer le Tableau de Contingence puis lui ajouter les marges et le diviser par n pour avoir la matrice des fréquences et en même temps les marges lignes et colonnes. Travail qu’on peut faire aussi en lançant l’analyse factorielle des correspondances CA :

1.

> chir <- read.csv2("C:/Users/serie3-FCA-MAC-21-22/ex2-ser-3.csv",row.names=1)
> (n <- sum(chir))

## [1] 698

donc l’effectif total est 698.

2.

> poids <- sum
> (M <- addmargins(as.matrix(chir),FUN=poids))

## Margins computed over dimensions
## in the following order:
## 1: 
## 2:

##       EXCELLENT BON MOYEN MAUVAIS poids
## C25          16   6     0       1    23
## C35          59  27     4       4    94
## C45          63  39    10       3   115
## C55         150  52    11       6   219
## C65          89  33     7       5   134
## C75          54  16     7       5    82
## C85          20   6     4       1    31
## poids       451 179    43      25   698

> (MF <- round(M/n,5))  #   Matrice des fréquences

##       EXCELLENT     BON   MOYEN MAUVAIS   poids
## C25     0.02292 0.00860 0.00000 0.00143 0.03295
## C35     0.08453 0.03868 0.00573 0.00573 0.13467
## C45     0.09026 0.05587 0.01433 0.00430 0.16476
## C55     0.21490 0.07450 0.01576 0.00860 0.31375
## C65     0.12751 0.04728 0.01003 0.00716 0.19198
## C75     0.07736 0.02292 0.01003 0.00716 0.11748
## C85     0.02865 0.00860 0.00573 0.00143 0.04441
## poids   0.64613 0.25645 0.06160 0.03582 1.00000

Les profils moyens lignes et colonnes

> MF[8,-5] #  le (-) afin d'enlever la marge

## EXCELLENT       BON     MOYEN   MAUVAIS 
##   0.64613   0.25645   0.06160   0.03582

> MF[-8,5] #  le (-) afin d'enlever la marge

##     C25     C35     C45     C55     C65     C75     C85 
## 0.03295 0.13467 0.16476 0.31375 0.19198 0.11748 0.04441

3.

> (MT <- round(MF[-8,5]%*%t(MF[8,-5]),5)) # afin d'enlever les marges

##      EXCELLENT     BON   MOYEN MAUVAIS
## [1,]   0.02129 0.00845 0.00203 0.00118
## [2,]   0.08701 0.03454 0.00830 0.00482
## [3,]   0.10646 0.04225 0.01015 0.00590
## [4,]   0.20272 0.08046 0.01933 0.01124
## [5,]   0.12404 0.04923 0.01183 0.00688
## [6,]   0.07591 0.03013 0.00724 0.00421
## [7,]   0.02869 0.01139 0.00274 0.00159

> (Z <- MF[-8,-5]-MT) # afin d'enlever les marges

##     EXCELLENT      BON    MOYEN  MAUVAIS
## C25   0.00163  0.00015 -0.00203  0.00025
## C35  -0.00248  0.00414 -0.00257  0.00091
## C45  -0.01620  0.01362  0.00418 -0.00160
## C55   0.01218 -0.00596 -0.00357 -0.00264
## C65   0.00347 -0.00195 -0.00180  0.00028
## C75   0.00145 -0.00721  0.00279  0.00295
## C85  -0.00004 -0.00279  0.00299 -0.00016

ou en utilisant le Test de khi-deux \(\chi^2\) :

> k <- chisq.test(chir);k

## 
##  Pearson's Chi-squared test
## 
## data:  chir
## X-squared = 17.136, df = 18, p-value = 0.5138

On voit que le Test de khi-deux n’est pas significatif (p-value=0.5137735) mais ce n’est pas une raison pour arrêter l’exploration des données.

str(k)

## List of 9
##  $ statistic: Named num 17.1
##   ..- attr(*, "names")= chr "X-squared"
##  $ parameter: Named int 18
##   ..- attr(*, "names")= chr "df"
##  $ p.value  : num 0.514
##  $ method   : chr "Pearson's Chi-squared test"
##  $ data.name: chr "chir"
##  $ observed : int [1:7, 1:4] 16 59 63 150 89 54 20 6 27 39 ...
##   ..- attr(*, "dimnames")=List of 2
##   .. ..$ : chr [1:7] "C25" "C35" "C45" "C55" ...
##   .. ..$ : chr [1:4] "EXCELLENT" "BON" "MOYEN" "MAUVAIS"
##  $ expected : num [1:7, 1:4] 14.9 60.7 74.3 141.5 86.6 ...
##   ..- attr(*, "dimnames")=List of 2
##   .. ..$ : chr [1:7] "C25" "C35" "C45" "C55" ...
##   .. ..$ : chr [1:4] "EXCELLENT" "BON" "MOYEN" "MAUVAIS"
##  $ residuals: num [1:7, 1:4] 0.295 -0.223 -1.311 0.714 0.26 ...
##   ..- attr(*, "dimnames")=List of 2
##   .. ..$ : chr [1:7] "C25" "C35" "C45" "C55" ...
##   .. ..$ : chr [1:4] "EXCELLENT" "BON" "MOYEN" "MAUVAIS"
##  $ stdres   : num [1:7, 1:4] 0.505 -0.403 -2.412 1.45 0.486 ...
##   ..- attr(*, "dimnames")=List of 2
##   .. ..$ : chr [1:7] "C25" "C35" "C45" "C55" ...
##   .. ..$ : chr [1:4] "EXCELLENT" "BON" "MOYEN" "MAUVAIS"
##  - attr(*, "class")= chr "htest"

k$observed

##     EXCELLENT BON MOYEN MAUVAIS
## C25        16   6     0       1
## C35        59  27     4       4
## C45        63  39    10       3
## C55       150  52    11       6
## C65        89  33     7       5
## C75        54  16     7       5
## C85        20   6     4       1

k$expected

##     EXCELLENT       BON     MOYEN   MAUVAIS
## C25  14.86103  5.898281  1.416905 0.8237822
## C35  60.73639 24.106017  5.790831 3.3667622
## C45  74.30516 29.491404  7.084527 4.1189112
## C55 141.50287 56.161891 13.491404 7.8438395
## C65  86.58166 34.363897  8.255014 4.7994269
## C75  52.98281 21.028653  5.051576 2.9369628
## C85  20.03009  7.949857  1.909742 1.1103152

sum(k$expected)   # = n effectif total

## [1] 698

round(k$expected/n,5) # MT

##     EXCELLENT     BON   MOYEN MAUVAIS
## C25   0.02129 0.00845 0.00203 0.00118
## C35   0.08701 0.03454 0.00830 0.00482
## C45   0.10645 0.04225 0.01015 0.00590
## C55   0.20273 0.08046 0.01933 0.01124
## C65   0.12404 0.04923 0.01183 0.00688
## C75   0.07591 0.03013 0.00724 0.00421
## C85   0.02870 0.01139 0.00274 0.00159

ou encore en utilisant FactoMineR :

> chir.ca <- CA(chir)

> plot(chir.ca,invisible = "col")

> summary(chir.ca)

## 
## Call:
## CA(X = chir) 
## 
## The chi square of independence between the two variables is equal to 17.13601 (p-value =  0.5137735 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3
## Variance               0.012   0.010   0.003
## % of var.             49.680  39.408  10.912
## Cumulative % of var.  49.680  89.088 100.000
## 
## Rows
##             Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3
## C25       |     2.212 | -0.183  9.082  0.501 | -0.173 10.185  0.446 |  0.060
## C35       |     1.533 | -0.005  0.029  0.002 | -0.086 10.346  0.653 |  0.063
## C45       |     9.011 |  0.229 70.744  0.958 | -0.048  3.949  0.042 |  0.001
## C55       |     2.453 | -0.067 11.438  0.569 | -0.019  1.171  0.046 | -0.055
## C65       |     0.460 | -0.047  3.541  0.939 | -0.012  0.269  0.057 |  0.003
## C75       |     4.904 | -0.044  1.866  0.046 |  0.182 40.200  0.793 |  0.082
## C85       |     3.979 |  0.095  3.300  0.101 |  0.272 33.880  0.824 | -0.082
##              ctr   cos2  
## C25        4.422  0.054 |
## C35       19.726  0.345 |
## C45        0.013  0.000 |
## C55       35.262  0.385 |
## C65        0.067  0.004 |
## C75       29.370  0.160 |
## C85       11.139  0.075 |
## 
## Columns
##             Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3
## EXCELLENT |     3.516 | -0.071 26.398  0.916 |  0.011  0.797  0.022 | -0.018
## BON       |     7.820 |  0.127 34.179  0.533 | -0.118 36.807  0.455 |  0.019
## MOYEN     |     9.829 |  0.268 36.413  0.452 |  0.294 55.028  0.542 | -0.032
## MAUVAIS   |     3.385 | -0.101  3.010  0.108 |  0.141  7.369  0.211 |  0.254
##              ctr   cos2  
## EXCELLENT  8.192  0.062 |
## BON        3.370  0.012 |
## MOYEN      2.398  0.007 |
## MAUVAIS   86.040  0.681 |

> chir.ca$call$marge.row

##        C25        C35        C45        C55        C65        C75        C85 
## 0.03295129 0.13467049 0.16475645 0.31375358 0.19197708 0.11747851 0.04441261

> chir.ca$call$marge.col

##  EXCELLENT        BON      MOYEN    MAUVAIS 
## 0.64613181 0.25644699 0.06160458 0.03581662

> (MT <- round(chir.ca$call$marge.row%*%t(chir.ca$call$marge.col),5))

##      EXCELLENT     BON   MOYEN MAUVAIS
## [1,]   0.02129 0.00845 0.00203 0.00118
## [2,]   0.08701 0.03454 0.00830 0.00482
## [3,]   0.10645 0.04225 0.01015 0.00590
## [4,]   0.20273 0.08046 0.01933 0.01124
## [5,]   0.12404 0.04923 0.01183 0.00688
## [6,]   0.07591 0.03013 0.00724 0.00421
## [7,]   0.02870 0.01139 0.00274 0.00159

4. Profils lignes et colonnes centrés :

d’abords calculons les matrices des produits scalaires \(Q=D_k^{-1}\) et \(P=D_l^{-1}\)

> (Q <- Dk.1 <- round(solve(diag(chir.ca$call$marge.col)),5))

##         [,1]    [,2]     [,3]  [,4]
## [1,] 1.54767 0.00000  0.00000  0.00
## [2,] 0.00000 3.89944  0.00000  0.00
## [3,] 0.00000 0.00000 16.23256  0.00
## [4,] 0.00000 0.00000  0.00000 27.92

> (P <- Dl.1 <- round(solve(diag(chir.ca$call$marge.row)),5))

##          [,1]    [,2]    [,3]    [,4]    [,5]   [,6]     [,7]
## [1,] 30.34783 0.00000 0.00000 0.00000 0.00000 0.0000  0.00000
## [2,]  0.00000 7.42553 0.00000 0.00000 0.00000 0.0000  0.00000
## [3,]  0.00000 0.00000 6.06957 0.00000 0.00000 0.0000  0.00000
## [4,]  0.00000 0.00000 0.00000 3.18721 0.00000 0.0000  0.00000
## [5,]  0.00000 0.00000 0.00000 0.00000 5.20896 0.0000  0.00000
## [6,]  0.00000 0.00000 0.00000 0.00000 0.00000 8.5122  0.00000
## [7,]  0.00000 0.00000 0.00000 0.00000 0.00000 0.0000 22.51613

> (profr.centr <- P %*% Z)

##          EXCELLENT          BON        MOYEN      MAUVAIS
## [1,]  0.0494669629  0.004552175 -0.061606095  0.007586957
## [2,] -0.0184153144  0.030741694 -0.019083612  0.006757232
## [3,] -0.0983270340  0.082667543  0.025370803 -0.009711312
## [4,]  0.0388202178 -0.018995772 -0.011378340 -0.008414234
## [5,]  0.0180750912 -0.010157472 -0.009376128  0.001458509
## [6,]  0.0123426900 -0.061372962  0.023749038  0.025110990
## [7,] -0.0009006452 -0.062820003  0.067323229 -0.003602581

> (profc.centr <- Z %*% Q)

##              [,1]         [,2]        [,3]       [,4]
## C25  0.0025227021  0.000584916 -0.03295210  0.0069800
## C35 -0.0038382216  0.016143682 -0.04171768  0.0254072
## C45 -0.0250722540  0.053110373  0.06785210 -0.0446720
## C55  0.0188506206 -0.023240662 -0.05795024 -0.0737088
## C65  0.0053704149 -0.007603908 -0.02921861  0.0078176
## C75  0.0022441215 -0.028114962  0.04528884  0.0823640
## C85 -0.0000619068 -0.010879438  0.04853535 -0.0044672

\[\begin{eqnarray} Excellent(F^1)& = & \dfrac{1}{\sqrt{0,012}}\left[C_{25}F^1 \times 0,00252+C_{35}F^1\times -0,00385+C_{45}F^1\times -0,02507\right.\\ &\;&+ C_{55}F^1\times 0,01884+C_{65}F^1\times 0,00535+C_{75}F^1 \times 0,00226+C_{85}F^1\times -0,00006]\\ & = & 9.13\times[-0.0005+0-\underline{\bf 0.00575}-0.0013-0.0003-0.0001+0.0-0.000…] \end{eqnarray}\]

Donc excellent est dû à C45 (grâce à son coefficient \(0.0057\)) et non à C55 et C65.

Pour Moyen :
\[\begin{eqnarray} Moyen(F^1)& = & \dfrac{1}{\sqrt{0,012}}\left[C_{25}F^1\times -0,003295+ …+ C_{85}F^1\times -0,04854\right]\\ & = & 0,11\times \left[-0.006+0.002+\underline{\bf 0.0155}+0.0039+0.0014-0.002+0.0046\right] \end{eqnarray}\]

même chose que précédemment. C’est NORMAL !

Exercice 3

Enoncé² :

Considérons \(18282\) individus pour lesquels on connaît la CSP (modalités agriculteur AGRI, cadre supérieur CADR, inactif INAC, et ouvrier OUVR) et le choix de l’hébergement pour les vacances HEB (modalités camping CAMP, HOTEL, location LOCA, et résidence secondaire RESI). Les résultats sont présentés comme suit :

CSP	CAMP	HOTEL	LOCA	RESI
AGRI	239	155	129	0
CADR	1003	1556	1821	1521
INAC	682	1944	967	1333
OUVR	2594	1124	2176	1038

1) Quelle méthode proposez-vous pour étudier la nature de la liaison entre la CSP et le HEB ? Justifier.

2) Calculer les tableaux des profils-ligne et des profils-colonne.

3) A partir de l’un des tableaux ci-dessus, interpréter la valeur 0,391.

4) Combien d’axes proposez-vous de retenir pour résumer ces données ? Justifier.

5) Calculer l’inertie Totale \(\phi^2\). En déduire la statistique de \(\chi^2\).

6) Quelle sont les points lignes (respt colonnes) dont la contribution, aux deux premiers axes, est supérieure à la moyenne (ou poids) ? (utiliser un tableau avec les signes des coordonnées comme ci-contre :

les signes des coordonnées	-	+
\(F^1\)	?	?
\(F^2\)	?	?

7) Sur l’axe \(F^1\) , quelles sont les modalités lignes qui se ressemblent ?(voir mapping et cos2).

8) Déduire de la question 6) une interprétation du graphique ci-dessous « CA factor map ».

9) Pour aller plus loin, un des axes (\(F^1\) , \(F^2\)) décrit le type de vacances choisis alors que l’autre est celui des moyens financiers consacrés aux vacances. Interprétez.

Réponse 3 :

Question 1

Ce tableau croisant deux variables qualitatives est un Tableau de Contingence.

Question 2

On commence par importer le Tableau de Contingence puis lui ajouter les marges et le diviser par n pour avoir la matrice des fréquences et en même temps les marges lignes et colonnes :

1.

> csp <- read.csv2("C:/Users/serie3-FCA-MAC-21-22/ex3-ser-3.csv",row.names=1)
> (n <- sum(csp))

## [1] 18282

donc l’effectif total est 18282.

2.

> poids <- sum
> (M <- addmargins(as.matrix(csp),FUN=poids))

## Margins computed over dimensions
## in the following order:
## 1: 
## 2:

##       CAMP HOTEL LOCA RESI poids
## AGRI   239   155  129    0   523
## CADR  1003  1556 1821 1521  5901
## INAC   682  1944  967 1333  4926
## OUVR  2594  1124 2176 1038  6932
## poids 4518  4779 5093 3892 18282

> MF <- M/n
> round(MF,3)

##        CAMP HOTEL  LOCA  RESI poids
## AGRI  0.013 0.008 0.007 0.000 0.029
## CADR  0.055 0.085 0.100 0.083 0.323
## INAC  0.037 0.106 0.053 0.073 0.269
## OUVR  0.142 0.061 0.119 0.057 0.379
## poids 0.247 0.261 0.279 0.213 1.000

> (profr <- round(sweep(MF[-5,-5],1,MF[-5,5],"/"),3))

##       CAMP HOTEL  LOCA  RESI
## AGRI 0.457 0.296 0.247 0.000
## CADR 0.170 0.264 0.309 0.258
## INAC 0.138 0.395 0.196 0.271
## OUVR 0.374 0.162 0.314 0.150

> (profc <- round(sweep(MF[-5,-5],2,MF[5,-5],"/"),3))

##       CAMP HOTEL  LOCA  RESI
## AGRI 0.053 0.032 0.025 0.000
## CADR 0.222 0.326 0.358 0.391
## INAC 0.151 0.407 0.190 0.342
## OUVR 0.574 0.235 0.427 0.267

Question 3

\(39,1\%\) des vacanciers qui ont choisi resi sont des cadres.

Question 4

D’abord lançons la méthode de l’afc :

> csp.ca <- CA(csp)

> summary(csp.ca)

## 
## Call:
## CA(X = csp) 
## 
## The chi square of independence between the two variables is equal to 2067.911 (p-value =  0 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3
## Variance               0.098   0.014   0.001
## % of var.             86.855  12.256   0.889
## Cumulative % of var.  86.855  99.111 100.000
## 
## Rows
##         Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3    ctr
## AGRI  |    11.426 | -0.441  5.676  0.488 | -0.431 38.347  0.465 | -0.137 53.116
## CADR  |    11.878 |  0.140  6.430  0.532 |  0.129 38.451  0.449 | -0.027 22.841
## INAC  |    41.939 |  0.379 39.307  0.921 | -0.109 23.200  0.077 |  0.020 10.548
## OUVR  |    47.869 | -0.355 48.586  0.997 |  0.001  0.002  0.000 |  0.019 13.495
##         cos2  
## AGRI   0.047 |
## CADR   0.019 |
## INAC   0.003 |
## OUVR   0.003 |
## 
## Columns
##         Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3    ctr
## CAMP  |    50.528 | -0.443 49.372  0.960 | -0.088 13.714  0.038 |  0.022 12.201
## HOTEL |    32.729 |  0.325 28.056  0.842 | -0.139 36.594  0.155 | -0.019  9.210
## LOCA  |     9.394 | -0.130  4.822  0.504 |  0.124 30.953  0.457 | -0.036 36.367
## RESI  |    20.461 |  0.286 17.750  0.852 |  0.110 18.739  0.127 |  0.045 42.222
##         cos2  
## CAMP   0.002 |
## HOTEL  0.003 |
## LOCA   0.039 |
## RESI   0.021 |

Méthodes du Coude et de kaiser

1. Méthode du coude

> barplot(csp.ca$eig[,1], col="turquoise3",main="M.Coude")
> lines(csp.ca$eig[,1], col="violetred2",lwd=1.3)
> text(csp.ca$eig[,1], paste(round(csp.ca$eig[,3],1),"%"),col="blue",cex=1.5,pos=1)

L’ebouli des valeurs propres ne nous permet de retenir qu’un seul axe.

2. Méthode Méthode de kaiser

> lb <- mean(csp.ca$eig[,1])
> barplot(csp.ca$eig[,1], col="cyan",main="M.kaiser")
> abline(h=lb,lty=2,col=2)
> fleches()

Là aussi, on aboutit à la même conclusion.

Autre Méthode pour le choix des axes :

> seuil <- mean(csp.ca$eig[,1])
> i0 <- which(csp.ca$eig[,1]>=seuil) # les n° des axes dont les val-propres >= seuil
> if(length(i0)==1) {
+ lambda <- data.frame(csp.ca$eig[1:2,1]) # réecrire comme data.frame pour pouvoir ajouter les noms (lignes et colonnes)
+ print("Kaiser nous permet de retenir le 1er axe, mais on sera contraint de prendre le 2 ème :")  
+ 
+ names(lambda) <- " Les axes à retenir" # ajout nom de la colonne 
+ row.names(lambda) <- paste("F",c(i0,2),sep="") # ajout noms des lignes (les components)
+ lambda
+ } else {
+ lambda <- data.frame(csp.ca$eig[i0,1])
+ names(lambda) <- paste("Kaiser nous a permis de retenir les",length(i0),"axes suivants :")
+ row.names(lambda) <- paste("F",i0,sep="")
+ lambda}    

## [1] "Kaiser nous permet de retenir le 1er axe, mais on sera contraint de prendre le 2 ème :"

Question 5

L’inertie totale est la somme des valeurs propres : \[\phi^2=I_T=\sum_{k=1}^3 I(F^k)=0.1131119\] ce qui implique que le chi-deux est egal a \[\chi ^2 = n\times\phi^2=18282\times 0.1131119=2067.9111079\] ou directement par le test de chi-deux : 2067.9111079.

Question 6

Puisqu’il s’agit du cas qualitatif (des modalités), le seuil de contribution sera en fonction du poids (ici on prendra \(1\times poids\)) ou aussi \(|F^k_i|=|coord^k_i|≥\sqrt{λ_k}\).

Remarque

J’ai choisi de travailler avec la première condition(contrib. et poids) vu que la relation entre \(coord_{MCA}\) et \(coord_{CA}\) nous compliquera les calculs!

Extraction des modalités lignes les plus contributives sur l’axe 1

> seuil <- csp.ca$call$marge.row*100
> i <- which(csp.ca$row$contrib[,1] >= seuil)
> sel <- row.names(data.frame(csp.ca$row$contrib[i,1]))
> Tab <- data.frame(cbind(sign(csp.ca$row$coord[sel,1]),csp.ca$row$contrib[sel,1]))
> names(Tab) <- c("signe", "C.I.F1")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F1,decreasing = TRUE),]
> dfn <- Tabn[order(Tabn$C.I.F1,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

Extraction des modalités lignes les plus contributives sur l’axe 2

> seuil <- csp.ca$call$marge.row*100
> i <- which(csp.ca$row$contrib[,2] >= seuil)
> sel <- row.names(data.frame(csp.ca$row$contrib[i,2]))
> Tab <- data.frame(cbind(sign(csp.ca$row$coord[sel,2]),csp.ca$row$contrib[sel,2]))
> names(Tab) <- c("signe", "C.I.F2")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F2,decreasing = TRUE),]
> dfn <- Tabn[order(Tabn$C.I.F2,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

Extraction des modalités colonnes les plus contributives sur l’axe 1

> seuil <- csp.ca$call$marge.col*100
> i <- which(csp.ca$col$contrib[,1] >= seuil)
> sel <- row.names(data.frame(csp.ca$col$contrib[i,1]))
> Tab <- data.frame(cbind(sign(csp.ca$col$coord[sel,1]),csp.ca$col$contrib[sel,1]))
> names(Tab) <- c("signe", "C.I.F1")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F1,decreasing = TRUE),]
> dfn <-Tabn[order(Tabn$C.I.F1,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

Extraction des modalités colonnes les plus contributives sur l’axe 2

> i <- which(csp.ca$col$contrib[,2] >= seuil)
> sel <- row.names(data.frame(csp.ca$col$contrib[i,2]))
> Tab <- data.frame(cbind(sign(csp.ca$col$coord[sel,2]),csp.ca$col$contrib[sel,2]))
> names(Tab) <- c("signe", "C.I.F2")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F2,decreasing = TRUE),]
> dfn <-Tabn[order(Tabn$C.I.F2,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

Tableau récapulatif des contributions

Signes_Coord	Négatifs	Positifs
\(F^1\)	AGRI -OUVR - CAMP	INAC- HOT
\(F^2\)	AGRI - HOT	CADR - LOC

Question 7

Sur l’axe \(F^1\), les cadres ont un comportement voisin de celui des Inactifs en préférant l’Hotel ou Resid, vu que d’une part Inactif et Hotel caractérisent positivement \(F^1\) et d’une autre part Cadres et Resi sont bien représentés sur \(F^1\). A l’opposé, les AGRI se comportent comme les ouvriers, en choisissant plus le camping.

Question 8

Pour interpréter, il faut reprendre la question 6). Sur l’axe \(F^2\), on trouve que les cadres vont plus à loc et moins à l’hotel et en cela ils s’opposent aux agri qui eux choisissent l’hotel et moins loc.

En terme de Qualité de Représentation (QR), on remarque que l’hotel se fait moins remarqué en vu de cela, on peut dire que le sous-groupe de \(F^2\) comporte moins d’individus choisissant l’hotel que les autres modes d’hébergements.

Question 9

On peut remarquer un certain ordre de modalités (effet Guttman) : agriculteur \(\rightarrow\) Camping \(\rightarrow\) Ouvrier \(\rightarrow\) Cadre \(\rightarrow\) Résidence \(\rightarrow\) Inactif \(\rightarrow\) hotel, qui est dû aux coûts de ces hebergements et aux moyens Financiers de chaque type de CSP.
De ce fait \(F^1\) exprime les moyens Financiers et \(F^2\) celui du type de vacances choisi : (Loca et Resi) Sédentaires (comportement des Familles et \(\pm\) les âgés exprimant un esprit “tranquille”\(\rightarrow\) stabilité \(\rightarrow\) se deplace peu) et (Hotel-Camping) tendance itinérante (les aventuriers et \(\pm\) jeunes exprimant un esprit “vagabond”\(\rightarrow\) mouvement \(\rightarrow\) errer)

Exercice 4

Enoncé :

On interroge 6 personnes sur la couleur de leurs cheveux (CB, CC et CR pour blond, châtain et roux), la couleur de leurs yeux (YB, YV et YM pour bleu, vert et marron) et leur sexe (H/F). On a donc trois variables (avec respectivement 3, 3 et 2 modalités) mesurées sur 6 individus. On donne le tableau brut (ci-dessous).

\[\begin{eqnarray} CB &\;& YB &\;& H \\ CB &\;& YV &\;& H \\ CC &\;& YB &\;& F \\ CC &\;& YM &\;& H \\ CR &\;& YV &\;& F \\ CB &\;& YB &\;& F \end{eqnarray}\]

1- Ecrire le tableau disjonctif complet.
2- En déduire le tableau de BURT.
3- Lancer l’ACM, AFC… avec R.

Réponse 4 :

Question 1

Ce tableau M est du type “individus x Variables” qualitatives. Il est donc bien adapté pour la méthode d’ Analyse des Correspondances Multiple.
Ce tableau peut-être exprimé en un Tableau Disjonctif Complet : \(X\) et par suite en un tableau de Burt : \(X'X\).
L’application de l’ACM sur M donne, à quelques modifications près, le même résultat que l’application de l’AFC sur les deux autres tableaux :

Mais avant donnons quelques éléments à prendre en considérations :

\(n=6, \; p=3,\; K_1=3, \; K_2=3,\; K_3=2\; et K=8\)

> X1<- factor(c("CB","CB","CC","CC","CR","CB"))
> X2<- factor(c("YB","YV","YB","YM","YV","YB"))
> X3<- factor(c("H","H","F","H","F","F"))
> M <- data.frame(X1,X2,X3)
> names(M) <- c("CHEV","YEUX","SEXE")
> M

> Y <- c("S1","S2","S3","S4","S5","S6")
> row.names(M) <- Y;M

> TDC<-cbind(table(Y,X1),table(Y,X2),table(Y,X3))
> TDC1<-addmargins(TDC); TDC1

##     CB CC CR YB YM YV F H Sum
## S1   1  0  0  1  0  0 0 1   3
## S2   1  0  0  0  0  1 0 1   3
## S3   0  1  0  1  0  0 1 0   3
## S4   0  1  0  0  1  0 0 1   3
## S5   0  0  1  0  0  1 1 0   3
## S6   1  0  0  1  0  0 1 0   3
## Sum  3  2  1  3  1  2 3 3  18

> TB<-t(TDC)%*%TDC
> TB1<-addmargins(TB); TB1

##     CB CC CR YB YM YV F H Sum
## CB   3  0  0  2  0  1 1 2   9
## CC   0  2  0  1  1  0 1 1   6
## CR   0  0  1  0  0  1 1 0   3
## YB   2  1  0  3  0  0 2 1   9
## YM   0  1  0  0  1  0 0 1   3
## YV   1  0  1  0  0  2 1 1   6
## F    1  1  1  2  0  1 3 0   9
## H    2  1  0  1  1  1 0 3   9
## Sum  9  6  3  9  3  6 9 9  54

Comparaison des différentes méthodes de l’ACM (sur différents Tableaux) :

A part les Contributions qui sont les mêmes pour tous les Tableaux, on donne les relations entre les valeurs propres, les coordonnées et les Qualités de Représentations.

M.MCA <- MCA(M);summary(M.MCA);plot(M.MCA)

## 
## Call:
## MCA(X = M) 
## 
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3   Dim.4   Dim.5
## Variance               0.639   0.478   0.427   0.077   0.045
## % of var.             38.344  28.685  25.607   4.648   2.716
## Cumulative % of var.  38.344  67.029  92.636  97.284 100.000
## 
## Individuals
##       Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3    ctr   cos2  
## S1 | -0.244  1.549  0.059 | -0.781 21.289  0.611 |  0.399  6.218  0.159 |
## S2 |  0.191  0.956  0.027 | -0.118  0.488  0.010 |  1.056 43.546  0.836 |
## S3 | -0.191  0.956  0.027 | -0.118  0.488  0.010 | -1.056 43.546  0.836 |
## S4 | -1.349 47.495  0.683 |  0.900 28.223  0.304 |  0.078  0.236  0.002 |
## S5 |  1.349 47.495  0.683 |  0.900 28.223  0.304 | -0.078  0.236  0.002 |
## S6 |  0.244  1.549  0.059 | -0.781 21.289  0.611 | -0.399  6.218  0.159 |
## 
## Categories
##       Dim.1    ctr   cos2 v.test    Dim.2    ctr   cos2 v.test    Dim.3    ctr
## CB |  0.080  0.166  0.006  0.178 | -0.810 22.901  0.657 -1.812 |  0.539 11.337
## CC | -0.964 16.150  0.464 -1.524 |  0.565  7.422  0.160  0.894 | -0.749 14.594
## CR |  1.688 24.773  0.570  1.688 |  1.301 19.678  0.339  1.301 | -0.119  0.184
## YB | -0.080  0.166  0.006 -0.178 | -0.810 22.901  0.657 -1.812 | -0.539 11.337
## YM | -1.688 24.773  0.570 -1.688 |  1.301 19.678  0.339  1.301 |  0.119  0.184
## YV |  0.964 16.150  0.464  1.524 |  0.565  7.422  0.160  0.894 |  0.749 14.594
## F  |  0.585  8.910  0.342  1.307 |  0.000  0.000  0.000  0.000 | -0.782 23.885
## H  | -0.585  8.910  0.342 -1.307 |  0.000  0.000  0.000  0.000 |  0.782 23.885
##      cos2 v.test  
## CB  0.290  1.205 |
## CC  0.280 -1.184 |
## CR  0.003 -0.119 |
## YB  0.290 -1.205 |
## YM  0.003  0.119 |
## YV  0.280  1.184 |
## F   0.612 -1.749 |
## H   0.612  1.749 |
## 
## Categorical variables (eta2)
##        Dim.1 Dim.2 Dim.3  
## CHEV | 0.788 0.717 0.334 |
## YEUX | 0.788 0.717 0.334 |
## SEXE | 0.342 0.000 0.612 |

TDC.ca <- CA(TDC); summary(TDC.ca)

## 
## Call:
## CA(X = TDC) 
## 
## The chi square of independence between the two variables is equal to 30 (p-value =  0.708131 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3   Dim.4   Dim.5
## Variance               0.639   0.478   0.427   0.077   0.045
## % of var.             38.344  28.685  25.607   4.648   2.716
## Cumulative % of var.  38.344  67.029  92.636  97.284 100.000
## 
## Rows
##      Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2     Dim.3
## S1 |   166.667 |  -0.244   1.549   0.059 |  -0.781  21.289   0.611 |   0.399
## S2 |   222.222 |   0.191   0.956   0.027 |  -0.118   0.488   0.010 |   1.056
## S3 |   222.222 |  -0.191   0.956   0.027 |  -0.118   0.488   0.010 |  -1.056
## S4 |   444.444 |  -1.349  47.495   0.683 |   0.900  28.223   0.304 |   0.078
## S5 |   444.444 |   1.349  47.495   0.683 |   0.900  28.223   0.304 |  -0.078
## S6 |   166.667 |   0.244   1.549   0.059 |  -0.781  21.289   0.611 |  -0.399
##        ctr    cos2  
## S1   6.218   0.159 |
## S2  43.546   0.836 |
## S3  43.546   0.836 |
## S4   0.236   0.002 |
## S5   0.236   0.002 |
## S6   6.218   0.159 |
## 
## Columns
##      Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2     Dim.3
## CB |   166.667 |   0.080   0.166   0.006 |  -0.810  22.901   0.657 |   0.539
## CC |   222.222 |  -0.964  16.150   0.464 |   0.565   7.422   0.160 |  -0.749
## CR |   277.778 |   1.688  24.773   0.570 |   1.301  19.678   0.339 |  -0.119
## YB |   166.667 |  -0.080   0.166   0.006 |  -0.810  22.901   0.657 |  -0.539
## YM |   277.778 |  -1.688  24.773   0.570 |   1.301  19.678   0.339 |   0.119
## YV |   222.222 |   0.964  16.150   0.464 |   0.565   7.422   0.160 |   0.749
## F  |   166.667 |   0.585   8.910   0.342 |   0.000   0.000   0.000 |  -0.782
## H  |   166.667 |  -0.585   8.910   0.342 |   0.000   0.000   0.000 |   0.782
##        ctr    cos2  
## CB  11.337   0.290 |
## CC  14.594   0.280 |
## CR   0.184   0.003 |
## YB  11.337   0.290 |
## YM   0.184   0.003 |
## YV  14.594   0.280 |
## F   23.885   0.612 |
## H   23.885   0.612 |

TB.ca <- CA(TB,ncp=7)  # j'ai pris la totalité des axes d'inerties non nuls pour des raisons de calculs futurs

plot(TB.ca,invisible="col");summary(TB.ca)

## 
## Call:
## CA(X = TB, ncp = 7) 
## 
## The chi square of independence between the two variables is equal to 44.66667 (p-value =  0.6492994 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3   Dim.4   Dim.5   Dim.6   Dim.7
## Variance               0.408   0.229   0.182   0.006   0.002   0.000   0.000
## % of var.             49.373  27.633  22.021   0.726   0.248   0.000   0.000
## Cumulative % of var.  49.373  77.006  99.027  99.752 100.000 100.000 100.000
## 
## Rows
##      Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2     Dim.3
## CB |    74.074 |  -0.064   0.166   0.009 |  -0.560  22.901   0.707 |   0.352
## CC |   111.111 |   0.770  16.150   0.594 |   0.391   7.422   0.153 |  -0.489
## CR |   148.148 |  -1.349  24.773   0.683 |   0.900  19.678   0.304 |  -0.078
## YB |    74.074 |   0.064   0.166   0.009 |  -0.560  22.901   0.707 |  -0.352
## YM |   148.148 |   1.349  24.773   0.683 |   0.900  19.678   0.304 |   0.078
## YV |   111.111 |  -0.770  16.150   0.594 |   0.391   7.422   0.153 |   0.489
## F  |    80.247 |  -0.467   8.910   0.453 |   0.000   0.000   0.000 |  -0.511
## H  |    80.247 |   0.467   8.910   0.453 |   0.000   0.000   0.000 |   0.511
##        ctr    cos2  
## CB  11.337   0.279 |
## CC  14.594   0.239 |
## CR   0.184   0.002 |
## YB  11.337   0.279 |
## YM   0.184   0.002 |
## YV  14.594   0.239 |
## F   23.885   0.542 |
## H   23.885   0.542 |
## 
## Columns
##      Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2     Dim.3
## CB |    74.074 |  -0.064   0.166   0.009 |  -0.560  22.901   0.707 |   0.352
## CC |   111.111 |   0.770  16.150   0.594 |   0.391   7.422   0.153 |  -0.489
## CR |   148.148 |  -1.349  24.773   0.683 |   0.900  19.678   0.304 |  -0.078
## YB |    74.074 |   0.064   0.166   0.009 |  -0.560  22.901   0.707 |  -0.352
## YM |   148.148 |   1.349  24.773   0.683 |   0.900  19.678   0.304 |   0.078
## YV |   111.111 |  -0.770  16.150   0.594 |   0.391   7.422   0.153 |   0.489
## F  |    80.247 |  -0.467   8.910   0.453 |   0.000   0.000   0.000 |  -0.511
## H  |    80.247 |   0.467   8.910   0.453 |   0.000   0.000   0.000 |   0.511
##        ctr    cos2  
## CB  11.337   0.279 |
## CC  14.594   0.239 |
## CR   0.184   0.002 |
## YB  11.337   0.279 |
## YM   0.184   0.002 |
## YV  14.594   0.239 |
## F   23.885   0.542 |
## H   23.885   0.542 |

On remarque que \(\lambda_{M.MCA}=\lambda_{TDC.ca}=\sqrt{\lambda_{TB.ca}}\), en effet :

round(M.MCA$eig[,1],3)

## dim 1 dim 2 dim 3 dim 4 dim 5 
## 0.639 0.478 0.427 0.077 0.045

round(TDC.ca$eig[,1],3)

## dim 1 dim 2 dim 3 dim 4 dim 5 
## 0.639 0.478 0.427 0.077 0.045

round(TB.ca$eig[,1],3)

## dim 1 dim 2 dim 3 dim 4 dim 5 dim 6 dim 7 
## 0.408 0.229 0.182 0.006 0.002 0.000 0.000

round(sqrt(TB.ca$eig[,1]),3)

## dim 1 dim 2 dim 3 dim 4 dim 5 dim 6 dim 7 
## 0.639 0.478 0.427 0.077 0.045 0.000 0.000

De plus \(Coord_{M.MCA}=Coord_{TDC.ca}=\dfrac{1}{\sqrt{\sqrt{\lambda_{TB.ca}}}}\times Coord_{TB.ca}\), en effet :

round(M.MCA$var$coord[,1],3)  # ici pour F1 donc lambda1

##     CB     CC     CR     YB     YM     YV      F      H 
##  0.080 -0.964  1.688 -0.080 -1.688  0.964  0.585 -0.585

round(TDC.ca$col$coord[,1],3)  # ici pour F1 donc lambda1

##     CB     CC     CR     YB     YM     YV      F      H 
##  0.080 -0.964  1.688 -0.080 -1.688  0.964  0.585 -0.585

round(1/sqrt(sqrt(TB.ca$eig[1,1]))*TB.ca$row$coord[,1],3) # ici pour F1 donc lambda1

##     CB     CC     CR     YB     YM     YV      F      H 
## -0.080  0.964 -1.688  0.080  1.688 -0.964 -0.585  0.585

round(1/sqrt(sqrt(TB.ca$eig[2,1]))*TB.ca$row$coord[,2],3) # ici pour F2 donc lambda2   ainsi de suite...

##     CB     CC     CR     YB     YM     YV      F      H 
## -0.810  0.565  1.301 -0.810  1.301  0.565  0.000  0.000

Encore; on a \(Cos2_{M.MCA\,j}=Cos2_{TDC.ca\,j}=\dfrac{\dfrac{Coord_{TB.ca}^{j\,2}}{\sqrt{\lambda_{TB.ca\,j}}}}{\sum_{k=1}^7{\dfrac{Coord^{k\,2}_{TB.ca}}{\sqrt{\lambda_{TB.ca\,k}}}}}\), en effet :

round(M.MCA$var$cos2[,1],3)  # ici pour F1 donc lambda1

##    CB    CC    CR    YB    YM    YV     F     H 
## 0.006 0.464 0.570 0.006 0.570 0.464 0.342 0.342

round(TDC.ca$col$cos2[,1],3)  # ici pour F1 donc lambda1

##    CB    CC    CR    YB    YM    YV     F     H 
## 0.006 0.464 0.570 0.006 0.570 0.464 0.342 0.342

round(TB.ca$col$cos2[,1],3)  # ici cos2 pour F1 donc sans Modification

##    CB    CC    CR    YB    YM    YV     F     H 
## 0.009 0.594 0.683 0.009 0.683 0.594 0.453 0.453

round(TB.ca$row$coord[1,1]^2/sqrt(TB.ca$eig[1,1])/sum(TB.ca$row$coord[1,]^2/sqrt(TB.ca$eig[,1])),3) # avec Modification

## [1] 0.006

Exercice 5

Enoncé³ :

Une compagnie d’assurance a compilé à propos de ses assurés des données sur leur taux de risque (0=normal,1=fort) pour le système cardio-vasculaire (CVas, coeur), le système locomoteur (Loco, risque de paralysie), le système neurologique (Neuro, cerveau) et le diabète (Diab). On obtient le tableau de Burt suivant

	CVasc.0	CVasc.1	Loco.0	Loco.1	Neuro.0	Neuro.1	Diab.0	Diab.1
CVasc.0	28464	0	27344	1120	26571	1893	22458	6006
CVasc.1	0	8742	?	785	7013	1729	6125	2617
Loco.0	27344	?	35301	0	32186	3115	27312	7989
Loco.1	1120	785	0	1905	1398	507	1271	634
Neuro.0	26571	7013	32186	1398	33584	0	26303	7281
Neuro.1	1893	1729	3115	507	0	3622	2280	1342
Diab.0	22458	6125	27312	1271	26303	2280	28583	0
Diab.1	6006	2617	7989	634	7281	1342	0	8623

1. Calculer les valeurs manquantes du tableau (Loco.0,CVasc.1). Les personnes ayant un risque locomoteur élevé ont-elles un risque de diabète plus grand ou plus petit que la moyenne ?

2. Calculer les valeurs propres de l’ACM.

3. Combien d’axes propres faut-il conserver ? Que peut-on dire alors de la qualité globale de la représentation ?

4. Quelles sont les catégories qui déterminent les deux premiers axes principaux ? (on détaillera les critères et on cherchera à être précis dans la réponse).

Réponse 5 :

Question 1

1. Ce tableau croise quatre variables qualitatives, c’est un Tableau de BURT.
Or on sait que les Loco.0 sont en nombre de \(35301\) (intesection Loco.0 et Loco.0). Ceux-là sont soit CVasco.0 soit CVasco.1, or ceux qui sont CVasco.0 sont en nombre de \(27344\), d’où ceux qui sont à risque fort sont en nombre de \(35301-27344= 7957\).

2. Les personnes ayant un risque de diabète sachant qu’elles ont un risque locomoteur élevé n’est autre que la fréquence conditionnelle \(f_8^{(4)}=\dfrac{f_{4 ,8}}{f_{4\,{\bf .}}}=\dfrac {634}{1905}=0.3328084\). Or la prportion des risques Diab.1 est \(\dfrac {nb(Diab.1)}{n=(nb(Diab.1)+nb(Diab.0))}=\dfrac {8623}{37106}=0.2323883\) qui est inférieure à 0.3328084. D’où les personnes ayant un risque locomoteur élevé ont un risque de diabète plus grand que la moyenne. Autrement un risque locomoteur fort augment le risque de Diabète.

Question 2

Choisissons d’abord la méthode factorielle à utiliser. Puisqu’ici on ne dispose que du Tableau de Burt, on est forcé de lancer l’acf :

> risq <- read.csv2("C:/Users/serie3-FCA-MAC-21-22/ex5-ser3-s3.csv",row.names=1) # importation du Tableau de BURT
> risq.ca <- CA(risq)

> plot(risq.ca,invisible = "col")

> summary(risq.ca)

## 
## Call:
## CA(X = risq) 
## 
## The chi square of independence between the two variables is equal to 155134.4 (p-value =  0 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3   Dim.4   Dim.5   Dim.6   Dim.7
## Variance               0.113   0.056   0.051   0.041   0.000   0.000   0.000
## % of var.             43.430  21.462  19.533  15.575   0.000   0.000   0.000
## Cumulative % of var.  43.430  64.892  84.425 100.000 100.000 100.000 100.000
## 
## Rows
##           Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3
## CVasc.0 |    15.457 | -0.204  7.019  0.514 | -0.011  0.045  0.002 |  0.145
## CVasc.1 |    50.328 |  0.664 22.855  0.514 |  0.037  0.145  0.002 | -0.473
## Loco.0  |     3.296 | -0.069  1.005  0.345 | -0.063  1.676  0.284 | -0.069
## Loco.1  |    61.079 |  1.283 18.618  0.345 |  1.165 31.063  0.284 |  1.286
## Neuro.0 |     6.476 | -0.130  3.390  0.592 | -0.012  0.058  0.005 |  0.035
## Neuro.1 |    60.049 |  1.209 31.431  0.592 |  0.111  0.538  0.005 | -0.323
## Diab.0  |    14.813 | -0.146  3.634  0.278 |  0.212 15.406  0.582 | -0.102
## Diab.1  |    49.102 |  0.485 12.047  0.278 | -0.702 51.068  0.582 |  0.338
##            ctr   cos2  
## CVasc.0  7.929  0.261 |
## CVasc.1 25.817  0.261 |
## Loco.0   2.244  0.347 |
## Loco.1  41.580  0.347 |
## Neuro.0  0.537  0.042 |
## Neuro.1  4.979  0.042 |
## Diab.0   3.920  0.135 |
## Diab.1  12.994  0.135 |
## 
## Columns
##           Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2    Dim.3
## CVasc.0 |    15.457 | -0.204  7.019  0.514 | -0.011  0.045  0.002 |  0.145
## CVasc.1 |    50.328 |  0.664 22.855  0.514 |  0.037  0.145  0.002 | -0.473
## Loco.0  |     3.296 | -0.069  1.005  0.345 | -0.063  1.676  0.284 | -0.069
## Loco.1  |    61.079 |  1.283 18.618  0.345 |  1.165 31.063  0.284 |  1.286
## Neuro.0 |     6.476 | -0.130  3.390  0.592 | -0.012  0.058  0.005 |  0.035
## Neuro.1 |    60.049 |  1.209 31.431  0.592 |  0.111  0.538  0.005 | -0.323
## Diab.0  |    14.813 | -0.146  3.634  0.278 |  0.212 15.406  0.582 | -0.102
## Diab.1  |    49.102 |  0.485 12.047  0.278 | -0.702 51.068  0.582 |  0.338
##            ctr   cos2  
## CVasc.0  7.929  0.261 |
## CVasc.1 25.817  0.261 |
## Loco.0   2.244  0.347 |
## Loco.1  41.580  0.347 |
## Neuro.0  0.537  0.042 |
## Neuro.1  4.979  0.042 |
## Diab.0   3.920  0.135 |
## Diab.1  12.994  0.135 |

Comparaison entre les valeurs propres, coordonnées contribution de Burt avec afc et ceux l’ACM :

> round(sqrt(risq.ca$eig[,1]),4) # risq.ca$svd$vs

##  dim 1  dim 2  dim 3  dim 4  dim 5  dim 6  dim 7 
## 0.3364 0.2365 0.2256 0.2015 0.0000 0.0000 0.0000

> round(risq.ca$row$inertia[1]*1000,3)# round(sum(risq.ca$row$coord[1,]^2*risq.ca$call$marge.row[1])*1000,3)

## [1] 15.457

> round(sweep(risq.ca$col$coord[,1:2],2,sqrt(sqrt(risq.ca$eig[1:2,1])),"/"),4)

##           Dim 1   Dim 2
## CVasc.0 -0.3514 -0.0235
## CVasc.1  1.1441  0.0765
## Loco.0  -0.1194 -0.1293
## Loco.1   2.2120  2.3956
## Neuro.0 -0.2248 -0.0247
## Neuro.1  2.0844  0.2287
## Diab.0  -0.2523  0.4356
## Diab.1   0.8364 -1.4438

> round(risq.ca$call$marge.col*10000,0)

## CVasc.0 CVasc.1  Loco.0  Loco.1 Neuro.0 Neuro.1  Diab.0  Diab.1 
##    1913     587    2372     128    2257     243    1921     579

> round(risq.ca$col$contrib[,1:2]*100,0)

##         Dim 1 Dim 2
## CVasc.0   702     4
## CVasc.1  2286    15
## Loco.0    100   168
## Loco.1   1862  3106
## Neuro.0   339     6
## Neuro.1  3143    54
## Diab.0    363  1541
## Diab.1   1205  5107

Question 3

a. Le nombre d’axes Total et d’inertie non nulle est dans le cas de BURT égal au nombre de modalités moins le nombre de variables :\(\sum_1^p{(K_j-1)}=K-P=8-4=4\).

b. Mais on ne retient que les axes dont les valeurs propres sont supérieures à la moyenne ici égale à \(\bar{\lambda}=\dfrac{\sum{\lambda_i}}{K-P}=\dfrac{I_T}{K-P}=\dfrac{K/P\,-\,1}{K-P}=\dfrac{1}{P}=0.25\). Et vu que le premier axe est le seul qui vérifie la condition : \(\lambda_1 \geq \bar{\lambda}\), on est obligé de prendre le deuxième axe pour former un plan. Mais vu aussi que l’inértie du plan est de 0.5729147 soit 57.3 \(\%\), on voit que ce n’est pas suffisant. La qualité de l’analyse laisse à désirer.

Question 4

Puisque il s’agit du cas qualitatif (des modalités), le seuil de contribution sera en fonction du poids (ici on prendra \(3\times poids\)) ce qui est exprimé par l’inégalité \(|F_i^k|=|coord_i^k|\geq \sqrt{3\times \lambda_k}\).

Remarque

J’ai choisi de travailler avec la première condition(contrib. et \(3\times poids\)) vu que la relation entre \(coord_{MCA}\) et \(coord_{CA}\) nous compliquera les calculs!

> M <- data.frame(sign(risq.ca$row$coord[,1]),risq.ca$row$contrib[,1],risq.ca$call$marge.row*300)
> names(M) <- c("sign_coord","ctr1","Tr_poids");M

Extraction des modalités les plus contributives positivement sur l’axe 1

> (Mp <- M[M$sign_coord == 1 & M$ctr1 >= M$Tr_poids,])

Extraction des modalités les plus contributives négativement sur l’axe 1

> (Mn <- M[M$sign_coord == -1 & M$ctr1 >= M$Tr_poids,])

Contributions sur l’axe 2

> M2 <- data.frame(sign(risq.ca$row$coord[,2]),risq.ca$row$contrib[,2],risq.ca$call$marge.row*300)
> names(M2) <- c("sign_coord","ctr2","Tr_poids");M2

Extraction des modalités les plus contributives positivement sur l’axe 2

> (M2p <- M2[M2$sign_coord == 1 & M2$ctr2 >= M2$Tr_poids,])

Extraction des modalités les plus contributives négativement sur l’axe 2

> (M2n <- M2[M2$sign_coord == -1 & M2$ctr2 >= M2$Tr_poids,])

Tableau récapulatif des contributions

Signes_Coord	Positifs	Négatifs
\(F^1\)	Neuro.1-Cvasc.1-Loco.1
\(F^2\)	Loco.1	Diab.1

Exercice 6

Enoncé⁴ :

Il s’agit de données (sans doute contestables) concernant les 2201 passagers et membres d’équipage du célèbre bateau « le Titanic», qui a coulé le 14 avril 1912. Il faut noter que tout le monde n’est pas d’accord sur le nombre de passagers et sur le nombre de victimes. Les variables sont :

Variable	Modalité 1	autres modalités
classe	0=équipage	1-3=classe
âge	0=enfant	1=adulte
sexe	0=féminin	1=masculin
survivant	0=non	1=oui

On donne ci-dessous le tableau de Burt des données ainsi que le poids des catégories (en 10000 èmes).

	class.0	class.1	class.2	class.3	age.0	age.1	sex.0	sex.1	surv.0	surv.1
class.0	885	0	0	0	0	885	23	862	673	212
class.1	0	325	0	0	6	319	145	180	122	203
class.2	0	0	285	0	24	261	106	179	167	118
class.3	0	0	0	706	79	627	196	510	528	178
age.0	0	6	24	79	109	0	45	64	52	57
age.1	885	319	261	627	0	2092	425	1667	1438	654
sex.0	23	145	106	196	45	425	470	0	126	344
sex.1	862	180	179	510	64	1667	0	1731	1364	367
surv.0	673	122	167	528	52	1438	126	1364	1490	0
surv.1	212	203	118	178	57	654	344	367	0	711
poids	4021	1477	1295	3208	495	9505	2135	7865	6770	3230

1. Quelle proportion d’enfants a survécu ? Quelle proportion de femmes a survécu ? Quelle est la proportion de femmes parmi les survivants ?

On fait l’analyse en correspondances multiples des variables class, âge et sexe. La variable surv sera discutée plus loin.

Calculer les valeurs propres de l’ACM, puis les coordonnées des catégories sur les deux premiers axes ainsi que leur contribution en 10000emes à ces axes.

2. Pourquoi y a-t-il 5 valeurs propres ? Quelle est leur somme ? Combien d’axes est-on conduit à conserver ?

3. Quelles sont les catégories qui déterminent les deux premiers axes ?

Réponse 6 :

Question 1

1. Ce tableau croise quatre variables qualitatives, c’est un Tableau de BURT.
Or on sait que les enfants âge.0 sont en nombre de \(109\) (intesection âge.0 et âge.0). Ceux-là sont soit morts surv.0 soit vivants surv.1, donc la proportion d’enfants qui a survécu est de \(\dfrac{57}{109}=52.3\%\)

2. De même, on sait que les femmes sex.0 sont en nombre de \(470\) (intesection sex.0 et sex.0). Celles-là sont soit mortes surv.0 soit vivantes surv.1, donc la proportion de femmes qui a survécu est de \(\dfrac{344}{470}=73.2\%\)

3. Encore, on sait que les survivants surv.1 sont en nombre de \(711\) (intesection surv.1 et surv.1). Ceux-là sont soit féminins sex.0 soit masculins sex.1, donc la proportion de femmes parmi les survivants est de \(\dfrac{344}{771}=48.4\%\)

Question 2

1. Lancement de la méthode avec variable supplémentaire :

> titan <- read.csv2("C:/Users/serie3-FCA-MAC-21-22/ex6-ser3-s3.csv",row.names=1)
> titan.ca <- CA(titan,row.sup = c(9,10), col.sup = c(9,10))

> plot(titan.ca,invisible = c("row","col.sup"))

> summary(titan.ca)

## 
## Call:
## CA(X = titan, row.sup = c(9, 10), col.sup = c(9, 10)) 
## 
## The chi square of independence between the two variables is equal to 11995.91 (p-value =  0 ).
## 
## Eigenvalues
##                        Dim.1   Dim.2   Dim.3   Dim.4   Dim.5   Dim.6   Dim.7
## Variance               0.241   0.145   0.111   0.068   0.040   0.000   0.000
## % of var.             39.812  23.941  18.348  11.282   6.616   0.000   0.000
## Cumulative % of var.  39.812  63.754  82.102  93.384 100.000 100.000 100.000
## 
## Rows
##           Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2  
## class.0 |    78.120 |  -0.684  26.039   0.804 |  -0.008   0.006   0.000 |
## class.1 |   100.327 |   0.548   6.129   0.147 |  -1.086  40.004   0.578 |
## class.2 |    99.241 |   0.555   5.510   0.134 |  -0.078   0.179   0.003 |
## class.3 |    79.288 |   0.382   6.462   0.197 |   0.541  21.612   0.395 |
## age.0   |   112.592 |   1.463  14.653   0.314 |   1.602  29.237   0.376 |
## age.1   |     5.866 |  -0.076   0.763   0.314 |  -0.083   1.523   0.376 |
## sex.0   |   102.354 |   1.038  31.807   0.749 |  -0.345   5.850   0.083 |
## sex.1   |    27.791 |  -0.282   8.636   0.749 |   0.094   1.589   0.083 |
##           Dim.3     ctr    cos2  
## class.0   0.044   0.230   0.003 |
## class.1  -0.502  11.172   0.124 |
## class.2   1.385  74.511   0.834 |
## class.3  -0.383  14.087   0.197 |
## age.0     0.000   0.000   0.000 |
## age.1     0.000   0.000   0.000 |
## sex.0     0.000   0.000   0.000 |
## sex.1     0.000   0.000   0.000 |
## 
## Columns
##           Iner*1000     Dim.1     ctr    cos2     Dim.2     ctr    cos2  
## class.0 |    78.120 |  -0.684  26.039   0.804 |  -0.008   0.006   0.000 |
## class.1 |   100.327 |   0.548   6.129   0.147 |  -1.086  40.004   0.578 |
## class.2 |    99.241 |   0.555   5.510   0.134 |  -0.078   0.179   0.003 |
## class.3 |    79.288 |   0.382   6.462   0.197 |   0.541  21.612   0.395 |
## age.0   |   112.592 |   1.463  14.653   0.314 |   1.602  29.237   0.376 |
## age.1   |     5.866 |  -0.076   0.763   0.314 |  -0.083   1.523   0.376 |
## sex.0   |   102.354 |   1.038  31.807   0.749 |  -0.345   5.850   0.083 |
## sex.1   |    27.791 |  -0.282   8.636   0.749 |   0.094   1.589   0.083 |
##           Dim.3     ctr    cos2  
## class.0   0.044   0.230   0.003 |
## class.1  -0.502  11.172   0.124 |
## class.2   1.385  74.511   0.834 |
## class.3  -0.383  14.087   0.197 |
## age.0     0.000   0.000   0.000 |
## age.1     0.000   0.000   0.000 |
## sex.0     0.000   0.000   0.000 |
## sex.1     0.000   0.000   0.000 |
## 
## Supplementary rows
##            Dim.1   cos2    Dim.2   cos2    Dim.3   cos2  
## surv.0  | -0.176  0.643 |  0.107  0.238 | -0.002  0.000 |
## surv.1  |  0.369  0.643 | -0.225  0.238 |  0.004  0.000 |
## 
## Supplementary columns
##            Dim.1   cos2    Dim.2   cos2    Dim.3   cos2  
## surv.0  | -0.176  0.643 |  0.107  0.238 | -0.002  0.000 |
## surv.1  |  0.369  0.643 | -0.225  0.238 |  0.004  0.000 |

> titan.ca$svd$vs

## [1] 4.910147e-01 3.807665e-01 3.333333e-01 2.613839e-01 2.001682e-01
## [6] 1.245378e-16 7.758386e-17

> (K <- 8)

## [1] 8

> (P <- 3)

## [1] 3

> (n <- titan.ca$call$N/P^2)

## [1] 2201

Comparaison entre valeurs propres, coordonnées contribution de Burt avec afc et ceux de l’ACM :

> round(sqrt(titan.ca$eig[,1]),4) # titan.ca$svd$vs

##  dim 1  dim 2  dim 3  dim 4  dim 5  dim 6  dim 7 
## 0.4910 0.3808 0.3333 0.2614 0.2002 0.0000 0.0000

> round(titan.ca$row$inertia[1]*1000,3)# round(sum(titan.ca$row$coord[1,]^2*titan.ca$call$marge.row[1])*1000,3)

## [1] 78.12

> round(sweep(titan.ca$col$coord[,1:2],2,sqrt(sqrt(titan.ca$eig[1:2,1])),"/"),4)

##           Dim 1   Dim 2
## class.0 -0.9767 -0.0133
## class.1  0.7819 -1.7592
## class.2  0.7917 -0.1258
## class.3  0.5448  0.8773
## age.0    2.0877  2.5969
## age.1   -0.1088 -0.1353
## sex.0    1.4813 -0.5594
## sex.1   -0.4022  0.1519

> round(titan.ca$call$marge.col*10000,0)

## class.0 class.1 class.2 class.3   age.0   age.1   sex.0   sex.1 
##    1340     492     432    1069     165    3168     712    2622

> round(titan.ca$col$contrib[,1:2]*100,0)

##         Dim 1 Dim 2
## class.0  2604     1
## class.1   613  4000
## class.2   551    18
## class.3   646  2161
## age.0    1465  2924
## age.1      76   152
## sex.0    3181   585
## sex.1     864   159

Question 4

a. Le nombre d’axes Total et d’inertie non nulle est dans le cas d’un tableau de BURT est égal aux nombre de modalités moins le nombre de variables :\(K-P=8-3=5\).

b. La somme des valeurs propres c’est l’inertie Totale et est égale à \(K/P - 1=1.6666667\)

c. Mais on ne retient que les axes dont les valeurs propres sont supérieures à la moyenne ici égale à \(\bar{\lambda}=\dfrac{\sum{\lambda_i}}{K-P}=\dfrac{I_T}{K-P}=\dfrac{K/P\,-\,1}{K-P}=\dfrac{1}{P}=0.3333333\). Dans ce cas on prendra trois axe.

> i0 <- which(titan.ca$svd$vs >= 0.33333) # les n° des axes dont les val-proprs >= 1
> lambda <- data.frame(titan.ca$svd$vs[i0]) # r?ecrire comme data.frame pour pouvoir ajouter les noms (lignes et colonnes)
> row.names(lambda)<- row.names(titan.ca$eig)[i0] # ajout noms des lignes (les components)
> names(lambda) <- "Les axes retenus sont"  # ajout nom de la colonne 
> lambda # Il y a une autre m?thode (voir plus loin): méthode de l'ebouli des valeurs propres ( tuyaux d'orgue : barplot)

> barplot(titan.ca$svd$vs,col="blue",axes=FALSE,ylim=c(0,.8),main=" Les valeurs propres \n des axes à retenir ")
> axis(side=2,las=2,at=round(titan.ca$svd$vs,1),labels=TRUE,col.axis=2)
> fleches()
> abline(h=.333,lty=2,lwd=2,col=2)

Question 4

Puisque il s’agit du cas qualitatif (des modalités), le seuil de contribution sera en fonction du poids (ici on prendra \(2\times poids\)) ou aussi \(|F_i^k|=|coord_i^k|\geq \sqrt{2\times \lambda_k}\).

Remarque

J’ai choisi de travailler avec la première condition(contrib. et 2*poids) vu que la relation entre \(coord_{MCA}\) et \(coord_{CA}\) nous compliquera les calculs !

> seuil <- titan.ca$call$marge.row*200
> i <- which(titan.ca$row$contrib[,1] >= seuil)
> sel <- row.names(data.frame(titan.ca$row$contrib[i,1]))
> Tab <- data.frame(cbind(sign(titan.ca$row$coord[sel,1]),titan.ca$row$contrib[sel,1]))
> names(Tab) <- c("signe", "C.I.F1")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F1,decreasing = TRUE),]
> dfn <- Tabn[order(Tabn$C.I.F1,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

> i <- which(titan.ca$row$contrib[,2] >= seuil)
> sel <- row.names(data.frame(titan.ca$row$contrib[i,2]))
> Tab <- data.frame(cbind(sign(titan.ca$row$coord[sel,2]),titan.ca$row$contrib[sel,2]))
> names(Tab) <- c("signe", "C.I.F2")
> Tabp <- Tab[which(sign(Tab[,1])==1),]
> Tabn <- Tab[which(sign(Tab[,1])==-1),]
> dfp <- Tabp[order(Tabp$C.I.F2,decreasing = TRUE),]
> dfn <-Tabn[order(Tabn$C.I.F2,decreasing = FALSE),]
> (dfT <- rbind(dfp,dfn))

Autres méthodes plus longues “à mon sens” néanmoins on peut utiliser les méthodes graphiques avec le package “factoextra”

> M <- data.frame(sign(titan.ca$row$coord[,1]),titan.ca$row$contrib[,1],titan.ca$call$marge.row*200)
> names(M) <- c("sign_coord","ctr1","de_poids");M

Extraction des modalités les plus contributives positivement sur l’axe 1

> (Mp <- M[M$sign_coord == 1 & M$ctr1 >= M$de_poids,])

Extraction des modalités les plus contributives négativement sur l’axe 1

> (Mn <- M[M$sign_coord == -1 & M$ctr1 >= M$de_poids,])

Contributions sur l’axe 2

> M2 <- data.frame(sign(titan.ca$row$coord[,2]),titan.ca$row$contrib[,2],titan.ca$call$marge.row*200)
> names(M2) <- c("sign_coord","ctr2","de_poids");M2

Extraction des modalités les plus contributives positivement sur l’axe 2

> (M2p <- M2[M2$sign_coord == 1 & M2$ctr2 >= M2$de_poids,])

Extraction des modalités les plus contributives négativement sur l’axe 2

> (M2n <- M2[M2$sign_coord == -1 & M2$ctr2 >= M2$de_poids,])

Tableau récapulatif des contributions

Signes_Coord	Positifs	Négatifs
\(F^1\)	age.0 - sex.0
\(F^2\)	age.0 - class.3	class.1

---

1. Salles-Le Gac, D. et Herrera, R.R. (2002) Initiation à l’analyse factorielle des données.↩︎

2. Cours 1èrepartie – Sylvie Viguier-Pla↩︎

3. J.-M. Lasgouttes — Cours d’analyse de données 2019-2020 — Université Paris I↩︎

4. J.-M. Lasgouttes — Cours d’analyse de données 2019-2020 — Université Paris I↩︎