Description
- Base de données accidents corporels de la circulation
- Variables utilisées
Partie I.
- Préparation des données
- Visualisation des données
Partie II.
- Préparation des données
- Visualisation des données

Description

L’Analyse Factorielle des Correspondances (A.F.C.) est une méthode de Statistique Descriptive Multidimensionnelle qui a pour objectif d’analyser la liaison entre deux variables qualitatives.

Dans ce projet, les liaisons qui sont étudiées sont, dans un premier temps, celles entre les usagers de route (conducteurs, passagers, piétons) et la gravité de l’accident dans lequel ils ont été impliqués et ensuite le lien entre la gravité de l’accident et le motif du déplacement.

Les données utilisées pour ce projet sont celles du fichier ‘usagers-2018’ des bases de données annuelles des accidents corporels de la circulation routière du site data.gouv.fr.

Base de données accidents corporels de la circulation

Est appelé accident corporel, un accident survenu sur une voie ouverte à la circulation publique, impliquant au moins un véhicule et ayant fait au moins une victime ayant nécessité des soins. Pour chaque accident corporel, les informations sont saisies (par l’unité des forces de l’ordre) dans une fiche intitulée bulletin d’analyse des accidents corporels (BAAC).

Dans les fiches BAAC, nous retrouvons l’ensemble l’intégralité des accidents corporels de la circulation intervenus durant une année précise en France métropolitaine ainsi que les départements d’Outre-mer (Guadeloupe, Guyane, Martinique, La Réunion et Mayotte depuis 2012).

Les bases de données sont extraites du fichier BAAC et contiennent des informations de localisation de l’accident, telles que renseignées ainsi que des informations concernant les caractéristiques de l’accident et son lieu, les véhicules impliqués et leurs victimes.

Les bases de données allant de 2005 à 2018 sont annuelles et sont composées de 4 fichiers (Caractéristiques – Lieux – Véhicules – Usagers) au format csv. Nous utilisons ici seulement le fichier usagers de l’année 2018. Un accident corporel (mortel et non mortel) de la circulation routière :

implique au moins une victime,
survient sur une voie publique ou privée, ouverte à la circulation publique,
implique au moins un véhicule. Un accident corporel implique un certain nombre d’usagers.

Parmi ceux-ci, on distingue :

les personnes indemnes : impliquées non décédées et dont l’état ne nécessite aucun soin médical du fait de l’accident,
les victimes : impliquées non indemnes.

Parmi les victimes, on distingue :

les personnes tuées : personnes qui décèdent du fait de l’accident, sur le coup ou dans les trente jours qui suivent l’accident,
les personnes blessées : victimes non tuées. Parmi les personnes blessées, il convient de différencier :
les blessés dits « hospitalisés » : victimes hospitalisées plus de 24 heures,
les blessés légers : victimes ayant fait l’objet de soins médicaux mais n’ayant pas été admises comme patients à l’hôpital plus de 24 heures.

Pour plus d’informations: https://www.data.gouv.fr/fr/datasets/r/8d4df329-bbbb-434c-9f1f-596d78ad529f

Variables utilisées

Le fichier usagers comprend initialement 12 variables telles que le numéro du véhicule impliqué, le sexe, le motif du déplacement (voir annexe pour plus de détails) et concerne les individus impliqués dans l’accident. L’analyse factorielle des correspondances a été faite sur les variables :

catu
Catégorie d’usager :

1 - Conducteur
2 - Passager
3 - Piéton

grav
Gravité de l’accident : Les usagers accidentés sont classés en trois catégories de victimes plus les indemnes.

1 - Indemne
2 - Tué
3 - Blessé hospitalisé
4 - Blessé léger

trajet
Motif du déplacement au moment de l’accident :

1 – Domicile – travail
2 – Domicile – école
3 – Courses – achats
4 – Utilisation professionnelle
5 – Promenade – loisirs
9 – Autre

Les variables du fichier usagers-2018.csv sont de nature qualitative, y compris ‘catu’, ‘grav’ et ‘trajet’.

La variable ‘catu’ est une variable qualitative nominale, pareillement pour la variable ‘trajet’, alors que la gravité de l’accident est une variable qualitative ordinale.

Pour faciliter la lecture des tableaux et graphiques, les variables du fichier sont renommées (par exemple, pour la colonne trajet, on passe de 1 à domicile_travail).

Partie I.

Dans un premier temps, nous souhaitons déterminer le lien entre la catégorie d’usager (catu) et la gravité de l’accident (grav).

Préparation des données

#Importation
X=read.delim("var_AFC1.csv",header=T,sep=",")
X=X[,-1]

#Vérification importation
dim(X)

## [1] 130169      2

sum(X)

## [1] 504252

head(X)

##   catu grav
## 1    1    3
## 2    1    1
## 3    1    1
## 4    3    4
## 5    1    3
## 6    1    1

