前言

轉(zhuǎn)載自：http://www.reibang.com/p/de283990ecd1
以獲得博主的轉(zhuǎn)載許可權(quán)
最近日常閑逛的時(shí)候股淡，無(wú)意間看到大神@六六_ryx寫(xiě)的這篇推送租悄，在這里我們大家一起學(xué)習(xí)如何用R畫(huà)橫斷坐標(biāo)軸

示例數(shù)據(jù)

我們以原推送的示例數(shù)據(jù)為例：

df <- data.frame(name=c("AY","BY","CY","DY","EY","FY","GY"),Money=c(1510,1230,995,48,35,28,10))
df

#加載 R 包
library(ggplot2)
# ggplot畫(huà)圖
p0 <- ggplot(df, aes(name,Money,fill = name)) +
  geom_col(position = position_dodge(width = 0.8),color="black") +
  labs(x = NULL, y = NULL) +
  scale_fill_brewer(palette="Accent")+
  #scale_x_discrete(expand = c(0, 0)) +
  scale_y_continuous(breaks = seq(0, 1600, 400), limits = c(0, 1600), expand = c(0,0)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.title = element_blank())

p0

全圖

正常圖形是這樣的

分割組合法

這個(gè)方法就是把一張圖按自己的需求截取成兩張拆融，然后再拼接成一張

p1 = p0 + coord_cartesian(ylim = c(0,50)) +  #以y軸為基礎(chǔ)截取p0的0-50部分
  theme_classic()+
  theme(legend.position = "none")

p1

p1

p2 = p0 + coord_cartesian(ylim = c(700,1600)) + #以y軸為基礎(chǔ)截取p0的700-1600部分
  theme_classic() + 
  theme(axis.line.x = element_line(colour = "white"),
        axis.text.x = element_blank(),axis.ticks.x = element_blank(),
        legend.position = c(0.85,0.6))

p2

p2

library(grid)

grid.newpage()
plot_site1 = viewport(x = 0.008,y = 0,width = 0.994,height = 0.4,just = c('left','bottom')) #其中x,y是調(diào)位置參數(shù)用的
plot_site2 = viewport(x = -0.035,y = 0.4,width = 1,height = 0.5,just = c('left','bottom')) #其中x,y是調(diào)位置參數(shù)用的
print(p1,vp = plot_site1)
print(p2,vp = plot_site2)

image.png

這個(gè)辦法比較笨汪茧，而且不好看

plotrix R包

library(plotrix)

gap.barplot(df$Money,gap = c(50,740),xaxlab = df$name,ytics = c(50,700,800,900,1000,1100,1200,1300,1400,1500,1600),
            col = rainbow(7),xlim = c(0,8),width) #gap為設(shè)置斷點(diǎn)區(qū)間

image.png

我們還可以改的更魔性化一點(diǎn)：

axis.break(2,50,breakcol = "snow",style = "gap") #數(shù)字代表斷軸位置
axis.break(2,50*(1+0.02),breakcol = "black",style = "slash") #根據(jù)不同風(fēng)格改形狀

image.png

大神自編函數(shù)

鏈接：https://blog.csdn.net/u014801157/article/details/24372371
我們看看原函數(shù)形式：

