使用 position_stack 技术对文本/标签进行抖动

Question

考虑以下data.frame和图表：

library(ggplot2)
library(scales)
df <- data.frame(L=rep(LETTERS[1:2],each=4),
                 l=rep(letters[1:4],2),
                 val=c(96.5,1,2,0.5,48,0.7,0.3,51))
#   L l  val
# 1 A a 96.5
# 2 A b  1.0
# 3 A c  2.0
# 4 A d  0.5
# 5 B a 48.0
# 6 B b  0.7
# 7 B c  0.3
# 8 B d 51.0

ggplot(df,aes(x=L,y=val,fill=l)) +
  geom_bar(stat="identity") +
  geom_text(aes(label=percent(val/100)),position=position_stack(vjust =0.5))

由于一些数值较小，导致某些标签难以辨认。我想要将这些标签进行垂直抖动。我知道使用position_jitter可以实现这一点，但它似乎与堆叠条形图不兼容。

- moodymudskipper

---

相关：使用hjust交替geom_text位置 - Jaap

Answer 1

我们可以使用position_jitter_stack()创建一个新的Position。

 position_jitter_stack <- function(vjust = 1, reverse = FALSE, 
                                  jitter.width = 1, jitter.height = 1,
                                  jitter.seed = NULL, offset = NULL) {
  ggproto(NULL, PositionJitterStack, vjust = vjust, reverse = reverse, 
          jitter.width = jitter.width, jitter.height = jitter.height,
          jitter.seed = jitter.seed, offset = offset)
}

PositionJitterStack <- ggproto("PositionJitterStack", PositionStack,
  type = NULL,
  vjust = 1,
  fill = FALSE,
  reverse = FALSE,
  jitter.height = 1,
  jitter.width = 1,
  jitter.seed = NULL,
  offset = 1,

  setup_params = function(self, data) {
    list(
      var = self$var %||% ggplot2:::stack_var(data),
      fill = self$fill,
      vjust = self$vjust,
      reverse = self$reverse,
      jitter.height = self$jitter.height,
      jitter.width = self$jitter.width,
      jitter.seed = self$jitter.seed,
      offset = self$offset
    )
  },

  setup_data = function(self, data, params) {
    data <- PositionStack$setup_data(data, params)
    if (!is.null(params$offset)) {
      data$to_jitter <- sapply(seq(nrow(data)), function(i) {
        any(abs(data$y[-i] - data$y[i]) <= params$offset)
      })
    } else {
      data$to_jitter <- TRUE
      }
    data
  },

  compute_panel = function(data, params, scales) {
    data <- PositionStack$compute_panel(data, params, scales)

    jitter_df <- data.frame(width = params$jitter.width,
                            height = params$jitter.height)

    if (!is.null(params$jitter.seed)) jitter_df$seed = params$jitter.seed
    jitter_positions <- PositionJitter$compute_layer(
      data[data$to_jitter, c("x", "y")],
      jitter_df
    )

    data$x[data$to_jitter] <- jitter_positions$x
    data$y[data$to_jitter] <- jitter_positions$y

    data
  }
)

并将其绘制出来...

ggplot(df,aes(x=L,y=val,fill=l)) +
  geom_bar(stat="identity") +
  geom_text(aes(label=percent(val/100)),
            position = position_jitter_stack(vjust =0.5,
             jitter.height = 0.1,
             jitter.width =  0.3, offset = 1))

或者，我们可以编写一个非常简单的repel函数。

library(rlang)

position_stack_repel <- function(vjust = 1, reverse = FALSE, 
                                 offset = 1) {
  ggproto(NULL, PositionStackRepel, vjust = vjust, reverse = reverse,
          offset = offset)
}