#On renomme les variables
X$catu[X$catu == 1] <- "Conducteur"
X$catu[X$catu == 2] <- "Passager"
X$catu[X$catu == 3] <- "Piéton"

X$grav[X$grav == 1] <- "Indemne"
X$grav[X$grav == 2] <- "Tué"
X$grav[X$grav == 3] <- "Blessé hospitalisé"
X$grav[X$grav == 4] <- "Blessé léger"

#On renomme les colonnes du fichier
names(X)[1] <- "var1"
names(X)[2] <- "var2"

#Vérification
colnames(X)

## [1] "var1" "var2"

#On transforme les variables en qualitatives
X$var1=as.factor(X$var1)
X$var2=as.factor(X$var2)

Visualisation des données

Tableau de contingence

library(knitr)
library(kableExtra)
#Création d'un tableau de contingence
Z=matrix(table(X[,1],X[,2]),nlevels(X[,1]),nlevels(X[,2]))
rownames(Z)=levels(X[,1])
colnames(Z)=levels(X[,2])
X_tab_cont=Z
rm(Z)

Total <- sum

kable(addmargins(X_tab_cont,FUN = Total),"html",caption = "Tableau de contigence")%>%
  kable_styling(bootstrap_options = "basic")

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

Tableau de contigence
	Blessé hospitalisé	Blessé léger	Indemne	Tué	Total
Conducteur	14933	32953	45728	2411	96025
Passager	3802	10632	8277	473	23184
Piéton	3434	6775	243	508	10960
Total	22169	50360	54248	3392	130169

Les 130 169 individus impliqués dans les accidents de la route ont été répartis dans cette table de contingence selon la catégorie d’usager (en lignes, 3 modalités) et la gravité de l’accident (en colonnes, 4 modalités).Nous comptons donc (4+3) 7 modalités (et axes) au total.

Parmi les 96 025 conducteurs, il y en a 14 933 qui ont été hospitalisés à la suite de l’accident, 32 953 qui ont été légèrement blessés, 45 728 qui sont sortis indemne de l’accident et 2 411 qui ont été tués.

Graphique des contributions

#nbre de ligne et colonne
n=nrow(X_tab_cont);p=ncol(X_tab_cont)

#nbre d'axe égale 2
library(ade4)
afc = dudi.coa( X_tab_cont , scannf = F, nf=2)
kept_axes =afc$nf

### Histogramme des valeurs propres
contributions=afc$eig/sum(afc$eig)
g=barplot(afc$eig,main="Graphique des contributions",col="orange")
text(g,afc$eig,labels=paste(round(100*contributions,2),"%"),pos=3,xpd=NA)

Le graphique des contributions qui renvoie le pourcentage d’informations contenu dans chaque axe, mais dans l’AFC, il dépend aussi du nombre d’axe, choisis.*

Nous constatons que l’axe 1 contient 96,94% de l’information initiale. Nous étudierons donc principalement cet axe.

*le choix du nombre d’axes a été fait en fonction des tests a priori et est fixé à 2.

Tableau d’interpretation

Aperçu du tableau d’interprétation initiale :

#Importation tableau interpretation
library(readr)
tbl_interpretation <- read_delim("tableau_interpretation1_AFC.csv", 
                                 ";", escape_double = FALSE, trim_ws = TRUE)
kable(tbl_interpretation,"html" )%>%
  kable_styling(bootstrap_options = "basic", full_width = F)

X1	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR_1	COS2_1	QLT_1
Conducteur	73.77	0.36	0.46	15.8	0.98	0.98	0.38	10.4	0.02	1
Passager	17.81	4.61	-0.45	3.7	0.6	0.6	-2.1	78.5	0.4	1
Piéton	8.42	10.88	-3.09	80.5	1	1	1.15	11.1	0	1
NA	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
Blessé hospitalisé	17.03	3.25	-0.94	15.2	0.92	0.92	1.54	40.1	0.08	1
Blessé léger	38.69	1.52	-0.81	25.1	0.96	0.96	-0.93	33.6	0.04	1
Indemne	41.68	1.4	1.18	58.2	1	1	0.04	0.1	0	1
Tué	2.61	10.63	-0.76	1.5	0.65	0.65	3.17	26.2	0.35	1

#Segmentation de la table interpretation
#Création table pour la 1ère variable
tbl_int_var1 <- tbl_interpretation[1:nlevels(X$var1), ]
colnames(tbl_int_var1) <- c("variable","poids rel.","CTR inertie","axe 1", "CTR",   "COS2",
                            "QLT","axe 2", "CTR","COS2","QLT")
#Aperçu de la table
head(tbl_int_var1)

