4  Mesures Continues du Genre

4.1 Présentation des données

La base de données utilisée porte sur les pratiques culturelles des français, 2018, (Enquête sur les pratiques culturelles des Français, 2018) elle comprend un total de 1572 variables, réparties en plusieurs modules thématiques .

La structure thématique des variables se présente comme suit :

Domaine Nombre de variables
Variables socio-démographiques 190
Loisirs et vacances 41
Pratiques en amateur 201
Jeux vidéo 29
Films, séries, émissions 287
Information 41
Écoute de musique et d’émissions 109
Bibliothèque et livres 121
Concerts, cinéma, théâtre, danse et festivals 233
Musées, expositions et patrimoine 94
Équipements et internet 29
Situation principale vis-à-vis du travail et activité professionnelle 48
Ressources culturelles 40
Situation dans l’enfance 103
Logement 6

Cette répartition met en évidence la quantité considérable de données relatives aux pratiques culturelles et de loisirs (plus de 1000 variables au total dans ces modules) , qui constitue la base de l’analyse pour la construction des indices de genre continus.

Le nombre total d’individus dans l’échantillon est de 9 234 .

L’échantillon est composé de 4 162 hommes et 5 072 femmes .

On présente une répartition par âge, revenu, satisfaction, niveau de diplôme, situation d’emploi, état de santé et situation de couple. Pour la majorité de ces caractéristiques (âge, revenu, satisfaction, diplôme, situation emploi, santé, couple), des différences statistiquement signifficatives entre hommes et femmes sont notées (p < 0.001 dans la plupart des cas) .

On détaille ensuite la fréquence de participation à diverses pratiques culturelles et en amateur, ventilée par sexe. Ce tableau illustre la différenciation marquée des pratiques selon le genre.

Par exemple : Le tricot (“Knitting”) est pratiqué par 27% des femmes contre seulement 1.8% des hommes (p < 0.001) . Le bricolage (“DIY”) est l’activité de 64% des hommes contre 45% des femmes (p < 0.001) . La pêche/chasse (“Fishing hunting”) est pratiquée par 17% des hommes et 4.2% des femmes (p < 0.001) . Tenir un journal intime (“Diary”) est l’habitude de 24% des femmes contre 6.8% des hommes (p < 0.001) . La danse (“Dancing”) concerne 35% des femmes et 9.9% des hommes (p < 0.001) . Les jeux vidéo (“Video games”) sont pratiqués par 42% des hommes et 36% des femmes (p < 0.001) .

Ces données sur les pratiques culturelles différenciées sont ensuite utilisées pour construire les indices continus de genre, via l’Analyse des Correspondances Multiples (ACM) et la régression LASSO . Les coordonnées obtenues par l’ACM et les coeffcients de la régression LASSO pour différentes variables culturelles sont les poids utilisés pour calculer ces indices.

code R 
library(foreign)
library(questionr) 
library(ggplot2) 
library(tidyverse) 
library(ggmosaic)
library(GGally) 
library(dataMaid)
library(dplyr) 
library(GDAtools)
library(FactoMineR)
library(gtsummary) 
library(factoextra)
library(gtsummary) 
library(kableExtra)
library(RColorBrewer) 
library(FactoMineR) 
library(xtable) 
library(explor)
library(MASS)
code R 
data<-read.csv2("pc18_quetelet_octobre2023.csv")
code R 
data$Sex <- factor(data$SEXE, 
                            levels = c(1, 2), 
                            labels = c("Men", "Women"))
my_data_frame <- data |> dplyr::rename( 
  Knitting = A1001 , 
  Cards_games = A1002,  
  Gambling = A1003 , 
  Cooking = A1004 , 
  DIY = A1005  ,
  Vegetable_garden = A1006 , 
  Ornamental_garden = A1007,  
  Fishing_hunting = A1008 , 
  Collection = A1009  ,
  Vehicle_custom = A1010 , 
  No_Amateur=A1011,
  Making_music = A1901  ,
  Diary = A1902  ,
  Writing = A1903,  
  Painting = A1904,  
  Montage = A1905 , 
  Circus = A1906  ,
  Pottery = A1907 , 
  Theater = A1908 , 
  Drawing = A1909 , 
  Dancing = A1910,  
  Photography = A1911  ,
  Genealogy = A1912 , 
  Science = A1913  ,
  None = A1914  ,
  Video_games = B1  ,
  TV = C1  ,
  Radio = E1  ,
  Library = F1  ,
  Museums = H112,  
  Internet = I4 , 
  Concert = G2413 )


my_data_frame$Video_games <- ifelse(my_data_frame$Video_games == 1, 1, 0)
my_data_frame$TV <- ifelse(my_data_frame$TV == 5, 0, 1)
my_data_frame$Radio <- ifelse(my_data_frame$Radio == 5, 0, 1)
my_data_frame$Library<- ifelse(my_data_frame$Library == 1, 1, 0)
my_data_frame$Museums<- ifelse(my_data_frame$Museums == 1, 0, 1)
my_data_frame$Internet<- ifelse(my_data_frame$Internet == 5, 0, 1)
my_data_frame$Concert<- ifelse(my_data_frame$Concert == 1, 0, 1)

my_data_frame <- my_data_frame %>%
  mutate(
    DIPLOMA = case_when(
      DIPLOM %in% c(1, 2, 3) ~ "Sans diplôme",
      DIPLOM %in% c(4, 5) ~ "CEP / Brevet / DNB",
      DIPLOM == 6 ~ "CAP / BEP",
      DIPLOM == 7 ~ "Bac général / technologique",
      DIPLOM == 8 ~ "Capacité / DAEU / ESEU",
      DIPLOM == 9 ~ "Bac professionnel / équivalent",
      DIPLOM %in% c(10, 11, 12) ~ "Bac+2 à Bac+5 (hors doctorat)",
      DIPLOM == 13 ~ "Doctorat",
      DIPLOM %in% c(14, 15) ~ NA_character_,
      TRUE ~ NA_character_
    )
  )


my_data_frame <- my_data_frame %>%
  mutate(satisfaction = case_when(
    A2 %in% 1 ~ "Low",      # 1 à 4 -> Low
    A2 %in% 2 ~ "Medium",   # 5 à 7 -> Medium
    A2 %in% 3 ~ "High",    # 8 à 10 -> High
    TRUE ~ NA_character_              
  ))  
my_data_frame <- my_data_frame %>%
  mutate(Income = case_when(
    CRITREVENU %in% 1:4 ~ "Low",      # 1 à 4 -> Low
    CRITREVENU %in% 5:7 ~ "Medium",   # 5 à 7 -> Medium
    CRITREVENU %in% 8:10 ~ "High",    # 8 à 10 -> High
    TRUE ~ NA_character_              
  ))

my_data_frame <- my_data_frame %>%
  mutate(Health = case_when(
    A15 %in% 1:2 ~ "Good",      # 1 à 4 -> Low
    A15 %in% 3 ~ "Medium",   # 5 à 7 -> Medium
    A15 %in% 4:5 ~ "Bad",    # 8 à 10 -> High
    TRUE ~ NA_character_              
  ))

my_data_frame <- my_data_frame %>%
  mutate(
    SITUA_lab = case_when(
      SITUA == 1 ~ "Occupe un emploi",
      SITUA == 2 ~ "Apprenti sous contrat ou stagiaire rémunéré",
      SITUA == 3 ~ "Etudiant, élève, en formation ou stagiaire non rémunéré",
      SITUA == 4 ~ "Chômeur (inscrit ou non à Pôle Emploi)",
      SITUA == 5 ~ "Retraité ou retiré des affaires ou en préretraite",
      SITUA == 6 ~ "Femme ou homme au foyer",
      SITUA == 7 ~ "Inactif ou inactive pour cause d'invalidité",
      SITUA == 8 ~ "Autre situation d'inactivité",
      SITUA == 9 ~ "NSP",
      SITUA == 10 ~ "REF",
      TRUE ~ NA_character_
    )
  )



my_data_frame <- my_data_frame %>%
  mutate(Couple = case_when(
    VITENCOUPLE %in% 1:2 ~ "Yes",     
    VITENCOUPLE %in% 3~ "No",  
    
    TRUE ~ NA_character_              
  ))

quartiles <- quantile(data$AGE, probs = c(0.25, 0.5, 0.75), na.rm = TRUE)

my_data_frame$age_group <- cut(
  my_data_frame$AGE,
  breaks = 4,  # Automatically divide into 4 slices
  labels = c("[15-38[", "[38-54[", "[54-67[", "[67-97["),  # Labels optionnels
  include.lowest = TRUE 
)
code R 
table <- my_data_frame |>
  tbl_summary(
    include = c( "age_group", "Income","Health", "satisfaction","Couple" ),
    by = "Sex"
  ) |>
  add_overall(last = TRUE) |>
  add_p()

