Navigation – Plan du site

AccueilNumérosN° 4, vol. 8EnquêtesL’espace contemporain des goûts cult(…)Annexe 9 : Programme R des analyses (…)

L’espace contemporain des goûts culturels

Annexe 9 : Programme R des analyses de l’article

Nicolas Robette et Olivier Roueff

Texte intégral

library(GDAtools)

# Chargement des donnees
load('PCF2008_etc.RData')
Xtele <- data.frame(freq.tv, allum.tv, qui.tv, chain=tv.chain1, freq.arte, emi=emi.tv[, -20], serie=serie.tv, manq.tv, duree.tv)
levels(Xtele$freq.tv)[4:5] <- c('rare/jms', 'rare/jms')
Xlectu <- data.frame(liv=catliv, pref=catliv.pref, nbl=nbliv.lu, char, moliere,
pratt, quoti, quot=nom.quoti[, c(1, 9, 11)], rev=revue[, c(2, 3, 5, 6, 17)],
aim.auteur[, c(1, 6, 10:13)])
levels(Xlectu$pref)[9] <- 'bd'
levels(Xlectu$char)[1:2] <- c('connait', 'connait')
levels(Xlectu$pratt)[1:2] <- c('connait', 'connait')
Xcine <- data.frame(freq=cine.12m, gpref=gpref.film[, -c(7, 8, 11, 12, 15, 16, 17)], gjms=jms.film[, -c(1, 2, 3, 4, 5, 6, 7, 10, 17)], vu=
vu.film[, -c(14:15)], aim=aim.film[, -5], beurk=beurk.film[, -c(10, 12, 13)])
x <- musique[, -c(33:60)] # on elimine Benabar and co
v <- names(x) %in% c('svt_acco', 'svt_blues', 'svt_count', 'svt_disco', 'svt_relax',
'svt_film', 'svt_regg',
'svt_soul', 'svt_lati', 'svt_rai')
x <- x[, !v] # on elimine qd < 1%
x <- data.frame(x, celeb[, c('boulez', 'rieu')])
Xmusq <- x[, -c(13, 14)] # on elimine jms_Vfr et jms_Wld

# Definition de la sous-population etudiee
zoom <- c(21, 22, 23, 31, 33, 34, 35, 37, 38, 42, 43, 45, 46, 47, 48, 52, 53, 54, 55, 56, 62, 63, 64,
65, 67, 68, 69)
condi <- csp42 %in% zoom



## =============
## ACMs separees
## =============

a <- c(1, 2)