## # A tibble: 3 x 11
##   variable `poids rel.` `CTR inertie` `axe 1` CTR   COS2  QLT   `axe 2` CTR  
##   <chr>    <chr>        <chr>         <chr>   <chr> <chr> <chr> <chr>   <chr>
## 1 Conduct… 73.77        0.36          0.46    15.8  0.98  0.98  0.38    10.4 
## 2 Passager 17.81        4.61          -0.45   3.7   0.6   0.6   -2.1    78.5 
## 3 Piéton   8.42         10.88         -3.09   80.5  1     1     1.15    11.1 
## # … with 2 more variables: COS2 <chr>, QLT <chr>

#Création table pour la 2ème variable

#Numéro des lignes à sélectionner
#On sélectionne deux lignes après la fin de la 1ère variable
debut_ligne <- nlevels(X$var1)+2
#On va jusqu'à la fin du fichier
fin_ligne <- nrow(tbl_interpretation)

#On créer la table
tbl_int_var2 <- tbl_interpretation[debut_ligne:fin_ligne , ]

#Vérification de la table
dim(tbl_int_var2)

## [1]  4 11

#On renomme les colonnes
colnames(tbl_int_var2) <- c("variable","poids rel.","CTR inertie","axe 1", "CTR",   "COS2",
                            "QLT","axe 2", "CTR","COS2","QLT")

#Aperçu de la table
head(tbl_int_var2)

## # A tibble: 4 x 11
##   variable `poids rel.` `CTR inertie` `axe 1` CTR   COS2  QLT   `axe 2` CTR  
##   <chr>    <chr>        <chr>         <chr>   <chr> <chr> <chr> <chr>   <chr>
## 1 Blessé … 17.03        3.25          -0.94   15.2  0.92  0.92  1.54    40.1 
## 2 Blessé … 38.69        1.52          -0.81   25.1  0.96  0.96  -0.93   33.6 
## 3 Indemne  41.68        1.4           1.18    58.2  1     1     0.04    0.1  
## 4 Tué      2.61         10.63         -0.76   1.5   0.65  0.65  3.17    26.2 
## # … with 2 more variables: COS2 <chr>, QLT <chr>

#Formattage conditionnel
#Coloration des correspondances var1
df <- tbl_int_var1

#Créer un vecteur de couleurs
#Valeurs négatives
colfunc.neg <- colorRampPalette(c("cyan", "cyan3"))
col.neg <- colfunc.neg(nrow(df))

#Valeurs positives
colfunc.pos <- colorRampPalette(c("yellow", "yellow2"))
col.pos <- colfunc.pos(nrow(df))

for (i in 1:nrow(df)){ #test pour axe1
  if (df[i,6]>0.5) {
    if (df[i,4]>0) {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background = col.pos[i])
    } else {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background=col.neg[i])
    } 
  }
  if (df[i,10]>0.5) { #test pour axe2
    if (df[i,8]>0) {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.pos[i])
    } else {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.neg[i])
    } 
  }
}
Y = kable(df, "html", escape = F, align = "c") %>%
  kable_styling(bootstrap_options = "bordered",row_label_position = "c", full_width = T, 
                latex_options="scale_down", fixed_thead = T)

#Coloration des correspondances var2
df <- tbl_int_var2

col.neg <- colfunc.neg(nrow(df))
col.pos <- colfunc.pos(nrow(df))

for (i in 1:nrow(df)){ #test pour axe1
  if (df[i,6]>0.5) {
    if (df[i,4]>0) {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background = col.pos[i])
    } else {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background=col.neg[i])
    } 
  }
  if (df[i,10]>0.5) { #test pour axe2
    if (df[i,8]>0) {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.pos[i])
    } else {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.neg[i])
    } 
  }
}
Z = kable(df, "html", escape = F, align = "c") %>%
  kable_styling(bootstrap_options = "bordered",row_label_position = "c", full_width = T, 
                latex_options="scale_down", fixed_thead = T)

Y;Z

variable	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
Conducteur	73.77	0.36	0.46	15.8	0.98	0.98	0.38	10.4	0.02	1
Passager	17.81	4.61	-0.45	3.7	0.6	0.6	-2.1	78.5	0.4	1
Piéton	8.42	10.88	-3.09	80.5	1	1	1.15	11.1	0	1

variable	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
Blessé hospitalisé	17.03	3.25	-0.94	15.2	0.92	0.92	1.54	40.1	0.08	1
Blessé léger	38.69	1.52	-0.81	25.1	0.96	0.96	-0.93	33.6	0.04	1
Indemne	41.68	1.4	1.18	58.2	1	1	0.04	0.1	0	1
Tué	2.61	10.63	-0.76	1.5	0.65	0.65	3.17	26.2	0.35	1

Le tableau d’interprétation contient :

