Couleur étiquette pour graphe MCA

[Lorraine Bauer]

Bonjour à tous,
J'ai fait une MCA avec ade4, avec la fonction scatter.dudi() j'ai construit mon graphique individus/variables et je voudrais simplement le customiser un peu : j'ai simplement envie de colorer le fond des étiquettes de variables. Voici mon code pour le moment :

Code : Tout sélectionner

resADE4<-dudi.acm(data, scannf = F)
scatter.dudi(resADE4,posieig="bottomright",clab.row = 0.7,clab.col=1.2)


Quelqu'un aurait-il une astuce ? Je vous remercie d'avance.
Lorraine

[Nicolas Péru]

Salut,

rien de bien direct. 2 Solutions, soit tu édites via un logiciel de graphisme soit tu édite le code source des fonctions d'ade4.
Ce package a l'avantage de fournir un code directement accessible du coup tu peux facilement le modifier. il faut juste repérer les bonnes fonctions.
Je te propose de ne pas vraiment passer par un scatter qui produit souvent un graphique où tout se supperpose. Donc ci-dessous une version modifiée de s.arrow qui est la fonction qui trace les flêches des variables dans toutes les représentations de ce type dans ade4.

1ère étape, on ajoute un argument "colboxes" à la fonction scatterutil.eti.circ qui deveint scatterutil.eti.circ2 pour ne pas écraser la version d'origine.

Code : Tout sélectionner

scatterutil.eti.circ2 <-
function (x, y, label, clabel, origin = c(0, 0), boxes = TRUE, colboxes="white")
{
    if (is.null(label))
        return(invisible())
    if (any(is.na(label)))
        return(invisible())
    if (any(label == ""))
        return(invisible())
    xref <- x - origin[1]
    yref <- y - origin[2]
    for (i in 1:(length(x))) {
        cha <- as.character(label[i])
        cha <- paste(" ", cha, " ", sep = "")
        cex0 <- par("cex") * clabel
        xh <- strwidth(cha, cex = cex0)
        yh <- strheight(cha, cex = cex0) * 5/6
        if ((xref[i] > yref[i]) & (xref[i] > -yref[i])) {
            x1 <- x[i] + xh/2
            y1 <- y[i]
        }
        else if ((xref[i] > yref[i]) & (xref[i] <= (-yref[i]))) {
            x1 <- x[i]
            y1 <- y[i] - yh
        }
        else if ((xref[i] <= yref[i]) & (xref[i] <= (-yref[i]))) {
            x1 <- x[i] - xh/2
            y1 <- y[i]
        }
        else if ((xref[i] <= yref[i]) & (xref[i] > (-yref[i]))) {
            x1 <- x[i]
            y1 <- y[i] + yh
        }
        if (boxes) {
            rect(x1 - xh/2, y1 - yh, x1 + xh/2, y1 + yh, col =colboxes,
                border = 1)
        }
        text(x1, y1, cha, cex = cex0)
    }
}

étape 2 on incorpore cette modification à la fonction s.arrow

Code : Tout sélectionner

s.arrow2 <-
function (dfxy, xax = 1, yax = 2, label = row.names(dfxy), clabel = 1,
    pch = 20, cpoint = 0, boxes = TRUE, edge = TRUE, origin = c(0,
        0), xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
    cgrid = 1, sub = "", csub = 1.25, possub = "bottomleft",
    pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE, colboxes="white")
{
    arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1,
        edge) {
        d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
        if (d0 < 1e-07)
            return(invisible())
        segments(x0, y0, x1, y1, lty = lty)
        h <- strheight("A", cex = par("cex"))
        if (d0 > 2 * h) {
            x0 <- x1 - h * (x1 - x0)/d0
            y0 <- y1 - h * (y1 - y0)/d0
            if (edge)
                arrows(x0, y0, x1, y1, angle = ang, length = len,
                  lty = 1)
        }
    }
    dfxy <- data.frame(dfxy)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
        cgrid = cgrid, include.origin = TRUE, origin = origin,
        sub = sub, csub = csub, possub = possub, pixmap = pixmap,
        contour = contour, area = area, add.plot = add.plot)
    if (grid & !add.plot)
        scatterutil.grid(cgrid)
    if (addaxes & !add.plot)
        abline(h = 0, v = 0, lty = 1)
    if (cpoint > 0)
        points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
    for (i in 1:(length(coo$x))) arrow1(origin[1], origin[2],
        coo$x[i], coo$y[i], edge = edge)
    if (clabel > 0)
        scatterutil.eti.circ2(coo$x, coo$y, label, clabel, origin,
            boxes,colboxes=colboxes)
    if (csub > 0)
        scatterutil.sub(sub, csub, possub)
    box()
    invisible(match.call())
}

