r - 按组划分的阴影 fiddle 图

Question

我正在尝试在 R 中生成分组 fiddle 图的变体(最好使用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 生成了上述(单个) fiddle 图:

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

正如您在代码中注意到的那样，我使用水平密度函数从头开始构建 fiddle 图，然后翻转轴。当我尝试生成分组 fiddle 图时出现问题，主要是因为将出现组 X 和 Z 的轴已用作 fiddle 的“高度”密度。我确实尝试通过按组重复所有计算来达到相同的结果，但我陷入了最后一步:

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

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

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

Answer 1

想法

为了好玩，我快速编写了一个半 fiddle 几何图形。它基本上是从 GeomViolin 进行大量复制和粘贴，为了使其运行，我必须访问一些内部 ggplot2 函数，这些函数不会通过 导出>::: 这意味着该解决方案将来可能无法运行(如果 ggplot 团队决定更改其内部功能)。

但是，此解决方案有效，您可以指定上部和下部的 alpha 级别。 geom 假设您只提供一个分位数。该代码仅进行了表面测试，但它让您了解如何完成此操作。如前所述，它在很大程度上是来自 GeomViolin 的简单复制和粘贴，其中我添加了一些代码，找出哪些值低于和高于分位数，并将底层的 GeomPolygon 分割为2 部分，因为该函数仅使用单个 alpha 值。它同样适用于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()

<小时/>

图表