re,
Attention les ellipses de factoextra et de s.class ne sont pas directement comparables parce que pas définies pour le même niveau de confiance.
Je trouve les fonctions de factoextra très bien faits, mais il y a toujours un truc qui me gène avec la représentation de factoextra, c'est que le ratio entre les axes n'est pas de 1. Dans ton exemple on a l'impression que la "plus grande dimension" du nuage de point général (et pas les sous nuages) est la deuxième (ordonnées) alors qu'en fait ça devrait être la première (abcisse).
Je rajouterai à chaque fois coord_fixed() par exemple.
De plus ce code ne permet pas de modifier les boîtes et le texte uniquement des labels représentés au barycentre des points d'un groupe.
Pour mimer la fonction s.class :
Code : Tout sélectionner
xy <- cbind.data.frame(x = runif(200, -1, 1), y = runif(200, -1, 1))
posi <- factor(xy$x > 0) : factor(xy$y > 0)
posi <- factor(posi, labels = c("F:F", "F:T", "T:F", "T:T"))
library(showtext)
library(ggplot2)
font_add("Symbol", "symbol.ttf") # pour l'exemple
showtext_auto()
StatBary <- ggproto("StatBary", Stat,
compute_group = function(data, scales) {
tab <- data[c("x", "y")]
mns <- colMeans(tab)
res <- as.data.frame(as.list(mns))
colnames(res) <- c("x", "y")
res
}
, required_aes = c("x", "y")
)
StatStar <- ggproto("StatStar", Stat,
compute_group = function(data, cstar, scales) {
tab <- data[c("x", "y")]
mns <- colMeans(tab)
tabn <- t(tab)-mns
tabn <- tabn*cstar
tabn <- tabn + mns
tabn <- t(tabn)
tabn <- as.data.frame(tabn)
res <- as.data.frame(as.list(mns))
res <- cbind(res, tabn)
colnames(res) <- c("x", "y", "xend", "yend")
res
}
, required_aes = c("x", "y")
)
stat_class <- function (mapping = NULL, data = NULL,
position = "identity", cstar = 1, cellipse = 1.5, clabel = 1, cpoint = 1, ...,
show.legend = FALSE, inherit.aes = TRUE)
{
l1 <- list()
if (cellipse > 0) {
level <- 1-exp(-0.5*(cellipse)^2)
l1 <- c(l1, layer(data = data, mapping = mapping, stat = StatEllipse, geom = "path",
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = rlang:::list2(type = "t", level = level, segments = 51, na.rm = FALSE)))
}
if (cstar > 0) {
l1 <- c(l1, layer(data = data, mapping = mapping, stat = StatStar, geom = "segment",
position = position, show.legend = show.legend & (!cellipse > 0), inherit.aes = inherit.aes,
params = rlang:::list2(cstar = cstar)))
}
if (clabel) {
l1 <- c(l1, layer(data = data, mapping = mapping, stat = StatBary,
geom = "label", position = position, show.legend = show.legend & (!(cellipse > 0 | cstar > 0)),
inherit.aes = inherit.aes, params = rlang:::list2(...)))
}
if (cpoint > 0 ) {
l1 <- c(l1, layer(data = data, mapping = mapping, stat = StatIdentity,
geom = "point", position = position, show.legend = show.legend & (!(cellipse > 0 | cstar > 0 | clabel > 0)),
inherit.aes = inherit.aes, params = rlang:::list2()))
}
l1
}
ggplot(xy, aes(x, y, label = posi, color = posi)) +
geom_vline(xintercept = 0) +
geom_hline(yintercept = 0) +
stat_class(family = "Symbol") +
coord_fixed() +
theme_bw()
Cordialement,
Maxime