基于R语言绘制坐标轴截断图

来源：生信拾光评论5,031

画图时经常遇到不同组的数据大小相差很大，大数据就会掩盖小数据的变化规律，这时候可以对Y轴进行截断，从而可以在不同层面（大数据和小数据层面）全面反映数据变化情况，如下图所示。

基于R语言绘制坐标轴截断图-图片1

搜索截断图绘制的方法，有根据Excel绘制的，但是感觉操作繁琐；这里根据网上资料总结基于R的3种方法：

  • 分割 组合法，如基于ggplot2, 利用coord_cartesian()将整个图形分割成多个图片,再用grid 包组合分割结果
  • plotrix R包
  • 基本绘图函数 plotrix R包

示例数据

  1. df <- data.frame(name=c("AY","BY","CY","DY","EY","FY","GY"),Money=c(1510,1230,995,48,35,28,10))
  2. df
  3.  
  4. #加载 R 包
  5. library(ggplot2)
  6. # ggplot画图
  7. p0 <- ggplot(df, aes(name,Money,fill = name))  
  8. geom_col(position = position_dodge(width = 0.8),color="black")  
  9. labs(x = NULL, y = NULL)  
  10. scale_fill_brewer(palette="Accent") 
  11. #scale_x_discrete(expand = c(0, 0))  
  12. scale_y_continuous(breaks = seq(0, 1600, 400), limits = c(0, 1600), expand = c(0,0))  
  13. theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.title = element_blank())

基于R语言绘制坐标轴截断图-图片2

方法一：分割 组合法

这种方法的思路是分别绘制不同层级大小的图形，然后组合图形。如可一用ggplot2中的coord_cartesian()函数分割，ylim指定y轴的区间范围。

参考：http://blog.sciencenet.cn/blog-3406804-1156908.html

  1. ### 小数据层级
  2. p1 <- p0   coord_cartesian(ylim = c(0, 50))  
  3. theme_classic() 
  4. theme(legend.position="none")
  5.  
  6. ### 大数据层级
  7. # 不显示X轴坐标和文本标记
  8. p2 <-p0   coord_cartesian(ylim = c(700, 1600))  
  9. theme_classic()  
  10. theme(axis.line.x = element_line(colour="white"),
  11. axis.text.x = element_blank(), axis.ticks.x = element_blank(),
  12. legend.position = c(0.85, 0.6))

 

基于R语言绘制坐标轴截断图-图片3

基于R语言绘制坐标轴截断图-图片4

grid组合图形, grid.newpage()新建画布, viewport()命令将画板分割为不同的区域。