Poids rel. : poids relatif, soit le pourcentage d’individus dans la table possédant les qualités de la variable.
CTR inertie : Contribution à l’inertie, “Inertie“ (physique) ou “ Variance” (statistique)
Axe 1 : coordonnée de la variable sur l’axe 1
Axe 2 : coordonnée de la variable sur l’axe 2
CTR : contribution
COS2 : Cosinus carré
QLT : Qualité, la somme partielle de cosinus carrés

Remarque :

Les points de faible contribution à l’inertie totale sont :
soit des points légers,
soit des points proches du centre de gravité
La contribution décroît en fonction de l’effectif, plus l’effectif est faible, plus la contribution est forte et plus le point est éloigné du centre de gravité.

La majorité des individus du fichier sont des conducteurs qui représentent 73,77% des individus, ensuite il y a les passagers qui représentent 17,81% du fichier et seulement 8,42% des personnes sont des piétons.

Aussi, les individus impliqués dans les accidents corporels sont majoritairement indemnes (41,68%) ou légèrement blessés (38,69%). Il y a 17,03% des personnes accidentées qui ont été hospitalisées et 2,61% sont décédées.

Les variables colorées sont celles qui sont significatives (avec un COS2 supérieur à 0,5), elles sont jaunes si elles sont situées positivement sur l’axe 1 ou bleu dans le cas contraire.

Ici, toutes les variables sont significativement liées à l’axe principal. Quand l’axe 1 prend une valeur forte, ‘indemne’ et ‘conducteur’ prennent aussi une valeur forte. Quand l’axe 1 prend une valeur faible, le reste des variables prennent aussi des valeurs faibles.

De plus, les variables ‘piétons’ et ‘tués’ ont une contribution à l’inertie très élevée, et inversement, ‘conducteur’ et ‘indemne’ ont une contribution à l’inertie très faible. Les variables ‘piétons’ et ‘tués’ contribuent fortement à la variance du nuage de points et sont écartés du centre de gravité (représentés dans le mapping ci-après).

Ce schéma simplifié de l’axe 1 permet d’interpréter les liens entre les deux variables :

Il y a un sureffectif de piétons (et plus ou moins de passagers) qui ont été grièvement ou légèrement blessés ou même tués⁽¹⁾.
Il y a un sureffectif de conducteurs sortis indemnes de l’accident⁽²⁾.

De plus :

Il y a un sous-effectif de piétons (et plus ou moins de passagers) qui sont sortis indemnes de l’accident⁽³⁾
Il y a un sous-effectif de conducteurs qui ont dû être soit hospitalisés ou blessés légèrement ou qui ont été tués⁽⁴⁾.

Ces liens sont représentés graphiquement sur ce ‘mapping’ :

Mapping

### Vue (Mapping) ####
sureffectif <- colors()[139]
souseffectif <- colors()[88]

if (kept_axes>=2){
  P=apply(X_tab_cont,2,sum)/sum(X_tab_cont)
  
  plot(afc$c1[,1:2],
       xlim=range(c(afc$c1[,1],afc$l1[,1])),
       ylim=range(c(afc$c1[,2],afc$l1[,2])),
       cex=p*P*2,pch=2,
       main = "Mapping",
       xlab=paste("Facteur 1   -   ",round(100*contributions[1],2)," %",sep=""),
       ylab=paste("Facteur 2   -   ",round(100*contributions[2],2)," %",sep=""))
  
  text(afc$c1[,1:2],labels=colnames(X_tab_cont),cex=0.75,
       font=2,pos=3,xpd=NA)
  
  abline(h=0,v=0,col="black")
  
  P=apply(X_tab_cont,1,sum)/sum(X_tab_cont)
  points(afc$l1[,1:2],cex=n*P*2,col="red") 
  text(afc$l1[,1:2],labels=rownames(X_tab_cont),cex=0.75,
       font=3,pos=3,xpd=NA,col="red")
  
  legend("bottomleft",c("sureffectif","sous-effectif"),lty = 1,
         col=c(sureffectif,souseffectif),cex=0.75,bty="n")
}

### Mapping des liens entre variables ###

#Agréger les coordonnées des points
gravite <- afc$c1[,1:2]
colnames(gravite) <- c("x","y")
gravite

##                             x           y
## Blessé hospitalisé -0.9445853  1.53533602
## Blessé léger       -0.8056959 -0.93185512
## Indemne             1.1815498  0.03939399
## Tué                -0.7610138  3.17049357

individu <- afc$l1[,1:2]
colnames(individu) <- c("x","y")
individu

##                     x          y
## Conducteur  0.4627489  0.3760818
## Passager   -0.4547225 -2.0994838
## Piéton     -3.0924431  1.1460929

coord <- rbind(gravite,individu)
coord

##                             x           y
## Blessé hospitalisé -0.9445853  1.53533602
## Blessé léger       -0.8056959 -0.93185512
## Indemne             1.1815498  0.03939399
## Tué                -0.7610138  3.17049357
## Conducteur          0.4627489  0.37608180
## Passager           -0.4547225 -2.09948382
## Piéton             -3.0924431  1.14609292

