stat_function 和 legends：创建具有映射到不同变量的两个单独颜色图例的图

Question

我想将两种不同类型的图与 ggplot2 结合在一张图像中。这是我使用的代码：

fun.bar <- function(x, param = 4) {
  return(((x + 1) ^ (1 - param)) / (1 - param))
}

plot.foo <- function(df, par = c(1.7, 2:8)) {
  require(ggplot2)
  require(reshape2)
  require(RColorBrewer)
  melt.df <- melt(df)
  melt.df$ypos <- as.numeric(melt.df$variable)
  p <- ggplot(data = melt.df, aes(x = value, y = ypos, colour = variable)) +
    geom_point(position = "jitter", alpha = 0.2, size = 2) + 
    xlim(-1, 1) + ylim(-5, 5) + 
    guides(colour = 
      guide_legend("Type", override.aes = list(alpha = 1, size = 4)))
 pal <- brewer.pal(length(par), "Set1")
 for (i in seq_along(par)) {
   p <- p + stat_function(fun = fun.bar, 
     arg = list(param = par[i]), colour = pal[i], size = 1.3)
  }
  p
}

df.foo <- data.frame(A=rnorm(1000, sd=0.25), 
  B=rnorm(1000, sd=0.25), C=rnorm(1000, sd=0.25))
plot.foo(df.foo)

结果，我得到了以下图片。 但是，我想要另一个颜色从红色到粉红色的图例，在图的下部显示有关曲线参数的信息。问题是这两个部分的关键美学是颜色，因此通过scale_colour_manual() 手动覆盖会破坏现有的图例。

我知道有一个“一种审美——一个传奇”的概念，但是在这种特定情况下我该如何绕过这个限制呢？

Answer 1

在查看之前在 SO 上的stat_function 和legend 示例时，我的印象是，如果不对stat_summary 生成的每条曲线进行一些硬编码，要让两者幸福地生活在一起并不容易（我很高兴发现我错了）。参见例如here、here 和 here。在最后一个答案中@baptiste 写道：“在绘图之前构建一个data.frame 会更好”。这就是我在回答中尝试的：我使用该函数预先计算了数据，然后在图中使用geom_line 而不是stat_summary。

# load relevant packages
library(ggplot2)
library(reshape2)
library(RColorBrewer)
library(gridExtra)
library(gtable)
library(plyr)

# create base data
df <- data.frame(A = rnorm(1000, sd = 0.25), 
                 B = rnorm(1000, sd = 0.25),
                 C = rnorm(1000, sd = 0.25))    
melt.df <- melt(df)
melt.df$ypos <- as.numeric(melt.df$variable)

# plot points only, to get a colour legend for points
p1 <- ggplot(data = melt.df, aes(x = value, y = ypos, colour = variable)) +
  geom_point(position = "jitter", alpha = 0.2, size = 2) + 
  xlim(-1, 1) + ylim(-5, 5) +
  guides(colour = 
           guide_legend("Type", override.aes = list(alpha = 1, size = 4)))

p1

# grab colour legend for points
legend_points <- gtable_filter(ggplot_gtable(ggplot_build(p1)), "guide-box")

# grab colours for points. To be used in final plot
point_cols <- unique(ggplot_build(p1)[["data"]][[1]]$colour)


# create data for lines
# define function for lines
fun.bar <- function(x, param = 4) {
  return(((x + 1) ^ (1 - param)) / (1 - param))
}

# parameters for lines
pars = c(1.7, 2:8)

# for each value of parameters and x (i.e. x = melt.df$value),
# calculate ypos for lines
df2 <- ldply(.data = pars, .fun = function(pars){
  ypos = fun.bar(melt.df$value, pars)
  data.frame(pars = pars, value = melt.df$value, ypos)
})

# colour palette for lines
line_cols <- brewer.pal(length(pars), "Set1")    

# plot lines only, to get a colour legends for lines
# please note that when using ylim:
# "Observations not in this range will be dropped completely and not passed to any other layers"
# thus the warnings
p2 <- ggplot(data = df2,
             aes(x = value, y = ypos, group = pars, colour = as.factor(pars))) +
  geom_line() +
  xlim(-1, 1) + ylim(-5, 5) +
  scale_colour_manual(name = "Param", values = line_cols, labels = as.character(pars))

p2

# grab colour legend for lines
legend_lines <- gtable_filter(ggplot_gtable(ggplot_build(p2)), "guide-box") 


# plot both points and lines with legend suppressed
p3 <- ggplot(data = melt.df, aes(x = value, y = ypos)) +
  geom_point(aes(colour = variable),
             position = "jitter", alpha = 0.2, size = 2) +
  geom_line(data = df2, aes(group = pars, colour = as.factor(pars))) +
  xlim(-1, 1) + ylim(-5, 5) +
  theme(legend.position = "none") +
  scale_colour_manual(values = c(line_cols, point_cols))
  # the colours in 'scale_colour_manual' are added in the order they appear in the legend
  # line colour (2, 3) appear before point cols (A, B, C)
  # slightly hard-coded
  # see alternative below