PositionStackRepel <- ggproto("PositionStackRepel", PositionStack,
  type = NULL,
  vjust = 1,
  fill = FALSE,
  reverse = FALSE,
  offset = 1,

  setup_params = function(self, data) {
    list(
      var = self$var %||% ggplot2:::stack_var(data),
      fill = self$fill,
      vjust = self$vjust,
      reverse = self$reverse,
      offset = self$offset
    )
  },

  setup_data = function(self, data, params) {
    data <- PositionStack$setup_data(data, params)
    data <- data[order(data$x), ]
    data$to_repel <- unlist(by(data, data$x, function(x) {
      sapply(seq(nrow(x)), function(i) {
        (x$y[i]) / sum(x$y) < 0.1 & (
          (if (i != 1) (x$y[i-1] / sum(x$y)) < 0.1 else FALSE) | (
            if (i != nrow(x)) (x$y[i+1] / sum(x$y)) < 0.1 else FALSE))
      })
    }))
    data
  },

  compute_panel = function(data, params, scales) {
    data <- PositionStack$compute_panel(data, params, scales)
    data[data$to_repel, "x"] <- unlist(
      by(data[data$to_repel, ], data[data$to_repel, ]$x, 
         function(x) seq(x$x[1] - 0.3, x$x[1] + 0.3, length.out = nrow(x))))
    data
  }
)

绘制它：

ggplot(df,aes(x=L,y=val,fill=l)) +
  geom_bar(stat="identity") +
  geom_text(aes(label=percent(val/100)),
            position = position_stack_repel(vjust =0.5))

- erocoar

---

另外，%||% 函数来自于 rlang 包，因此您应该添加一个库调用。 - moodymudskipper

很高兴能帮到你！我会在周末研究改进排斥功能（例如添加垂直的或更好的检测），并将其添加到我的 ggpol 库中 - 也会在这里更新 :) - erocoar

非常好，它非常适用于我的示例，这是我的主要用例。感谢包括dir="v"选项，它也运行顺畅。对于这个新的解决方案，标签的位置取决于设备的尺寸，这在大多数情况下可能是一件好事，但以前并不是这样，因此现在为了保持一致性，应该先创建一个具有给定尺寸的设备。我建议将dir/v/h重命名为direction/x/y，这样它就与ggrepel保持一致，除非您正在与我不知道的其他内容保持一致。 - moodymudskipper

不幸的是，对于没有 vjust 的 position_stack() 它无法正常工作。 - moodymudskipper

最后，使用我的示例数据，spacing参数没有起作用。我试图设置标签之间的垂直最小间隔，但是您的函数认为左侧不需要排斥，尽管它略微重叠。选项check_overlap会使标签消失。 - moodymudskipper

Answer 2

我找到了两种解决方案，都需要预先计算标签的基本位置。一种是使用position_jitter，另一种是使用ggrepel（由用户@gfgm在已删除的答案中建议）。

创建位置：

请注意，我需要首先放置NAs，因此我使用了如何使用arrange()使NA显示在最前面。

library(dplyr)
df <- df %>%
  group_by(L) %>%
  arrange(!is.na(l), desc(l)) %>% 
  mutate(pos = cumsum(val) - val/2)) # the -val/2 is to center the text

position_jitter 解决方案

set.seed(2)
ggplot(df,aes(x=L,y=val,fill=l)) +
  geom_bar(stat="identity") +
  geom_text(aes(y=pos,label=percent(val/100)),position = position_jitter(width = 0,height=4))

ggrepel 解决方案

library(ggrepel)
ggplot(df,aes(x=L,y=val,fill=l)) +
  geom_bar(stat="identity") +
  geom_text_repel(aes(y=pos,label=percent(val/100)),direction="y",box.padding=0)

两种方法的比较

ggrepel 解决方案不需要手动校准，输出结果不完美但是一致，同时具有很强的灵活性，在大多数问题的变体中都是首选解决方案。请注意，geom_text_repel 具有 seed 参数，但在我的情况下它并不影响结果。

position_jitter 不会给出一致的结果，位置是随机的，对于大多数情况来说，它不如文本叠加 (我认为它像处理点那样抖动)。但是，针对特定的图表，通过预先使用 set.seed 可以获得比 ggrepel 更好的解决方案，因此在某些报告方面可能更好，在其他时间则更糟。

如果 geom_text_repel 支持 position_stack，我就不必经历第一步的痛苦了，但不幸的是它不支持。

这两种解决方案都有一个稍微让人烦恼的问题，就是会抖动那些本来不应该抖动的孤立标签(这个问题由 @erocoar 的解决方案处理)。

- moodymudskipper

---

请发布两种方法的屏幕截图？ - smci

这很好。我删除了我的答案，正是因为ggrepel缺少position_stack。现在实际上正在查看它，看看是否有一种解决方法 - 如果可以添加就太好了。 - gfgm