#Création fonction qui va lier les points
lien <- function(variable1,variable2,type_ligne,col_ligne){
  x1 <- coord$x[rownames(coord) == variable1]
  y1 <- coord$y[rownames(coord) == variable1]
  
  x2 <- coord$x[rownames(coord) == variable2]
  y2 <- coord$y[rownames(coord) == variable2]
  
  x12 <- c(x1,x2)
  y12 <- c(y1,y2)
  
  lines(x12,y12,lty=type_ligne,col=col_ligne)
}

#Ajouter les liens au graphique
#Variables en sureffectifs
lien("Conducteur","Indemne",1,sureffectif)
lien("Piéton","Blessé hospitalisé",1,sureffectif)
lien("Piéton","Blessé léger",1,sureffectif)
lien("Piéton","Tué",1,sureffectif)
lien("Passager","Blessé hospitalisé",2,sureffectif)
lien("Passager","Blessé léger",2,sureffectif)
lien("Passager","Tué",2,sureffectif)

#Variables en sous-effectifs
lien("Conducteur","Blessé hospitalisé",1,souseffectif)
lien("Conducteur","Blessé léger",1,souseffectif)
lien("Conducteur","Tué",1,souseffectif)
lien("Piéton","Indemne",1,souseffectif)
lien("Passager","Indemne",2,souseffectif)

Nous pouvons conclure que les individus les plus vulnérables aux accidents de la route sont les piétons, et ceux qui en sorte indemne sont souvent les conducteurs.

Partie II.

Maintenant, nous analyserons la liaison entre la gravité de l’accident (grav) et le motif de déplacement (trajet).

Préparation des données

#Importation
X=read.delim("var_AFC2.csv",header=T,sep=",")
X=X[,-1]

head(X)

##   grav trajet
## 1    3      0
## 2    1      5
## 3    1      0
## 4    4      0
## 5    3      5
## 6    1      0

#Vérification importation
dim(X)

## [1] 130169      2

sum(X)

## [1] NA

#On enlève les valeurs manquantes
X <- na.omit(X)
sum(X)

## [1] 780899

#On renomme les variables
X$grav[X$grav == 1] <- "Indemne"
X$grav[X$grav == 2] <- "Tué"
X$grav[X$grav == 3] <- "Blessé hospitalisé"
X$grav[X$grav == 4] <- "Blessé léger"

X$trajet[X$trajet == 1] <- "domicile_travail"
X$trajet[X$trajet == 2] <- "domicile_école"
X$trajet[X$trajet == 3] <- "courses_achats"
X$trajet[X$trajet == 4] <- "utilisation_pro"
X$trajet[X$trajet == 5] <- "loisirs"
X$trajet[X$trajet == 9] <- "autre"
X$trajet[X$trajet == 0] <- "autre" #0 pas indiqué dans la description donc on met 'autre'

#On renomme les colonnes du fichier
names(X)[1] <- "var1"
names(X)[2] <- "var2"

#Vérification
colnames(X)

## [1] "var1" "var2"

#On transforme les variables en qualitatives
X$var1=as.factor(X$var1)
X$var2=as.factor(X$var2)

Visualisation des données

Tableau de contingence

library(knitr)
library(kableExtra)
#Création d'un tableau de contingence
Z=matrix(table(X[,1],X[,2]),nlevels(X[,1]),nlevels(X[,2]))
rownames(Z)=levels(X[,1])
colnames(Z)=levels(X[,2])
X_tab_cont=Z
rm(Z)

Total <- sum

kable(addmargins(X_tab_cont,FUN = Total),"html",caption = "Tableau de contigence")%>%
  kable_styling(bootstrap_options = "basic")

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

Tableau de contigence
	autre	courses_achats	domicile_école	domicile_travail	loisirs	utilisation_pro	Total
Blessé hospitalisé	5833	802	582	2760	11264	920	22161
Blessé léger	16836	1292	1500	7603	19596	3473	50300
Indemne	16213	1509	1046	7314	19943	8179	54204
Tué	832	155	46	338	1868	151	3390
Total	39714	3758	3174	18015	52671	12723	130055

Dans cette partie, 130055 individus sont concernées et nous comptons (4 modalités lignes + 6 modalités colonnes) 10 modalités.

Graphique des contributions

#nbre de ligne et colonne
n=nrow(X_tab_cont);p=ncol(X_tab_cont)

#nbre d'axe égale 2
library(ade4)
afc = dudi.coa( X_tab_cont , scannf = F, nf=2)
kept_axes =afc$nf

### Histogramme des valeurs propres
contributions=afc$eig/sum(afc$eig)
g=barplot(afc$eig,main="Graphique des contributions",col="orange")
text(g,afc$eig,labels=paste(round(100*contributions,2),"%"),pos=3,xpd=NA)