## ACM sur TELEVISION
apply(Xtele[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xtele) # on repere les 'junk categories' (99, etc)
junk1 <- c(9, 14, 22:28, 30:31, 37:38, 77, 80:81, 83, 86, 91:92, 98:99)
acm.tele <- csMCA(Xtele, subcloud=condi, excl=junk1, row.w=pcf$POIDS)

titre <- paste0('ACM gouts television, axes ', a[1], '-', a[2])
plot(acm.tele, points='best', main=titre, axes=a, col='darkorchid')
dev.print(png, filename='ACM television.png', width=900, height=900)

titre <- paste0('ACM gouts television, axes ', a[1], '-', a[2], ' (var supplementaires)')
plot(acm.tele, col='white', main=titre, axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(acm.tele, age, axes=a, col='orange', vname='age')
textvarsup(acm.tele, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(acm.tele, sexe, axes=a, col='deeppink')
textvarsup(acm.tele, csp42, axes=a, col='black', vname='pcs')
textvarsup(acm.tele, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(acm.tele, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(acm.tele, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(acm.tele, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(acm.tele, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='ACM television, variables illustratives.png', width=900, height=900)

## ACM sur LECTURE
apply(Xlectu[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xlectu)
junk2 <- c(33, 36, 38:40, 42:43, 45:49, 55, 58, 62, 65) # on repere les 'junk categories' (99, etc)
acm.lectu <- csMCA(Xlectu, subcloud=condi, excl=junk2, row.w=pcf$POIDS)

titre <- paste0('ACM gouts lecture, axes ', a[1], '-', a[2])
plot(acm.lectu, points='best', main=titre, axes=a, col='steelblue1')
dev.print(png, filename='ACM lecture.png', width=900, height=900)

titre <- paste0('ACM gouts lecture, axes ', a[1], '-', a[2], ' (var supplementaires)')
plot(acm.lectu, col='white', main=titre, axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(acm.lectu, age, axes=a, col='orange', vname='age')
textvarsup(acm.lectu, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(acm.lectu, sexe, axes=a, col='deeppink')
textvarsup(acm.lectu, csp42, axes=a, col='black', vname='pcs')
textvarsup(acm.lectu, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(acm.lectu, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(acm.lectu, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(acm.lectu, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(acm.lectu, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='ACM lecture, variables illustratives.png', width=900, height=900)

## ACM sur CINEMA
apply(Xcine[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xcine)
acm.cine <- csMCA(Xcine, subcloud=condi, row.w=pcf$POIDS)

titre <- paste0('ACM gouts cinema, axes ', a[1], '-', a[2])
plot(acm.cine, points='best', main=titre, axes=a, col='tomato3')
dev.print(png, filename='ACM cinema.png', width=900, height=900)

titre <- paste0('ACM gouts cinema, axes ', a[1], '-', a[2], ' (var supplementaires)')
plot(acm.cine, col='white', main=titre, axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(acm.cine, age, axes=a, col='orange', vname='age')
textvarsup(acm.cine, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(acm.cine, sexe, axes=a, col='deeppink')
textvarsup(acm.cine, csp42, axes=a, col='black', vname='pcs')
textvarsup(acm.cine, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(acm.cine, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(acm.cine, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(acm.cine, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(acm.cine, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='ACM cinema, variables illustratives.png', width=900, height=900)

## ACM sur MUSIQUE
apply(Xmusq[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xmusq)
junk4 <- c(8, 11, 13:25, 66, 69:70, 72, 74:75, 77:79, 95, 99) # on repere les 'junk categories' (99, etc) 3, 4, 7, 15, 16, 17, 19
acm.musq <- csMCA(data=Xmusq, subcloud=condi, excl=junk4, row.w=pcf$POIDS)

titre <- paste0('ACM gouts musique, axes ', a[1], '-', a[2])
plot(acm.musq, points='best', main=titre, axes=a, col='seagreen4')
dev.print(png, filename='ACM musique.png', width=900, height=900)

titre <- paste0('ACM gouts musique, axes ', a[1], '-', a[2], ' (var supplementaires)')
plot(acm.musq, col='white', main=titre, axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(acm.musq, age, axes=a, col='orange', vname='age')
textvarsup(acm.musq, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(acm.musq, sexe, axes=a, col='deeppink')
textvarsup(acm.musq, csp42, axes=a, col='black', vname='pcs')
textvarsup(acm.musq, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(acm.musq, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(acm.musq, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(acm.musq, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(acm.musq, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='ACM musique, variables illustratives.png', width=900, height=900)



## =============================================
## ACM "classique", avec les 4 DOMAINES ensemble
## =============================================

Xtot <- data.frame(Xtele, Xlectu, Xcine, Xmusq)
junktot <- c(junk1, junk2+99, junk4+99+98+115)
acm <- csMCA(data=Xtot, subcloud=condi, excl=junktot, row.w=pcf$POIDS)

a <- c(1, 2)
domain <- c(rep('tele', times=77), rep('lect', times=82), rep('cine', times=115), rep('musq',
times=73))
nv <- nrow(acm$var$coord)
ctrbest <- acm$var$contrib[, a[1]]>=100/nv | acm$var$contrib[, a[2]]>=100/nv

titre <- paste0('ACM 4 domaines, axes ', a[1], '-', a[2])
plot(acm, col='white', axes=a, main=titre)
text(acm$var$coord[domain=='tele' & ctrbest==TRUE, a], rownames(acm$var$coord)[domain=='tele' & ctrbest==TRUE], col='steelblue1')
text(acm$var$coord[domain=='lect' & ctrbest==TRUE, a], rownames(acm$var$coord)[domain=='lect' & ctrbest==TRUE], col='darkorchid')
text(acm$var$coord[domain=='cine' & ctrbest==TRUE, a], rownames(acm$var$coord)[domain=='cine' & ctrbest==TRUE], col='tomato3')
text(acm$var$coord[domain=='musq' & ctrbest==TRUE, a], rownames(acm$var$coord)[domain=='musq' & ctrbest==TRUE], col='seagreen4')
dev.print(png, filename='ACM 4 domaines.png', width=900, height=900)

titre <- paste0('ACM 4 domaines, axes ', a[1], '-', a[2], ' (var supplementaires)')
plot(acm, col='white', main=titre, axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(acm, age, axes=a, col='orange', vname='age')
textvarsup(acm, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(acm, sexe, axes=a, col='deeppink')
textvarsup(acm, csp42, axes=a, col='black', vname='pcs')
textvarsup(acm, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(acm, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(acm, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(acm, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(acm, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='ACM 4 domaines, var illustratives.png', width=900, height=900)



## ===============
## AFM, 4 DOMAINES
## ===============

l_acm <- list(acm.musq, acm.cine, acm.tele, acm.lectu)
afm <- multiMCA(l_acm)

# inverser l'axe 1
#afm$ind$coord[, 1] <- -afm$ind$coord[, 1]
#afm$VAR$mca1$coord[, 1] <- -afm$VAR$mca1$coord[, 1]
#afm$VAR$mca2$coord[, 1] <- -afm$VAR$mca2$coord[, 1]
#afm$VAR$mca3$coord[, 1] <- -afm$VAR$mca3$coord[, 1]
#afm$VAR$mca4$coord[, 1] <- -afm$VAR$mca4$coord[, 1]

a <- c(1, 2)

# Graphique AFM, variables actives (figure 1)
plot(afm, points='best', col=c('seagreen4', 'tomato3', 'darkorchid', 'steelblue1'), axes=a)
dev.print(tiff, filename='Figure 1.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', col=c('gray0', 'gray20', 'gray40', 'gray60'), axes=a)
dev.print(tiff, filename='Figure 1 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")

# Contributions des domaines (tableau 1)
round(afm$group$contrib[, a], 1)

# eta2 des proprietes sociales (tableau 2)
l <- list(sexe, age, diplo7, csp6, public3, revenu2, MER_diplo2, PER_csp6, PER_pays,
patrim$resII, patrim$epar, patrim$immo)
l <- lapply(l, function(x) factor(x[condi]))
n <- c('sexe', 'age', 'diplo7', 'csp6', 'publ-priv', 'revenu2', 'MER_diplo2', 'PER_csp6', 'PER_pays', 'resII', 'epar', 'immo')
dimeta2(afm, l, n, dim=1:2)

# Coordonnees des modalites "notables" (tableaux 3 et 4)
temp <- do.call('rbind.data.frame', lapply(afm$VAR, function(x) x$coord))
aides <- list()
for(i in 1:ncol(temp)) {
x <- temp[, i]
names(x) <- substr(rownames(temp), 6, nchar(rownames(temp)))
x <- x[order(x)]
aides[[i]] <- x[abs(x)>=0.5]
}
aides[[1]]
aides[[2]]

# Graphiques AFM par domaine, variables actives (figures 2 a 5)
plot(afm, points='best', groups=1, col='seagreen4', axes=a)
dev.print(tiff, filename='Figure 2.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=1, col='black', axes=a)
dev.print(tiff, filename='Figure 2 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=2, col='tomato3', axes=a)
dev.print(tiff, filename='Figure 3.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=2, col='black', axes=a)
dev.print(tiff, filename='Figure 3 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=3, col='darkorchid', axes=a)
dev.print(tiff, filename='Figure 4.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=3, col='black', axes=a)
dev.print(tiff, filename='Figure 4 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=4, col='steelblue1', axes=a)
dev.print(tiff, filename='Figure 5.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, points='best', groups=4, col='black', axes=a)
dev.print(tiff, filename='Figure 5 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")

# Graphique AFM, variables illustratives (proprietes sociales)
plot(afm, points='best', col=c('white', 'white', 'white', 'white'), axes=a)
abline(h=0, v=0, col='lightgray')
textvarsup(afm, age, axes=a, col='orange', vname='age')
textvarsup(afm, diplo7, sel=1:6, axes=a, col='darkolivegreen3')
textvarsup(afm, sexe, axes=a, col='deeppink')
textvarsup(afm, csp42, axes=a, col='black', vname='pcs')
textvarsup(afm, revenu2, sel=1:5, axes=a, col='blue', vname='rev')
textvarsup(afm, PER_csp6, sel=1:6, axes=a, col='red', vname='Pere')
textvarsup(afm, MER_diplo2, sel=1:5, axes=a, col='darkgreen', vname='Mere')
textvarsup(afm, public3, sel=2:4, axes=a, col='steelblue1')
textvarsup(afm, PER_pays, sel=1:2, axes=a, col='gray60', vname='Pere')
dev.print(png, filename='AFM, variables illustratives.png', width=900, height=900)





## ===================================
## ANALYSES SELON LES CLASSES SOCIALES
## ===================================

frac.bourg <- factor(csp42 %in% c(23, 31, 33, 34, 35, 37, 38))
levels(frac.bourg) <- c('0', 'bourgeoisie')
frac.pbourg <- factor(csp42 %in% c(21, 22, 42, 43, 45, 46, 47, 48))
levels(frac.pbourg) <- c('0', 'intermediaire')
frac.clpop <- factor(csp42 %in% c(52, 53, 54, 55, 56, 62, 63, 64, 65, 67, 68, 69))
levels(frac.clpop) <- c('0', 'populaire')

a <- c(1, 2)

# Graphique avec les ellipses (figure 6)
plot(afm, type='i', axes=a, col='black')
conc.ellipse(afm, var=frac.bourg, sel=2, col='steelblue1')
conc.ellipse(afm, var=frac.pbourg, sel=2, col='seagreen4')
conc.ellipse(afm, var=frac.clpop, sel=2, col='tomato3')
dev.print(tiff, filename='Figure 6.tif', res=300, compression="lzw", height=10, width=10, units="in")
plot(afm, type='i', axes=a, col='black')
conc.ellipse(afm, var=frac.bourg, sel=2, col='gray0')
conc.ellipse(afm, var=frac.pbourg, sel=2, col='gray25')
conc.ellipse(afm, var=frac.clpop, sel=2, col='gray50')
dev.print(tiff, filename='Figure 6 (N&B).tif', res=300, compression="lzw", height=10, width=10, units="in")

# Variance des classes (tableau 5)
fraction <- factor(interaction(frac.bourg, frac.pbourg, frac.clpop)[condi]);
levels(fraction) <- c('bourg', 'pbourg', 'clpop')
round(varsup(afm, fraction)$var[1:3, a], 1)



## ===============
## AFM BOURGEOISIE
## ===============

zoom <- c(23, 31, 33, 34, 35, 37, 38)
condi <- csp42 %in% zoom

apply(Xtele[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xtele[condi, ])
junk1 <- c(9, 14, 22:28, 30:31, 37:38, 77, 80:81, 83, 86, 91:92, 98:99, 82)
acm.tele <- csMCA(Xtele, subcloud=condi, excl=junk1, row.w=pcf$POIDS)

apply(Xlectu[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xlectu[condi, ])
junk2 <- c(36, 38:40, 42:43, 45:49, 55, 58, 62, 65)
acm.lectu <- csMCA(Xlectu, subcloud=condi, excl=junk2, row.w=pcf$POIDS)

apply(Xcine[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xcine[condi, ])
acm.cine <- csMCA(Xcine, subcloud=condi, row.w=pcf$POIDS)

apply(Xmusq[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xmusq[condi, ])
junk4 <- c(8, 11, 13:25, 66, 69:70, 72, 74:75, 77:79, 95, 99)
acm.musq <- csMCA(data=Xmusq, subcloud=condi, excl=junk4, row.w=pcf$POIDS)

l_acm <- list(acm.musq, acm.cine, acm.tele, acm.lectu)
afm <- multiMCA(l_acm)

a <- c(1, 2)

# Contributions des domaines aux axes (tableau 6)
round(afm$group$contrib[, a], 1)

# eta2 des variables de position sociale (tableau 7)
l <- list(sexe, age, diplo7, csp42, public3, revenu2, MER_diplo2, PER_csp6, PER_pays,
patrim$resII, patrim$epar, patrim$immo)
l <- lapply(l, function(x) factor(x[condi]))
n <- c('sexe', 'age', 'diplo7', 'csp42', 'publ-priv', 'revenu2', 'MER_diplo2', 'PER_csp6', 'PER_pays', 'resII', 'epar', 'immo')
dimeta(afm, l, n, dim=a)

# Coordonnees des modalites "notables" (tableau 8)
temp <- do.call('rbind.data.frame', lapply(afm$VAR, function(x) x$coord))
aides <- list()
for(i in 1:ncol(temp)) {
x <- temp[, i]
names(x) <- substr(rownames(temp), 6, nchar(rownames(temp)))
x <- x[order(x)]
aides[[i]] <- x[abs(x)>=0.5]
}
aides[[1]]



## ======================
## AFM PETITE BOURGEOISIE
## ======================

zoom <- c(21, 22, 42, 43, 45, 46, 47, 48)
condi <- csp42 %in% zoom

apply(Xtele[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xtele[condi, ])
junk1 <- c(9, 14, 22:28, 30:31, 37:38, 77, 80:81, 83, 86, 91:92, 98:99, 82)
acm.tele <- csMCA(Xtele, subcloud=condi, excl=junk1, row.w=pcf$POIDS)

apply(Xlectu[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xlectu[condi, ])
junk2 <- c(36, 38:40, 42:43, 45:49, 55, 58, 62, 65)
acm.lectu <- csMCA(Xlectu, subcloud=condi, excl=junk2, row.w=pcf$POIDS)

apply(Xcine[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xcine[condi, ])
acm.cine <- csMCA(Xcine, subcloud=condi, row.w=pcf$POIDS)

apply(Xmusq[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xmusq[condi, ])
junk4 <- c(8, 11, 13:25, 66, 69:70, 72, 74:75, 77:79, 95, 99)
acm.musq <- csMCA(data=Xmusq, subcloud=condi, excl=junk4, row.w=pcf$POIDS)

l_acm <- list(acm.musq, acm.cine, acm.tele, acm.lectu)
afm <- multiMCA(l_acm)

a <- c(1, 2)

# Contributions des domaines aux axes (tableau 6)
round(afm$group$contrib[, a], 1)

# eta2 des variables de position sociale (tableau 7)
l <- list(sexe, age, diplo7, csp42, public3, revenu2, MER_diplo2, PER_csp6, PER_pays,
patrim$resII, patrim$epar, patrim$immo)
l <- lapply(l, function(x) factor(x[condi]))
n <- c('sexe', 'age', 'diplo7', 'csp42', 'publ-priv', 'revenu2', 'MER_diplo2', 'PER_csp6', 'PER_pays', 'resII', 'epar', 'immo')
dimeta2(afm, l, n, dim=a)

# Coordonnees des modalites "notables" (tableau 8)
temp <- do.call('rbind.data.frame', lapply(afm$VAR, function(x) x$coord))
aides <- list()
for(i in 1:ncol(temp)) {
x <- temp[, i]
names(x) <- substr(rownames(temp), 6, nchar(rownames(temp)))
x <- x[order(x)]
aides[[i]] <- x[abs(x)>=0.5]
}
aides[[1]]



## ======================
## AFM CLASSES POPULAIRES
## ======================

zoom <- c(52, 53, 54, 55, 56, 62, 63, 64, 65, 67, 68, 69)
condi <- csp42 %in% zoom

apply(Xtele[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xtele[condi, ])
junk1 <- c(9, 14, 22:28, 30:31, 37:38, 77, 80:81, 83, 86, 91:92, 98:99, 82)
acm.tele <- csMCA(Xtele, subcloud=condi, excl=junk1, row.w=pcf$POIDS)

apply(Xlectu[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xlectu[condi, ])
junk2 <- c(36, 38:40, 42:43, 45:49, 55, 58, 62, 65)
acm.lectu <- csMCA(Xlectu, subcloud=condi, excl=junk2, row.w=pcf$POIDS)

apply(Xcine[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xcine[condi, ])
acm.cine <- csMCA(Xcine, subcloud=condi, row.w=pcf$POIDS)

apply(Xmusq[condi, ], 2, wtable, w=pcf$POIDS[condi])
getindexcat(Xmusq[condi, ])
junk4 <- c(8, 11, 13:25, 66, 69:70, 72, 74:75, 77:79, 95, 99)
acm.musq <- csMCA(data=Xmusq, subcloud=condi, excl=junk4, row.w=pcf$POIDS)

l_acm <- list(acm.musq, acm.cine, acm.tele, acm.lectu)
afm <- multiMCA(l_acm)

a <- c(1, 2)

# Contributions des domaines aux axes (tableau 6)
round(afm$group$contrib[, a], 1)

# eta2 des variables de position sociale (tableau 7)
l <- list(sexe, age, diplo7, csp42, public3, revenu2, MER_diplo2, PER_csp6, PER_pays,
patrim$resII, patrim$epar, patrim$immo)
l <- lapply(l, function(x) factor(x[condi]))
n <- c('sexe', 'age', 'diplo7', 'csp42', 'publ-priv', 'revenu2', 'MER_diplo2', 'PER_csp6', 'PER_pays', 'resII', 'epar', 'immo')
dimeta(afm, l, n, dim=a)

# Coordonnees des modalites "notables" (tableau 8)
temp <- do.call('rbind.data.frame', lapply(afm$VAR, function(x) x$coord))
aides <- list()
for(i in 1:ncol(temp)) {
x <- temp[, i]
names(x) <- substr(rownames(temp), 6, nchar(rownames(temp)))
x <- x[order(x)]
aides[[i]] <- x[abs(x)>=0.5]
}
aides[[1]]




## ===============================
## Residus de Pearson (tableau 10)
## ===============================

round(chisq.test(table(diplo7[condi], Xmusq$gpref[condi])[1:6, 1:10])$stdres, 2)
round(chisq.test(table(fraction, Xmusq$gpref[condi])[, 1:10])$stdres, 2)

Haut de page

Pour citer cet article

Référence électronique

Nicolas Robette et Olivier Roueff, « Annexe 9 : Programme R des analyses de l’article  », Sociologie [En ligne], N° 4, vol. 8 |  2017, mis en ligne le 13 janvier 2018, consulté le 08 mars 2026. URL : http://journals.openedition.org/sociologie/3283

Haut de page

Auteurs

Nicolas Robette

Articles du même auteur

Olivier Roueff

Articles du même auteur

Haut de page

Droits d’auteur

Le texte et les autres éléments (illustrations, fichiers annexes importés), sont « Tous droits réservés », sauf mention contraire.

Haut de page

Rechercher dans OpenEdition Search

Vous allez être redirigé vers OpenEdition Search