在热图的图例连续渐变色条周围绘制边框

Question

如何在连续渐变色条周围添加边框。默认情况下，ggplot 使用scale_fill_gradient 中指定的填充颜色。

我找到的最接近的答案是 one，但它并没有帮助我完成这项任务。

我也用图例键尝试过这个，但没有帮助我。

legend.key = element_rect(colour = "black", size = 4)

请查看下面的当前和预期图表。

数据：

df1 <- structure(list(go = structure(c(17L, 16L, 15L, 14L, 13L, 12L, 
                                       11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, 17L, 16L, 15L, 
                                       14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, 
                                       17L, 16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 
                                       3L, 2L, 1L, 17L, 16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 
                                       6L, 5L, 4L, 3L, 2L, 1L), 
                                     .Label = c("q", "p", "o", "n", "m", "l", "k", "j", "i", "h", "g", "f", "e", "d", "c", "b", "a"), 
                                     class = c("ordered", "factor")), 
                      variable = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 
                                             2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 
                                             3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 
                                             4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L), 
                                           class = "factor", .Label = c("a", "b", "c", "d")),
                      value = c(-0.626453810742332, 0.183643324222082, -0.835628612410047, 1.59528080213779, 0.329507771815361, 
                                -0.820468384118015, 0.487429052428485, 0.738324705129217, 0.575781351653492, 
                                -0.305388387156356, 1.51178116845085, 0.389843236411431, -0.621240580541804, 
                                -2.2146998871775, 1.12493091814311, -0.0449336090152309, -0.0161902630989461, 
                                0.943836210685299, 0.821221195098089, 0.593901321217509, 0.918977371608218, 
                                0.782136300731067, 0.0745649833651906, -1.98935169586337, 0.61982574789471, 
                                -0.0561287395290008, -0.155795506705329, -1.47075238389927, -0.47815005510862, 
                                0.417941560199702, 1.35867955152904, -0.102787727342996, 0.387671611559369, 
                                -0.0538050405829051, -1.37705955682861, -0.41499456329968, -0.394289953710349, 
                                -0.0593133967111857, 1.10002537198388, 0.763175748457544, -0.164523596253587, 
                                -0.253361680136508, 0.696963375404737, 0.556663198673657, -0.68875569454952, 
                                -0.70749515696212, 0.36458196213683, 0.768532924515416, -0.112346212150228, 
                                0.881107726454215, 0.398105880367068, -0.612026393250771, 0.341119691424425, 
                                -1.12936309608079, 1.43302370170104, 1.98039989850586, -0.367221476466509, 
                                -1.04413462631653, 0.569719627442413, -0.135054603880824, 2.40161776050478, 
                                -0.0392400027331692, 0.689739362450777, 0.0280021587806661, -0.743273208882405, 
                                0.188792299514343, -1.80495862889104, 1.46555486156289)), 
                 .Names = c("go", "variable", "value"), row.names = c(NA, -68L), class = "data.frame")

代码：

library('ggplot2')
ggplot( data = df1, mapping = aes( x = variable, y = go ) ) +  # draw heatmap
  geom_tile( aes( fill = value ),  colour = "white") +
  scale_fill_gradient( low = "white", high = "black",
                       guide = guide_colorbar(label = TRUE,
                                              draw.ulim = TRUE, 
                                              draw.llim = TRUE,
                                              ticks = TRUE, 
                                              nbin = 10,
                                              label.position = "bottom",
                                              barwidth = 13,
                                              barheight = 1.3, 
                                              direction = 'horizontal')) +
  scale_y_discrete(position = "right") +
  scale_x_discrete(position = "top") +
  coord_flip() +
  theme(axis.text.x = element_text(),
        axis.title = element_blank(),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        legend.position = 'bottom',
        legend.title = element_blank(),
        legend.key = element_rect(colour = "black", size = 4)
  )

当前图表：

预期图表：

Answer 1

从 2018 年 5 月 2 日起，这现在可以在 ggplot2 的 github 版本中实现，并将成为 ggplot2 2.3 的一部分：

