Arbre de classification: exemple la fierté canadienne
Jean-Herman Guay, professeur titulaire, Université de Sherbrooke
avril 2017

On cherche ici à établir des variables explicatives de la fierté canadienne. La base de données provient de l'Enquête sociale générale du Canada (2013). Dans un premier temps on récupère la base. On crée ensuite des variables dichotomiques. Le questionnaire est diponible ici. La question utilisée est PRD_10. Les réponses ont été traduites en une variable dichotomique. Les valeurs «très fier» et «fier» ont été regroupées et associées à la fierté canadienne (=1). Toutes les autres valeurs «plutôt fier», «pas très fier», «pas du tout fier» ont été associées à la non-fierté (=0).

base=read.csv("http://dimension.usherbrooke.ca/voute/esg-89M0032X-F-2013-C27_F1.csv", header=TRUE, encoding="latin1", row.names=1)
dim(base)

table(base$PRD_10)
table(base$PRCODE)
table(base$LANCH)
table(base$DH1GED)
table(base$REP_05)

base=subset(base, base$PRD_10<6)

base$fierte[base$PRD_10>=3]=0
base$fierte[base$PRD_10<3]=1

base$Universitaire[base$DH1GED!=4]=0
base$Universitaire[base$DH1GED==4]=1

base$Quebec[base$PRCODE!=24]=0
base$Quebec[base$PRCODE==24]=1

base$Francophone[base$LANCH!=2]=0
base$Francophone[base$LANCH==2]=1
Régressions linéaires et régressions logistiques
On procède à des régressions en vue de valider la significativité des variables de l'hypothèse. Régressions classiques et régressions logistiques. On effectue avec cette dernière un ensemble de simulations. Comme le modèle est unique, il nous laisse croire qu'il existe des différences entre les universitaires et les non-universitaires, autant au Québec que dans le reste du Canada.



modele=lm(PRD_10~Francophone+Quebec+Universitaire, data=base, weights=WGHT_PER)
summary(modele)
modele2=glm(fierte~Francophone+Quebec+Universitaire, data=base, weights=WGHT_PER)
summary(modele2)


simulation=data.frame(Francophone=1, Quebec=1, Universitaire=1)
predict(modele2, newdata=simulation, type="response")

simulation=data.frame(Francophone=0, Quebec=0, Universitaire=0)
predict(modele2, newdata=simulation, type="response")

simulation=data.frame(Francophone=1, Quebec=1, Universitaire=0)
predict(modele2, newdata=simulation, type="response")

simulation=data.frame(Francophone=1, Quebec=1, Universitaire=1)
predict(modele2, newdata=simulation, type="response")

simulation=data.frame(Francophone=0, Quebec=0, Universitaire=0)
predict(modele2, newdata=simulation, type="response")

simulation=data.frame(Francophone=0, Quebec=0, Universitaire=1)
predict(modele2, newdata=simulation, type="response")

Régression avec classification
On procède enfin à des analyses de classification selon la logique développée par Breiman, Friedman, Olshen et Stone (Classification and Regression Trees, 1984). Le résultat est intéressant. Les variables francophones et universitaires ne sont pas significatives au Canada anglais, mais elles le sont au Québec. On peut donc conclure qu'en général la fierté canadienne est de l'ordre de 90% (89,74%). Cependant, au Québec, chez les universitaires francophones, elle n'est plus que de 53% (52,72%)

library(rpart)
fit <- rpart(fierte~Francophone+Quebec+Universitaire, data=base)


printcp(fit)
plotcp(fit)
summary(fit)


plot(fit, uniform=TRUE,
     main="Arbre de classification\n de la fierté canadienne à partir de\n l'Enquête sociale générale du Canada, 2013")
text(fit, use.n=TRUE, all=TRUE, cex=.8)



Validation de la différence entre la régression et la classification



> modele=glm(fierte~Francophone+Quebec+Universitaire, data=base, family=binomial)
> summary(modele)

Call:
glm(formula = fierte ~ Francophone + Quebec + Universitaire,
    family = binomial, data = base)

Deviance Residuals:
    Min       1Q   Median       3Q      Max
-2.4113   0.3352   0.3352   0.4245   0.9719

Coefficients:
              Estimate Std. Error z value Pr(>|z|)
