连线柱状堆积图进阶

感谢老俊俊的大力支持。我们会每日跟新，欢迎您关注老俊俊的生信笔记。

点击上方关注我们

后续

昨天我们绘制了 带连线的柱状堆积图 ，但是对于 分面的效果 还没有达到，今天研究了一下，成功的绘制出了 分面的连线柱形堆积图 ，现在将代码和经验分享给大家。

参考图：

操练

下面是实验代码和探索过程：

# 加载R包
library(ggplot2)
library(tidyverse)
library(reshape2)

# 设置工作路径
setwd('C:/Users/admin/Desktop')

# 读取数据
bar <- read.table('bar2.txt',header = T)

# 查看数据内容
bar
   sample  C  B  A  D  type
1      s1 18 45 60 28 test1
2      s2 15 41 65 30 test1
3      s3 25 40 59 27 test1
4      s4 19 36 63 35 test1
5      s5 23 33 61 32 test1
6      s1 16 45 54 28 test2
7      s2 13 41 60 52 test2
8      s3 28 40 55 41 test2
9      s4 19 36 49 29 test2
10     s5 23 29 57 31 test2
11     s1 18 38 49 30 test3
12     s2 15 34 66 41 test3
13     s3 25 46 50 36 test3
14     s4 19 39 60 48 test3
15     s5 23 29 71 55 test3

可以看到有 s1 到 s5 的样本，每个样本有 A B C D 四个组，总共有 3 个实验类型，test1、test2、test3，我们后面根据这个来分面。

# 宽数据转为长数据
da <- melt(bar)

# 查看内容
head(da,3)
  sample  type variable value
1     s1 test1        C    18
2     s2 test1        C    15
3     s3 test1        C    25

不加连线画个分面看看：

# 不加连线分面图
ggplot(data = da,aes(x = sample,y = value)) +
  geom_bar(aes(fill = variable),stat = 'identity',
           # 填充型
           position = position_fill(),
           # 柱子宽度
           width = 0.5) +
  theme_bw() +
  # 按type分面
  facet_wrap(~type,ncol = 3)

我们先把 样本名 和 实验类型 赋值保存起来方便后面使用：

# 提取样品名
my_sample <- unique(da$sample)
my_sample
[1] "s1" "s2" "s3" "s4" "s5"

# 提取实验类型
mtype <- unique(da$type)
mtype
[1] "test1" "test2" "test3"

不知道小伙伴们还记不记得昨天我们计算 累计和值 和 累计百分比 的优化代码，今天我们使用这个。

但是！昨天我们仅仅是对一个实验或者一个图计算的，像今天我们有三个实验类型，再用上面代码就错了，思路：按 type 分组取出数据保存为 3 个 list ：

# 按type分组保存数据
mty <- lapply(mtype, function(x){ da %>% filter(type == x)})

然我我们用 循环对这个 list 元素 进行计算 累计百分比 ，最后把结果合并：

# 按type分组保存数据
mty <- lapply(mtype, function(x){ da %>% filter(type == x)})

# 循环计算累计百分比
mres <- list()
for (i in 1:length(mty)) {
  lapply(my_sample,function(x){mty[[i]] %>% filter(sample == x) %>%
      mutate(vlaue_per = lapply(.$value, function(x){x / sum(.$value)})) %>%
      select(vlaue_per) %>% t() %>% rev() %>% cumsum()}) %>%
    Reduce(cbind,.) %>% as.data.frame() -> mres[[i]]
}

# 合并数据
link_da <- mres %>% Reduce(rbind,.)
link_da

        init        V2        V3        V4        V5
1  0.1854305 0.1986755 0.1788079 0.2287582 0.2147651
2  0.5827815 0.6291391 0.5695364 0.6405229 0.6241611
3  0.8807947 0.9006623 0.8344371 0.8758170 0.8456376
4  1.0000000 1.0000000 1.0000000 1.0000000 1.0000000
5  0.1958042 0.3132530 0.2500000 0.2180451 0.2214286
6  0.5734266 0.6746988 0.5853659 0.5864662 0.6285714
7  0.8881119 0.9216867 0.8292683 0.8571429 0.8357143
8  1.0000000 1.0000000 1.0000000 1.0000000 1.0000000
9  0.2222222 0.2628205 0.2292994 0.2891566 0.3089888
10 0.5851852 0.6858974 0.5477707 0.6506024 0.7078652
11 0.8666667 0.9038462 0.8407643 0.8855422 0.8707865
12 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000

接下来整理一下数据，添加组名和 实验名称 ：

# 添加列名
colnames(link_da) <- my_sample

# 获取组名
variable <- rev(unique(da$variable))
variable
[1] D A B C
Levels: C B A D

# 添加组名
link_da$variable <- rep(variable,length(mtype))

# 添加实验名
link_da$type <- rep(mtype,each = length(variable))
link_da

          s1        s2        s3        s4        s5 variable  type
