Как изменить легенду о графике, используя функцию ggproto в ggplot2?

Question

В анализе основных компонентов я извлекаю результат компонента в prcomp() для точечного графика. Я хочу добавить метки имен групп, тогда центр каждой группы рассчитывается в каждой группе, используя MASS::cov.trob(), Я создаю новую статистику и перестраиваю новый geom, используя ggplot2::ggproto() для того, чтобы выставить этикетки каждой группы. Тем не менее, новый граф имеет неразумную легенду, потому что он должен быть легендой-точкой, а не легендой-персонажем. Я пробовал несколько вариантов этого, но ни один из них, кажется, не работает. Есть идеи? Вот мой код:

# data
data(Cars93, package = "MASS")
car_df <- Cars93[, c(3, 5, 13:15, 17, 19:25)]
car_df <- subset(car_df, Type == "Large" | Type == "Midsize" | Type == "Small")
x1 <- mean(car_df$Price) + 2 * sd(car_df$Price)
x2 <- mean(car_df$Price) - 2 * sd(car_df$Price)
car_df <- subset(car_df, Price > x2 | Price < x1)
car_df <- na.omit(car_df)

# Principal Component Analysis
car.pca <- prcomp(car_df[, -1], scale = T)
car.pca_pre <- cbind(as.data.frame(predict(car.pca)[, 1:2]), car_df[, 1])
colnames(car.pca_pre) <- c("PC1", "PC2", "Type")
head(car.pca_pre)

# create a new stat
library(ggplot2)
StatLabel <- ggproto("StatLabel" ,Stat,
               compute_group = function(data, scales) {
                library(MASS)
                df <- data.frame(data$x,data$y)
                center <- cov.trob(df)$center
                names(center)<- NULL 
                center <- t(as.data.frame(center))
                center <- as.data.frame(cbind(center))
                colnames(center) <- c("x","y")
                rownames(center) <- NULL
                return(center)
                },
                required_aes = c("x", "y")
)

stat_label <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", 
    ..., parse = FALSE, nudge_x = 0, nudge_y = 0, label.padding = unit(0.15, 
        "lines"), label.r = unit(0.15, "lines"), label.size = 0.1, 
    na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) 
{
    if (!missing(nudge_x) || !missing(nudge_y)) {
        if (!missing(position)) {
            stop("Specify either `position` or `nudge_x`/`nudge_y`", 
                call. = FALSE)
        }
        position <- position_nudge(nudge_x, nudge_y)
    }
    layer(data = data, mapping = mapping, stat = StatLabel, geom = GeomLabel, 
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(parse = parse, label.padding = label.padding, 
            label.r = label.r, label.size = label.size, na.rm = na.rm, 
            ...))
}

# plot
ggplot(car.pca_pre, aes(PC1, PC2, color = Type)) + geom_point() + 
stat_label(aes(label = Type))

Answer 1

Я не думаю, что было бы очень естественно иметь ваши новые показатели показа статов в легенде, поскольку они не наносят никаких точек. По сути, ggplot, по-видимому, дает приоритет над текстовой легендой, когда и точки, и текст имеют объединенную легенду. Самое простое решение - не использовать легенду по умолчанию для вашей метки.

Вы можете изменить свою функцию, чтобы иметь show.legend = FALSE по умолчанию, а затем ваш график будет отображать легенду точки вместо этого.

stat_label <- function (mapping = NULL, 
                        data = NULL, 
                        stat = "identity", 
                        position = "identity", 
                        ..., 
                        parse = FALSE, 
                        nudge_x = 0, nudge_y = 0, 
                        label.padding = unit(0.15, "lines"), 
                        label.r = unit(0.15, "lines"), 
                        label.size = 0.1, 
                        na.rm = FALSE, 
                        show.legend = FALSE,       ## <--- change
                        inherit.aes = TRUE) 
{
  if (!missing(nudge_x) || !missing(nudge_y)) {
    if (!missing(position)) {
      stop("Specify either `position` or `nudge_x`/`nudge_y`", 
           call. = FALSE)
    }
    position <- position_nudge(nudge_x, nudge_y)
  }
  layer(data = data, mapping = mapping, stat = StatLabel, geom = GeomLabel, 
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(parse = parse, label.padding = label.padding, 
                      label.r = label.r, label.size = label.size, na.rm = na.rm, 
                      ...))
}

# plot
ggplot(car.pca_pre, aes(PC1, PC2, color = Type)) + geom_point() + 
  stat_label(aes(label = Type))