(Intercept)    2.85106    0.03329   85.66   <2e-16 ***
Francophone   -0.85741    0.06591  -13.01   <2e-16 ***
Quebec        -0.99920    0.06473  -15.44   <2e-16 ***
Universitaire -0.48983    0.04661  -10.51   <2e-16 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 16803  on 25403  degrees of freedom
Residual deviance: 15286  on 25400  degrees of freedom
AIC: 15294


> #Au Québec
> simulation=data.frame(Francophone=1, Quebec=1, Universitaire=0)
> predict(modele, newdata=simulation, type="response")
        1
0.7299668
> simulation=data.frame(Francophone=1, Quebec=1, Universitaire=1)
> predict(modele, newdata=simulation, type="response")
        1
0.6235458
>
> #Dans le reste du Canada
> simulation=data.frame(Francophone=1, Quebec=0, Universitaire=0)
> predict(modele, newdata=simulation, type="response")
        1
0.8801288
> simulation=data.frame(Francophone=1, Quebec=0, Universitaire=1)
> predict(modele, newdata=simulation, type="response")
        1
0.8181439

#En s'appuyant sur une régression logistique, on constate que les variables sont toutes significatives.  En procédant à des simulations, on voit un effet marqué très net du fait d'être ou non universitaire.  Cela semble contredire l'analyse de classification. Dans ce cas, laquelle des deux est juste?

#Créons une base pour le Québec

Number of Fisher Scoring iterations: 5
> #Base pour le Québec
> baseQc=subset(base, base$PRCODE==24)
> modeleQc=glm(fierte~Francophone+Universitaire, data=baseQc,family=binomial)
> summary(modeleQc)

Call:
glm(formula = fierte ~ Francophone + Universitaire, family = binomial,
    data = baseQc)

Deviance Residuals:
    Min       1Q   Median       3Q      Max
-2.2391  -1.2696   0.8027   0.8027   1.0879

Coefficients:
              Estimate Std. Error z value Pr(>|z|)
(Intercept)    2.42179    0.09715  24.930   <2e-16 ***
Francophone   -1.45442    0.09880 -14.720   <2e-16 ***
Universitaire -0.75318    0.07712  -9.767   <2e-16 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 5552.7  on 4878  degrees of freedom
Residual deviance: 5224.5  on 4876  degrees of freedom
AIC: 5230.5

Number of Fisher Scoring iterations: 4

>
> simulation=data.frame(Francophone=1,  Universitaire=1)
> predict(modeleQc, newdata=simulation, type="response")
        1
0.5533429
> simulation=data.frame(Francophone=1,  Universitaire=0)
> predict(modeleQc, newdata=simulation, type="response")
        1
0.7245938
>


#Créons ensuite une base pour le reste du Canada
#La variable Francophone n'est plus significative.  Quant à variable universitaire, son effet dégringole considérablement, l'écart n'est plus que de deux points.  Si la variable reste significative, c'est que le N est évidemment important.  Quant on effectue un lm plutôt qu'un glm, on constate aisément la chute du R carré.
> #Base pour le reste du Canada
> baseROC=subset(base, base$PRCODE!=24)
> modeleROC=glm(fierte~Francophone+Universitaire, data=baseROC,family=binomial)
> summary(modeleROC)

Call:
glm(formula = fierte ~ Francophone + Universitaire, family = binomial,
    data = baseROC)

Deviance Residuals:
    Min       1Q   Median       3Q      Max
-2.4279   0.3519   0.3519   0.3519   0.4191

Coefficients:
              Estimate Std. Error z value Pr(>|z|)
(Intercept)    2.75097    0.03489  78.850  < 2e-16 ***
Francophone    0.14249    0.14857   0.959    0.338
Universitaire -0.36282    0.05981  -6.067 1.31e-09 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 9989.2  on 20524  degrees of freedom
Residual deviance: 9952.5  on 20522  degrees of freedom
AIC: 9958.5

Number of Fisher Scoring iterations: 5

>
> simulation=data.frame(Francophone=0,  Universitaire=1)
> predict(modeleROC, newdata=simulation, type="response")
        1
0.9159196
> simulation=data.frame(Francophone=0,  Universitaire=0)
> predict(modeleROC, newdata=simulation, type="response")
        1
0.9399682
>
> simulation=data.frame(Francophone=1,  Universitaire=1)
> predict(modeleROC, newdata=simulation, type="response")
        1