1  0.1854305 0.1986755 0.1788079 0.2287582 0.2147651        D test1
2  0.5827815 0.6291391 0.5695364 0.6405229 0.6241611        A test1
3  0.8807947 0.9006623 0.8344371 0.8758170 0.8456376        B test1
4  1.0000000 1.0000000 1.0000000 1.0000000 1.0000000        C test1
5  0.1958042 0.3132530 0.2500000 0.2180451 0.2214286        D test2
6  0.5734266 0.6746988 0.5853659 0.5864662 0.6285714        A test2
7  0.8881119 0.9216867 0.8292683 0.8571429 0.8357143        B test2
8  1.0000000 1.0000000 1.0000000 1.0000000 1.0000000        C test2
9  0.2222222 0.2628205 0.2292994 0.2891566 0.3089888        D test3
10 0.5851852 0.6858974 0.5477707 0.6506024 0.7078652        A test3
11 0.8666667 0.9038462 0.8407643 0.8855422 0.8707865        B test3
12 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000        C test3

整理好 link_da 数据后，我们用 老方法 画一个：

# 绘图
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) +
  theme_bw() +
  # 按type分面
  facet_wrap(~type,ncol = 3)

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

我们用昨天的优化的代码，然后需要修改一下：

# 优化
tp <- link_da %>% select(-variable)
# rep(2:(ncol(tp)-1),each = 2)
xp <- tp[,c(1,rep(2:(ncol(tp)-2),each = 2),ncol(tp)-1,ncol(tp))]
xp
          s1        s2      s2.1        s3      s3.1        s4      s4.1        s5  type
1  0.1854305 0.1986755 0.1986755 0.1788079 0.1788079 0.2287582 0.2287582 0.2147651 test1
2  0.5827815 0.6291391 0.6291391 0.5695364 0.5695364 0.6405229 0.6405229 0.6241611 test1
...
# number samples
ns = length(my_sample)

# y
# seq(1,ncol(xp)-1,2)
y = xp[,c(seq(1,ncol(xp)-1,2),ncol(xp))] %>% melt(value.name = 'y') %>%
  rename('variable1' = 'variable')
y
    type variable1         y
1  test1        s1 0.1854305
2  test1        s1 0.5827815
3  test1        s1 0.8807947
4  test1        s1 1.0000000
5  test2        s1 0.1958042
6  test2        s1 0.5734266
...

# seq(1.25,ns,1) 添加对应x位置
y$x = rep(seq(1.25,ns,1),each = (ns-1)*length(mtype))
y
    type variable1         y    x
1  test1        s1 0.1854305 1.25
2  test1        s1 0.5827815 1.25
3  test1        s1 0.8807947 1.25
...

# yend
# seq(2,ncol(xp),2)
yend = xp[,c(seq(2,ncol(xp),2),ncol(xp))] %>% melt(value.name = 'yend') %>%
  rename('variable2' = 'variable','type2' = 'type')
yend
   type2 variable2      yend
1  test1        s2 0.1986755
2  test1        s2 0.6291391
3  test1        s2 0.9006623
4  test1        s2 1.0000000
5  test2        s2 0.3132530
6  test2        s2 0.6746988
7  test2        s2 0.9216867
8  test2        s2 1.0000000
...

# seq(1.75,ns,1) 添加对应xend位置
yend$xend = rep(seq(1.75,ns,1),each = (ns-1)*length(mtype))
yend
   type2 variable2      yend xend
1  test1        s2 0.1986755 1.75
2  test1        s2 0.6291391 1.75
3  test1        s2 0.9006623 1.75
...

最后合并数据：

# 合并
link_res <- cbind(y,yend)
link_res

    type variable1         y    x type2 variable2      yend xend
1  test1        s1 0.1854305 1.25 test1        s2 0.1986755 1.75
2  test1        s1 0.5827815 1.25 test1        s2 0.6291391 1.75
3  test1        s1 0.8807947 1.25 test1        s2 0.9006623 1.75
...

最后绘图：

# 绘图
ggplot(data = da,aes(x = sample,y = value)) +
  geom_bar(aes(fill = variable),stat = 'identity',
           position = position_fill(),
           size = 1,color = 'black',
           width = 0.5) +
  theme_bw(base_size = 16) +
  # 分面
  facet_wrap(~type,ncol = 3) +
  # 自己定义颜色
  scale_fill_manual(values =
                      c('D' = '#DA0037','A' = '#FFC107',
                        'B' = '#0A81AB','C' = '#F55C47')) +
  xlab('LaoJunJun Test Sample') + ylab('Percent of Value') +
  # 细节调整
  theme(legend.title = element_blank(),
        axis.text = element_text(face = 'bold'),
        axis.text.x = element_text(size = 16),
        strip.text.x = element_text(face = 'bold')) +
  # 添加连线
  geom_segment(data = link_res,
               aes(x = x,xend = xend,y = y,yend = yend),
               size = 1 ,color = 'black')