r - 用 geom_violin 填充透明度

Question

如何增加 fiddle 图填充的 alpha 而不是边界线的 alpha？

将 alpha 作为参数更改为 geom_violin() 会导致填充和线条发生变化。

Answer 1

如果您希望避免绘制两次，可以执行以下操作。自推出 extension mechanism我们可以很容易地修改现有的source code定义我们自己的geoms。

首先我们需要检查 geom_violin 中发生了什么.实际绘图是使用 GeomPolygon$draw_panel(newdata, ...) 完成的。所以诀窍是修补 geom_polygon .所需的修改非常简单:在绘图 block 中

  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")