table
Characteristic Men
N = 4,1621		 Women
N = 5,0721		 Overall
N = 9,2341		 p-value2
age_group


<0.001
    [15-38[ 905 (22%) 1,135 (22%) 2,040 (22%)
    [38-54[ 1,404 (34%) 1,590 (31%) 2,994 (32%)
    [54-67[ 1,454 (35%) 1,737 (34%) 3,191 (35%)
    [67-97[ 399 (9.6%) 610 (12%) 1,009 (11%)
Income


<0.001
    High 1,432 (39%) 1,464 (33%) 2,896 (36%)
    Low 762 (21%) 1,284 (29%) 2,046 (25%)
    Medium 1,476 (40%) 1,644 (37%) 3,120 (39%)
    Unknown 492 680 1,172
Health


<0.001
    Bad 322 (7.8%) 461 (9.1%) 783 (8.5%)
    Good 2,984 (72%) 3,426 (68%) 6,410 (70%)
    Medium 841 (20%) 1,157 (23%) 1,998 (22%)
    Unknown 15 28 43
satisfaction


<0.001
    High 1,461 (35%) 1,656 (33%) 3,117 (34%)
    Low 1,488 (36%) 2,015 (40%) 3,503 (38%)
    Medium 1,207 (29%) 1,398 (28%) 2,605 (28%)
    Unknown 6 3 9
Couple 2,444 (59%) 2,567 (51%) 5,011 (54%) <0.001
    Unknown 4 9 13
1 n (%)
2 Pearson’s Chi-squared test
code R 
table <- my_data_frame |>
  tbl_summary(
    include = c(  "Knitting" , 
                  "Cards_games",  
                  "Gambling" , 
                  "Cooking" , 
                  "DIY"  ,
                  "Vegetable_garden" , 
                  "Ornamental_garden",  
                  "Fishing_hunting" , 
                  "Collection"  ,
                  "Vehicle_custom", 
                  "Making_music"   ,
                  "Diary" ,
                  "Writing" ,  
                  "Painting",  
                  "Montage"  , 
                  "Circus"   ,
                  "Pottery" , 
                  "Theater" , 
                  "Drawing" , 
                  "Dancing",  
                  "Photography"  ,
                  "Genealogy" , 
                  "Science"  ,
                  "None"  ,
                  "No_Amateur",
                  "Video_games"  ,
                  "TV" ,
                  "Radio"  ,
                  
                  "Museums",  
                  "Internet", 
                  "Concert"),
    by = "Sex"
  ) |>
  add_overall(last = TRUE) |>
  add_p()

table
Characteristic Men
N = 4,1621		 Women
N = 5,0721		 Overall
N = 9,2341		 p-value2
Knitting 73 (1.8%) 1,370 (27%) 1,443 (16%) <0.001
Cards_games 1,899 (46%) 2,764 (54%) 4,663 (50%) <0.001
Gambling 990 (24%) 970 (19%) 1,960 (21%) <0.001
Cooking 1,685 (40%) 3,473 (68%) 5,158 (56%) <0.001
DIY 2,667 (64%) 2,283 (45%) 4,950 (54%) <0.001
Vegetable_garden 1,335 (32%) 1,245 (25%) 2,580 (28%) <0.001
Ornamental_garden 1,793 (43%) 2,198 (43%) 3,991 (43%) 0.8
Fishing_hunting 722 (17%) 212 (4.2%) 934 (10%) <0.001
Collection 395 (9.5%) 281 (5.5%) 676 (7.3%) <0.001
Vehicle_custom 264 (6.3%) 60 (1.2%) 324 (3.5%) <0.001
Making_music 1,312 (32%) 1,830 (36%) 3,142 (34%) <0.001
Diary 285 (6.8%) 1,206 (24%) 1,491 (16%) <0.001
Writing 410 (9.9%) 746 (15%) 1,156 (13%) <0.001
Painting 667 (16%) 1,303 (26%) 1,970 (21%) <0.001
Montage 843 (20%) 586 (12%) 1,429 (15%) <0.001
Circus 116 (2.8%) 179 (3.5%) 295 (3.2%) 0.044
Pottery 264 (6.3%) 705 (14%) 969 (10%) <0.001
Theater 483 (12%) 800 (16%) 1,283 (14%) <0.001
Drawing 864 (21%) 1,285 (25%) 2,149 (23%) <0.001
Dancing 410 (9.9%) 1,782 (35%) 2,192 (24%) <0.001
Photography 1,175 (28%) 1,176 (23%) 2,351 (25%) <0.001
Genealogy 513 (12%) 575 (11%) 1,088 (12%) 0.14
Science 611 (15%) 469 (9.2%) 1,080 (12%) <0.001
None 1,394 (33%) 1,261 (25%) 2,655 (29%) <0.001
No_Amateur 276 (6.6%) 359 (7.1%) 635 (6.9%) 0.4
Video_games 1,760 (42%) 1,827 (36%) 3,587 (39%) <0.001
TV 3,878 (93%) 4,806 (95%) 8,684 (94%) 0.001
Radio 3,522 (85%) 4,186 (83%) 7,708 (83%) 0.007
Museums 4,101 (99%) 5,009 (99%) 9,110 (99%) 0.4
Internet 3,459 (83%) 4,185 (83%) 7,644 (83%) 0.4
Concert 3,344 (80%) 4,234 (83%) 7,578 (82%) <0.001
1 n (%)
2 Pearson’s Chi-squared test

Lecture: Parmi l’ensemble des individus interrogés, 16% pratiquent le tricot (Knitting); 27% des femmes le pratiquent contre 1,8% des hommes

Encadré Technique 1: Détails de la méthode ACM

L’ACM permet d’explorer les relations entre plusieurs variables qualitatives en projetant les individus et les modalités dans un espace de faible dimension. Elle est souvent utilisée pour analyser des questionnaires et des tableaux de contingence complexes.

Principaux résultats d’une ACM

  1. Inertie totale

Mesure la dispersion des données et est donnée par :

\(I_{\text{total}} = \frac{q}{q-1} \sum_{k} \lambda_k\)

où \(\lambda_k\) sont les valeurs propres et \(q\) est le nombre total de modalités.

  1. Valeurs propres \(\lambda_k\)

Elles indiquent la variance expliquée par chaque axe factoriel. Plus une valeur propre est élevée, plus l’axe correspondant est important dans l’analyse.

  1. Rapports de corrélation \(\eta^2\)

Le rapport de corrélation \(\eta^2\) mesure la liaison entre une variable et un axe factoriel :

\(\eta^2 = \frac{\sum_{i} f_i d_{i,k}^2}{\sum_{i} f_i d_{i}^2}\)

où $f_i $ est la fréquence de l’individu/modalité $i $, et \(d_{i,k}\)est sa distance à l’axe \(k\) .

  1. Coordonnées des individus et modalités

Elles sont obtenues à partir des vecteurs propres et permettent la représentation graphique des données :

\(C_{i,k} = \frac{v_{i,k}}{\sqrt{\lambda_k}}\)

où \(v_{i,k}\) est le vecteur propre associé à l’axe \(k\).

  1. Cos² (Qualité de représentation)

Indique dans quelle mesure un point est bien représenté sur un axe donné. Une valeur proche de **1** signifie que la projection sur cet axe est pertinente.

  1. Contributions

Elles mesurent l’importance d’une modalité ou d’un individu dans la construction d’un axe. Plus une contribution est élevée, plus l’élément joue un rôle important dans l’interprétation de l’axe.

code R 
pratiques_cols_1 <- c( "Knitting" , 
                     "Cards_games",  
                     "Gambling" , 
                     "Cooking" , 
                     "DIY"  ,
                     "Vegetable_garden" , 
                     "Fishing_hunting" , 
                     "Collection"  ,
                     "Vehicle_custom",
                     "Making_music"   ,
                     "Diary" ,
                     "Writing" ,  
                     "Painting",  
                     "Montage"  , 
                     "Pottery" , 
                     "Theater" , 
                     "Drawing" , 
                     "Dancing",  
                     "Photography"  ,
                     "Genealogy" , 
                     "Science"  ,
                     "None" ,
                     "Video_games"  ,
                    
                     "Concert"
                            )


#MCA

# Add Sex Column to the selection
cols_of_interest_1 <- c("Sex", "AGE", pratiques_cols_1)

# Build a new dataframe with these columns
data_pratiques <- my_data_frame[, cols_of_interest_1]
data_pratiques$AGE <- cut(data_pratiques$AGE, 
                          breaks = quantile(data_pratiques$AGE, probs = seq(0, 1, 0.25), na.rm = TRUE), 
                          include.lowest = TRUE)
ra_data <- na.omit(data_pratiques)

cols_to_factor <- c(  "Knitting" , 
                      "Cards_games",  
                      "Gambling" , 
                      "Cooking" , 
                      "DIY"  ,
                      "Vegetable_garden" , 
                      "Fishing_hunting" , 
                      "Collection"  ,
                      "Vehicle_custom",
                      "Making_music"   ,
                      "Diary" ,
                      "Writing" ,  
                      "Painting",  
                      "Montage"  , 
                      "Pottery" , 
                      "Theater" , 
                      "Drawing" , 
                      "Dancing",  
                      "Photography"  ,
                      "Genealogy" , 
                      "Science"  ,
                      "None"  ,
                      "Video_games"  ,
                      
                      "Concert")

# apply as.factor to these columnns
ra_data[cols_to_factor] <- lapply(ra_data[cols_to_factor], as.factor)

# running MCA with FactoMiner
acm2_fm <- ra_data |> 
  FactoMineR::MCA(
    ncp = Inf,
    graph = TRUE,
    quali.sup = 1:2
  )

code R 
# Extract modality names
modalites_names <- rownames(acm2_fm$var$coord)

# Check modality names
head(modalites_names)
[1] "Knitting_0"    "Knitting_1"    "Cards_games_0" "Cards_games_1"
[5] "Gambling_0"    "Gambling_1"
code R 
# Extract coordinates for dimension 2
coord_dim2_modalites <- acm2_fm$var$coord[, 2]

# Create a table associating the modalities and their coordinates in dimension 2
modalites_coord <- data.frame(Modalite = modalites_names, Coord_Dim2 = coord_dim2_modalites)



# Keep only the two necessary columns
modalites_coord_selected <- modalites_coord[, c("Modalite", "Coord_Dim2")]

print(modalites_coord_selected)
                             Modalite   Coord_Dim2
Knitting_0                 Knitting_0  0.061083540
Knitting_1                 Knitting_1 -0.329800319
Cards_games_0           Cards_games_0 -0.191733041
Cards_games_1           Cards_games_1  0.187950189
Gambling_0                 Gambling_0 -0.172468113
Gambling_1                 Gambling_1  0.640067884
Cooking_0                   Cooking_0 -0.003343761
Cooking_1                   Cooking_1  0.002642336
DIY_0                           DIY_0 -0.560199305
DIY_1                           DIY_1  0.484827035
Vegetable_garden_0 Vegetable_garden_0 -0.276379719
Vegetable_garden_1 Vegetable_garden_1  0.712802577
Fishing_hunting_0   Fishing_hunting_0 -0.175132414
Fishing_hunting_1   Fishing_hunting_1  1.556315888
Collection_0             Collection_0 -0.065206794
Collection_1             Collection_1  0.825502582
Vehicle_custom_0     Vehicle_custom_0 -0.060085983
Vehicle_custom_1     Vehicle_custom_1  1.652364534
Making_music_0         Making_music_0  0.097404491
Making_music_1         Making_music_1 -0.188856829
Diary_0                       Diary_0  0.099861613
Diary_1                       Diary_1 -0.518597229
Writing_0                   Writing_0  0.057148968
Writing_1                   Writing_1 -0.399350660
Painting_0                 Painting_0  0.029400939
Painting_1                 Painting_1 -0.108410366
Montage_0                   Montage_0 -0.091139295
Montage_1                   Montage_1  0.497790202
Pottery_0                   Pottery_0  0.008044356
Pottery_1                   Pottery_1 -0.068613627
Theater_0                   Theater_0  0.066669573
Theater_1                   Theater_1 -0.413164281
Drawing_0                   Drawing_0  0.021651695
Drawing_1                   Drawing_1 -0.071383089
Dancing_0                   Dancing_0  0.168522075
Dancing_1                   Dancing_1 -0.541392541
Photography_0           Photography_0 -0.083774581
Photography_1           Photography_1  0.245266032
Genealogy_0               Genealogy_0 -0.026958429
Genealogy_1               Genealogy_1  0.201841328
Science_0                   Science_0 -0.061028864
Science_1                   Science_1  0.460767922
None_0                         None_0 -0.072250527
None_1                         None_1  0.179034357
Video_games_0           Video_games_0 -0.251059915
Video_games_1           Video_games_1  0.395242637
Concert_0                   Concert_0 -0.048232041
Concert_1                   Concert_1  0.010540018
code R 
# Initialize a vector to store the index of each individual
data_pratiques$indice_culturel <- 0

# Browse each individual
for (i in 1:nrow(data_pratiques)) {
  
  # Initialize individual's index to 0
  indice_individu <- 0
  
  # Browse each practice column (columns 3 to 27)
  for (pratique in 3:27) {
    
    # Retrieve the individual's response for this practice (0 or 1)
    reponse <- data_pratiques[i, pratique]
    
    # If the answer is 1, add the coordinate of the corresponding modality to the index.
    if (reponse == 1) {
      
      # Create the modality name (e.g. “knitting_1” or “knitting_0”)
      nom_modalite_1 <- paste0(names(data_pratiques)[pratique], "_1")
      nom_modalite_0 <- paste0(names(data_pratiques)[pratique], "_0")
      
      # Find the coordinate associated with the corresponding modality
      if (nom_modalite_1 %in% modalites_coord$Modalite) {
        indice_individu <- indice_individu + modalites_coord$Coord_Dim2[modalites_coord$Modalite == nom_modalite_1]
      }
      if (nom_modalite_0 %in% modalites_coord$Modalite) {
        indice_individu <- indice_individu + modalites_coord$Coord_Dim2[modalites_coord$Modalite == nom_modalite_0]
      }
    }
  }
  
  # Assign the calculated index to the individual
  data_pratiques$indice_culturel[i] <- indice_individu
}
####Normalisation

# Calculate minimum and maximum index values
min_indice <- min(data_pratiques$indice_culturel, na.rm = TRUE)
max_indice <- max(data_pratiques$indice_culturel, na.rm = TRUE)

# Normalize index
data_pratiques$indice_culturel_normalise <- (data_pratiques$indice_culturel - min_indice) / (max_indice - min_indice)

# Check results

head(data_pratiques[, c("indice_culturel", "indice_culturel_normalise")])
  indice_culturel indice_culturel_normalise
1       3.9263677                 0.8629797
2       0.8918710                 0.4200471
3       0.2275676                 0.3230815
4       0.2360965                 0.3243264
5       0.5743836                 0.3737048
6       0.4256581                 0.3519960

Notre indice est donc construit de la façon suivante:

\[I_{1j} = \sum_{k=1}^{Z} w_{1k} \cdot X_{k j}\]

Dans cette expression, \(I_{1j}\) désigne l’indice de l’individu \(j\), tandis que \(w_{1k}\) représente le poids associé à chaque variable culturelle \(X_{kj}\). La somme englobe toutes les variables culturelles \(Z\), ce qui nous permet de saisir l’engagement culturel global de l’individu.

code R 
my_data_frame$identity<-data_pratiques$indice_culturel_normalise
my_data_frame$indice<-ra_data$indice_culturel
ggplot(my_data_frame, aes(x = identity, fill = Sex)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c("blue", "pink")) + 
  labs(title = "Density of The Normalized Cultural Index by Sexe",
       x = "Normalized Cultural Index",
       y = "Density",
       fill = "Sexe") +
  theme_minimal()

code R 
stat_des_indice<-my_data_frame%>%
  tbl_summary(include=c("identity"),by = "Sex",
              statistic = list(
            all_continuous() ~ "{min} - {max}"
        )) %>%
  add_overall(last = TRUE) %>%
  add_p()
stat_des_indice
Characteristic Men
N = 4,1621		 Women
N = 5,0721		 Overall
N = 9,2341		 p-value2
identity 0.01 - 1.00 0.00 - 0.87 0.00 - 1.00 <0.001
1 Min - Max
2 Wilcoxon rank sum test

4.2 Précision de l’indice (Accuracy)

code R 
predictor_var <- my_data_frame$identity

# List of cultural activities
cultural_activities <- c(
   "Knitting" , 
                      "Cards_games",  
                      "Gambling" , 
                      "Cooking" , 
                      "DIY"  ,
                      "Vegetable_garden" , 
                      "Fishing_hunting" , 
                      "Collection"  ,
                      "Vehicle_custom",
                      "Making_music"   ,
                      "Diary" ,
                      "Writing" ,  
                      "Painting",  
                      "Montage"  , 
                      "Pottery" , 
                      "Theater" , 
                      "Drawing" , 
                      "Dancing",  
                      "Photography"  ,
                      "Genealogy" , 
                      "Science"  ,
                      "None"  ,
                      "Video_games"  ,
                      "Library"  ,
                      "Concert"
)

# Initialiser un tableau vide pour les résultats
result_table <- data.frame(Activity = character(), Accuracy = numeric(), stringsAsFactors = FALSE)

# Boucle sur chaque activité culturelle
for (activity in cultural_activities) {
  
  # Créer la formule du modèle
  model_formula <- as.formula(paste(activity, "~ identity"))
  
  # Estimer le modèle Probit
  model <- glm(model_formula, data = my_data_frame, family = binomial(link = "probit"))
  
  # Prédictions
  predicted <- ifelse(predict(model, type = "response") >= 0.5, 1, 0)
  
  # Calcul de l'exactitude
  correct_predictions <- sum(predicted == my_data_frame[[activity]], na.rm = TRUE)
  total_predictions <- nrow(my_data_frame)
  accuracy <- (correct_predictions / total_predictions) * 100
  
  # Ajouter la ligne au tableau de résultats
  result_table[nrow(result_table) + 1, ] <- list(Activity = activity, Accuracy = accuracy)
}

# Afficher le tableau final
print(result_table)
           Activity Accuracy
1          Knitting 84.40546
2       Cards_games 50.49816
3          Gambling 79.21811
4           Cooking 56.15118
5               DIY 52.83734
6  Vegetable_garden 72.55794
7   Fishing_hunting 93.40481
8        Collection 92.49513
9    Vehicle_custom 97.04353
10     Making_music 66.36344
11            Diary 84.96859
12          Writing 87.48105
13         Painting 78.66580
14          Montage 84.41629
15          Pottery 89.50617
16          Theater 86.10570
17          Drawing 76.72731
18          Dancing 79.33723
19      Photography 74.53974
20        Genealogy 88.21746
21          Science 88.32575
22             None 70.14295
23      Video_games 61.93416
24          Library 16.60169
25          Concert 82.06628

4.3 Comparaisons avec des mesures existantes

code R 
my_data_frame$identity_scale <- cut(
  my_data_frame$identity,
  breaks = 7,  # Automatically divide into 7 slices
  labels = c("Very Feminine", "1", "2", "3", "4", "5", "Very Masculine"), 
  include.lowest = TRUE  
)
table1 <-
  my_data_frame |> 
  tbl_summary(include = c(identity_scale),
  by=Sex ,)|> 
    add_p()
table1
Characteristic Men
N = 4,1621		 Women
N = 5,0721		 p-value2
identity_scale

<0.001
    Very Feminine 6 (0.1%) 246 (4.9%)
    1 631 (15%) 2,220 (44%)
    2 2,274 (55%) 2,270 (45%)
    3 852 (20%) 274 (5.4%)
    4 324 (7.8%) 56 (1.1%)
    5 61 (1.5%) 5 (<0.1%)
    Very Masculine 14 (0.3%) 1 (<0.1%)
1 n (%)
2 Pearson’s Chi-squared test

4.4 Indice alternatif: Méthode de LASSO

Note

Construction d’un indice par régression LASSO

La régression LASSO (Least Absolute Shrinkage and Selection Operator) est une méthode de régression pénalisée qui sélectionne automatiquement les variables les plus pertinentes en contraignant la somme des valeurs absolues des coefficients. Dans notre analyse, nous avons utilisé la régression LASSO avec validation croisée sur un ensemble d’activités culturelles pour prédire le sexe des individus (homme ou femme).

Les variables ayant des coeffcients non nuls après régularisation ont été retenues. Un score linéaire a ensuite été calculé pour chaque individu sous la forme : \[ \text{IndiceLASSO} = \sum_{j \in S} \beta_j \, x_j \] où S est l’ensemble des variables sélectionnées, βj leur coefficient estimé, et xj la valeur observée de la variable pour un individu donné. Cet indice est ensuite normalisé entre 0 et 1 pour faciliter l’interprétation. Il reflète le positionnement d’un individu sur une dimension latente déterminée automatiquement par les pratiques différenciatrices selon le sexe.

code R 
### 1️⃣ Préparation des données ----
library(glmnet)
library(ggplot2)

# Liste des variables
vars <- c("SEXE", "Knitting", "Cards_games", "Gambling", "Cooking", "DIY",
          "Vegetable_garden", "Ornamental_garden", "Fishing_hunting", "Collection",
          "Vehicle_custom", "Making_music", "Diary", "Writing", "Painting", "Montage",
          "Circus", "Pottery", "Theater", "Drawing", "Dancing", "Photography",
          "Genealogy", "Science", "None", "No_Amateur", "Video_games", "TV",
          "Radio", "Library", "Museums", "Internet", "Concert")

# Sous-ensemble des variables
df_subset <- my_data_frame[, vars]

# Remplacer NA par 0 dans les variables explicatives
df_subset[,-1] <- lapply(df_subset[,-1], function(x) { x[is.na(x)] <- 0; x })

# Convertir SEXE en facteur binaire
df_subset$SEXE <- as.factor(df_subset$SEXE)

# Split train / test
set.seed(123)
n <- nrow(df_subset)
train_index <- sample(seq_len(n), size = floor(2*n/3))

train_data <- df_subset[train_index, ]
test_data  <- df_subset[-train_index, ]

### 2️⃣ Matrices X et y ----
x_train <- model.matrix(SEXE ~ ., data = train_data)[, -1]
y_train <- train_data$SEXE

x_test <- model.matrix(SEXE ~ ., data = test_data)[, -1]
y_test <- test_data$SEXE

### 3️⃣ LASSO avec CV ----
cv_lasso <- cv.glmnet(x_train, y_train, alpha = 1, family = "binomial")
best_lambda <- cv_lasso$lambda.min
cat("Meilleur lambda :", best_lambda, "\n")
Meilleur lambda : 0.0007031016
code R 
# Coefficients non nuls
coef_lasso <- coef(cv_lasso, s = "lambda.min")
coeffs_df <- data.frame(
  Variable = rownames(as.matrix(coef_lasso)),
  Coefficient = as.numeric(coef_lasso)
)
coeffs_nz <- subset(coeffs_df, Coefficient != 0 & Variable != "(Intercept)")
print(coeffs_nz)
            Variable Coefficient
2           Knitting  2.98242981
3        Cards_games  0.26392201
4           Gambling -0.35960101
5            Cooking  1.21424483
6                DIY -1.03128656
7   Vegetable_garden -0.31484191
8  Ornamental_garden  0.32275720
9    Fishing_hunting -1.48259504
10        Collection -0.82958419
11    Vehicle_custom -1.55077014
12      Making_music -0.12868620
13             Diary  1.38419740
14           Writing -0.19190960
15          Painting  0.44889901
16           Montage -1.10040003
17            Circus -0.07251206
18           Pottery  0.50947384
19           Theater -0.11880824
20           Drawing -0.06715409
21           Dancing  1.56074804
22       Photography -0.37176873
23         Genealogy -0.49266909
24           Science -0.80041792
25              None -0.13557802
26        No_Amateur  0.52796323
27       Video_games -0.17248226
28                TV  0.43000010
29             Radio -0.27969494
30           Library  0.66452149
31           Museums -0.20554024
32          Internet  0.07508547
33           Concert  0.03839690
code R 
### 4️⃣ Calcul de l'indice composite ----
vars_kept <- intersect(coeffs_nz$Variable, colnames(x_test))
x_test_reduced <- x_test[, vars_kept, drop = FALSE]
coef_vector <- coeffs_nz$Coefficient[match(vars_kept, coeffs_nz$Variable)]

# Score brut
test_data$score_LASSO <- as.numeric(x_test_reduced %*% coef_vector)

# Normalisation
min_s <- min(test_data$score_LASSO, na.rm = TRUE)
max_s <- max(test_data$score_LASSO, na.rm = TRUE)
test_data$score_normalise_LASSO <- if (max_s > min_s) {
  (test_data$score_LASSO - min_s) / (max_s - min_s)
} else { 0 }

### 5️⃣ Visualisation ----
ggplot(test_data, aes(x = score_normalise_LASSO, color = SEXE, fill = SEXE)) +
  geom_density(alpha = 0.4) +
  labs(title = "Densité du Score Normalisé (LASSO)",
       x = "Score Normalisé",
       y = "Densité") +
  scale_fill_manual(values = c("blue", "pink")) +
  scale_color_manual(values = c("blue", "pink")) +
  theme_minimal()

code R 
# ✅ 1. On garde uniquement les variables présentes à la fois dans les coeffs et dans my_data_frame
vars_kept <- intersect(coeffs_nz$Variable, colnames(my_data_frame))

# ✅ 2. Sous‐ensemble de la matrice de données
x_full_reduced <- my_data_frame[, vars_kept, drop = FALSE]

# ✅ 3. Vecteur des coefficients dans le même ordre que les variables conservées
coef_vector <- coeffs_nz$Coefficient[match(vars_kept, coeffs_nz$Variable)]

# ✅ 4. Calcul du score brut LASSO
my_data_frame$score_LASSO <- as.numeric(as.matrix(x_full_reduced) %*% coef_vector)

# ✅ 5. Normalisation du score
min_s <- min(my_data_frame$score_LASSO, na.rm = TRUE)
max_s <- max(my_data_frame$score_LASSO, na.rm = TRUE)

my_data_frame$score_normalise_LASSO <- if (max_s > min_s) {
  (my_data_frame$score_LASSO - min_s) / (max_s - min_s)
} else {
  0
}
code R 
predictor_var <- my_data_frame$score_LASSO

# List of cultural activities
cultural_activities <- c(
   "Knitting" , 
                      "Cards_games",  
                      "Gambling" , 
                      "Cooking" , 
                      "DIY"  ,
                      "Vegetable_garden" , 
                      "Fishing_hunting" , 
                      "Collection"  ,
                      "Vehicle_custom",
                      "Making_music"   ,
                      "Diary" ,
                      "Writing" ,  
                      "Painting",  
                      "Montage"  , 
                      "Pottery" , 
                      "Theater" , 
                      "Drawing" , 
                      "Dancing",  
                      "Photography"  ,
                      "Genealogy" , 
                      "Science"  ,
                      "None"  ,
                      "Video_games"  ,
                      "Library"  ,
                      "Concert"
)

# Initialiser un tableau vide pour les résultats
result_table <- data.frame(Activity = character(), Accuracy = numeric(), stringsAsFactors = FALSE)

# Boucle sur chaque activité culturelle
for (activity in cultural_activities) {
  
  # Créer la formule du modèle
  model_formula <- as.formula(paste(activity, "~ score_LASSO"))
  
  # Estimer le modèle Probit
  model <- glm(model_formula, data = my_data_frame, family = binomial(link = "probit"))
  
  # Prédictions
  predicted <- ifelse(predict(model, type = "response") >= 0.5, 1, 0)
  
  # Calcul de l'exactitude
  correct_predictions <- sum(predicted == my_data_frame[[activity]], na.rm = TRUE)
  total_predictions <- nrow(my_data_frame)
  accuracy <- (correct_predictions / total_predictions) * 100
  
  # Ajouter la ligne au tableau de résultats
  result_table[nrow(result_table) + 1, ] <- list(Activity = activity, Accuracy = accuracy)
}

# Afficher le tableau final
print(result_table)
           Activity Accuracy
1          Knitting 72.73121
2       Cards_games 50.21659
3          Gambling 78.77410
4           Cooking 54.02859
5               DIY 50.77973
6  Vegetable_garden 72.05978
7   Fishing_hunting 89.88521
8        Collection 92.67923
9    Vehicle_custom 96.49123
10     Making_music 61.72840
11            Diary 73.85748
12          Writing 87.48105
13         Painting 76.96556
14          Montage 84.13472
15          Pottery 89.50617
16          Theater 86.10570
17          Drawing 76.72731
18          Dancing 64.71735
19      Photography 74.53974
20        Genealogy 88.21746
21          Science 88.30409
22             None 71.24756
23      Video_games 56.08620
24          Library 15.29131
25          Concert 82.06628
code R 
my_data_frame$score_scale <- cut(
  my_data_frame$score_normalise_LASSO,
  breaks = 7,  # Automatically divide into 7 slices
  labels = c("Very Masculine", "1", "2", "3", "4", "5", "Very Feminine"), 
  include.lowest = TRUE  
)
table1 <-
  my_data_frame |> 
  tbl_summary(include = c(score_scale),
  by=Sex ,)|>
  add_p()
    
table1
Characteristic Men
N = 4,1621		 Women
N = 5,0721		 p-value2
score_scale

<0.001
    Very Masculine 25 (2.7%) 1 (<0.1%)
    1 186 (20%) 19 (1.2%)
    2 441 (47%) 223 (14%)
    3 251 (27%) 594 (36%)
    4 32 (3.4%) 514 (31%)
    5 3 (0.3%) 224 (14%)
    Very Feminine 1 (0.1%) 60 (3.7%)
    Unknown 3,223 3,437
1 n (%)
2 Pearson’s Chi-squared test
code R 
# Proportions de 'score_scale' par genre
table_score_gender <- table(my_data_frame$score_scale, my_data_frame$Sex)
table_score_gender_percent <- prop.table(table_score_gender, 2) * 100  # Calcul par genre
table_score_gender_percent
                
                         Men       Women
  Very Masculine  2.66240682  0.06116208
  1              19.80830671  1.16207951
  2              46.96485623 13.63914373
  3              26.73056443 36.33027523
  4               3.40788072 31.43730887
  5               0.31948882 13.70030581
  Very Feminine   0.10649627  3.66972477
code R 
# Proportions de 'satisfaction' par genre
table_satisfaction_gender <- table(my_data_frame$satisfaction, my_data_frame$Sex)
table_satisfaction_gender_percent <- prop.table(table_satisfaction_gender, 2) * 100  # Calcul par genre
table_satisfaction_gender_percent
        
              Men    Women
  High   35.15399 32.66917
  Low    35.80366 39.75143
  Medium 29.04235 27.57940
code R 
# Visualiser la relation entre indice_normalise et score_normalise
library(ggplot2)
ggplot(my_data_frame, aes(x = identity, y = score_normalise_LASSO)) +
  geom_point(alpha = 0.5) +
  labs(title = "Relation entre indice_normalise et score_normalise", 
       x = "Indice Normalisé", 
       y = "Score Normalisé") +
  theme_minimal() +
  geom_smooth(method = "lm", col = "red", se = FALSE)  # Ajouter une droite de régression linéaire

code R 
# Convertir les variables en facteurs si nécessaire
my_data_frame$DIPLOM <- as.factor(my_data_frame$DIPLOM)
my_data_frame$SEXE <- as.factor(my_data_frame$SEXE)
my_data_frame$CLASSIF <- as.factor(my_data_frame$CLASSIF)
my_data_frame$Income <- as.factor(my_data_frame$Income)
my_data_frame$Health <- as.factor(my_data_frame$Health)
my_data_frame$satisfaction <- as.factor(my_data_frame$satisfaction)
my_data_frame$SITUA <- as.factor(my_data_frame$SITUA)
my_data_frame$CS2D <- as.factor(my_data_frame$CS2D)

# Créer une fonction pour comparer les modèles avec 'score' et 'Sex' comme prédicteurs
compare_models <- function(variable) {
  # Affichage de la variable actuellement traitée
  cat("Traitement de la variable :", variable, "\n")
  
  # Modèle avec score comme prédicteur
  model_score <- polr(as.formula(paste(variable, "~ score_normalise_LASSO")), data = my_data_frame, method = "logistic")
  
  # Modèle avec sexe comme prédicteur
  model_sex <- polr(as.formula(paste(variable, "~ SEXE")), data = my_data_frame, method = "logistic")
  
  # Comparer l'AIC des deux modèles
  aic_score <- AIC(model_score)
  aic_sex <- AIC(model_sex)
  
  # Comparer et retourner le meilleur modèle
  if (aic_score < aic_sex) {
    return(data.frame(variable = variable, best_predictor = "Score", AIC_score = aic_score, AIC_sex = aic_sex))
  } else {
    return(data.frame(variable = variable, best_predictor = "Sex", AIC_score = aic_score, AIC_sex = aic_sex))
  }
}

# Liste des variables d'intérêt à analyser
variables <- c("DIPLOM", "CLASSIF", "SITUA", "satisfaction", "Health", "Income", "CS2D")

# Appliquer la fonction pour chaque variable d'intérêt et combiner les résultats
results <- do.call(rbind, lapply(variables, compare_models))
Traitement de la variable : DIPLOM 
Traitement de la variable : CLASSIF 
Traitement de la variable : SITUA 
Traitement de la variable : satisfaction 
Traitement de la variable : Health 
Traitement de la variable : Income 
Traitement de la variable : CS2D
code R 
# Afficher les résultats sous forme de tableau
print(results)
      variable best_predictor AIC_score   AIC_sex
1       DIPLOM          Score 11289.847 41877.259
2      CLASSIF          Score  2397.286  9303.852
3        SITUA          Score  7175.685 24316.900
4 satisfaction          Score  5550.873 20141.519
5       Health          Score  3288.556 14578.985
6       Income          Score  4835.411 17469.113
7         CS2D          Score  8191.713 29114.292
code R 
# Convertir les variables en facteurs si nécessaire
my_data_frame$DIPLOM <- as.factor(my_data_frame$DIPLOM)
my_data_frame$SEXE <- as.factor(my_data_frame$SEXE)
my_data_frame$CLASSIF <- as.factor(my_data_frame$CLASSIF)
my_data_frame$Income <- as.factor(my_data_frame$Income)
my_data_frame$Health <- as.factor(my_data_frame$Health)
my_data_frame$satisfaction <- as.factor(my_data_frame$satisfaction)
my_data_frame$SITUA <- as.factor(my_data_frame$SITUA)
my_data_frame$CS2D <- as.factor(my_data_frame$CS2D)

# Créer une fonction pour comparer les modèles avec 'score' et 'Sex' comme prédicteurs
compare_models <- function(variable) {
  # Affichage de la variable actuellement traitée
  cat("Traitement de la variable :", variable, "\n")
  
  # Modèle avec score comme prédicteur
  model_score <- polr(as.formula(paste(variable, "~ score_normalise_LASSO")), data = my_data_frame, method = "logistic")
  
  # Modèle avec sexe comme prédicteur
  model_id <- polr(as.formula(paste(variable, "~ identity")), data = my_data_frame, method = "logistic")
  
  # Comparer l'AIC des deux modèles
  aic_score <- AIC(model_score)
  aic_id <- AIC(model_id)
  
  # Comparer et retourner le meilleur modèle
  if (aic_score < aic_id) {
    return(data.frame(variable = variable, best_predictor = "Score", AIC_score = aic_score, AIC_id = aic_id))
  } else {
    return(data.frame(variable = variable, best_predictor = "id", AIC_score = aic_score, AIC_id = aic_id))
  }
}

# Liste des variables d'intérêt à analyser
variables <- c("satisfaction", "Health", "Income")

# Appliquer la fonction pour chaque variable d'intérêt et combiner les résultats
results <- do.call(rbind, lapply(variables, compare_models))
Traitement de la variable : satisfaction 
Traitement de la variable : Health 
Traitement de la variable : Income
code R 
# Afficher les résultats sous forme de tableau
print(results)
      variable best_predictor AIC_score   AIC_id
1 satisfaction          Score  5550.873 20142.02
2       Health          Score  3288.556 14580.80
3       Income          Score  4835.411 17466.37

4.5 Variables socio-économiques et score de genre

4.5.1 Femmes:

code R 
df_femmes <- my_data_frame %>% 
  filter(Sex == "Women")

# Choix des variables explicatives
group_vars <- c("Income", "age_group", "DIPLOMA", "Health")

# Créer un tableau avec score_scale en colonnes et les variables explicatives en lignes
table_lasso_femmes_inverse <- 
  df_femmes %>%
  tbl_summary(
    by = score_scale,              # score_scale en colonnes
    include = all_of(group_vars),  # variables explicatives en lignes
    statistic = all_categorical() ~ "{p}%",
    missing = "no"
  )%>%
  add_p()
table_lasso_femmes_inverse
Characteristic Very Masculine
N = 11		 1
N = 191		 2
N = 2231		 3
N = 5941		 4
N = 5141		 5
N = 2241		 Very Feminine
N = 601		 p-value
Income







    High 0% 33% 39% 40% 42% 41% 38%
    Low 0% 28% 28% 23% 24% 26% 30%
    Medium 100% 39% 34% 37% 34% 34% 32%
age_group







    [15-38[ 0% 37% 30% 30% 29% 33% 28%
    [38-54[ 0% 32% 34% 36% 35% 26% 30%
    [54-67[ 100% 26% 28% 28% 29% 35% 33%
    [67-97[ 0% 5.3% 7.6% 6.6% 7.0% 6.3% 8.3%
DIPLOMA







    Bac général / technologique 0% 11% 16% 18% 17% 16% 22%
    Bac professionnel / équivalent 0% 16% 6.3% 4.2% 4.5% 3.6% 3.3%
    Bac+2 à Bac+5 (hors doctorat) 100% 21% 43% 42% 48% 54% 57%
    CAP / BEP 0% 16% 16% 15% 14% 9.4% 6.7%
    Capacité / DAEU / ESEU 0% 0% 0.5% 0.3% 0.4% 0.4% 0%
    CEP / Brevet / DNB 0% 16% 11% 14% 13% 12% 10%
    Doctorat 0% 0% 2.3% 1.0% 1.0% 1.8% 1.7%
    Sans diplôme 0% 21% 5.0% 4.7% 2.9% 3.6% 0%
Health







    Bad 0% 0% 7.7% 5.2% 4.9% 6.7% 5.0%
    Good 100% 84% 77% 79% 77% 75% 70%
    Medium 0% 16% 16% 16% 18% 18% 25%
1

4.5.2 Hommes:

code R 
df_hommes <- my_data_frame %>% 
  filter(Sex == "Men")

# Choix des variables explicatives
group_vars <- c("Income", "age_group", "DIPLOMA", "Health")

# Créer un tableau avec score_scale en colonnes et les variables explicatives en lignes
table_lasso_hommes_inverse <- 
  df_hommes %>%
  tbl_summary(
    by = score_scale,              # score_scale en colonnes
    include = all_of(group_vars),  # variables explicatives en lignes
    statistic = all_categorical() ~ "{p}%",
    missing = "no"
  ) %>%
  add_p()
table_lasso_hommes_inverse
Characteristic Very Masculine
N = 251		 1
N = 1861		 2
N = 4411		 3
N = 2511		 4
N = 321		 5
N = 31		 Very Feminine
N = 11		 p-value
Income







    High 55% 47% 49% 42% 63% 100% 100%
    Low 18% 15% 17% 21% 10% 0% 0%
    Medium 27% 38% 34% 37% 27% 0% 0%
age_group







    [15-38[ 40% 39% 27% 30% 38% 33% 0%
    [38-54[ 36% 37% 32% 35% 22% 67% 0%
    [54-67[ 20% 22% 34% 28% 25% 0% 0%
    [67-97[ 4.0% 3.2% 7.5% 6.8% 16% 0% 100%
DIPLOMA







    Bac général / technologique 8.0% 13% 16% 12% 9.4% 33% 0%
    Bac professionnel / équivalent 8.0% 5.9% 7.3% 8.0% 3.1% 0% 0%
    Bac+2 à Bac+5 (hors doctorat) 32% 45% 42% 48% 63% 67% 100%
    CAP / BEP 24% 16% 20% 15% 6.3% 0% 0%
    Capacité / DAEU / ESEU 0% 0.5% 0.2% 0% 0% 0% 0%
    CEP / Brevet / DNB 24% 15% 9.3% 10% 3.1% 0% 0%
    Doctorat 0% 1.6% 2.7% 3.2% 9.4% 0% 0%
    Sans diplôme 4.0% 2.7% 3.2% 4.0% 6.3% 0% 0%
Health







    Bad 0% 2.2% 5.3% 6.4% 6.3% 0% 0%
    Good 88% 85% 82% 76% 81% 100% 100%
    Medium 12% 13% 13% 17% 13% 0% 0%
1

4.6 Distance aux normes

code R 
library(dplyr)
library(ggplot2)

# S'assurer que SEXE est bien un facteur clair
my_data_frame$Sex <- factor(my_data_frame$Sex, levels = c("Men", "Women"))

# Calcul direct du z-score par groupe (pas de jointure)
my_data_frame <- my_data_frame %>%
  group_by(Sex) %>%
  mutate(
    mean_gender = mean(score_normalise_LASSO, na.rm = TRUE),
    sd_gender = sd(score_normalise_LASSO, na.rm = TRUE),
    distance_abs = abs((score_normalise_LASSO - mean_gender) / sd_gender)
  ) %>%
  ungroup()

# Calcul des moyennes des distances par sexe
mean_distances <- my_data_frame %>%
  group_by(Sex) %>%
  summarise(
    mean_distance = mean(distance_abs, na.rm = TRUE),
    .groups = "drop"
  )

# Visualisation
ggplot(my_data_frame, aes(x = distance_abs, color = Sex, fill = Sex)) +
  geom_density(alpha = 0.4) +
  labs(
    title = "Density of Distance to the Norm (Score), by Sex",
    x = "Distance to the Norm (Z-score)",
    y = "Density"
  ) +
  scale_fill_manual(values = c("blue", "pink")) +
  scale_color_manual(values = c("blue", "pink")) +
  theme_minimal() +
  geom_vline(
    data = mean_distances,
    aes(xintercept = mean_distance, color = Sex),
    linetype = "dashed"
  ) +
  theme(legend.title = element_blank())

code R 
library(dplyr)
library(ggplot2)
library(plotly)

# Convertir DIPLOM et Sex en facteurs
my_data_frame$DIPLOM <- as.factor(my_data_frame$DIPLOM)
my_data_frame$Sex <- as.factor(my_data_frame$Sex)

# Création des quartiles de distance_abs
my_data_frame <- my_data_frame %>%
  mutate(quartile_distance = cut(distance_abs, 
                                 breaks = quantile(distance_abs, probs = c(0, 0.25, 0.5, 0.75, 1), na.rm = TRUE), 
                                 include.lowest = TRUE, 
                                 labels = c("Q1", "Q2", "Q3", "Q4")))  # Étiquettes des quartiles

# Créer un tableau de proportions
df_proportions <- my_data_frame %>%
  group_by(Sex, DIPLOM, quartile_distance) %>%
  summarise(count = n(), .groups = "drop") %>%
  group_by(Sex, DIPLOM) %>%
  mutate(proportion = count / sum(count))  # Calcul de la proportion

# Ajouter une colonne avec les descriptions des diplômes
diplome_labels <- c(
  "Vous n'avez jamais été à l'école ou vous l'avez quittée avant la fin du primaire",
  "Aucun diplôme et scolarité interrompue à la fin du primaire ou avant la fin du collège",
  "Aucun diplôme et scolarité jusqu'à la fin du collège et au-delà",
  "CEP",
  "BEPC, brevet élémentaire, brevet des collèges, DNB",
  "CAP, BEP ou diplôme équivalent",
  "Baccalauréat général ou technologique, brevet supérieur",
  "Capacité en droit, DAEU, ESEU",
  "Baccalauréat professionnel, brevet professionnel, de technicien ou d'enseignement, diplôme équivalent",
  "BTS, DUT, DEUST, diplôme de la santé ou social de niveau Bac+2 ou diplôme équivalent",
  "Licence, licence pro, maîtrise ou autre diplôme de niveau Bac+3 ou 4 ou diplôme équivalent",
  "Master, DEA, DESS, diplôme grande école de niveau Bac+5, doctorat de santé",
  "Doctorat de recherche (hors santé)",
  "NSP",
  "REF"
)

# Ajouter les libellés des diplômes à df_proportions
df_proportions <- df_proportions %>%
  mutate(DIPLOM_label = diplome_labels[as.numeric(DIPLOM)])

# Séparer les données en deux sous-ensembles (Hommes et Femmes)
df_men <- df_proportions %>% filter(Sex == "Men")
df_women <- df_proportions %>% filter(Sex == "Women")

# Graphique pour les hommes
fig_men <- plot_ly(df_men, 
                   x = ~DIPLOM, 
                   y = ~proportion, 
                   color = ~quartile_distance, 
                   type = "bar",
                   text = ~paste(DIPLOM_label, "<br>", round(proportion*100, 1), "%"),  # Affichage du libellé et proportion
                   textposition = "inside") %>%
  layout(title = "Proportion de score_scale par niveau de diplôme (Hommes)",
         xaxis = list(title = "Niveau de diplôme"),
         yaxis = list(title = "Proportion", tickformat = "%"),
         barmode = "stack",  # Empilement des barres
         hovermode = "closest")  # Afficher les informations les plus proches du survol

# Graphique pour les femmes
fig_women <- plot_ly(df_women, 
                     x = ~DIPLOM, 
                     y = ~proportion, 
                     color = ~quartile_distance, 
                     type = "bar",
                     text = ~paste(DIPLOM_label, "<br>", round(proportion*100, 1), "%"),  # Affichage du libellé et proportion
                     textposition = "inside") %>%
  layout(title = "Proportion de score_scale par niveau de diplôme (Femmes)",
         xaxis = list(title = "Niveau de diplôme"),
         yaxis = list(title = "Proportion", tickformat = "%"),
         barmode = "stack",  # Empilement des barres
         hovermode = "closest")  # Afficher les informations les plus proches du survol

# Afficher les deux graphiques séparés
fig_men
code R 
fig_women

4.7 Variables Socio-éco et influence sur le score de Genre

code R 
anova = aov(score_normalise_LASSO ~ DIPLOMA+SITUA_lab+Income+age_group, data=my_data_frame)
summary(anova)
              Df Sum Sq Mean Sq F value   Pr(>F)    
DIPLOMA        7   0.69 0.09917   3.628 0.000677 ***
SITUA_lab      7   0.82 0.11754   4.300 9.78e-05 ***
Income         2   0.52 0.25892   9.471 8.02e-05 ***
age_group      3   0.09 0.03036   1.110 0.343547    
Residuals   2247  61.43 0.02734                     
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
6967 observations effacées parce que manquantes
code R 
# Installer les packages si nécessaire
# install.packages("plotly")
# install.packages("dplyr")

library(plotly)
library(dplyr)

# -----------------------------
# 1️⃣ ANOVA multi-facteurs
# -----------------------------
anova_model <- aov(score_normalise_LASSO ~ DIPLOMA + SITUA_lab + Income + age_group, data = my_data_frame)
summary(anova_model)
              Df Sum Sq Mean Sq F value   Pr(>F)    
DIPLOMA        7   0.69 0.09917   3.628 0.000677 ***
SITUA_lab      7   0.82 0.11754   4.300 9.78e-05 ***
Income         2   0.52 0.25892   9.471 8.02e-05 ***
age_group      3   0.09 0.03036   1.110 0.343547    
Residuals   2247  61.43 0.02734                     
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
6967 observations effacées parce que manquantes
code R 
# -----------------------------
# 2️⃣ Moyennes par catégorie
# -----------------------------
categorical_vars <- c("DIPLOMA", "SITUA_lab", "Income", "age_group")
mean_tables <- list()

for (var in categorical_vars) {
  mean_tables[[var]] <- my_data_frame %>%
    group_by(.data[[var]]) %>%
    summarise(mean_score = mean(score_normalise_LASSO, na.rm = TRUE)) %>%
    arrange(desc(mean_score))
  
  cat("\nMoyennes pour", var, ":\n")
  print(mean_tables[[var]])
}

Moyennes pour DIPLOMA :
# A tibble: 9 × 2
  DIPLOMA                        mean_score
  <chr>                               <dbl>
1 Capacité / DAEU / ESEU              0.526
2 Bac+2 à Bac+5 (hors doctorat)       0.516
3 Bac général / technologique         0.511
4 CEP / Brevet / DNB                  0.500
5 Doctorat                            0.484
6 Sans diplôme                        0.479
7 CAP / BEP                           0.472
8 Bac professionnel / équivalent      0.465
9 <NA>                                0.447

Moyennes pour SITUA_lab :
# A tibble: 10 × 2
   SITUA_lab                                               mean_score
   <chr>                                                        <dbl>
 1 Femme ou homme au foyer                                      0.550
 2 Autre situation d'inactivité                                 0.531
 3 Chômeur (inscrit ou non à Pôle Emploi)                       0.530
 4 Retraité ou retiré des affaires ou en préretraite            0.511
 5 Inactif ou inactive pour cause d'invalidité                  0.507
 6 Occupe un emploi                                             0.499
 7 Etudiant, élève, en formation ou stagiaire non rémunéré      0.482
 8 Apprenti sous contrat ou stagiaire rémunéré                  0.383
 9 NSP                                                          0.254
10 REF                                                        NaN    

Moyennes pour Income :
# A tibble: 4 × 2
  Income mean_score
  <fct>       <dbl>
1 Low         0.521
2 <NA>        0.503
3 High        0.497
4 Medium      0.496

Moyennes pour age_group :
# A tibble: 4 × 2
  age_group mean_score
  <fct>          <dbl>
1 [67-97[        0.518
2 [54-67[        0.510
3 [15-38[        0.498
4 [38-54[        0.496
code R 
# Convertir les variables en facteurs si nécessaire


library(MASS)
my_data_frame$DIPLOM <- as.factor(my_data_frame$DIPLOM)
my_data_frame$SEXE <- as.factor(my_data_frame$SEXE)
my_data_frame$CLASSIF <- as.factor(my_data_frame$CLASSIF)
my_data_frame$Income <- as.factor(my_data_frame$Income)
my_data_frame$Health <- as.factor(my_data_frame$Health)
my_data_frame$satisfaction <- as.factor(my_data_frame$satisfaction)
my_data_frame$SITUA <- as.factor(my_data_frame$SITUA)
my_data_frame$CS2D <- as.factor(my_data_frame$CS2D)

# Fonction pour comparer 3 modèles (score, sexe, identity) et afficher tous les AIC
compare_models <- function(variable) {
  cat("Traitement de la variable :", variable, "\n")
  
  # Modèle avec score
  model_score <- polr(
    as.formula(paste(variable, "~ score_normalise_LASSO")),
    data = my_data_frame,
    method = "logistic"
  )
  
  # Modèle avec identity
  model_identity <- polr(
    as.formula(paste(variable, "~ identity")),
    data = my_data_frame,
    method = "logistic"
  )
  
  # Modèle avec sexe
  model_sex <- polr(
    as.formula(paste(variable, "~ SEXE")),
    data = my_data_frame,
    method = "logistic"
  )
  
  # Récupération des AIC
  aic_score    <- AIC(model_score)
  aic_identity <- AIC(model_identity)
  aic_sex      <- AIC(model_sex)
  
  # Identifier le meilleur AIC
  aics <- c(aic_score, aic_identity, aic_sex)
  best_pred <- c("Score", "Identity", "Sexe")[which.min(aics)]
  
  # Retourner tout dans une ligne
  return(data.frame(
    variable = variable,
    AIC_score = aic_score,
    AIC_identity = aic_identity,
    AIC_sex = aic_sex,
    best_predictor = best_pred
  ))
}

# Liste des variables à analyser
variables <- c("DIPLOM", "CLASSIF", "SITUA", "satisfaction", "Health", "Income", "CS2D")

# Appliquer la fonction à chaque variable
results <- do.call(rbind, lapply(variables, compare_models))
Traitement de la variable : DIPLOM 
Traitement de la variable : CLASSIF 
Traitement de la variable : SITUA 
Traitement de la variable : satisfaction 
Traitement de la variable : Health 
Traitement de la variable : Income 
Traitement de la variable : CS2D
code R 
# Afficher les résultats
print(results)
      variable AIC_score AIC_identity   AIC_sex best_predictor
1       DIPLOM 11289.847     41832.98 41877.259          Score
2      CLASSIF  2397.286      9575.92  9303.852          Score
3        SITUA  7175.685     24351.05 24316.900          Score
4 satisfaction  5550.873     20142.02 20141.519          Score
5       Health  3288.556     14580.80 14578.985          Score
6       Income  4835.411     17466.37 17469.113          Score
7         CS2D  8191.713     29007.09 29114.292          Score

4.8 Identité, distance aux normes et satisfaction

code R 
library(ggplot2)
ggplot(my_data_frame, aes(x = satisfaction, y = score_normalise_LASSO)) +
  stat_summary(fun = mean, geom = "point", color = "blue") +
  stat_summary(fun.data = mean_cl_normal, geom = "errorbar", width = 0.2) +
  geom_smooth(aes(group = 1), method = "lm", se = FALSE, color = "red") +
  theme_minimal()

code R 
library(ggplot2)
ggplot(my_data_frame, aes(x = satisfaction, y = distance_abs)) +
  stat_summary(fun = mean, geom = "point", color = "blue") +
  stat_summary(fun.data = mean_cl_normal, geom = "errorbar", width = 0.2) +
  geom_smooth(aes(group = 1), method = "lm", se = FALSE, color = "red") +
  theme_minimal()

code R 
library(ggplot2)
ggplot(my_data_frame, aes(x = Health, y = distance_abs)) +
  stat_summary(fun = mean, geom = "point", color = "blue") +
  stat_summary(fun.data = mean_cl_normal, geom = "errorbar", width = 0.2) +
  geom_smooth(aes(group = 1), method = "lm", se = FALSE, color = "red") +
  theme_minimal()

code R 
library(nnet)

model1 <- multinom(A15 ~ score_normalise_LASSO, data = my_data_frame)
# weights:  21 (12 variable)
initial  value 5008.772724 
iter  10 value 3254.829129
iter  20 value 3133.642779
iter  30 value 3133.430501
iter  40 value 3133.386324
final  value 3133.383358 
converged
code R 
model2 <- multinom(A15 ~ Sex, data = my_data_frame)
# weights:  21 (12 variable)
initial  value 17968.534316 
iter  10 value 13042.004757
iter  20 value 12264.214947
iter  30 value 12263.403578
iter  40 value 12263.370539
final  value 12263.370116 
converged
code R 
model3 <- multinom(A15 ~ score_normalise_LASSO + Sex, data = my_data_frame)
# weights:  28 (18 variable)
initial  value 5008.772724 
iter  10 value 3224.638944
iter  20 value 3133.201044
iter  30 value 3131.854173
final  value 3131.795249 
converged
code R 
summary(model1)
Call:
multinom(formula = A15 ~ score_normalise_LASSO, data = my_data_frame)

Coefficients:
  (Intercept) score_normalise_LASSO
2  -0.2452581             0.5452804
3  -1.4623490             1.1626467
4  -2.5219562             0.8121527
5  -5.0510787             1.7901069
6  -9.2680873             4.2966425
7  -4.1177394            -2.1536633

Std. Errors:
  (Intercept) score_normalise_LASSO
2   0.1411183             0.2694211
3   0.1891055             0.3510821
4   0.3106840             0.5794429
5   0.8407330             1.4883184
6   3.7184675             5.8435892
7   1.1976419             2.5938498

Residual Deviance: 6266.767 
AIC: 6290.767
code R 
summary(model2)
Call:
multinom(formula = A15 ~ Sex, data = my_data_frame)

Coefficients:
  (Intercept)   SexWomen
2   0.2916000 0.00715383
3  -0.4168971 0.18497831
4  -1.5202662 0.22372144
5  -3.3903113 0.23193459
6  -5.0721827 0.55936286
7  -5.2055519 0.40494337

Std. Errors:
  (Intercept)   SexWomen
2  0.03700241 0.05062577
3  0.04441585 0.05935040
4  0.06609018 0.08694581
5  0.15504893 0.20212536
6  0.35468482 0.43471891
7  0.37899581 0.47713435

Residual Deviance: 24526.74 
AIC: 24550.74
code R 
summary(model3)
Call:
multinom(formula = A15 ~ score_normalise_LASSO + Sex, data = my_data_frame)

Coefficients:
  (Intercept) score_normalise_LASSO    SexWomen
2  -0.2830389             0.8161784 -0.15551825
3  -1.4592873             1.1112351  0.03512062
4  -2.5163010             0.7469515  0.04171016
5  -5.0708609             1.9926263 -0.12904807
6 -11.9417951             2.7439648  3.88853302
7  -4.1498301            -1.9398873 -0.12970873

Std. Errors:
  (Intercept) score_normalise_LASSO   SexWomen
2   0.1438847             0.3363564  0.1149746
3   0.1920664             0.4358984  0.1535314
4   0.3157861             0.7202196  0.2529148
5   0.8465490             1.8398141  0.6741908
6  12.2677024             6.7589881 12.1020745
7   1.2451788             3.2562632  1.0291558

Residual Deviance: 6263.59 
AIC: 6299.59
code R 
AIC(model1, model2, model3)
       df       AIC
model1 12  6290.767
model2 12 24550.740
model3 18  6299.590
code R 
library(caret)
library(vip)


ggplot(my_data_frame, aes(x = score_normalise_LASSO, fill = Health)) +
  geom_density(alpha = 0.5) +
  facet_wrap(~ Sex) +
  labs(title = "Distribution de Health selon score et sexe") +
  theme_minimal()

code R 
my_data_frame$A15 <- my_data_frame$A15 |>
  as.ordered()
levels(my_data_frame$A15) <- c("Très bon", "bon", "Assez bon", "Mauvais", "Très mauvais", "NSP", "REF")

rego <- MASS::polr(
  A15 ~ Sex + CRITREVENU + age_group + score_scale,
  data = my_data_frame
)
rego
Call:
MASS::polr(formula = A15 ~ Sex + CRITREVENU + age_group + score_scale, 
    data = my_data_frame)

Coefficients:
                SexWomen               CRITREVENU         age_group[38-54[ 
            -0.004537008             -0.097691294              1.011117519 
        age_group[54-67[         age_group[67-97[             score_scale1 
             1.465948262              2.292831593              0.092958543 
            score_scale2             score_scale3             score_scale4 
             0.192760132              0.260843248              0.298410044 
            score_scale5 score_scaleVery Feminine 
             0.399337571              0.683792451 

Intercepts:
        Très bon|bon        bon|Assez bon    Assez bon|Mauvais 
         -0.01733322           1.93169458           3.56796729 
Mauvais|Très mauvais     Très mauvais|NSP              NSP|REF 
          5.46890575           6.66726777           6.82173287 

Residual Deviance: 5915.407 
AIC: 5949.407 
(6660 observations effacées parce que manquantes)
code R 
rego3 <- ordinal::clm(
  A15 ~ Sex + age_group  + DIPLOM,
  data = my_data_frame
)
rego3
formula: A15 ~ Sex + age_group + DIPLOM
data:    my_data_frame

 link  threshold nobs logLik    AIC      niter max.grad cond.H 
 logit flexible  9234 -11354.35 22756.69 7(0)  8.59e-13 2.4e+03

Coefficients:
        SexWomen age_group[38-54[ age_group[54-67[ age_group[67-97[ 
          0.1273           0.9498           1.5091           2.2304 
         DIPLOM2          DIPLOM3          DIPLOM4          DIPLOM5 
         -0.3936          -0.8269          -0.7601          -1.2484 
         DIPLOM6          DIPLOM7          DIPLOM8          DIPLOM9 
         -0.9916          -1.2357          -0.6964          -1.3348 
        DIPLOM10         DIPLOM11         DIPLOM12         DIPLOM13 
         -1.4266          -1.6018          -1.7734          -2.1445 
        DIPLOM14         DIPLOM15 
         -0.7401          -0.3771 

Threshold coefficients:
        Très bon|bon        bon|Assez bon    Assez bon|Mauvais 
             -1.0557               0.9091               2.5709 
Mauvais|Très mauvais     Très mauvais|NSP              NSP|REF 
              4.4310               5.6890               6.5100