ggplot2：显示嵌套分割小提琴块

Question

我有以下数据集：

df <- data.frame(dens = rnorm(5000),
             split = as.factor(sample(1:2, 5000, replace = T)),
             method = as.factor(sample(c("A","B"), 5000, replace = T)),
             counts = sample(c(1, 10, 100, 1000, 10000), 5000, replace = T))

我想要做的是为每个计数在 A 组和 B 组中的分裂 1 和 2 做分裂小提琴图（这将在对数刻度中，但这对于这个例子并不重要）。每个设置都有四个组，但它有一个嵌套的方面。

所以，我可以做到以下几点：

df$key <- factor(paste(df$split, df$method))

然后：

library(ggplot2)
ggplot(df, aes(x = factor(counts), y = dens, fill = split)) +
geom_violin(aes(fill = key), scale = "width", draw_quantiles = c(0.25, 0.5, 0.75)) + scale_fill_manual(values = cbPalette) + theme_bw()

这给了我以下情节：

但我真正想要的是浅蓝色和深蓝色作为分裂小提琴情节的两半，浅绿色和深绿色作为另一个小提琴分裂情节的两半，这些情节应该捆绑在一起一起。我也希望不同的计数彼此分开，但我觉得我可以解决这个问题。

请注意，这个问题与我列出的问题或Split violin plot with ggplot2 不同，因为我们为每个“计数”合并了两个不同级别的嵌套分割小提琴图。

我试图关注enter link description here 但是 我不知道如何将这样的嵌套组设置添加到那里的代码中，我正在寻找一些建议。

这是我尝试过的：

GeomSplitViolin <- ggproto("GeomSplitViolin", GeomViolin, 
  draw_group = function(self, data, ..., draw_quantiles = NULL){
    # By @YAK: https://stackoverflow.com/questions/35717353/split-violin-plot-with-ggplot2
    data <- transform(data, xminv = x - violinwidth * (x - xmin), xmaxv = x + violinwidth * (xmax - x))
    grp <- data[1,'group']
    newdata <- plyr::arrange(transform(data, x = if(grp%%2==1) xminv else xmaxv), if(grp%%2==1) y else -y)
    newdata <- rbind(newdata[1, ], newdata, newdata[nrow(newdata), ], newdata[1, ])
    newdata[c(1,nrow(newdata)-1,nrow(newdata)), 'x'] <- round(newdata[1, 'x']) 
    if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) {
      stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <= 1))
      quantiles <- create_quantile_segment_frame(data, draw_quantiles, split = TRUE, grp = grp)
      aesthetics <- data[rep(1, nrow(quantiles)), setdiff(names(data), c("x", "y")), drop = FALSE]
      aesthetics$alpha <- rep(1, nrow(quantiles))
      both <- cbind(quantiles, aesthetics)
      quantile_grob <- GeomPath$draw_panel(both, ...)
      ggplot2:::ggname("geom_split_violin", grid::grobTree(GeomPolygon$draw_panel(newdata, ...), quantile_grob))
    }
    else {
      ggplot2:::ggname("geom_split_violin", GeomPolygon$draw_panel(newdata, ...))
    }
  }
)

create_quantile_segment_frame <- function (data, draw_quantiles, split = FALSE, grp = NULL) {
  dens <- cumsum(data$density)/sum(data$density)
  ecdf <- stats::approxfun(dens, data$y)
  ys <- ecdf(draw_quantiles)
  violin.xminvs <- (stats::approxfun(data$y, data$xminv))(ys)
  violin.xmaxvs <- (stats::approxfun(data$y, data$xmaxv))(ys)
  violin.xs <- (stats::approxfun(data$y, data$x))(ys)
  if (grp %% 2 == 0) {
    data.frame(x = ggplot2:::interleave(violin.xs, violin.xmaxvs), 
               y = rep(ys, each = 2), group = rep(ys, each = 2)) 
  } else {
    data.frame(x = ggplot2:::interleave(violin.xminvs, violin.xs), 
               y = rep(ys, each = 2), group = rep(ys, each = 2)) 
  }
}



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

library(ggplot2)
ggplot(df, aes(x = factor(counts), y = dens, fill = interaction(split,method))) +
           geom_split_violin(draw_quantiles = c(0.25, 0.5, 0.75)) + scale_fill_manual(values=RColorBrewer::brewer.pal(name="Paired",n=4)) + theme_light() + theme(legend.position="bottom")

这是我得到的：

可以看出，绿色图像位于蓝色图像之上。我该如何解决这个问题？谢谢！

编辑：按照 Axeman 的建议，我快到了：

   levels(df$split) <- factor(0:3)

   library(ggplot2)
   ggplot(df, aes(x = interaction(split, counts), y = dens, fill = key)) + geom_split_violin(draw_quantiles = c(0.25, 0.5, 0.75)) + scale_fill_manual(values=RColorBrewer::brewer.pal(name="Paired",n=4)) + theme_light() + theme(legend.position="bottom") + scale_x_discrete(interaction(df$split,df$counts)[-length(interaction(df$split,df$counts))], drop = FALSE)

快到了！

想要两个修复：拆分和计数之间的最后一次交互产生的空白，以及仅对每束计数的比例。 想知道这些是否应该是 Stackoverflow 上的单独问题。

快到了！

library(ggplot2)
ggplot(df, aes(x = interaction(split, counts), y = dens, fill = key)) + geom_split_violin(draw_quantiles = c(0.25, 0.5, 0.75)) +scale_fill_manual(values=RColorBrewer::brewer.pal(name="Paired",n=4)) + theme_light() + theme(legend.position="bottom") + scale_x_discrete(limits=levels(interaction(df$split,df$counts))[-length(levels(interaction(df$split,df$counts)))],drop = FALSE)

这会产生：

我仍然需要将计数值放在 x 轴上，在两个图之间。

Answer 1

我认为这个问题已经变得太长了，这个问题的基本部分已经回答了。我提出了一个关于如何更改离散比例的新问题。希望有人知道！无论如何，这是这个问题的答案（谢谢，Axe！）。它在我的问题的编辑版本中。

library(ggplot2)
df <- data.frame(dens = rnorm(5000),
             split = factor(sample(1:2, 5000, replace = T)),
             method = factor(sample(c("A","B"), 5000, replace = T)),
             counts = factor(sample(c(1, 10, 100, 1000, 10000), 5000, replace = T)))

df$key <- factor(paste(df$split, df$method))

levels(df$split) <- factor(0:2)
library(ggplot2)

ggplot(df, aes(x = interaction(split, counts), y = dens, fill = key)) +
  geom_split_violin(draw_quantiles = c(0.25, 0.5, 0.75)) +
  scale_fill_manual(values=RColorBrewer::brewer.pal(name="Paired",n=4)) + 
  theme_light() + 
  theme(legend.position="bottom") + 
  scale_x_discrete(
    limits = levels(interaction(df$split,df$counts))[-length(levels(interaction(df$split,df$counts)))],
    drop = FALSE, 
    name = "Counts"
  )