Le nombre d’axe choisis est égale à deux. L’axe 1 contient 78,42% de l’information initiale et l’axe 2 contient 21,23%. Les deux axes représentent 99,65% de l’information initiale, l’analyse se portera sur ces deux axes seulement.

Tableau d’interpretation

#Importation tableau interpretation
library(readr)
tbl_interpretation <- read_delim("tableau_interpretation_AFC.csv", 
                                 ";", escape_double = FALSE, trim_ws = TRUE)
kable(tbl_interpretation,"html" )%>%
  kable_styling(bootstrap_options = "basic", full_width = F)

X1	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR_1	COS2_1	QLT_1
Blessé hospitalisé	17.04	3.48	-1.47	36.9	0.86	0.86	1.15	22.4	0.14	1
Blessé léger	38.68	1.53	-0.42	6.8	0.33	0.33	-1.16	52.2	0.67	1
Indemne	41.68	1.39	1.09	49.7	0.96	0.96	0.45	8.4	0.04	1
Tué	2.61	9.06	-1.59	6.6	0.59	0.59	2.55	17	0.41	1
NA	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
autre	30.54	1.05	0.11	0.4	0.04	0.04	-1.02	31.8	0.96	1
courses_achats	2.89	2.64	-0.52	0.8	0.3	0.3	1.54	6.8	0.7	1
domicile_école	2.44	3.89	-0.8	1.6	0.42	0.42	-1.8	7.9	0.58	1
domicile_travail	13.85	0.98	0.06	0.1	0.01	0.01	-0.99	13.5	0.99	1
loisirs	40.5	1.23	-0.7	19.7	0.71	0.71	0.86	30.3	0.29	1
utilisation_pro	9.78	8.92	2.81	77.5	0.97	0.97	1	9.7	0.03	1

#Segmentation de la table interpretation
#Création table pour la 1ère variable
tbl_int_var1 <- tbl_interpretation[1:nlevels(X$var1), ]
colnames(tbl_int_var1) <- c("variable","poids rel.","CTR inertie","axe 1", "CTR",   "COS2",
                            "QLT","axe 2", "CTR","COS2","QLT")
#Aperçu de la table
head(tbl_int_var1)

## # A tibble: 4 x 11
##   variable `poids rel.` `CTR inertie` `axe 1` CTR   COS2  QLT   `axe 2` CTR  
##   <chr>    <chr>        <chr>         <chr>   <chr> <chr> <chr> <chr>   <chr>
## 1 Blessé … 17.04        3.48          -1.47   36.9  0.86  0.86  1.15    22.4 
## 2 Blessé … 38.68        1.53          -0.42   6.8   0.33  0.33  -1.16   52.2 
## 3 Indemne  41.68        1.39          1.09    49.7  0.96  0.96  0.45    8.4  
## 4 Tué      2.61         9.06          -1.59   6.6   0.59  0.59  2.55    17   
## # … with 2 more variables: COS2 <chr>, QLT <chr>

#Création table pour la 2ème variable

#Numéro des lignes à sélectionner
#On sélectionne deux lignes après la fin de la 1ère variable
debut_ligne <- nlevels(X$var1)+2
#On va jusqu'à la fin du fichier
fin_ligne <- nrow(tbl_interpretation)

#On créer la table
tbl_int_var2 <- tbl_interpretation[debut_ligne:fin_ligne , ]

#Vérification de la table
dim(tbl_int_var2)

## [1]  6 11

#On renomme les colonnes
colnames(tbl_int_var2) <- c("variable","poids rel.","CTR inertie","axe 1", "CTR",   "COS2",
                            "QLT","axe 2", "CTR","COS2","QLT")

#Aperçu de la table
head(tbl_int_var2)

## # A tibble: 6 x 11
##   variable `poids rel.` `CTR inertie` `axe 1` CTR   COS2  QLT   `axe 2` CTR  
##   <chr>    <chr>        <chr>         <chr>   <chr> <chr> <chr> <chr>   <chr>
## 1 autre    30.54        1.05          0.11    0.4   0.04  0.04  -1.02   31.8 
## 2 courses… 2.89         2.64          -0.52   0.8   0.3   0.3   1.54    6.8  
## 3 domicil… 2.44         3.89          -0.8    1.6   0.42  0.42  -1.8    7.9  
## 4 domicil… 13.85        0.98          0.06    0.1   0.01  0.01  -0.99   13.5 
## 5 loisirs  40.5         1.23          -0.7    19.7  0.71  0.71  0.86    30.3 
## 6 utilisa… 9.78         8.92          2.81    77.5  0.97  0.97  1       9.7  
## # … with 2 more variables: COS2 <chr>, QLT <chr>

#Formattage conditionnel
#Coloration des correspondances var1
df <- tbl_int_var1

