条形图连线 / 如何在R中使用grid.arrange连接两个图表 / ggplot2

Question

在Facebook的研究中，我发现了这些美丽的柱状图，它们通过线条连接以指示排名变化：

https://research.fb.com/do-jobs-run-in-families/

我希望使用ggplot2创建它们。条形图部分很容易：

library(ggplot2)
library(ggpubr)
state1 <- data.frame(state=c(rep("ALABAMA",3), rep("CALIFORNIA",3)), 
                 value=c(61,94,27,10,30,77), 
                 type=rep(c("state","local","fed"),2),
                 cumSum=c(rep(182,3), rep(117,3)))
state2 <- data.frame(state=c(rep("ALABAMA",3), rep("CALIFORNIA",3)), 
                 value=c(10,30,7,61,94,27), 
                 type=rep(c("state","local","fed"),2),
                 cumSum=c(rep(117,3), rep(182,3)))
fill <- c("#40b8d0", "#b2d183", "#F9756D")

p1 <- ggplot(data = state1) +
  geom_bar(aes(x = reorder(state, value), y = value, fill = type), stat="identity") +
  theme_bw() + 
  scale_fill_manual(values=fill) + 
  labs(x="", y="Total budget in 1M$") +
  theme(legend.position="none", 
        legend.direction="horizontal", 
        legend.title = element_blank(),
        axis.line = element_line(size=1, colour = "black"),
        panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(),
        panel.border = element_blank(), panel.background = element_blank()) +
  coord_flip() 

p2 <- ggplot(data = state2) +
  geom_bar(aes(x = reorder(state, value), y = value, fill = type), stat="identity") +
  theme_bw() + 
  scale_fill_manual(values=fill) + labs(x="", y="Total budget in 1M$") +
  theme(legend.position="none", 
        legend.direction="horizontal", 
        legend.title = element_blank(),
        axis.line = element_line(size=1, colour = "black"),
        panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(),
        panel.border = element_blank(), 
        panel.background = element_blank()) +
  scale_x_discrete(position = "top") + 
  scale_y_reverse() +
  coord_flip()

p3 <- ggarrange(p1, p2, common.legend = TRUE, legend = "bottom")

但是我无法想出解决线条部分的方法。例如，在左侧添加线条时

p3 + geom_segment(aes(x = rep(1:2, each=3), xend = rep(1:10, each=3), 
                   y = cumSum[order(cumSum)], yend=cumSum[order(cumSum)]+10), size = 1.2)

问题在于这些线无法连接到右侧，效果如下： 基本上，我想要将左侧的“California”条与右侧的“California”条连接起来。

为了做到这一点，我认为必须以某种方式访问图表的上级层次。我已经研究了视口，并能够用geom_segment制作出一个图表，但是我无法找到适合这些线的正确布局：

subplot <- ggplot(data = state1) + 
  geom_segment(aes(x = rep(1:2, each=3), xend = rep(1:2, each=3), 
                   y = cumSum[order(cumSum)], yend =cumSum[order(cumSum)]+10), 
               size = 1.2)

vp <- viewport(width = 1, height = 1, x = 1, y = unit(0.7, "lines"), 
               just ="right", "bottom"))
print(p3)
print(subplot, vp = vp)

非常感谢您的帮助或提示。

- Ben

---

alluvial 可能是绘制线条的有用包（剩下的挑战将是弄清如何在 alluvial 图上绘制条形图）。 - 12b345b6b78

很棒的问题！考虑上传你的图表以吸引更多关注。 - Roman

如果您可以计算条形图的相对x/y中心位置，那么您可以使用类似于grid.lines(x = unit(c(.475, .525), "npc"), y = unit(c(.7, .4), "npc"))的方法，但这似乎非常不专业... - Roman

你能详细说明一下你希望如何连接这些行吗？在你的代码中cumSum没有被定义。 - Z.Lin

Answer 1

这是一个非常有趣的问题。我使用了patchwork库来进行近似，它允许您将ggplot图形组合在一起，并提供了一种易于控制布局的方式——我更喜欢它而不是基于grid.arrange的方法，对于某些情况它比cowplot效果更好。

我扩展了数据集，只是为了在这两个数据框中获取更多值。

library(tidyverse)
library(patchwork)

set.seed(1017)

state1 <- data_frame(
  state = rep(state.name[1:5], each = 3),
  value = floor(runif(15, 1, 100)),
  type = rep(c("state", "local", "fed"), times = 5)
)

state2 <- data_frame(
  state = rep(state.name[1:5], each = 3),
  value = floor(runif(15, 1, 100)),
  type = rep(c("state", "local", "fed"), times = 5)
)

然后我创建了一个数据框，根据原始的数据框中的其他值（state1或state2）为每个州分配排名。

ranks <- bind_rows(
  state1 %>% mutate(position = 1),
  state2 %>% mutate(position = 2)
)  %>%
  group_by(position, state) %>%
  summarise(state_total = sum(value)) %>%
  mutate(rank = dense_rank(state_total)) %>%
  ungroup()

