按组的阴影小提琴图

Question

我正在尝试在 R 中生成一个分组小提琴图的变体（最好使用ggplot2），类似于下面的：

由以下可重现的示例代码生成：

# Load libraries #
library(tidyverse)

# Create dummy data #
set.seed(321)
df <- data.frame(X = rep(c("X1", "X2"), each = 100), 
                 Y = rgamma(n = 200, shape = 2, rate = 2),
                 Z = rep(c("Za", "Zb"), rep = 100),
                 stringsAsFactors = FALSE)

# Grouped violin plot #
df %>% 
  ggplot(., aes(x = X, y = Y, fill = Z)) + 
    geom_violin(draw_quantiles = 0.5) + 
    scale_fill_manual(values = c("Za" = "red", "Zb" = "blue"))

我想要的变化是中位数上方的密度与中位数下方的密度相比应该具有不同的阴影，如下图所示：

我使用以下代码为数据中的X = X1 和Z = Za 组合生成了上述（单个）小提琴图：

## Shaded violin plot ##
# Calculate limits and median #
df.lim <- df %>% 
            filter(X == "X1", Z == "Za") %>% 
            summarise(Y_min = min(Y),
                      Y_qnt = quantile(Y, 0.5),
                      Y_max = max(Y))

# Calculate density, truncate at limits and assign shade category #
df.dens <- df %>% 
            filter(X == "X1", Z == "Za") %>% 
            do(data.frame(LOC  = density(.$Y)$x,
                          DENS = density(.$Y)$y)) %>%
            filter(LOC >= df.lim$Y_min, LOC <= df.lim$Y_max) %>% 
            mutate(COL = ifelse(LOC > df.lim$Y_qnt, "Empty", "Filled"))

# Find density values at limits #
df.lim.2 <- df.dens %>% 
              filter(LOC == min(LOC) | LOC == max(LOC))

# Produce shaded single violin plot #
df.dens %>% 
  ggplot(aes(x = LOC)) + 
    geom_area(aes(y =  DENS, alpha = COL), fill = "red") +
    geom_area(aes(y = -DENS, alpha = COL), fill = "red") +
    geom_path(aes(y =  DENS)) +
    geom_path(aes(y = -DENS)) +
    geom_segment(data = df.lim.2, aes(x = LOC, y = DENS, xend = LOC, yend = -DENS)) +
    coord_flip() + 
    scale_alpha_manual(values = c("Empty" = 0.1, "Filled" = 1))

正如您将在代码中注意到的那样，我正在使用density 函数从头开始构建小提琴图，然后水平翻转轴。当我尝试生成分组小提琴图时出现问题，主要是因为组@98​​7654332@ 和Z 将出现在其中的轴已经用于密度的“高度”。我确实尝试通过按组重复所有计算来达到相同的结果，但我被困在最后一步：

## Shaded grouped violin plot ##
# Calculate limits and median by group #
df.lim <- df %>% 
            group_by(X, Z) %>% 
            summarise(Y_min = min(Y),
                      Y_qnt = quantile(Y, 0.5),
                      Y_max = max(Y))

# Calculate density, truncate at limits and assign shade category by group #
df.dens <- df %>% 
            group_by(X, Z) %>% 
            do(data.frame(LOC  = density(.$Y)$x,
                          DENS = density(.$Y)$y)) %>%
            left_join(., df.lim, by = c("X", "Z")) %>% 
            filter(LOC >= Y_min, LOC <= Y_max) %>% 
            mutate(COL = ifelse(LOC > Y_qnt, "Empty", "Filled"))

# Find density values at limits by group #
df.lim.2 <- df.dens %>%
              group_by(X, Z) %>% 
              filter(LOC == min(LOC) | LOC == max(LOC))

# Produce shaded grouped violin plot #
df.dens %>% 
  ggplot(aes(x = LOC, group = interaction(X, Z))) + 
    # The following two lines don't work when included #
    #geom_area(aes(y =  DENS, alpha = COL), fill = "red") +
    #geom_area(aes(y = -DENS, alpha = COL), fill = "red") +
    geom_path(aes(y =  DENS)) +
    geom_path(aes(y = -DENS)) +
    geom_segment(data = df.lim.2, aes(x = LOC, y = DENS, xend = LOC, yend = -DENS)) +
    coord_flip() + 
    scale_alpha_manual(values = c("Empty" = 0.1, "Filled" = 1))

运行上面的代码将为每个组生成小提琴图的轮廓，每个组都在另一个之上。但是一旦我尝试包含 geom_area 行，代码就会失败。

我的直觉告诉我，我需要以某种方式将“阴影”小提琴图生成为新的geom，然后可以在ggplot2 图形的一般结构下使用它，但我不知道该怎么做，因为我的编码技能并没有延伸那么远。任何帮助或指示，无论是沿着我的思路还是在不同的方向，都将不胜感激。感谢您的宝贵时间。

