ggbump 平滑曲线图

搬运链接: https://github.com/davidsjoberg/ggbump

这个图我能用来做什么？我可以用来表示不同发育阶段 DNA 甲基化的整体变化情况，比如: 野生型和突变体的不同处理或者发育阶段 XXX 的相对变化过程。也许你会说普通的折线图不就好了。是好了啊，当时看到新的东西为何不看看。。如下:

Xin-Jian He, Taiping Chen, Jian-Kang Zhu , *Cell Research*, 2011

安装包

devtools::install_github("davidsjoberg/ggbump")
if(!require(pacman)) install.packages("pacman")
library(ggbump)
pacman::p_load(tidyverse, cowplot, wesanderson)

数据格式

df <- tibble(country = c("India", "India", "India", "Sweden", "Sweden", "Sweden", "Germany", "Germany", "Germany", "Finland", "Finland", "Finland"),
             year = c(2011, 2012, 2013, 2011, 2012, 2013, 2011, 2012, 2013, 2011, 2012, 2013),
             rank = c(4, 2, 2, 3, 1, 4, 2, 3, 1, 1, 4, 3))

knitr::kable(df)

|country | year| rank|
|:-------|----:|----:|
|India   | 2011|    4|
|India   | 2012|    2|
|India   | 2013|    2|
|Sweden  | 2011|    3|
|Sweden  | 2012|    1|
|Sweden  | 2013|    4|
|Germany | 2011|    2|
|Germany | 2012|    3|
|Germany | 2013|    1|
|Finland | 2011|    1|
|Finland | 2012|    4|
|Finland | 2013|    3|

绘图

ggplot(df, aes(year, rank, color = country)) +
  geom_point(size = 7) + # 这里就是把 12 个点标上。
  geom_text(data = df %>% filter(year == min(year)),
            aes(x = year - .1, label = country), size = 5, hjust = 1) + # 这里就是把最开始时期的标签给加上，最左边 Finland
  geom_text(data = df %>% filter(year == max(year)),
            aes(x = year + .1, label = country), size = 5, hjust = 0) + # 这里就是把最后时期的标签给加上，最右边 Finland
  geom_bump(aes(smooth = 8), size = 2) + # 连线，smooth 平滑曲线， size 线条粗细
  scale_x_continuous(limits = c(2010.6, 2013.4),
                     breaks = seq(2011, 2013, 1)) + # X 轴标签 2011 2012 2013
  theme_minimal_grid(font_size = 14, line_size = 0) + # 背景主题
  theme(legend.position = "none",
        panel.grid.major = element_blank()) + # 去除 legend ，以及中间的背景线条
  labs(y = "RANK",
       x = NULL) +
  scale_y_reverse() + # 反转 Y 轴坐标，本来 India 在最上面，Finland 最下面，现在反过来，也就是反序
  scale_color_manual(values = wes_palette(n = 4, name = "GrandBudapest1")) # 自定义颜色

拆分函数

接下来让我们打开封装包来探探里面有什么函数。

• sigmoid()

sigmoid <- function(x_from, x_to, y_from, y_to, smooth = 5, n = 100) {
  x <- seq(-smooth, smooth, length = n)
  y <- exp(x) / (exp(x) + 1)
  data.frame(x = (x + smooth) / (smooth * 2) * (x_to - x_from) + x_from,
             y = y * (y_to - y_from) + y_from)
}

• rank_sigmoid()

rank_sigmoid <- function(x, y, smooth = 8) {
  .df <- dplyr::tibble(x = x,
                y = y) %>%
    dplyr::mutate(x_lag = dplyr::lag(x),
                 y_lag = dplyr::lag(y)) %>%
    tidyr::drop_na("x_lag")
    purrr::pmap_dfr(.df, ~sigmoid(x_from = ..3, x_to = ..1, y_from = ..4, y_to = ..2, smooth  = smooth))
}

• StatBump()

StatBump <- ggplot2::ggproto("StatBump", ggplot2::Stat,
                           compute_group = function(data, scales) {
                             if(nrow(data) == 1) {
                               warning("'StatBump' needs at least two observations per group")
                               return(data %>% dplyr::slice(0))
                             }
                             if("smooth" %in% names(data)) {
                               smoother <- unique(data[, "smooth"])
                               data <- data %>% dplyr::select(-smooth)
                             } else {
                               smoother <- 5
                             }

                             out <-rank_sigmoid(data$x, data$y, smooth = smoother) %>%
                               dplyr::mutate(key = 1) %>%
                               dplyr::left_join(data %>%
                                                  dplyr::select(-x, -y) %>%
                                                  dplyr::mutate(key = 1) %>%
                                                  dplyr::distinct(),
                                                by = "key") %>%
                               dplyr::select(-key) %>%
                               as.data.frame()
                             out
                           },

                           required_aes = c("x", "y"),
                           default_aes = ggplot2::aes(smooth = 5)

• geom_bump()

geom_bump <- function(mapping = NULL, data = NULL, geom = "line",
                              position = "identity", na.rm = FALSE, show.legend = NA,
                              inherit.aes = TRUE, ...) {
  ggplot2::layer(
    stat = StatBump, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

就是构建 ggplot2::layer() 中的 stat 函数

这个包相关的优秀图集：

https://github.com/davidsjoberg/ggbump/wiki/My-year-on-Spotify