# devtools::install_github("tidyverse/ggplot2") # do this once, to install github version
library(ggplot2)
ggplot( data = df1, mapping = aes( x = variable, y = go ) ) +  # draw heatmap
  geom_tile( aes( fill = value ),  colour = "white") +
  scale_fill_gradient( low = "white", high = "black",
                       guide = guide_colorbar(label = TRUE,
                                              draw.ulim = TRUE, 
                                              draw.llim = TRUE,
                                           # here comes the code change:
                                              frame.colour = "black",
                                              ticks = TRUE, 
                                              nbin = 10,
                                              label.position = "bottom",
                                              barwidth = 13,
                                              barheight = 1.3, 
                                              direction = 'horizontal')) +
  scale_y_discrete(position = "right") +
  scale_x_discrete(position = "top") +
  coord_flip() +
  theme(axis.text.x = element_text(),
        axis.title = element_blank(),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        legend.position = 'bottom',
        legend.title = element_blank()
  )

具体来说，guide_colorbar() 中添加了以下参数：

• frame.colour 颜色条周围边框的颜色。如果NULL，则不绘制任何帧。
• frame.linewidth边框线宽。
• frame.linetype 边框线型。
• ticks.colour 绘制的刻度线的颜色。
• ticks.linewidth 刻度线的宽度。

这五个参数应该允许最常用的样式。在我看来，更复杂的样式（例如外部的刻度线）需要重新考虑指南的主题。

Answer 2

更新：此答案现已过时。请改用this one。我留下过时的答案只是因为同样的原则适用于其他问题。

ggplot2 图例绘制代码有点乱，而且不是很可定制。我看到获得这种效果的唯一方法是对guide_colorbar() 进行修改。不幸的是，这需要复制大量的 ggplot2 代码。

我目前正在运行 ggplot2 的开发版本，因此我将发布的确切代码只能保证与该版本一起运行。 （截至今天，2018 年 4 月 27 日，我正在使用 github 上的内容）。但该原理也适用于已发布的版本。

一旦我们定义了新的图例函数，首先是绘图代码：

ggplot(data = df1, mapping = aes(x = variable, y = go)) +  # draw heatmap
  geom_tile(aes(fill = value),  colour = "white") +
  scale_fill_gradient(low = "white", high = "black",
                      guide = guide_colorbar2(label = TRUE,
                                              draw.ulim = TRUE, 
                                              draw.llim = TRUE,
                                              ticks = TRUE, 
                                              nbin = 10,
                                              label.position = "bottom",
                                              barwidth = 13,
                                              barheight = 1.3, 
                                              direction = 'horizontal')) +
  scale_y_discrete(position = "right") +
  scale_x_discrete(position = "top") +
  coord_flip() +
  theme(axis.text.x = element_text(),
        axis.title = element_blank(),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        legend.position = 'bottom',
        legend.title = element_blank(),
        legend.key = element_rect(colour = "black", size = 4),
        # the following corresponds to 4pt due to current bug
        # in legend code; this will hopefully be fixed before
        # the next ggplot2 release
        legend.spacing.y = grid::unit(40, "pt")
  )

您的代码有两个更改。我写了guide_colorbar2 而不是guide_colorbar，并在主题代码中添加了legend.spacing.y 行以将标签从颜色栏上移开。结果如下：

现在复制的颜色条代码。这主要是 ggplot2 的逐字副本。对于正在使用的所有内部 ggplot2 函数，我们必须在函数调用前添加 ggplot:::，例如ggplot2:::width_cm 而不是 width_cm。画出轮廓的实际变化只是多加了两行代码，而且用cmets清楚地标明了。

# the code below uses functions from these libraries
library(rlang)
library(grid)
library(gtable)
library(scales)

