用geom_violin填充透明度

Question

如何增加小提琴圖的填充的alpha值而不是邊界線的alpha值？

將alpha作爲參數更改爲geom_violin()會導致填充和換行。

Answer 1

如果您希望避免繪圖兩次，可以執行以下操作。自從引入extension mechanism以來，我們可以輕鬆修改現有的source code來定義我們自己的幾何。

首先我們需要檢查geom_violin中發生了什麼。實際繪圖是用GeomPolygon$draw_panel(newdata, ...)完成的。所以訣竅是鼓搗geom_polygon。所需的修飾是非常簡單的：在密謀阻止

polygonGrob(munched$x, munched$y, default.units = "native", 
    id = munched$group, 
    gp = gpar(
     col = alpha(first_rows$colour, first_rows$alpha), 
     fill = alpha(first_rows$fill, first_rows$alpha), 
     lwd = first_rows$size * .pt, 
     lty = first_rows$linetype 
    ) 
) 

只需更換顏色規格col = first_rows$colour。

好的，我們很好去。只需聲明我們的自定義geom_violin2，從原始來源借用代碼並應用幾個臨時修復。

library(grid) 
GeomPolygon2 <- ggproto("GeomPolygon2", Geom, 
         draw_panel = function(data, panel_scales, coord) { 
          n <- nrow(data) 
          if (n == 1) return(zeroGrob()) 
          munched <- coord_munch(coord, data, panel_scales) 
          munched <- munched[order(munched$group), ] 
          first_idx <- !duplicated(munched$group) 
          first_rows <- munched[first_idx, ] 
          ggplot2:::ggname("geom_polygon", 
              polygonGrob(munched$x, munched$y, default.units = "native", 
                 id = munched$group, 
                 gp = gpar(
                 col = first_rows$colour, 
                 fill = alpha(first_rows$fill, first_rows$alpha), 
                 lwd = first_rows$size * .pt, 
                 lty = first_rows$linetype 
                 ) 
              ) 
         ) 
         }, 
         default_aes = aes(colour = "NA", fill = "grey20", size = 0.5, linetype = 1, 
              alpha = NA), 
         handle_na = function(data, params) { 
          data 
         }, 
         required_aes = c("x", "y"), 
         draw_key = draw_key_polygon 
) 

`%||%` <- function (a, b) 
{ 
    if (!is.null(a)) 
    a 
    else b 
} 

GeomViolin2 <- ggproto("GeomViolin", Geom, 
         setup_data = function(data, params) { 
         data$width <- data$width %||% 
          params$width %||% (resolution(data$x, FALSE) * 0.9) 
         plyr::ddply(data, "group", transform, 
            xmin = x - width/2, 
            xmax = x + width/2 
         ) 
         }, 

         draw_group = function(self, data, ..., draw_quantiles = NULL) { 
         data <- transform(data, 
              xminv = x - violinwidth * (x - xmin), 
              xmaxv = x + violinwidth * (xmax - x) 
         ) 
         newdata <- rbind(
          plyr::arrange(transform(data, x = xminv), y), 
          plyr::arrange(transform(data, x = xmaxv), -y) 
         ) 
         newdata <- rbind(newdata, newdata[1,]) 
         if (length(draw_quantiles) > 0) { 
          stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <= 1)) 
          quantiles <- create_quantile_segment_frame(data, draw_quantiles) 
          aesthetics <- data[ 
          rep(1, nrow(quantiles)), 
          setdiff(names(data), c("x", "y")), 
          drop = FALSE 
          ] 
          both <- cbind(quantiles, aesthetics) 
          quantile_grob <- GeomPath$draw_panel(both, ...) 
          ggplot2:::ggname("geom_violin", grobTree(
          GeomPolygon2$draw_panel(newdata, ...), 
          quantile_grob) 
          ) 
         } else { 
          ggplot2:::ggname("geom_violin", GeomPolygon2$draw_panel(newdata, ...)) 
         } 
         }, 
         draw_key = draw_key_polygon, 
         default_aes = aes(weight = 1, colour = "grey20", fill = "white", size = 0.5, 
             alpha = NA, linetype = "solid"), 
         required_aes = c("x", "y") 
) 

geom_violin2 <- function(mapping = NULL, data = NULL, stat = "ydensity", 
         draw_quantiles = NULL, position = "dodge", 
         trim = TRUE, scale = "area", 
         na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, 
         ...) { 
    layer(
    data = data, 
    mapping = mapping, 
    stat = stat, 
    geom = GeomViolin2, 
    position = position, 
    show.legend = show.legend, 
    inherit.aes = inherit.aes, 
    params = list(
     trim = trim, 
     scale = scale, 
     draw_quantiles = draw_quantiles, 
     na.rm = na.rm, 
     ... 
    ) 
) 
} 

現在看！我承認，顏色是可疑的。但是您可以清楚地看到邊框不受alpha的影響。

ggplot(mtcars, aes(factor(cyl), mpg)) + 
    geom_violin2(alpha = 0.7, size = 3, colour = "blue", fill = "red")