p3

# arrange plot and legends for points and lines with viewports
# define plotting regions (viewports)
# some hard-coding of positions
grid.newpage()
vp_plot <- viewport(x = 0.45, y = 0.5,
                    width = 0.9, height = 1)

vp_legend_points <- viewport(x = 0.91, y = 0.7,
                      width = 0.1, height = 0.25)

vp_legend_lines <- viewport(x = 0.93, y = 0.35,
                         width = 0.1, height = 0.75)

# add plot
print(p3, vp = vp_plot)

# add legend for points
upViewport(0)
pushViewport(vp_legend_points)
grid.draw(legend_points)

# add legend for lines
upViewport(0)
pushViewport(vp_legend_lines)
grid.draw(legend_lines)

# A second alternative, with greater control over the colours
# First, plot both points and lines with colour legend suppressed
# let ggplot choose the colours
p3 <- ggplot(data = melt.df, aes(x = value, y = ypos)) +
  geom_point(aes(colour = variable),
             position = "jitter", alpha = 0.2, size = 2) +
  geom_line(data = df2, aes(group = pars, colour = as.factor(pars))) +
  xlim(-1, 1) + ylim(-5, 5) +
  theme(legend.position = "none")

p3

# build p3 for rendering
# get a list of data frames (one for each layer) that can be manipulated
pp3 <- ggplot_build(p3)

# grab the whole vector of point colours from plot p1
point_cols_vec <- ggplot_build(p1)[["data"]][[1]]$colour

# grab the whole vector of line colours from plot p2
line_cols_vec <- ggplot_build(p2)[["data"]][[1]]$colour

# replace 'colour' values for points, with the colours from plot p1
# points are in the first layer -> first element in the 'data' list
pp3[["data"]][[1]]$colour <- point_cols_vec

# replace 'colour' values for lines, with the colours from plot p2
# lines are in the second layer -> second element in the 'data' list
pp3[["data"]][[2]]$colour <- line_cols_vec

# build a plot grob from the data generated by ggplot_build
# to be used in grid.draw below
grob3 <- ggplot_gtable(pp3)

# arrange plot and the two legends with viewports
# define plotting regions (viewports)
vp_plot <- viewport(x = 0.45, y = 0.5,
                    width = 0.9, height = 1)

vp_legend_points <- viewport(x = 0.91, y = 0.7,
                             width = 0.1, height = 0.25)

vp_legend_lines <- viewport(x = 0.92, y = 0.35,
                            width = 0.1, height = 0.75)

grid.newpage()

pushViewport(vp_plot)
grid.draw(grob3)

upViewport(0)
pushViewport(vp_legend_points)
grid.draw(legend_points)

upViewport(0)
pushViewport(vp_legend_lines)
grid.draw(legend_lines)

Answer 2

我想分享一个我在等待这个问题的答案时使用的快速技巧。

fun.bar <- function(x, param = 4) {
  return(((x + 1) ^ (1 - param)) / (1 - param))
}

plot.foo <- function(df, par = c(1.7, 2:8)) {
  require(ggplot2)
  require(reshape2)
  require(RColorBrewer)
  melt.df <- melt(df)
  melt.df$ypos <- as.numeric(melt.df$variable)
  # the trick is to override factor levels
  levels(melt.df$variable) <- 1:nlevels(melt.df$variable)
  p <- ggplot(data = melt.df, aes(x = value, y = ypos, colour = variable)) +
    geom_point(position = "jitter", alpha = 0.2, size = 2) + 
    xlim(-1, 1) + ylim(-5, 5) + 
    guides(colour = 
      guide_legend("Type", override.aes = list(alpha = 1, size = 4)))
  pal <- brewer.pal(length(par), "Set1")
  for (i in seq_along(par)) {
    p <- p + stat_function(fun = fun.bar, 
      arg = list(param = par[i]), colour = pal[i], size = 1.3)
  }
  # points are displayed by supplying values for manual scale
  p + scale_colour_manual(values = pal, limits = seq_along(par), labels = par) + 
  # this needs proper "for" cycle to remove hardcoded labels
  annotate("text", x = 0.8, y = 1, label = "A", size = 8) +
  annotate("text", x = 0.8, y = 2, label = "B", size = 8) +
  annotate("text", x = 0.8, y = 3, label = "C", size = 8)
}

df.foo <- data.frame(A=rnorm(1000, sd=0.25), 
  B=rnorm(1000, sd=0.25), C=rnorm(1000, sd=0.25))
plot.foo(df.foo)

这种解决方法甚至不如@Henrik 提供的答案那么棒，但适合我的一次性需求。