Et voilà ce que ça donne avec un exemple reproductible.

Code : Tout sélectionner

data(meaudret)
env.pca <- dudi.pca(meaudret$env)

code de la figure ci-dessous
s.arrow2(env.pca$co,colboxes=c("transparent"))
s.arrow2(env.pca$co[1:5,],colboxes=c("red"),add.p=T)
s.arrow2(env.pca$co[6:9,],colboxes=c("blue"),add.p=T)


[Logez Maxime]

T'as vraiment aucun sens de l’esthétisme !
Qu'il est moche ton exemple. En plus c'est pas le beau et le orange tes couleurs préférées maintenant ?

[Pierre Bady]

hello,

mais non ... t'inquiètes pas! il y a pire ... regarde les immondes heatmaps utilisés par les "geneticators" ... leurs gradients de couleurs font saigner mes petits yeux ... :'(

sinon, tu peux essayer d'ajouter le label en blanc ou seulement colorer le texte et le contour de l'étiquette :)

Example sans modification de functions

Code : Tout sélectionner

require(ade4)
data(deug)
deug.dudi <- dudi.pca(deug$tab, center = deug$cent,scale = FALSE, scan = FALSE)
s.arrow(deug.dudi$c1,clabel=0)
s.class(deug.dudi$c1,fac=as.factor(1:nrow(deug.dudi$c1)),add.p=TRUE, col=topo.colors(nrow(deug.dudi$c1)))

@++


pierre

[Nicolas Péru]

T'as vraiment aucun sens de l’esthétisme !
Qu'il est moche ton exemple. En plus c'est pas le beau et le orange tes couleurs préférées maintenant ?

tsss..les goûts et les couleurs. Je ne vais même pas aller plus loin sur ton commentaire :P

[Lorraine Bauer]

Merci à tous !
J'ai de très beaux graphes à présent. Les collègues vont me jalouser, c'est sûr !
Du coup, j'ai aussi compris quelques trucs avec ade4, je n'étais pas du tout habitué à ce package, j'utilisais plutôt FactoMineR.
Sur l'esthétisme, je dois repeindre mon salon et je n'arrive pas à choisir ma couleur, j'ai testé plusieurs échantillons (gris... bof....vers-gris...bof....rouge terre....bof....gris-bleu...bof...), mon mur ne ressemble à plus rien à présent... Quelqu'un aurait-il LE morceau de code du bon gout à me passer pour mon mur ;) ??
A très bientôt !
L

[Pierre Bady]

hello,

j'aime bien les niveaux de gris ... avec du rouge ... c'est un peu gothique/coca ... mais bon, je ne suis pas réputé pour mon bon goût en matière de couleur :p

En plus, ça dépend beaucoup de tes interlocuteurs. Par exemple, ma cheffe ne réagit quasiment qu'aux gradients de couleur de type matlab (cf en dessous).

jet.colors <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan","#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))

Sinon, il ya plein d'info sur le sujet dans le document suivant: http://pbil.univ-lyon1.fr/R_svn/pdf/tdr18.pdf


@++ et bon coloriage :)


Pierre