r - 如何将图例从颜色条更改为 "regular legend"，仍然使用颜色渐变

Question

包shinyscreenshot无法打印plotly颜色条(shiny screenshot appears with colorless legend)，所以我正在寻找一种仍然使用颜色渐变但将图例显示为的方法如果它被因式分解。

---

示例

带颜色条的原点图

目标

图例中是否有 4、5 或 X 个数据点并不重要。

---

MWE

library(ggplot2)
library(plotly)

ggplotly(
  ggplot(data=mtcars,
         aes(x=mpg, y=cyl, color=qsec)) +
    geom_point()
)

Answer 1

Plotly 不会为您制作离散的图例，但您仍然可以实现它。

首先，我将 ggplot 和 ggplotly 分配给对象。

plt <- ggplotly(
  ggplot(data=mtcars,
         aes(x=mpg, y=cyl, color=qsec)) +
    geom_point()
)

g <- ggplot(data=mtcars,
            aes(x=mpg, y=cyl, color=qsec)) +
  geom_point()

接下来，使用ggplot对象背后的数据，结合mtcars，通过qsec数据框获取颜色，以便您知道什么颜色与什么值相配。

colByVal <- cbind(ggplot_build(g)$data[[1]], mtcars) %>% 
  as.data.frame() %>% 
  select(colour, qsec) %>% arrange(qsec) %>% 
  group_by(colour) %>% 
  summarise(qsec = median(qsec)) %>% as.data.frame()

我认为四个或五个值是理想的。我只是使用 summary 来选择它们。然而，这不是必要的。显然，您可以选择任意数量的值。这些是我将在图例中显示的值。

parts <- summary(colByVal$qsec)
# drop the mean or median (the same color probably)
parts <- parts[-4]

接下来，使用 DescTools::Closest 查找最接近汇总值的 qsec 值。

vals <- lapply(parts, function(k) {
  DescTools::Closest(colByVal$qsec, k)[1]
}) %>% unlist(use.names = F)

使用这些 qsec 值以及按颜色显示值的数据框来获取与这些值关联的颜色。

cols <- colByVal %>% 
  filter(qsec %in% vals) %>% select(colour) %>% 
  unlist(use.names = F)

使用颜色和值(图例标签)、形状和注释(圆圈和文本)来重建图例。每个图例项之间只有一个元素需要更改，即图例条目的 y 位置。

ys <- seq(from = .7, by = .07, length.out = length(cols))

有两个功能:形状和注释。使用lapply，通过这些函数遍历值、颜色和 y 值以创建形状和注释。

# create shapes
shp <- function(y, cr) { # y0, and fillcolor
  list(type = "circle",
       xref = "paper", x0 = 1.1, x1 = 1.125,
       yref = "paper", y0 = y, y1 = y + .025,
       fillcolor = cr, yanchor = "center",
       line = list(color = cr))
}
# create labels
ano <- function(ya, lab) { # y and label
  list(x = 1.13, y = ya + .035, text = lab, 
       xref = "paper", yref = "paper", 
       xanchor = "left", yanchor = 'top', 
       showarrow = F)
}
# the shapes list
shps <- lapply(1:length(cols),
               function(j) {
                 shp(ys[j], cols[j])
               })
# the labels list
labs <- lapply(1:length(cols),
               function(i) {
                 ano(ys[i], as.character(vals[i]))
               })

当您使用 ggplotly 时，由于某种原因，它会以空形状结束 ggplotly 对象。这会干扰在 layout 中调用 shapes 的能力(这是正确的方法)。你必须用形状来解决这个问题。此外，图例栏需要消失。一旦您放下图例栏，Plotly 将调整绘图边距。如果您不重新添加边距，则使用形状和注释创建的图例将被隐藏。

# ggplot > ggplotly adds an empty shape; this conflicts with calling it in
#   layout(); we'll replace 'shapes' first
plt$x$layout$shapes <- shps
plt %>% hide_colorbar() %>% 
  layout(annotations = labs, showlegend = F, 
         margin = list(t = 30, r = 100, l = 50, b = 30, pad = 3))

所有代码都集中在一个 block 中:

library(tidyverse)
library(plotly)
# original plot
plt <- ggplotly(
  ggplot(data=mtcars,
         aes(x=mpg, y=cyl, color=qsec)) +
    geom_point()
)
g <- ggplot(data=mtcars,
            aes(x=mpg, y=cyl, color=qsec)) +
  geom_point()
# color by qsec values frame
colByVal <- cbind(ggplot_build(g)$data[[1]], mtcars) %>% 
  as.data.frame() %>% 
  select(colour, qsec) %>% arrange(qsec) %>% 
  group_by(colour) %>% 
  summarise(qsec = median(qsec)) %>% as.data.frame()

parts <- summary(colByVal$qsec)
# drop the mean or median (the same color probably)
parts <- parts[-4]

vals <- lapply(parts, function(k) {
  DescTools::Closest(colByVal$qsec, k)[1]
}) %>% unlist(use.names = F)

cols <- colByVal %>% 
  filter(qsec %in% vals) %>% select(colour) %>% 
  unlist(use.names = F)

ys <- seq(from = .7, by = .07, length.out = length(cols))

# create shapes
shp <- function(y, cr) { # y0, and fillcolor
  list(type = "circle",
       xref = "paper", x0 = 1.1, x1 = 1.125,
       yref = "paper", y0 = y, y1 = y + .025,
       fillcolor = cr, yanchor = "center",
       line = list(color = cr))
}
# create labels
ano <- function(ya, lab) { # y and label
  list(x = 1.13, y = ya + .035, text = lab, 
       xref = "paper", yref = "paper", 
       xanchor = "left", yanchor = 'top', 
       showarrow = F)
}
# the shapes list
shps <- lapply(1:length(cols),
               function(j) {
                 shp(ys[j], cols[j])
               })
# the labels list
labs <- lapply(1:length(cols),
               function(i) {
                 ano(ys[i], as.character(vals[i]))
               })
# ggplot > ggplotly adds an empty shape; this conflicts with calling it in
#   layout(); we'll replace 'shapes' first
plt$x$layout$shapes <- shps
plt %>% hide_colorbar() %>% 
  layout(annotations = labs, showlegend = F, 
         margin = list(t = 30, r = 100, l = 50, b = 30, pad = 3))