# this is a verbatim copy, with colorbar replaced by colorbar2
# (note also the class statement at the very end of this function) 
guide_colorbar2 <- function(

  # title
  title = waiver(),
  title.position = NULL,
  title.theme = NULL,
  title.hjust = NULL,
  title.vjust = NULL,

  # label
  label = TRUE,
  label.position = NULL,
  label.theme = NULL,
  label.hjust = NULL,
  label.vjust = NULL,

  # bar
  barwidth = NULL,
  barheight = NULL,
  nbin = 20,
  raster = TRUE,

  # ticks
  ticks = TRUE,
  draw.ulim= TRUE,
  draw.llim = TRUE,

  # general
  direction = NULL,
  default.unit = "line",
  reverse = FALSE,
  order = 0,

  ...) {

  if (!is.null(barwidth) && !is.unit(barwidth)) barwidth <- unit(barwidth, default.unit)
  if (!is.null(barheight) && !is.unit(barheight)) barheight <- unit(barheight, default.unit)

  structure(list(
    # title
    title = title,
    title.position = title.position,
    title.theme = title.theme,
    title.hjust = title.hjust,
    title.vjust = title.vjust,

    # label
    label = label,
    label.position = label.position,
    label.theme = label.theme,
    label.hjust = label.hjust,
    label.vjust = label.vjust,

    # bar
    barwidth = barwidth,
    barheight = barheight,
    nbin = nbin,
    raster = raster,

    # ticks
    ticks = ticks,
    draw.ulim = draw.ulim,
    draw.llim = draw.llim,

    # general
    direction = direction,
    default.unit = default.unit,
    reverse = reverse,
    order = order,

    # parameter
    available_aes = c("colour", "color", "fill"), ..., name = "colorbar"),
    class = c("guide", "colorbar2")
  )
}

# this saves us from copying the code over. Just call the ggplot2
# version of the function
guide_train.colorbar2 <- function(...) {
  ggplot2:::guide_train.colorbar(...)
}

# this saves us from copying the code over. Just call the ggplot2
# version of the function    
guide_merge.colorbar2 <- function(...) {
  ggplot2:::guide_merge.colorbar(...)
}

# this saves us from copying the code over. Just call the ggplot2
# version of the function
guide_geom.colorbar2 <- function(...) {
  ggplot2:::guide_geom.colorbar(...)
}

