其他
绘制带连线的柱状堆积图
点击上方关注我们
故事的开始
前几天有粉丝找我，叫我帮忙绘制一张 带连线 的 柱状堆积图 ，我想：这连线咋加上去？ 然后粉丝又说不需要了。那行吧，我看了一下参考图，感觉还挺好玩的，网上找了一些教程，也没有说的特别详细的，今天自己琢磨了一下，分享给大家。
参考图，分面了一下：
尝试
首先构造一个简单的柱形图数据：
# 加载R包
library(ggplot2)
library(tidyverse)
library(ggsci)
library(reshape2)
# 设置工作路径
setwd('C:/Users/admin/Desktop')
# 读取数据
bar <- read.table('bar.txt',header = T)
# 查看内容
bar
sample C B A D
1 s1 10 30 55 28
2 s2 34 57 45 17
这里我们有 s1，s2 两个样本，每个样本有 A、B、C、D 4 个分组，先默认绘制正常的堆积图看看：
# 宽数据转为长数据
da <- melt(bar)
# 查看内容
head(da,3)
sample variable value
1 s1 C 10
2 s2 C 34
3 s1 B 30
绘图：
# 默认绘图
p <- ggplot(data = da,aes(x = sample,y = value)) +
# 添加柱子
geom_bar(aes(fill = variable),stat = 'identity',
# 柱子边框颜色、粗细
color = 'black',size =1,
# 柱子宽度
width = 0.5) +
scale_fill_npg() +
# 主题细节调整
theme_bw(base_size = 14,
base_line_size = 1,
base_rect_size = 2) +
theme(panel.grid = element_blank(),
axis.text = element_text(size = 14),
axis.text.x = element_text(size = 18),
legend.position = 'top',
legend.title = element_blank()) +
xlab('') + ylab('')
p
纵坐标是每个分组的数值区间，如果想 添加连线 的话，纵坐标的值应该是 分组累积的值 ，我们计算一下：
da %>% filter(sample == 's1')
sample variable value
1 s1 C 10
2 s1 B 30
3 s1 A 55
4 s1 D 28
图例分组顺序从上到下也是 C-B-A-D ，计算求和应该从下往上计算，也就是说把 value 列颠倒过来累计求和：
da %>% filter(sample == 's1') %>% select(value) %>%
t() %>% rev() %>% cumsum()
[1] 28 83 113 123
然后对 s1、s2 进行同样操作，合并成数据框：
# 计算累计求和
s1 <- da %>% filter(sample == 's1') %>% select(value) %>%
t() %>% rev() %>% cumsum()
s2 <- da %>% filter(sample == 's2') %>% select(value) %>%
t() %>% rev() %>% cumsum()
# 对应分组列
variable <- rev(unique(da$variable))
# 合并
link_da <- data.frame(variable = variable,s1 = s1,s2 = s2)
link_da
variable s1 s2
1 D 28 17
2 A 83 62
3 B 113 119
4 C 123 153
然后我们使用 geom_segment 函数添加连线：
p + geom_segment(data = link_da,aes(x = 1.25,xend = 1.75,y = s1,yend = s2),
# 连线颜色、粗细
color = 'black',size = 1)
如果我们换成填充格式的堆积图这样就不行了，画出来的会是这样：
ggplot(data = da,aes(x = sample,y = value)) +
# 添加柱子
geom_bar(aes(fill = variable),stat = 'identity',
# 柱子边框颜色、粗细
color = 'black',size =1,
# 填充样式
position = position_fill(),
# 柱子宽度
width = 0.5) +
scale_fill_npg() +
# 主题细节调整
theme_bw(base_size = 14,
base_line_size = 1,
base_rect_size = 2) +
theme(panel.grid = element_blank(),
axis.text = element_text(size = 14),
axis.text.x = element_text(size = 18),
legend.position = 'top',
legend.title = element_blank()) +
xlab('') + ylab('') +
geom_segment(data = link_da,aes(x = 1.25,xend = 1.75,y = s1,yend = s2),
# 连线颜色、粗细
color = 'black',size = 1)
如果改为填充行， geom_bar 函数 会在内部计算好每个分组占的比例在绘图，那么我们的连线位置应该也是百分比的比例，我们同样来计算每个样本分组的百分比：
# 对应分组列
variable <- rev(unique(da$variable))
# 计算百分比
s1 <- da %>% filter(sample == 's1') %>%
mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
select(vlaue_per) %>% t() %>% rev() %>% cumsum()
s2 <- da %>% filter(sample == 's2') %>%
mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
select(vlaue_per) %>% t() %>% rev() %>% cumsum()
# 合并
link_da <- data.frame(variable = variable,s1 = s1,s2 = s2)
link_da
variable s1 s2
1 D 0.2276423 0.1111111
2 A 0.6747967 0.4052288
3 B 0.9186992 0.7777778
4 C 1.0000000 1.0000000
再绘图试一试：
# 绘图
ggplot(data = da,aes(x = sample,y = value)) +
geom_bar(aes(fill = variable),stat = 'identity',
position = position_fill(),
color = 'black',size =1,
width = 0.5) +
geom_segment(data = link_da,
aes(x = 1.25,xend = 1.75,y = s1,yend = s2),
size = 1 ,color = 'black') +
scale_fill_npg() +
scale_y_continuous(labels = scales::label_percent()) +
theme_bw(base_size = 14,
base_line_size = 1,
base_rect_size = 2) +
theme(panel.grid = element_blank(),
axis.text = element_text(size = 14),
axis.text.x = element_text(size = 18),
legend.position = 'top',
legend.title = element_blank()) +
xlab('') + ylab('')
OK！没问题。
上面我我们看到计算 累计值 或者 累计百分比 是基本上代码是一样的，如果有多个样本一个一个输入会比较麻烦，我们可以优化一下代码，减少输入：
# 代码优化
# 对应分组列
# variable <- rev(unique(da$variable))
# 计算累计求和
# s1 <- da %>% filter(sample == 's1') %>% select(value) %>%
# t() %>% rev() %>% cumsum()
# s2 <- da %>% filter(sample == 's2') %>% select(value) %>%
# t() %>% rev() %>% cumsum()
# 优化后
# 提取样品名
my_sample <- unique(da$sample)
link_da <- lapply(my_sample,function(x){da %>% filter(sample == x) %>% select(value) %>%
t() %>% rev() %>% cumsum()}) %>%
Reduce(cbind,.) %>% as.data.frame()
# 合并
colnames(link_da) <- my_sample
link_da$variable <- variable
link_da
s1 s2 variable
1 28 17 D
2 83 62 A
3 113 119 B
4 123 153 C
可以看到结果是一样的。计算 累计百分比 的优化，结构差不多，替换一下代码即可：
# 对应分组列
# variable <- rev(unique(da$variable))
# 计算百分比
# s1 <- da %>% filter(sample == 's1') %>%
# mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
# select(vlaue_per) %>% t() %>% rev() %>% cumsum()
#
# s2 <- da %>% filter(sample == 's2') %>%
# mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
# select(vlaue_per) %>% t() %>% rev() %>% cumsum()
# 优化后
# 提取样品名
my_sample <- unique(da$sample)
link_da <- lapply(my_sample,function(x){da %>% filter(sample == x) %>%
mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
select(vlaue_per) %>% t() %>% rev() %>% cumsum()}) %>%
Reduce(cbind,.) %>% as.data.frame()
# 合并
colnames(link_da) <- my_sample
link_da$variable <- variable
link_da
s1 s2 variable
1 0.2276423 0.1111111 D
2 0.6747967 0.4052288 A
3 0.9186992 0.7777778 B
4 1.0000000 1.0000000 C
多个样本添加连接线
常规操作，直接读入数据，代码直接运行，不用修改：
# 读取数据
bar <- read.table('bar1.txt',header = T)
# 查看内容
bar
sample C B A D
1 s1 18 45 60 28
2 s2 15 41 65 30
3 s3 25 40 59 27
4 s4 19 36 63 35
5 s5 23 33 61 32
# 宽数据转为长数据
da <- melt(bar)
# 查看内容
head(da,3)
sample variable value
1 s1 C 18
2 s2 C 15
3 s3 C 25
# 提取样品名
my_sample <- unique(da$sample)
link_da <- lapply(my_sample,function(x){da %>% filter(sample == x) %>%
mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
select(vlaue_per) %>% t() %>% rev() %>% cumsum()}) %>%
Reduce(cbind,.) %>% as.data.frame()
# 合并
colnames(link_da) <- my_sample
link_da$variable <- variable
link_da
s1 s2 s3 s4 s5 variable
1 0.1854305 0.1986755 0.1788079 0.2287582 0.2147651 D
2 0.5827815 0.6291391 0.5695364 0.6405229 0.6241611 A
3 0.8807947 0.9006623 0.8344371 0.8758170 0.8456376 B
4 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 C
# 绘图
p <- ggplot(data = da,aes(x = sample,y = value)) +
geom_bar(aes(fill = variable),stat = 'identity',
position = position_fill(),
color = 'black',size =1,
width = 0.5) +
scale_fill_npg() +
scale_y_continuous(labels = scales::label_percent()) +
theme_bw(base_size = 14,
base_line_size = 1,
base_rect_size = 2) +
theme(panel.grid = element_blank(),
axis.text = element_text(size = 14),
axis.text.x = element_text(size = 18),
legend.position = 'top',
legend.title = element_blank()) +
xlab('') + ylab('')
p
给 每两个样本间添加连接线 ：
p + geom_segment(data = link_da,
aes(x = 1.25,xend = 1.75,y = s1,yend = s2),
size = 1 ,color = 'black') +
geom_segment(data = link_da,
aes(x = 2.25,xend = 2.75,y = s2,yend = s3),
size = 1 ,color = 'black') +
geom_segment(data = link_da,
aes(x = 3.25,xend = 3.75,y = s3,yend = s4),
size = 1 ,color = 'black') +
geom_segment(data = link_da,
aes(x = 4.25,xend = 4.75,y = s4,yend = s5),
size = 1 ,color = 'black')
我们发现上面方法简单易懂，但是对于有很多个样本时，再靠手输就比较累了，我们可以优化一下代码，使得只改变几个参数就能运行：
思路：
geom_segment 需要接收多个样本的 x、xend、y、yend 4 个参数值，我们把这些全部计算出来 合并到四列 就行了。
# 查看内容
link_da
s1 s2 s3 s4 s5 variable
1 0.1854305 0.1986755 0.1788079 0.2287582 0.2147651 D
2 0.5827815 0.6291391 0.5695364 0.6405229 0.6241611 A
3 0.8807947 0.9006623 0.8344371 0.8758170 0.8456376 B
4 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 C
以上代表各个样本之间的 y 和 yend，比如 s1 是 s1 和 s2 的 y，s2 是 s1 和 s2 的 yend，s2 是 s2 和 s3 的 y，s3 是 s2 和 s3 的 yend，依次类推，我们把中间两两之间的值提取出来：
tp <- link_da %>% select(-variable)
# rep(2:(ncol(tp)-1),each = 2)
xp <- tp[,c(1,rep(2:(ncol(tp)-1),each = 2),ncol(tp))]
xp
s1 s2 s2.1 s3 s3.1 s4 s4.1 s5
1 0.1854305 0.1986755 0.1986755 0.1788079 0.1788079 0.2287582 0.2287582 0.2147651
2 0.5827815 0.6291391 0.6291391 0.5695364 0.5695364 0.6405229 0.6405229 0.6241611
3 0.8807947 0.9006623 0.9006623 0.8344371 0.8344371 0.8758170 0.8758170 0.8456376
4 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000
# number samples
ns = length(unique(y$variable))
# y
# seq(1,ncol(xp),2)
y = xp[,seq(1,ncol(xp),2)] %>% melt(value.name = 'y') %>% rename('variable1' = 'variable')
y
variable1 y
1 s1 0.1854305
2 s1 0.5827815
3 s1 0.8807947
...
# seq(1.25,(ns+1),1) 添加对应x位置
y$x = rep(seq(1.25,(ns+1),1),each = ns)
y
variable1 y x
1 s1 0.1854305 1.25
2 s1 0.5827815 1.25
3 s1 0.8807947 1.25
...
# yend
# seq(2,ncol(xp),2)
yend = xp[,seq(2,ncol(xp),2)] %>% melt(value.name = 'yend') %>% rename('variable2' = 'variable')
yend
variable2 yend
1 s2 0.1986755
2 s2 0.6291391
3 s2 0.9006623
...
# seq(1.75,(ns+1),1) 添加对应xend位置
yend$xend = rep(seq(1.75,(ns+1),1),each = ns)
yend
variable2 yend xend
1 s2 0.1986755 1.75
2 s2 0.6291391 1.75
3 s2 0.9006623 1.75
...
通过上面的代码我吗获得了所有样本的 x、xend、y、yend ，我们合并检查一下：
# 合并
link_res <- cbind(y,yend)
link_res
variable1 y x variable2 yend xend
1 s1 0.1854305 1.25 s2 0.1986755 1.75
2 s1 0.5827815 1.25 s2 0.6291391 1.75
3 s1 0.8807947 1.25 s2 0.9006623 1.75
4 s1 1.0000000 1.25 s2 1.0000000 1.75
5 s2.1 0.1986755 2.25 s3 0.1788079 2.75
6 s2.1 0.6291391 2.25 s3 0.5695364 2.75
7 s2.1 0.9006623 2.25 s3 0.8344371 2.75
8 s2.1 1.0000000 2.25 s3 1.0000000 2.75
9 s3.1 0.1788079 3.25 s4 0.2287582 3.75
10 s3.1 0.5695364 3.25 s4 0.6405229 3.75
11 s3.1 0.8344371 3.25 s4 0.8758170 3.75
12 s3.1 1.0000000 3.25 s4 1.0000000 3.75
13 s4.1 0.2287582 4.25 s5 0.2147651 4.75
14 s4.1 0.6405229 4.25 s5 0.6241611 4.75
15 s4.1 0.8758170 4.25 s5 0.8456376 4.75
16 s4.1 1.0000000 4.25 s5 1.0000000 4.75
看起来没有什么问题，我们画个图看看：
# 绘图
ggplot(data = da,aes(x = sample,y = value)) +
geom_bar(aes(fill = variable),stat = 'identity',
position = position_fill(),
color = 'black',size =1,
width = 0.5) +
# 换个颜色
scale_fill_simpsons() +
scale_y_continuous(labels = scales::label_percent()) +
theme_bw(base_size = 14,
base_line_size = 1,
base_rect_size = 2) +
theme(panel.grid = element_blank(),
axis.text = element_text(size = 14),
axis.text.x = element_text(size = 18),
legend.position = 'top',
legend.title = element_blank()) +
xlab('') + ylab('') +
geom_segment(data = link_res,
aes(x = x,xend = xend,y = y,yend = yend),
size = 1 ,color = 'black')
这样就简洁多了，对于多种样本分面感觉会复杂一些，后面有时间再研究吧。
所以今天你学习了吗？
欢迎小伙伴留言评论！
今天的分享就到这里了，敬请期待下一篇！
最后欢迎大家分享转发，您的点赞是对我的鼓励和肯定！
如果觉得对您帮助很大，赏杯快乐水喝喝吧！
推 荐 阅 读