#Créer un vecteur de couleurs
#Valeurs négatives
colfunc.neg <- colorRampPalette(c("cyan", "cyan3"))
col.neg <- colfunc.neg(nrow(df))

#Valeurs positives
colfunc.pos <- colorRampPalette(c("yellow", "yellow2"))
col.pos <- colfunc.pos(nrow(df))

for (i in 1:nrow(df)){ #test pour axe1
  if (df[i,6]>0.5) {
    if (df[i,4]>0) {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background = col.pos[i])
    } else {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background=col.neg[i])
    } 
  }
  if (df[i,10]>0.5) { #test pour axe2
    if (df[i,8]>0) {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.pos[i])
    } else {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.neg[i])
    } 
  }
}
Y = kable(df, "html", escape = F, align = "c") %>%
  kable_styling(bootstrap_options = "bordered",row_label_position = "c", full_width = T, 
                latex_options="scale_down", fixed_thead = T)

#Coloration des correspondances var2
df <- tbl_int_var2

col.neg <- colfunc.neg(nrow(df))
col.pos <- colfunc.pos(nrow(df))

for (i in 1:nrow(df)){ #test pour axe1
  if (df[i,6]>0.5) {
    if (df[i,4]>0) {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background = col.pos[i])
    } else {
      df[i,c(1,4:6)] <- cell_spec(df[i,c(1,4:6)],background=col.neg[i])
    } 
  }
  if (df[i,10]>0.5) { #test pour axe2
    if (df[i,8]>0) {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.pos[i])
    } else {
      df[i,c(1,8:10)] <- cell_spec(df[i,c(1,8:10)],background = col.neg[i])
    } 
  }
}
Z = kable(df, "html", escape = F, align = "c") %>%
  kable_styling(bootstrap_options = "bordered",row_label_position = "c", full_width = T, 
                latex_options="scale_down", fixed_thead = T)

Y;Z

variable	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
Blessé hospitalisé	17.04	3.48	-1.47	36.9	0.86	0.86	1.15	22.4	0.14	1
Blessé léger	38.68	1.53	-0.42	6.8	0.33	0.33	-1.16	52.2	0.67	1
Indemne	41.68	1.39	1.09	49.7	0.96	0.96	0.45	8.4	0.04	1
Tué	2.61	9.06	-1.59	6.6	0.59	0.59	2.55	17	0.41	1

variable	poids rel.	CTR inertie	axe 1	CTR	COS2	QLT	axe 2	CTR	COS2	QLT
autre	30.54	1.05	0.11	0.4	0.04	0.04	-1.02	31.8	0.96	1
courses_achats	2.89	2.64	-0.52	0.8	0.3	0.3	1.54	6.8	0.7	1
domicile_école	2.44	3.89	-0.8	1.6	0.42	0.42	-1.8	7.9	0.58	1
domicile_travail	13.85	0.98	0.06	0.1	0.01	0.01	-0.99	13.5	0.99	1
loisirs	40.5	1.23	-0.7	19.7	0.71	0.71	0.86	30.3	0.29	1
utilisation_pro	9.78	8.92	2.81	77.5	0.97	0.97	1	9.7	0.03	1

Pour la plupart des accidents (40,5%), le motif de déplacement était les loisirs. 30,54% des accidents sont liés à des trajets autres que les déplacements du domicile pour aller à l’école ou au travail, pour faire les courses, pour les loisirs ou pour l’utilisation professionnelle. Le trajet domicile-travail représente 13,85% ; l’utilisation professionnelle 9,78% ; les courses/achats 2,89% et domicile-école 2,44%.

Positivement liés à l’axe 1, sont les variables ‘indemne’ et ‘utilisation_pro’ et négativement liés à cet axe sont les variables ‘blessé hospitalisé’, ‘tué’ et ‘loisirs’.

Il y a un sureffectif d’individus qui ont été tués ou hospitalisés alors qu’ils se déplaçaient pendant des activités de loisirs⁽¹⁾.

Il y a un sureffectif d’individus qui sont sortis indemnes de l’accident alors qu’ils étaient en déplacement professionnel⁽²⁾.

Il y a également un sous-effectif de personnes sorties indemnes des accidents pendant des activités de loisirs⁽³⁾ et il y a un sous-effectif de personnes tuées ou hospitalisées alors qu’ils étaient en déplacement professionnel⁽⁴⁾.

L’axe 2 révèle que : Il y a un sureffectif d’individus qui ont été légèrement blessés alors qu’ils se déplaçaient pour des trajets libellés ‘autres’ ou pour des trajets domicile-école ou domicile-travail⁽¹⁾. De plus, il y a un sous-effectif d’individus qui ont été légèrement blessés alors qu’ils se déplaçaient pour faire des courses/achats⁽²⁾.