# this is the function that does the actual legend drawing
# and that we have to modify
guide_gengrob.colorbar2 <- function(guide, theme) {
  # settings of location and size
  switch(guide$direction,
         "horizontal" = {
           label.position <- guide$label.position %||% "bottom"
           if (!label.position %in% c("top", "bottom")) stop("label position \"", label.position, "\" is invalid")

           barwidth <- convertWidth(guide$barwidth %||% (theme$legend.key.width * 5), "mm")
           barheight <- convertHeight(guide$barheight %||% theme$legend.key.height, "mm")
         },
         "vertical" = {
           label.position <- guide$label.position %||% "right"
           if (!label.position %in% c("left", "right")) stop("label position \"", label.position, "\" is invalid")

           barwidth <- convertWidth(guide$barwidth %||% theme$legend.key.width, "mm")
           barheight <- convertHeight(guide$barheight %||% (theme$legend.key.height * 5), "mm")
         })

  barwidth.c <- c(barwidth)
  barheight.c <- c(barheight)
  barlength.c <- switch(guide$direction, "horizontal" = barwidth.c, "vertical" = barheight.c)
  nbreak <- nrow(guide$key)

  grob.bar <-
    if (guide$raster) {
      image <- switch(guide$direction, horizontal = t(guide$bar$colour), vertical = rev(guide$bar$colour))
      rasterGrob(image = image, width = barwidth.c, height = barheight.c, default.units = "mm", gp = gpar(col = NA), interpolate = TRUE)
    } else {
      switch(guide$direction,
             horizontal = {
               bw <- barwidth.c / nrow(guide$bar)
               bx <- (seq(nrow(guide$bar)) - 1) * bw
               rectGrob(x = bx, y = 0, vjust = 0, hjust = 0, width = bw, height = barheight.c, default.units = "mm",
                        gp = gpar(col = NA, fill = guide$bar$colour))
             },
             vertical = {
               bh <- barheight.c / nrow(guide$bar)
               by <- (seq(nrow(guide$bar)) - 1) * bh
               rectGrob(x = 0, y = by, vjust = 0, hjust = 0, width = barwidth.c, height = bh, default.units = "mm",
                        gp = gpar(col = NA, fill = guide$bar$colour))
             })
    }

  # ********************************************************
  # here is the change to draw a border around the color bar
  grob.bar <- grobTree(grob.bar, 
    rectGrob(width = barwidth.c, height = barheight.c, default.units = "mm", gp = gpar(col = "black", fill = NA)))
  # ********************************************************

  # tick and label position
  tic_pos.c <- rescale(guide$key$.value, c(0.5, guide$nbin - 0.5), guide$bar$value[c(1, nrow(guide$bar))]) * barlength.c / guide$nbin
  label_pos <- unit(tic_pos.c, "mm")
  if (!guide$draw.ulim) tic_pos.c <- tic_pos.c[-1]
  if (!guide$draw.llim) tic_pos.c <- tic_pos.c[-length(tic_pos.c)]

  # title
  grob.title <- ggplot2:::ggname("guide.title",
                       element_grob(
                         guide$title.theme %||% calc_element("legend.title", theme),
                         label = guide$title,
                         hjust = guide$title.hjust %||% theme$legend.title.align %||% 0,
                         vjust = guide$title.vjust %||% 0.5
                       )
  )


  title_width <- convertWidth(grobWidth(grob.title), "mm")
  title_width.c <- c(title_width)
  title_height <- convertHeight(grobHeight(grob.title), "mm")
  title_height.c <- c(title_height)

  # gap between keys etc
  hgap <- ggplot2:::width_cm(theme$legend.spacing.x  %||% unit(0.3, "line"))
  vgap <- ggplot2:::height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_height, "cm")))

  # label
  label.theme <- guide$label.theme %||% calc_element("legend.text", theme)
  grob.label <- {
    if (!guide$label)
      zeroGrob()
    else {
      hjust <- x <- guide$label.hjust %||% theme$legend.text.align %||%
        if (any(is.expression(guide$key$.label))) 1 else switch(guide$direction, horizontal = 0.5, vertical = 0)
      vjust <- y <- guide$label.vjust %||% 0.5
      switch(guide$direction, horizontal = {x <- label_pos; y <- vjust}, "vertical" = {x <- hjust; y <- label_pos})

      label <- guide$key$.label

      # If any of the labels are quoted language objects, convert them
      # to expressions. Labels from formatter functions can return these
      if (any(vapply(label, is.call, logical(1)))) {
        label <- lapply(label, function(l) {
          if (is.call(l)) substitute(expression(x), list(x = l))
          else l
        })
        label <- do.call(c, label)
      }
      g <- element_grob(element = label.theme, label = label,
                        x = x, y = y, hjust = hjust, vjust = vjust)
      ggplot2:::ggname("guide.label", g)
    }
  }

  label_width <- convertWidth(grobWidth(grob.label), "mm")
  label_width.c <- c(label_width)
  label_height <- convertHeight(grobHeight(grob.label), "mm")
  label_height.c <- c(label_height)

  # ticks
  grob.ticks <-
    if (!guide$ticks) zeroGrob()
  else {
    switch(guide$direction,
           "horizontal" = {
             x0 = rep(tic_pos.c, 2)
             y0 = c(rep(0, nbreak), rep(barheight.c * (4/5), nbreak))
             x1 = rep(tic_pos.c, 2)
             y1 = c(rep(barheight.c * (1/5), nbreak), rep(barheight.c, nbreak))
           },
           "vertical" = {
             x0 = c(rep(0, nbreak), rep(barwidth.c * (4/5), nbreak))
             y0 = rep(tic_pos.c, 2)
             x1 = c(rep(barwidth.c * (1/5), nbreak), rep(barwidth.c, nbreak))
             y1 = rep(tic_pos.c, 2)
           })
    segmentsGrob(x0 = x0, y0 = y0, x1 = x1, y1 = y1,
                 default.units = "mm", gp = gpar(col = "white", lwd = 0.5, lineend = "butt"))
  }

  # layout of bar and label
  switch(guide$direction,
         "horizontal" = {
           switch(label.position,
                  "top" = {
                    bl_widths <- barwidth.c
                    bl_heights <- c(label_height.c, vgap, barheight.c)
                    vps <- list(bar.row = 3, bar.col = 1,
                                label.row = 1, label.col = 1)
                  },
                  "bottom" = {
                    bl_widths <- barwidth.c
                    bl_heights <- c(barheight.c, vgap, label_height.c)
                    vps <- list(bar.row = 1, bar.col = 1,
                                label.row = 3, label.col = 1)
                  })
         },
         "vertical" = {
           switch(label.position,
                  "left" = {
                    bl_widths <- c(label_width.c, vgap, barwidth.c)
                    bl_heights <- barheight.c
                    vps <- list(bar.row = 1, bar.col = 3,
                                label.row = 1, label.col = 1)
                  },
                  "right" = {
                    bl_widths <- c(barwidth.c, vgap, label_width.c)
                    bl_heights <- barheight.c
                    vps <- list(bar.row = 1, bar.col = 1,
                                label.row = 1, label.col = 3)
                  })
         })

  # layout of title and bar+label
  switch(guide$title.position,
         "top" = {
           widths <- c(bl_widths, max(0, title_width.c - sum(bl_widths)))
           heights <- c(title_height.c, vgap, bl_heights)
           vps <- with(vps,
                       list(bar.row = bar.row + 2, bar.col = bar.col,
                            label.row = label.row + 2, label.col = label.col,
                            title.row = 1, title.col = 1:length(widths)))
         },
         "bottom" = {
           widths <- c(bl_widths, max(0, title_width.c - sum(bl_widths)))
           heights <- c(bl_heights, vgap, title_height.c)
           vps <- with(vps,
                       list(bar.row = bar.row, bar.col = bar.col,
                            label.row = label.row, label.col = label.col,
                            title.row = length(heights), title.col = 1:length(widths)))
         },
         "left" = {
           widths <- c(title_width.c, hgap, bl_widths)
           heights <- c(bl_heights, max(0, title_height.c - sum(bl_heights)))
           vps <- with(vps,
                       list(bar.row = bar.row, bar.col = bar.col + 2,
                            label.row = label.row, label.col = label.col + 2,
                            title.row = 1:length(heights), title.col = 1))
         },
         "right" = {
           widths <- c(bl_widths, hgap, title_width.c)
           heights <- c(bl_heights, max(0, title_height.c - sum(bl_heights)))
           vps <- with(vps,
                       list(bar.row = bar.row, bar.col = bar.col,
                            label.row = label.row, label.col = label.col,
                            title.row = 1:length(heights), title.col = length(widths)))
         })

  # background
  grob.background <- ggplot2:::element_render(theme, "legend.background")

  # padding
  padding <- convertUnit(theme$legend.margin %||% margin(), "mm")
  widths <- c(padding[4], widths, padding[2])
  heights <- c(padding[1], heights, padding[3])

  gt <- gtable(widths = unit(widths, "mm"), heights = unit(heights, "mm"))
  gt <- gtable_add_grob(gt, grob.background, name = "background", clip = "off",
                        t = 1, r = -1, b = -1, l = 1)
  gt <- gtable_add_grob(gt, grob.bar, name = "bar", clip = "off",
                        t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col),
                        b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col))
  gt <- gtable_add_grob(gt, grob.label, name = "label", clip = "off",
                        t = 1 + min(vps$label.row), r = 1 + max(vps$label.col),
                        b = 1 + max(vps$label.row), l = 1 + min(vps$label.col))
  gt <- gtable_add_grob(gt, grob.title, name = "title", clip = "off",
                        t = 1 + min(vps$title.row), r = 1 + max(vps$title.col),
                        b = 1 + max(vps$title.row), l = 1 + min(vps$title.col))
  gt <- gtable_add_grob(gt, grob.ticks, name = "ticks", clip = "off",
                        t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col),
                        b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col))

  gt
}

Answer 3

我不确定您是否可以自动完成，但这里是使用grid.rect 手动绘制框的方法。您可以更改x、y、width 或height 以满足您的需求

library(grid)
grid.rect(x= 0.5, y = 0.075, width = 0.355, height = 0.05, 
          gp = gpar(lwd = 1, col = "black", fill = NA))

查看ggplot2源代码，我猜你可以修改draw_key_rect来获得边框颜色

draw_key_rect <- function(data, params, size) {
  rectGrob(gp = gpar(
    col = NA,
    fill = alpha(data$fill, data$alpha),
    lty = data$linetype
  ))
}

由reprex package (v0.2.0) 于 2018 年 4 月 27 日创建。