gap.barplot <- function(df, y.cols = 1:ncol(df), sd.cols = NULL, btm = NULL,
                        top = NULL, min.range = 10, max.fold = 5, ratio = 1, gap.width = 1, brk.type = "normal",
                        brk.bg = "white", brk.srt = 135, brk.size = 1, brk.col = "black", brk.lwd = 1,
                        cex.error = 1, ...) {
  if (missing(df))
    stop("No data provided.")
  if (is.numeric(y.cols))
    ycol <- y.cols else ycol <- colnames(df) == y.cols
    if (!is.null(sd.cols))
      if (is.numeric(sd.cols))
        scol <- sd.cols else scol <- colnames(df) == sd.cols
        ## Arrange data
        opts <- options()
        options(warn = -1)
        y <- t(df[, ycol])
        colnames(y) <- NULL
        if (missing(sd.cols))
          sdx <- 0 else sdx <- t(df[, scol])
        sdu <- y + sdx
        sdd <- y - sdx
        ylim <- c(0, max(sdu) * 1.05)
        ## 如果沒(méi)有設(shè)置btm或top篙挽，自動(dòng)計(jì)算
        if (is.null(btm) | is.null(top)) {
          autox <- .auto.breaks(dt = sdu, min.range = min.range, max.fold = max.fold)
          if (autox$flag) {
            btm <- autox$btm
            top <- autox$top
          } else {
            xx <- barplot(y, beside = TRUE, ylim = ylim, ...)
            if (!missing(sd.cols))
              errorbar(xx, y, sdu - y, horiz = FALSE, cex = cex.error)
            box()
            return(invisible(xx))
          }
        }
        ## Set up virtual y limits
        halflen <- btm - ylim[1]
        xlen <- halflen * 0.1 * gap.width
        v_tps1 <- btm + xlen  # virtual top positions
        v_tps2 <- v_tps1 + halflen * ratio
        v_ylim <- c(ylim[1], v_tps2)
        r_tps1 <- top  # real top positions
        r_tps2 <- ylim[2]
        ## Rescale data
        lmx <- summary(lm(c(v_tps1, v_tps2) ~ c(r_tps1, r_tps2)))
        lmx <- lmx$coefficients
        sel1 <- y > top
        sel2 <- y >= btm & y <= top
        y[sel1] <- y[sel1] * lmx[2] + lmx[1]
        y[sel2] <- btm + xlen/2
        sel1 <- sdd > top
        sel2 <- sdd >= btm & sdd <= top
        sdd[sel1] <- sdd[sel1] * lmx[2] + lmx[1]
        sdd[sel2] <- btm + xlen/2
        sel1 <- sdu > top
        sel2 <- sdu >= btm & sdu <= top
        sdu[sel1] <- sdu[sel1] * lmx[2] + lmx[1]
        sdu[sel2] <- btm + xlen/2
        ## bar plot
        xx <- barplot(y, beside = TRUE, ylim = v_ylim, axes = FALSE, names.arg = NULL,
                      ...)
        ## error bars
        if (!missing(sd.cols))
          errorbar(xx, y, sdu - y, horiz = FALSE, cex = cex.error)
        ## Real ticks and labels
        brks1 <- pretty(seq(0, btm, length = 10), n = 4)
        brks1 <- brks1[brks1 >= 0 & brks1 < btm]
        brks2 <- pretty(seq(top, r_tps2, length = 10), n = 4)
        brks2 <- brks2[brks2 > top & brks2 <= r_tps2]
        labx <- c(brks1, brks2)
        ## Virtual ticks
        brks <- c(brks1, brks2 * lmx[2] + lmx[1])
        axis(2, at = brks, labels = labx)
        box()
        ## break marks
        pos <- par("usr")
        xyratio <- (pos[2] - pos[1])/(pos[4] - pos[3])
        xlen <- (pos[2] - pos[1])/50 * brk.size
        px1 <- pos[1] - xlen
        px2 <- pos[1] + xlen
        px3 <- pos[2] - xlen
        px4 <- pos[2] + xlen
        py1 <- btm
        py2 <- v_tps1
        rect(px1, py1, px4, py2, col = brk.bg, xpd = TRUE, border = brk.bg)
        x1 <- c(px1, px1, px3, px3)
        x2 <- c(px2, px2, px4, px4)
        y1 <- c(py1, py2, py1, py2)
        y2 <- c(py1, py2, py1, py2)
        px <- .xy.adjust(x1, x2, y1, y2, xlen, xyratio, angle = brk.srt * pi/90)
        if (brk.type == "zigzag") {
          x1 <- c(x1, px1, px3)
          x2 <- c(x2, px2, px4)
          if (brk.srt > 90) {
            y1 <- c(y1, py2, py2)
            y2 <- c(y2, py1, py1)
          } else {
            y1 <- c(y1, py1, py1)
            y2 <- c(y2, py2, py2)
          }
        }
        if (brk.type == "zigzag") {
          px$x1 <- c(pos[1], px2, px1, pos[2], px4, px3)
          px$x2 <- c(px2, px1, pos[1], px4, px3, pos[2])
          mm <- (v_tps1 - btm)/3
          px$y1 <- rep(c(v_tps1, v_tps1 - mm, v_tps1 - 2 * mm), 2)
          px$y2 <- rep(c(v_tps1 - mm, v_tps1 - 2 * mm, btm), 2)
        }
        par(xpd = TRUE)
        segments(px$x1, px$y1, px$x2, px$y2, lty = 1, col = brk.col, lwd = brk.lwd)
        options(opts)
        par(xpd = FALSE)
        invisible(xx)
}
## 繪制誤差線的函數(shù)
errorbar <- function(x, y, sd.lwr, sd.upr, horiz = FALSE, cex = 1, ...) {
  if (missing(sd.lwr) & missing(sd.upr))
    return(NULL)
  if (missing(sd.upr))
    sd.upr <- sd.lwr
  if (missing(sd.lwr))
    sd.lwr <- sd.upr
  if (!horiz) {
    arrows(x, y, y1 = y - sd.lwr, length = 0.1 * cex, angle = 90, ...)
    arrows(x, y, y1 = y + sd.upr, length = 0.1 * cex, angle = 90, ...)
  } else {
    arrows(y, x, x1 = y - sd.lwr, length = 0.1 * cex, angle = 90, ...)
    arrows(y, x, x1 = y + sd.upr, length = 0.1 * cex, angle = 90, ...)
  }
}
.xy.adjust <- function(x1, x2, y1, y2, xlen, xyratio, angle) {
  xx1 <- x1 - xlen * cos(angle)
  yy1 <- y1 + xlen * sin(angle)/xyratio
  xx2 <- x2 + xlen * cos(angle)
  yy2 <- y2 - xlen * sin(angle)/xyratio
  return(list(x1 = xx1, x2 = xx2, y1 = yy1, y2 = yy2))
}
## 自動(dòng)計(jì)算斷點(diǎn)位置的函數(shù)
.auto.breaks <- function(dt, min.range, max.fold) {
  datax <- sort(as.vector(dt))
  flags <- FALSE
  btm <- top <- NULL
  if (max(datax)/min(datax) < min.range)
    return(list(flag = flags, btm = btm, top = top))
  m <- max(datax)
  btm <- datax[2]
  i <- 3
  while (m/datax[i] > max.fold) {
    btm <- datax[i]
    flags <- TRUE
    i <- i + 1
  }
  if (flags) {
    btm <- btm + 0.05 * btm
    x <- 2
    top <- datax[i] * (x - 1)/x
    while (top < btm) {
      x <- x + 1
      top <- datax[i] * (x - 1)/x
      if (x > 100) {
        flags <- FALSE
        break
      }
    }
  }
  return(list(flag = flags, btm = btm, top = top))
}