0.9262623
> simulation=data.frame(Francophone=1,  Universitaire=0)
> predict(modeleROC, newdata=simulation, type="response")
        1
0.9475222
>


#Qu'en est-il en fait?

> #Cherchons enfin à vérifier ce qu'il en est d'une manière descriptive
>
> #Validation simple en créant des sous-ensembles pour obtenir finalement un simple tableau de fréquences.Le reste du Canada d'abord
>
> #Chez les francophones universitaires du ROC
> baseROCFrancoUniversitaires=subset(baseROC, baseROC$Francophone==1)
> baseROCFrancoUniversitaires=subset(baseROCFrancoUniversitaires, baseROCFrancoUniversitaires$Universitaire==1)
> prop.table(table(baseROCFrancoUniversitaires$fierte))

         0          1
0.08333333 0.91666667
>
> #Chez les francophones non-universitaires du ROC
> baseROCFrancoNONUniversitaires=subset(baseROC, baseROC$Francophone==1)
> baseROCFrancoNonUniversitaires=subset(baseROCFrancoNONUniversitaires, baseROCFrancoNONUniversitaires$Universitaire==0)
> prop.table(table(baseROCFrancoNONUniversitaires$fierte))

         0          1
0.05714286 0.94285714
>
> #Chez les anglophones universitaires du ROC
> baseROCAngloUniversitaires=subset(baseROC, baseROC$Francophone==0)
> baseROCAngloUniversitaires=subset(baseROCAngloUniversitaires, baseROCAngloUniversitaires$Universitaire==1)
> prop.table(table(baseROCAngloUniversitaires$fierte))

         0          1
0.08372978 0.91627022
>
> #Chez les anglophones non-universitaires du ROC
> baseROCAngloNonUniversitaires=subset(baseROC, baseROC$Francophone==0)
> baseROCAngloNonUniversitaires=subset(baseROCAngloNonUniversitaires, baseROCAngloNonUniversitaires$Universitaire==0)
> prop.table(table(baseROCAngloNonUniversitaires$fierte))

         0          1
0.06015978 0.93984022
>
>
> #La preuve est assez clair: dans le ROC, entre les quatre catégories, il y a très peu de variations de 92% à 94%
>
>
>
> #Au Québec à présent
> #Chez les francophones universitaires du Qc
> baseQCFrancoUniversitaires=subset(baseQc, baseQc$Francophone==1)
> baseQCFrancoUniversitaires=subset(baseQCFrancoUniversitaires, baseQCFrancoUniversitaires$Universitaire==1)
> prop.table(table(baseQCFrancoUniversitaires$fierte))

       0        1
0.472752 0.527248
>
> #Chez les francophones non-universitaires du Qc
> baseQCFrancoNONUniversitaires=subset(baseQc, baseQc$Francophone==1)
> baseQCFrancoNONUniversitaires=subset(baseQCFrancoNONUniversitaires, baseQCFrancoNONUniversitaires$Universitaire==0)
> prop.table(table(baseQCFrancoNONUniversitaires$fierte))

       0        1
0.268662 0.731338
>
>
> #Chez les non-francophones universitaires du Qc
> baseQCAngloUniversitaires=subset(baseQc, baseQc$Francophone==0)
> baseQCAngloUniversitaires=subset(baseQCAngloUniversitaires, baseQCAngloUniversitaires$Universitaire==1)
> prop.table(table(baseQCAngloUniversitaires$fierte))

        0         1
0.1146789 0.8853211
>
> #Chez les non-francophones non-universitaires du ROC
> baseQCAngloNonUniversitaires=subset(baseQc, baseQc$Francophone==0)
> baseQCAngloNonUniversitaires=subset(baseQCAngloNonUniversitaires, baseQCAngloNonUniversitaires$Universitaire==0)
> prop.table(table(baseQCAngloNonUniversitaires$fierte))

        0         1
0.1035673 0.8964327
>
>
> #La preuve est assez clair: dans le QC, entre les quatre catégories, il y a  de fortes variations de 52% à 90%. C'est donc l'analyse en classification qui apparaît comme étant la plus juste puisque l'effet des variables n'est pas  du tout le même dans les deux zones. Au Québec, les variables francophones/non francophones jouent très fortement alors que dans le reste du Canada elles ne jouent pas, ou si peu. La taille de l'effet est justement capté par l'analyse en classification, et trompeusement par une régression classique ou logistique.
>