x和y分别用于指定所放置子图在画板中的坐标，坐标取值范围为0~1，并使用just给定坐标起始位置；width和height用于指定所放置子图在画板中的高度和宽度。

  1. library(grid)
  2.  
  3. grid.newpage() #新建画布
  4. plot_site1 <- viewport(x = 0.008, y = 0, width = 0.994, height = 0.4, just = c(\'left\', \'bottom\'))
  5. plot_site2 <- viewport(x = 0.008, y = 0.4, width = 1, height = 0.5, just = c(\'left\', \'bottom\'))
  6. #plot_site3 <- viewport(x = 0, y = 0.7, width = 1, height = 0.3, just = c(\'left\', \'bottom\'))
  7. print(p1, vp = plot_site1)
  8. print(p2, vp = plot_site2)

基于R语言绘制坐标轴截断图-图片5

这种方法可以得到一个草图，图片对齐等细节调节需要多次尝试，或者可以导出在AI中修改。

方法二：plotrix R包

plotrix R中包含gap.plot()，gap.barplot() 和 gapboxplot()函数, 可以分别画出坐标轴截断的散点图、柱状图和箱线图。主要参数包括y ：要截断的数值向量; gap：截断的区间.

  1. ### 用法如下
  2. gap.barplot(y,gap,xaxlab,xtics,yaxlab,ytics,xlim=NA,ylim=NA,xlab=NULL,
  3. ylab=NULL,horiz=FALSE,col,...)
  4. ### Arguments
  5. y ：要截断的数值向量
  6. gap ：截断的区间
  7.  
  8. xaxlab ：labels for the x axis ticks
  9. xtics ：position of the x axis ticks
  10. yaxlab ：labels for the y axis ticks
  11. ytics ：position of the y axis ticks
  12. xlim ：Optional x limits for the plot
  13. ylim ：optional y limits for the plot
  14. xlab ：label for the x axis
  15. ylab ：label for the y axis
  16. horiz ：whether to have vertical or horizontal bars
  17. col ：color(s) in which to plot the values

参考：http://www.bioon.com.cn/protocol/showarticle.asp?newsid=66061

相同的数据，画图如下

  1. #install.packages ("plotrix")
  2. library (plotrix)
  3.  
  4. gap.barplot(df$Money,gap=c(50,740),xaxlab=df$name,ytics=c(50,700,800,900,1000,1100,1200,1300,1400,1500,1600),
  5. col=rainbow(7),xlim = c(0,8),width=0.06)

基于R语言绘制坐标轴截断图-图片6

接着使用axis breaks()函数去除中间的两道横线，并添加截断的标记，如//或z。

  • Axis:1,2,3,4分别代表下、左、上、右方位的坐标轴，即打算截取的坐标轴
  • breakppos：截断的位置，即截断符号添加的位置
  • style: gap,slash和z字形
  1. axis.break(2,50,breakcol="snow",style="gap") ##去掉中间的那两道横线；
  2. axis.break(2,50*(1 0.02),breakcol="black",style="slash")##在左侧Y轴把gap位置换成slash；
  3. #axis.break(4,50*(1 0.02),breakcol="black",style="slash")##在右侧Y轴把gap位置换成slash；

基于R语言绘制坐标轴截断图-图片7

这种方法是基于base plot绘图的，但是base plot的许多绘图参数与gap.barplot（）并不兼容，如space和width参数设置离坐标轴距离和bar的宽度。

方法三：基本绘图函数 plotrix R包

参考：https://blog.csdn.net/u014801157/article/details/24372371

作者ZGUANG@LZU自己编写的函数，可以手动设置断点，也可以由函数自动计算。断点位置的符号表示提供了平行线和zigzag两种，并且可设置背景颜色、大小、线型、平行线旋转角度等。

函数

  1. #\' 使用R基本绘图函数绘制y轴不连续的柱形图
  2. #\'
  3. #\' 绘制y轴不连续的柱形图，具有误差线添加功能。断点位置通过btm和top参数设置，如果不设置，函数可自动计算合适的断点位置。
  4. #\' @title gap.barplot function
  5. #\' @param df 长格式的data.frame，即数据框中每一列为一组绘图数据。
  6. #\' @param y.cols 用做柱形图y值的数据列（序号或名称），一列为一组。
  7. #\' @param sd.cols 与y值列顺序对应的误差值的数据列（序号或名称）。
  8. #\' @param btm 低位断点。如果btm和top均不设置，程序将自动计算和设置断点位置。
  9. #\' @param top 高位断点。
  10. #\' @param min.range 自动计算断点的阈值：最大值与最小值的最小比值
  11. #\' @param max.fold 自动计算断点时最大值与下方数据最大值的最大倍数比
  12. #\' @param ratio 断裂后上部与下部y轴长度的比例。
  13. #\' @param gap.width y轴断裂位置的相对物理宽度（非坐标轴实际刻度）
  14. #\' @param brk.type 断点类型，可设为normal或zigzag
  15. #\' @param brk.bg 断点处的背景颜色
  16. #\' @param brk.srt 断点标记线旋转角度
  17. #\' @param brk.size 断点标记线的大小（长度）
  18. #\' @param brk.col 断点标记线的颜色
  19. #\' @param brk.lwd 断点标记线的线宽
  20. #\' @param cex.error 误差线相对长度，默认为1
  21. #\' @param ... 其他传递给R基本绘图函数barplot的参数
  22. #\' @return 返回barplot的原始返回值，即柱形图的x坐标
  23. #\' @examples
  24. #\' datax <- na.omit(airquality)[,1:4]
  25. #\' cols <- cm.colors(ncol(datax))
  26. #\' layout(matrix(1:6, ncol=2))
  27. #\' set.seed(0)
  28. #\' for (ndx in 1:6){
  29. #\'     dt <- datax[sample(rownames(datax), 10), ]
  30. #\'     par(mar=c(0.5,2,0.5,0.5))
  31. #\'     brkt <- sample(c(\'normal\', \'zigzag\'), 1)
  32. #\'     gap.barplot(dt, col=cols, brk.type=brkt, max.fold=5, ratio=2)
  33. #\' }
  34. #\' @author ZG Zhao
  35. #\' @export
  36. gap.barplot <- function(df, y.cols = 1:ncol(df), sd.cols = NULL, btm = NULL,
  37.                         top = NULL, min.range = 10, max.fold = 5, ratio = 1, gap.width = 1, brk.type = "normal",
  38.                         brk.bg = "white", brk.srt = 135, brk.size = 1, brk.col = "black", brk.lwd = 1,
  39.                         cex.error = 1, ...) {
  40.   if (missing(df))
  41.     stop("No data provided.")
  42.   if (is.numeric(y.cols))
  43.     ycol <- y.cols else ycol <- colnames(df) == y.cols
  44.     if (!is.null(sd.cols))
  45.       if (is.numeric(sd.cols))
  46.         scol <- sd.cols else scol <- colnames(df) == sd.cols
  47.         ## Arrange data
  48.         opts <- options()
  49.         options(warn = -1)
  50.         y <- t(df[, ycol])
  51.         colnames(y) <- NULL
  52.         if (missing(sd.cols))
  53.           sdx <- 0 else sdx <- t(df[, scol])
  54.         sdu <- y   sdx
  55.         sdd <- y - sdx
  56.         ylim <- c(0, max(sdu) * 1.05)
  57.         ## 如果没有设置btm或top，自动计算
  58.         if (is.null(btm) | is.null(top)) {
  59.           autox <- .auto.breaks(dt = sdu, min.range = min.range, max.fold = max.fold)
  60.           if (autox$flag) {
  61.             btm <- autox$btm
  62.             top <- autox$top
  63.           } else {
  64.             xx <- barplot(y, beside = TRUE, ylim = ylim, ...)
  65.             if (!missing(sd.cols))
  66.               errorbar(xx, y, sdu - y, horiz = FALSE, cex = cex.error)
  67.             box()
  68.             return(invisible(xx))
  69.           }
  70.         }
  71.         ## Set up virtual y limits
  72.         halflen <- btm - ylim[1]
  73.         xlen <- halflen * 0.1 * gap.width
  74.         v_tps1 <- btm   xlen  # virtual top positions
  75.         v_tps2 <- v_tps1   halflen * ratio
  76.         v_ylim <- c(ylim[1], v_tps2)
  77.         r_tps1 <- top  # real top positions
  78.         r_tps2 <- ylim[2]
  79.         ## Rescale data
  80.         lmx <- summary(lm(c(v_tps1, v_tps2) ~ c(r_tps1, r_tps2)))
  81.         lmx <- lmx$coefficients
  82.         sel1 <- y > top
  83.         sel2 <- y >= btm & y <= top
  84.         y[sel1] <- y[sel1] * lmx[2]   lmx[1]
  85.         y[sel2] <- btm   xlen/2
  86.         sel1 <- sdd > top
  87.         sel2 <- sdd >= btm & sdd <= top
  88.         sdd[sel1] <- sdd[sel1] * lmx[2]   lmx[1]
  89.         sdd[sel2] <- btm   xlen/2
  90.         sel1 <- sdu > top
  91.         sel2 <- sdu >= btm & sdu <= top
  92.         sdu[sel1] <- sdu[sel1] * lmx[2]   lmx[1]
  93.         sdu[sel2] <- btm   xlen/2
  94.         ## bar plot
  95.         xx <- barplot(y, beside = TRUE, ylim = v_ylim, axes = FALSE, names.arg = NULL,
  96.                       ...)
  97.         ## error bars
  98.         if (!missing(sd.cols))
  99.           errorbar(xx, y, sdu - y, horiz = FALSE, cex = cex.error)
  100.         ## Real ticks and labels
  101.         brks1 <- pretty(seq(0, btm, length = 10), n = 4)
  102.         brks1 <- brks1[brks1 >= 0 & brks1 < btm]
  103.         brks2 <- pretty(seq(top, r_tps2, length = 10), n = 4)
  104.         brks2 <- brks2[brks2 > top & brks2 <= r_tps2]
  105.         labx <- c(brks1, brks2)
  106.         ## Virtual ticks
  107.         brks <- c(brks1, brks2 * lmx[2]   lmx[1])
  108.         axis(2, at = brks, labels = labx)
  109.         box()
  110.         ## break marks
  111.         pos <- par("usr")
  112.         xyratio <- (pos[2] - pos[1])/(pos[4] - pos[3])
  113.         xlen <- (pos[2] - pos[1])/50 * brk.size
  114.         px1 <- pos[1] - xlen
  115.         px2 <- pos[1]   xlen
  116.         px3 <- pos[2] - xlen
  117.         px4 <- pos[2]   xlen
  118.         py1 <- btm
  119.         py2 <- v_tps1
  120.         rect(px1, py1, px4, py2, col = brk.bg, xpd = TRUE, border = brk.bg)
  121.         x1 <- c(px1, px1, px3, px3)
  122.         x2 <- c(px2, px2, px4, px4)
  123.         y1 <- c(py1, py2, py1, py2)
  124.         y2 <- c(py1, py2, py1, py2)
  125.         px <- .xy.adjust(x1, x2, y1, y2, xlen, xyratio, angle = brk.srt * pi/90)
  126.         if (brk.type == "zigzag") {
  127.           x1 <- c(x1, px1, px3)
  128.           x2 <- c(x2, px2, px4)
  129.           if (brk.srt > 90) {
  130.             y1 <- c(y1, py2, py2)
  131.             y2 <- c(y2, py1, py1)
  132.           } else {
  133.             y1 <- c(y1, py1, py1)
  134.             y2 <- c(y2, py2, py2)
  135.           }
  136.         }
  137.         if (brk.type == "zigzag") {
  138.           px$x1 <- c(pos[1], px2, px1, pos[2], px4, px3)
  139.           px$x2 <- c(px2, px1, pos[1], px4, px3, pos[2])
  140.           mm <- (v_tps1 - btm)/3
  141.           px$y1 <- rep(c(v_tps1, v_tps1 - mm, v_tps1 - 2 * mm), 2)
  142.           px$y2 <- rep(c(v_tps1 - mm, v_tps1 - 2 * mm, btm), 2)
  143.         }
  144.         par(xpd = TRUE)
  145.         segments(px$x1, px$y1, px$x2, px$y2, lty = 1, col = brk.col, lwd = brk.lwd)
  146.         options(opts)
  147.         par(xpd = FALSE)
  148.         invisible(xx)
  149. }
  150. ## 绘制误差线的函数
  151. errorbar <- function(x, y, sd.lwr, sd.upr, horiz = FALSE, cex = 1, ...) {
  152.   if (missing(sd.lwr) & missing(sd.upr))
  153.     return(NULL)
  154.   if (missing(sd.upr))
  155.     sd.upr <- sd.lwr
  156.   if (missing(sd.lwr))
  157.     sd.lwr <- sd.upr
  158.   if (!horiz) {
  159.     arrows(x, y, y1 = y - sd.lwr, length = 0.1 * cex, angle = 90, ...)
  160.     arrows(x, y, y1 = y   sd.upr, length = 0.1 * cex, angle = 90, ...)
  161.   } else {
  162.     arrows(y, x, x1 = y - sd.lwr, length = 0.1 * cex, angle = 90, ...)
  163.     arrows(y, x, x1 = y   sd.upr, length = 0.1 * cex, angle = 90, ...)
  164.   }
  165. }
  166. .xy.adjust <- function(x1, x2, y1, y2, xlen, xyratio, angle) {
  167.   xx1 <- x1 - xlen * cos(angle)
  168.   yy1 <- y1   xlen * sin(angle)/xyratio
  169.   xx2 <- x2   xlen * cos(angle)
  170.   yy2 <- y2 - xlen * sin(angle)/xyratio
  171.   return(list(x1 = xx1, x2 = xx2, y1 = yy1, y2 = yy2))
  172. }
  173. ## 自动计算断点位置的函数
  174. .auto.breaks <- function(dt, min.range, max.fold) {
  175.   datax <- sort(as.vector(dt))
  176.   flags <- FALSE
  177.   btm <- top <- NULL
  178.   if (max(datax)/min(datax) < min.range)
  179.     return(list(flag = flags, btm = btm, top = top))
  180.   m <- max(datax)
  181.   btm <- datax[2]
  182.   i <- 3
  183.   while (m/datax[i] > max.fold) {
  184.     btm <- datax[i]
  185.     flags <- TRUE
  186.     i <- i   1
  187.   }
  188.   if (flags) {
  189.     btm <- btm   0.05 * btm
  190.     x <- 2
  191.     top <- datax[i] * (x - 1)/x
  192.     while (top < btm) {
  193.       x <- x   1
  194.       top <- datax[i] * (x - 1)/x
  195.       if (x > 100) {
  196.         flags <- FALSE
  197.         break
  198.       }
  199.     }
  200.   }
  201.   return(list(flag = flags, btm = btm, top = top))
  202. }

示例数据

  1. datax <- na.omit(airquality)[, 1:4]
  2. cols <- terrain.colors(ncol(datax) - 1)
  3. layout(matrix(1:4, ncol = 2))
  4. set.seed(0)
  5. for (ndx in 1:4) {
  6. dt <- datax[sample(rownames(datax), 10), ]
  7. dt <- cbind(dt, dt[, -1] * 0.1)
  8. par(mar = c(1, 3, 0.5, 0.5))
  9. brkt <- sample(c("normal", "zigzag"), 1)
  10. gap.barplot(dt, y.cols = 2:4, sd.cols = 5:7, col = cols, brk.type = brkt,
  11. brk.size = 0.6, brk.lwd = 2, max.fold = 5, ratio = 2, cex.error = 0.3)
  12. }

基于R语言绘制坐标轴截断图-图片8

实际数据

  1. gap.barplot(df, y.cols = 2, brk.type = "normal",col = rainbow(7),
  2.             brk.size = 0.6, brk.lwd = 2, max.fold = 5, ratio = 2, cex.error = 0.3)

基于R语言绘制坐标轴截断图-图片9

第3种方法可以直接计算截断值，另外可以添加error bar, 可以修改的细节处更多，而且包装成函数，整个分析时间也加快。

发表评论

匿名网友

拖动滑块以完成验证
加载失败