R语言学习笔记 -- ggplot2 绘制单侧误差线

采用ggplot2绘制误差线默认是上下两个方向均绘出，但有时对于柱状图只显示一个方向的误差线效果更好。想要实现这一目的，可以修改geom_errorbar的ymax/ymin的参数（但会多显示一条直线）或者geom_errorbar在geom_bar之前（前提要求误差线比柱子要短）。下面提供一个彻底解决该问题的方法---新增geom_uperrorbar函数。

library(ggplot2)
#' @export
#' @rdname geom_linerange
geom_uperrorbar <- function(mapping = NULL, data = NULL,
                          stat = "identity", position = "identity",
                          ...,
                          na.rm = FALSE,
                          orientation = NA,
                          show.legend = NA,
                          inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomUperrorbar,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      orientation = orientation,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomUperrorbar <- ggproto("GeomUperrorbar", Geom,
  default_aes = aes(colour = "black", size = 0.5, linetype = 1, width = 0.5,
    alpha = NA),

  draw_key = draw_key_path,

  required_aes = c("x|y", "ymin|xmin", "ymax|xmax"),

  setup_params = function(data, params) {
    GeomLinerange$setup_params(data, params)
  },

  extra_params = c("na.rm", "orientation"),

  setup_data = function(data, params) {
    data$flipped_aes <- params$flipped_aes
    data <- flip_data(data, params$flipped_aes)
    data$width <- data$width %||%
      params$width %||% (resolution(data$x, FALSE) * 0.9)
    data <- transform(data,
      xmin = x - width / 2, xmax = x + width / 2, width = NULL
    )
    flip_data(data, params$flipped_aes)
  },

  draw_panel = function(data, panel_params, coord, width = NULL, flipped_aes = FALSE) {
    data <- flip_data(data, flipped_aes)
    #x <- as.vector(rbind(data$xmin, data$xmax, NA, data$x,    data$x,    NA, data$xmin, data$xmax))
    #y <- as.vector(rbind(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin))
    sel <- data$y < 0 
    data$ymax[sel] <- data$ymin[sel]
    x <- as.vector(rbind(data$xmin, data$xmax, NA, data$x,    data$x))
    y <- as.vector(rbind(data$ymax, data$ymax, NA, data$ymax, data$y))
    data <- new_data_frame(list(
      x = x,
      y = y,
      colour = rep(data$colour, each = 5),
      alpha = rep(data$alpha, each = 5),
      size = rep(data$size, each = 5),
      linetype = rep(data$linetype, each = 5),
      group = rep(1:(nrow(data)), each = 5),
      row.names = 1:(nrow(data) * 5)
    ))
    data <- flip_data(data, flipped_aes)
    GeomPath$draw_panel(data, panel_params, coord)
  }
)

new_data_frame <- function(x = list(), n = NULL) {
  if (length(x) != 0 && is.null(names(x))) {
    abort("Elements must be named")
  }
  lengths <- vapply(x, length, integer(1))
  if (is.null(n)) {
    n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths)
  }
  for (i in seq_along(x)) {
    if (lengths[i] == n) next
    if (lengths[i] != 1) {
      abort("Elements must equal the number of rows or 1")
    }
    x[[i]] <- rep(x[[i]], n)
  }
  
  class(x) <- "data.frame"
  
  attr(x, "row.names") <- .set_row_names(n)
  x
}

以上代码参考ggplot2::geom_error源代码修改而得，参考stackoverflow帖子。

  library(tidyverse); library(ggpubr)
  df <- iris %>% 
    gather(Id, Value, Sepal.Length:Petal.Width)
  
  ggplot(df, aes(Species, Value, fill = Id)) + 
    geom_hline(aes(yintercept = 0), color = "grey") +
    geom_bar(aes(col = Id), stat = "summary", fun = mean, width = 0.6, fill = "transparent",
             position = position_dodge( .7)) +
    stat_summary(aes(col = Id), fun.data = 'mean_sd', geom = "uperrorbar", colour = "black", width = .4,
                 position = position_dodge( .7)) +
    theme_bw(base_size = 16) +
    theme(panel.grid   = element_blank())

如若柱状图中有小于0的情况，亦可实现。

  df2 <- iris %>% 
    mutate(Petal.Width = Petal.Width -2) %>% 
    gather(Id, Value, Sepal.Length:Petal.Width) 
  
  ggplot(df2, aes(Species, Value, fill = Id)) + 
    geom_hline(aes(yintercept = 0), color = "grey") +
    geom_bar(aes(col = Id), stat = "summary", fun = mean, width = 0.6, fill = "transparent",
             position = position_dodge( .7)) +
    stat_summary(aes(col = Id), fun.data = 'mean_sd', geom = "uperrorbar", colour = "black", width = .4,
                 position = position_dodge( .7)) +
    theme_bw(base_size = 16) +
    theme(panel.grid   = element_blank())