рисовать границу вокруг легенды непрерывный градиент цветная полоса тепловой карты

Как добавить границу вокруг непрерывной цветовой полосы градиента. По умолчанию ggplot берет цвет заливки, указанный в scale_fill_gradient.

Самый близкий ответ, который я нашел, это тот, но это не помогло мне с этой задачей.

Я также пробовал это с ключом легенды, но не помог мне.

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)
  )

Текущий график:

Ожидаемый график:

Ответ 1

Теперь это возможно в версии ggplot2 github2 от 2 мая 2018 года и будет частью 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.colour линий.
ticks.linewidth Ширина тиковых линий.

Эти пять аргументов должны учитывать наиболее часто запрашиваемые стили. По-моему, более сложные стили (например, тиковые линии снаружи) потребуют общего переосмысления того, как ориентируются гиды.

Ответ 2

Обновление: этот ответ устарел. Используйте это вместо этого. Я оставляю устаревший ответ только потому, что тот же принцип работает и для других проблем.

Код чертежа легенды ggplot2 немного беспорядок и не очень настраиваемый. Единственный способ, с помощью которого я могу получить этот эффект, - внести изменения в guide_colorbar(). К сожалению, для этого требуется скопировать много кода ggplot2.

В настоящее время я запускаю версию ggplot2 для разработки, поэтому точный код, который я буду размещать, гарантирован только с этим. (Я использую то, что на github на сегодняшний день, 4/27/2018). Но принцип будет работать и с выпущенной версией.

Сначала код построения, как только мы определили нашу новую функцию легенды:

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 в код темы, чтобы переместить ярлыки в сторону от colorbar. В результате получается следующее:

Теперь скопированный код цветового кода. Это в основном дословная копия ggplot2. Для всех внутренних функций ggplot2, которые используются, мы должны добавить ggplot: к вызову функции, например ggplot2:width_cm вместо width_cm. Фактическое изменение, которое рисует контур, является только двумя дополнительными строками кода, и оно четко отмечено комментариями.

# 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
}

Ответ 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
  ))
}

Создан в 2018-04-27 пакетом reprex (v0.2.0).