Answer 1

想法

为了好玩，我快速破解了一个半小提琴几何。它基本上是来自GeomViolin 的大量复制和粘贴，为了使其运行，我必须访问一些内部ggplot2 函数，这些函数不是通过::: 导出的，这意味着该解决方案可能无法运行未来（如果ggplot 团队决定改变他们的内部功能）。

但是，此解决方案有效，您可以指定上部和下部的 Alpha 级别。 geom 假设您只提供一个分位数。该代码仅经过表面测试，但它让您了解如何做到这一点。如前所述，它在很大程度上是来自GeomViolin 的简单复制和粘贴，我在其中添加了一些代码，找出哪些值低于和高于分位数并将底层GeomPolygon 分成两部分，因为这个函数只使用一个阿尔法值。它同样适用于groups 和coord_flip。

---

代码

library(grid)

GeomHalfViolin <- ggproto("GeomHalfViolin", GeomViolin,
  draw_group = function (self, data, ..., draw_quantiles = NULL, 
                         alpha_upper = .5, alpha_lower = 1) {
    data <- transform(data, xminv = x - violinwidth * (x - xmin), 
        xmaxv = x + violinwidth * (xmax - x))
    newdata <- rbind(transform(data, x = xminv)[order(data$y), 
        ], transform(data, x = xmaxv)[order(data$y, decreasing = TRUE), 
        ])
    newdata <- rbind(newdata, newdata[1, ])
    if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) {
        stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <= 
            1))
        stopifnot(length(draw_quantiles) <= 1)
        ## need to add ggplot::: to access ggplot2 internal functions here and there
        quantiles <- ggplot2:::create_quantile_segment_frame(data, draw_quantiles)
        ###------------------------------------------------
        ## find out where the quantile is supposed to be
        quantile_line <- unique(quantiles$y)
        ## which y values are below this quantile?
        ind <- newdata$y <= quantile_line
        ## set the alpha values accordingly
        newdata$alpha[!ind] <- alpha_upper
        newdata$alpha[ind] <- alpha_lower
        ###------------------------------------------------
        aesthetics <- data[rep(1, nrow(quantiles)), setdiff(names(data), 
            c("x", "y", "group")), drop = FALSE]
        aesthetics$alpha <- rep(1, nrow(quantiles))
        both <- cbind(quantiles, aesthetics)
        both <- both[!is.na(both$group), , drop = FALSE]
        quantile_grob <- if (nrow(both) == 0) {
            zeroGrob()
        }
        else {
            GeomPath$draw_panel(both, ...)
        }
        ###------------------------------------------------
        ## GeomPolygon uses a single alpha value by default
        ## Hence, split the violin in two parts
        ggplot2:::ggname("geom_half_violin",
                         grobTree(GeomPolygon$draw_panel(newdata[ind, ], ...),
                                  GeomPolygon$draw_panel(newdata[!ind, ], ...),
                                  quantile_grob))
        ###------------------------------------------------
    }
    else {
        ggplot2:::ggname("geom_half_violin", GeomPolygon$draw_panel(newdata, 
            ...))
    }
  } 
)

geom_half_violin <- function(mapping = NULL, data = NULL, stat = "ydensity",
                             position = "dodge", ..., draw_quantiles = NULL,
                             alpha_upper = .5, alpha_lower = 1, 
                             trim = TRUE, scale = "area", 
                             na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
    layer(data = data, mapping = mapping, stat = stat, geom = GeomHalfViolin, 
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(trim = trim, scale = scale, draw_quantiles = draw_quantiles, 
                      alpha_lower = alpha_lower, alpha_upper = alpha_upper,
                      na.rm = na.rm, ...))

}


library(tidyverse)

# Create dummy data #
set.seed(321)
df <- data.frame(X = rep(c("X1", "X2"), each = 100), 
                 Y = rgamma(n = 200, shape = 2, rate = 2),
                 Z = rep(c("Za", "Zb"), rep = 100),
                 stringsAsFactors = FALSE)

# Grouped violin plot #
df %>% 
  ggplot(., aes(x = X, y = Y, fill = Z)) + 
    geom_half_violin(draw_quantiles = 0.5, alpha_upper = .1) + 
    scale_fill_manual(values = c("Za" = "red", "Zb" = "blue"))
# no groups
df %>% filter(Z == "Za") %>% 
  ggplot(., aes(x = X, y = Y)) + 
    geom_half_violin(draw_quantiles = 0.5, alpha_upper = .1, fill = "red") + 
    scale_fill_manual(values = c("Za" = "red", "Zb" = "blue")) + 
    coord_flip()

---

图表