參數(shù)圖

下面我們用個(gè)例子來(lái)說(shuō)明：
首先用官方例子來(lái)說(shuō)明：

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

image.png

官方例子一畫(huà)就是四幅圖，如果我們要畫(huà)一幅圖井厌，可以搭配par()這個(gè)函數(shù)，選用fig這個(gè)參數(shù)
以下是我的畫(huà)法：

datax <- na.omit(airquality)[, 1:4]
cols <- terrain.colors(ncol(datax) - 1)
dt <- datax[sample(rownames(datax), 10), ]
dt <- cbind(dt, dt[, -1] * 0.1)
par(fig=c(0,1,0.05,1)) #四個(gè)參數(shù)代表位置信息
gap.barplot(dt, y.cols = 2:4, sd.cols = 5:7, col = cols, brk.type = brkt,
            brk.size = 0.6, brk.lwd = 2, max.fold = 5, ratio = 2, cex.error = 0.3)

image.png

這是不是很完美呢卦羡？

如果采用的是ggplot的話(huà)，不妨可以這樣做，原文：http://www.reibang.com/p/0e4fa8849479

set.seed(2019-01-19)
d <- data.frame(
    x = 1:20, 
    y = c(rnorm(5) + 4, rnorm(5) + 20, rnorm(5) + 5, rnorm(5) + 22)
)

ggplot(d, aes(x, y)) + geom_col()

未截?cái)?/div>

library(dplyr)

breaks = c(7, 17)
d$.type <- NA
d$.type[d$y < breaks[1]] = "small"
d$.type[d$y > breaks[2]] = "big"

d <- filter(d, .type == 'big') %>% 
    mutate(.type = "small", y = breaks[1]) %>% 
    bind_rows(d)

mymin = function(y) ifelse(y <= breaks[1], 0, breaks[2])               
p <- ggplot(d, aes(x, y)) + 
    geom_rect(aes(xmin = x - .4, xmax = x + .4, ymin = mymin(y), ymax = y)) +
    facet_grid(.type ~ ., scales = "free") + 
    theme(strip.text=element_blank())
p

截?cái)?/div>

嗯嗯幔虏，我是小潤(rùn)澤胸梆，我只負(fù)責(zé)傳播知識(shí)