我制作了一个简单的主题，使事物非常简洁并丢弃坐标轴标记：

theme_min <- function(...) theme_minimal(...) +
  theme(panel.grid = element_blank(), legend.position = "none", axis.title = element_blank())

颠簸图（中间那个）基于ranks数据框，没有标签。使用因子而不是数值变量来确定位置和排名，使我对间距有更多控制，并且让排名与离散的1到5值对齐，以便与柱状图中的州名相匹配。

p_ranks <- ggplot(ranks, aes(x = as.factor(position), y = as.factor(rank), group = state)) +
  geom_path() +
  scale_x_discrete(breaks = NULL, expand = expand_scale(add = 0.1)) +
  scale_y_discrete(breaks = NULL) +
  theme_min()
p_ranks

对于左侧的条形图，我按值对州进行排序，并将值变为负数以指向左侧，然后给它相同的极简主题：

p_left <- state1 %>%
  mutate(state = as.factor(state) %>% fct_reorder(value, sum)) %>%
  arrange(state) %>%
  mutate(value = value * -1) %>%
  ggplot(aes(x = state, y = value, fill = type)) +
    geom_col(position = "stack") +
    coord_flip() +
    scale_y_continuous(breaks = NULL) +
    theme_min() +
    scale_fill_brewer()
p_left

右侧的柱状图与左侧基本相同，唯一不同之处在于数值保持为正，并且我将x轴移到了顶部（在反转坐标时变为右侧）：

p_right <- state2 %>%
  mutate(state = as.factor(state) %>% fct_reorder(value, sum)) %>%
  arrange(state) %>%
  ggplot(aes(x = state, y = value, fill = type)) +
    geom_col(position = "stack") +
    coord_flip() +
    scale_x_discrete(position = "top") +
    scale_y_continuous(breaks = NULL) +
    theme_min() +
    scale_fill_brewer()

因为我已经加载了patchwork，所以我可以将绘图组合在一起并指定布局。

p_left + p_ranks + p_right +
  plot_layout(nrow = 1)

您可能需要进一步调整间距和边缘，比如使用expand_scale函数调整凸起图表的大小。我并没有尝试在y轴上添加刻度标记（即翻转后的底部），但如果您不向排名中添加虚拟轴线，事情可能会变得混乱。还有很多可以尝试的地方，但这是一个非常酷的可视化项目!

- camille

Answer 2

这里有一个纯粹的ggplot2方案，它将底层数据框组合成一个并在单个图中绘制所有内容：

数据处理：

library(dplyr)    
bar.width <- 0.9

# combine the two data sources
df <- rbind(state1 %>% mutate(source = "state1"),
            state2 %>% mutate(source = "state2")) %>%

  # calculate each state's rank within each data source
  group_by(source, state) %>%
  mutate(state.sum = sum(value)) %>%
  ungroup() %>%
  group_by(source) %>%
  mutate(source.rank = as.integer(factor(state.sum))) %>%
  ungroup() %>%

  # calculate the dimensions for each bar
  group_by(source, state) %>%
  arrange(type) %>% 
  mutate(xmin = lag(cumsum(value), default = 0),
         xmax = cumsum(value),
         ymin = source.rank - bar.width / 2,
         ymax = source.rank + bar.width / 2) %>% 
  ungroup() %>%

  # shift each data source's coordinates away from point of origin,
  # in order to create space for plotting lines
  mutate(x = ifelse(source == "state1", -max(xmax) / 2, max(xmax) / 2)) %>%
  mutate(xmin = ifelse(source == "state1", x - xmin, x + xmin),
         xmax = ifelse(source == "state1", x - xmax, x + xmax)) %>%

  # calculate label position for each data source
  group_by(source) %>%
  mutate(label.x = max(abs(xmax))) %>%
  ungroup() %>%
  mutate(label.x = ifelse(source == "state1", -label.x, label.x),
         hjust = ifelse(source == "state1", 1.1, -0.1))

情节：

ggplot(df, 
       aes(x = x, y = source.rank,
           xmin = xmin, xmax = xmax, 
           ymin = ymin, ymax = ymax,
           fill = type)) +
  geom_rect() +
  geom_line(aes(group = state)) +
  geom_text(aes(x = label.x, label = state, hjust = hjust),
            check_overlap = TRUE) +

  # allow some space for the labels; this may be changed
  # depending on plot dimensions
  scale_x_continuous(expand = c(0.2, 0)) +
  scale_fill_manual(values = fill) +

  theme_void() +
  theme(legend.position = "top")

数据源（与@camille相同）：

set.seed(1017)

state1 <- data_frame(
  state = rep(state.name[1:5], each = 3),
  value = floor(runif(15, 1, 100)),
  type = rep(c("state", "local", "fed"), times = 5)
)

state2 <- data_frame(
  state = rep(state.name[1:5], each = 3),
  value = floor(runif(15, 1, 100)),
  type = rep(c("state", "local", "fed"), times = 5)
)

- Z.Lin