Ces observations conviennent de dire que les personnes qui sortent pour des promenades ou pratiquer des loisirs on tendances à se retrouver dans des accidents graves et les personnes qui se déplacent pour un motif professionnel ont tendance à sortir indemne des accidents corporels. Nous pouvons aussi dire que les personnes qui se déplacent pour du domicile pour aller au travail ou à l’école, ou pour d’autres raisons sont enclines à être légèrement blessées en cas d’accident.

Mapping

### Vue (Mapping) ####
sureffectif <- colors()[139]
souseffectif <- colors()[88]

if (kept_axes>=2){
  P=apply(X_tab_cont,2,sum)/sum(X_tab_cont)
  
  plot(afc$c1[,1:2],
       xlim=range(c(afc$c1[,1],afc$l1[,1])),
       ylim=range(c(afc$c1[,2],afc$l1[,2])),
       cex=p*P*2,pch=2,
       main = "Mapping",
       xlab=paste("Facteur 1   -   ",round(100*contributions[1],2)," %",sep=""),
       ylab=paste("Facteur 2   -   ",round(100*contributions[2],2)," %",sep=""))
  
  text(afc$c1[,1:2],labels=colnames(X_tab_cont),cex=0.75,
       font=2,pos=3,xpd=NA)
  
  abline(h=0,v=0,col="black")
  
  P=apply(X_tab_cont,1,sum)/sum(X_tab_cont)
  points(afc$l1[,1:2],cex=n*P*2,col="red") 
  text(afc$l1[,1:2],labels=rownames(X_tab_cont),cex=0.75,
       font=3,pos=3,xpd=NA,col="red")
  
  legend("topright",c("sureffectif","sous-effectif"),lty = 1,
         col=c(sureffectif,souseffectif),cex=0.75,bty="n")
}

### Mapping des liens entre variables ###

#Agréger les coordonnées des points
gravite <- afc$c1[,1:2]
colnames(gravite) <- c("x","y")
gravite

##                            x          y
## autre             0.10861566 -1.0201506
## courses_achats   -0.52457178  1.5368689
## domicile_école   -0.80483753 -1.8001427
## domicile_travail  0.06291254 -0.9866539
## loisirs          -0.69742049  0.8646172
## utilisation_pro   2.81480765  0.9971452

trajet <- afc$l1[,1:2]
colnames(trajet) <- c("x","y")
trajet

##                             x         y
## Blessé hospitalisé -1.4717226  1.146338
## Blessé léger       -0.4205692 -1.161557
## Indemne             1.0914917  0.449475
## Tué                -1.5910745  2.554263

coord <- rbind(gravite,trajet)
coord

##                              x          y
## autre               0.10861566 -1.0201506
## courses_achats     -0.52457178  1.5368689
## domicile_école     -0.80483753 -1.8001427
## domicile_travail    0.06291254 -0.9866539
## loisirs            -0.69742049  0.8646172
## utilisation_pro     2.81480765  0.9971452
## Blessé hospitalisé -1.47172257  1.1463384
## Blessé léger       -0.42056923 -1.1615566
## Indemne             1.09149174  0.4494750
## Tué                -1.59107452  2.5542633

#Création fonction qui va lier les points
lien <- function(variable1,variable2,type_ligne,col_ligne){
  x1 <- coord$x[rownames(coord) == variable1]
  y1 <- coord$y[rownames(coord) == variable1]
  
  x2 <- coord$x[rownames(coord) == variable2]
  y2 <- coord$y[rownames(coord) == variable2]
  
  x12 <- c(x1,x2)
  y12 <- c(y1,y2)
  
  lines(x12,y12,lty=type_ligne,col=col_ligne)
}

#Ajouter les liens au graphique
#Variables en sureffectifs
lien("Tué","loisirs",1,sureffectif)
lien("Blessé hospitalisé","loisirs",1,sureffectif)
lien("Indemne","utilisation_pro",1,sureffectif)
lien("Blessé léger","autre",1,sureffectif)
lien("Blessé léger","domicile_école",1,sureffectif)
lien("Blessé léger","domicile_travail",1,sureffectif)

#Variables en sous-effectifs
lien("Tué","utilisation_pro",1,souseffectif)
lien("Blessé hospitalisé","utilisation_pro",1,souseffectif)
lien("Indemne","loisirs",1,souseffectif)
lien("Blessé léger","courses_achats",1,souseffectif)

Analyse Factorielle des Correspondances

des accidents corporels de la circulation

Ramlugon L.

26 avril 2020

Description

Base de données accidents corporels de la circulation

Variables utilisées

Partie I.

Préparation des données

Visualisation des données

Tableau de contingence

Graphique des contributions

Tableau d’interpretation

Mapping

Partie II.

Préparation des données

Visualisation des données

Tableau de contingence

Graphique des contributions

Tableau d’interpretation

Mapping