ggplot2：当重叠两个图以获得右侧的轴时，不显示第二个图的图例

Question

我正在使用ggplot_dual_axis()Stack Overflow 答案中的函数：如何将转换后的比例放在 ggplot2 的右侧？为了显示两个 Y 轴，一个在右侧，一个在左侧。该函数是一团乱七八糟的东西，基本上将两个图重叠在一起，一个 Y 轴在左侧，另一个 Y 轴在右侧。然而，它似乎并没有从正确的情节中获取所有元素，特别是图例。这很重要的原因是它首先显示左图，导致网格线被写在图例上。我对代码的理解不足以ggplot_dual_axis()修复它。有懂的人可以帮助我吗？

这是我的代码：

library(ggplot2)
library(reshape2)
library(scales) # for format_format

# See /sf/ask/1329230101/
ggplot_dual_axis <- function(lhs, rhs, axis.title.y.rhs = "rotate") {
  # 1. Fix the right y-axis label justification
    rhs <- rhs + theme(axis.text.y = element_text(hjust = 0))
  # 2. Rotate the right y-axis label by 270 degrees by default
    if (missing(axis.title.y.rhs) | 
        axis.title.y.rhs %in% c("rotate", "rotated")) {
        rhs <- rhs + theme(axis.title.y = element_text(angle = 270)) 
    }
  # 3a. Use only major grid lines for the left axis
    lhs <- lhs + theme(panel.grid.minor = element_blank())
  # 3b. Use only major grid lines for the right axis
  #     force transparency of the backgrounds to allow grid lines to show
    rhs <- rhs + theme(panel.grid.minor = element_blank(), 
        panel.background = element_rect(fill = "transparent", colour = NA), 
        plot.background = element_rect(fill = "transparent", colour = NA))
# Process gtable objects
  # 4. Extract gtable
    library("gtable") # loads the grid package
    g1 <- ggplot_gtable(ggplot_build(lhs))
    g2 <- ggplot_gtable(ggplot_build(rhs))
  # 5. Overlap the panel of the rhs plot on that of the lhs plot
    pp <- c(subset(g1$layout, name == "panel", se = t:r))
    g <- gtable_add_grob(g1, 
        g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)
  # Tweak axis position and labels
    ia <- which(g2$layout$name == "axis-l")
    ga <- g2$grobs[[ia]]
    ax <- ga$children[["axis"]]  # ga$children[[2]]
    ax$widths <- rev(ax$widths)
    ax$grobs <- rev(ax$grobs)
    ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
    g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
    g <- gtable_add_grob(g, ax, pp$t, length(g$widths) - 1, pp$b)
    g <- gtable_add_grob(g, g2$grobs[[7]], pp$t, length(g$widths), pp$b)
  # Display plot with arrangeGrob wrapper arrangeGrob(g)
    library("gridExtra")
    grid.newpage()
    return(arrangeGrob(g))
}

####### Set up data
t = read.table("beadle-enwiki-norestrict-50-50.nb.uniform.dat", header=TRUE)
colnames(t) = c("acc", "mean", "median", "degrees")
t2 = read.table("beadle-enwiki-restrict-50-50.nb.uniform.dat", header=TRUE)
colnames(t2) = c("acc.restrict", "mean.restrict", "median.restrict", "degrees")
# Convert from wide to long format (opposite is 'cast');
# cols will be 'x', 'metric' and 'value'
data = melt(unique(t), id = "degrees", variable.name="metric", value.name="value", na.rm=T)
data2 = melt(unique(t2), id = "degrees", variable.name="metric", value.name="value", na.rm=T)
data = rbind(data, data2)
data[data$metric == "acc","value"] = 3000 - data[data$metric == "acc","value"] * 100 
data[data$metric == "acc.restrict","value"] = 3000 - data[data$metric == "acc.restrict","value"] * 100 
# Extract only those where metric is Acc or Median
data = subset(data, metric=="acc" | metric=="median" | metric=="acc.restrict" |
    metric=="median.restrict")
# Create a data frame to simulate a horizontal line for Naive Bayes
# instead of geom_hline(), which produces two legends in a messed-up way,
# with metric values 1 and 2 duplicated in the two. You can eliminate the
# duplication by taking out 'linetype=metric' in the call to 'ggplot' below.
#newdf = data.frame(degrees=c(-Inf, Inf), value=84.49, metric="Naive Bayes")

create_ggplot = function() {
  return(ggplot(data, aes(degrees, value, group=metric, color=metric, shape=metric, linetype=metric)) +
  scale_x_sqrt(breaks=c(0.1,0.25,0.5,1,2,3,4,5), labels=format_format(drop0trailing=TRUE)) +
  # Override line types; not totally necessary
  scale_linetype_manual(values = c(1,3,1,3)) +
  # Override shapes; important to have NA for third (Naive Bayes) shape
  scale_shape_manual(values = c(16,17,18,21)) +
  # Override colors; not totally necessary
  scale_color_manual(values = c("red", "blue","orange","black")) +
  # Set the title on the legend. All three have to agree or we get multiple legends.
  # We can also set these as the first parameters to scale_*_manual(), e.g.
  # scale_linetype_manual("metric", values = c(1,3,1,3))
  labs(color = "metric", shape = "metric", linetype = "metric")
  )
}

####### Plot data
p1 = (create_ggplot()
  + xlab(NULL)
  + ylab("Kilometers")
  + scale_y_continuous(trans="reverse", breaks = seq(from = 0, to = 3000, by = 500))
  + geom_line(linetype = "blank")
  + geom_point() # Draw points for same
  # Put the legend inside of the plot ...
  + theme(legend.position=c(0.85,0.82))
  # ... and make the background transparent.
  + theme(legend.background=element_blank())
  )

p2 = (create_ggplot()
  + xlab("K-d subdivision factor")
  + ylab("Acc@161 (pct)")
  + scale_y_continuous(trans = "reverse",
        labels = c("30%", "25%", "20%", "15%", "10%", "5%", "0%"),
        breaks = seq(from = 0, to = 3000, by = 500))
  + geom_point()
  + geom_smooth(se = FALSE, span=0.2)
  #+ theme(legend.position=c(0.8,0.4))
  )

p <- ggplot_dual_axis(lhs = p1, rhs = p2)
print(p)

这是得到的：

注意网格线如何穿过图例；在言语中尤其明显。

另外，当我使用pdf()并将dev.off()图像另存为 PDF 时，我得到 3 页，其中前两页是空白的。知道如何解决这个问题并只获得一页吗？

谢谢！！

顺便说一句，这是文件beadle-enwiki-restrict-50-50.nb.uniform.dat：

Acc@161  Mean   Median Param
 26.47 1196.18  876.86 0.10
 25.98 1248.06  876.86 0.15
 26.47 1220.19  895.41 0.25
 25.00 1160.03  828.01 0.35
 28.92 1070.64  718.03 0.50
 29.41 1017.81  714.61 0.60
 30.39 1045.87  658.71 0.70
 31.37  970.27  670.57 0.75
 31.86  970.59  615.73 0.80
 31.37 1034.13  693.35 0.85
 32.84 1006.79  580.53 0.90
 30.39  970.15  670.58 0.95
 28.43 1043.27  734.25 1.05
 30.39  948.51  556.36 1.10
 29.90  961.27  628.30 1.15
 33.33 1025.30  655.12 1.20
 33.33 1025.30  655.12 1.20
 33.82  905.29  531.95 1.25
 29.90 1015.78  625.00 1.30
 28.43  959.12  570.56 1.35
 29.90  951.32  600.57 1.40
 28.92  920.92  603.40 1.45
 28.43  973.23  627.40 1.50
 31.86  905.70  504.89 1.55
 31.86  923.96  629.65 1.60
 32.84  948.97  576.03 1.65
 30.88  895.25  540.52 1.70
 29.41  929.82  655.11 1.75
 28.43 1001.63  698.88 1.80
 25.98 1002.50  639.88 1.85
 29.90  916.08  618.93 1.90
 28.92  912.40  571.47 1.95
 29.41 1013.34  652.83 1
 27.45  890.13  552.36 2.50
 27.45  890.13  552.36 2.50
 27.45  916.58  603.20 2
 27.45  916.58  603.20 2
 23.53  964.79  687.81 3.50
 26.96  933.72  634.51 3
 26.96  933.72  634.51 3
 15.69  998.84  671.73 4.50
 15.69  998.84  671.73 4.50
 18.63 1002.80  759.07 4
 18.63 1002.80  759.07 4
 13.73  981.85  662.07 5

这是文件beadle-enwiki-norestrict-50-50.nb.uniform.dat：

Acc@161  Mean   Median Param
 23.04 3922.81 1825.83 0.10
 22.06 3888.09 1806.71 0.15
 24.51 3490.37 1648.58 0.25
 22.55 4039.88 1758.75 0.35
 25.49 4125.88 1748.56 0.50
 25.49 4180.57 1757.72 0.60
 25.98 4320.85 1762.17 0.70
 27.94 3915.26 1110.75 0.75
 27.94 3895.97 1215.07 0.80
 25.00 4269.12 1765.45 0.85
 28.43 3877.07 1264.86 0.90
 26.47 4010.01 1261.95 0.95
 25.98 4338.20 1640.40 1.05
 25.98 3800.07 1115.98 1.10
 26.47 3924.18 1134.45 1.15
 25.98 3992.77 1400.51 1
 28.43 3966.25 1581.52 1.20
 29.90 3946.38 1169.55 1.25
 26.96 4036.76 1570.82 1.30
 25.00 4128.11 1597.96 1.35
 24.51 4293.44 1556.12 1.40
 23.04 4448.78 1725.62 1.45
 21.57 4401.99 1773.66 1.50
 26.96 3697.66 1066.88 1.55
 26.96 4033.89 1144.61 1.60
 27.45 3982.82 1081.80 1.65
 26.96 4050.45 1251.99 1.70
 25.49 3942.11 1117.52 1.75
 24.51 4265.03 1238.81 1.80
 23.53 3835.24 1250.52 1.85
 23.53 4123.50 1563.50 1.90
 24.02 4138.78 1258.69 1.95
 24.51 4321.01 1623.01 2
 24.02 4099.53 1216.75 2.50
 23.04 4294.64 1280.79 3
 20.59 4097.54 1262.57 3.50
 14.71 4612.40 1500.24 4
 11.76 5001.09 2029.41 4.50
 11.76 4913.45 1811.31 5

Answer 1

您可以使用 将绘图添加guide-box到lhs绘图顶部gtable_add_grob。这看起来像那样

dimGB1 <- c(subset(g1$layout, name == "guide-box", se = t:r))
g <- gtable_add_grob(g, 
                     g1$grobs[[which(g1$layout$name == "guide-box")]], 
                     dimGB1$t, dimGB1$l, dimGB1$b, dimGB1$l, z=-Inf)

请注意，z = -Inf将新的放在grob上面。整个函数将如下所示：

##' function named ggplot_dual_axis()
##' Takes 2 ggplot plots and makes a dual y-axis plot
##' function takes 2 compulsory arguments and 1 optional argument
##' arg lhs is the ggplot whose y-axis is to be displayed on the left
##' arg rhs is the ggplot whose y-axis is to be displayed on the right
##' arg 'axis.title.y.rhs' takes value "rotate" to rotate right y-axis label
##' The function does as little as possible, namely:
##'  # display the lhs plot without minor grid lines and with a
##'  transparent background to allow grid lines to show
##'  # display the rhs plot without minor grid lines and with a
##'  secondary y axis, a rotated axis label, without minor grid lines
##'  # justify the y-axis label by setting 'hjust = 0' in 'axis.text.y'
##'  # rotate the right plot 'axis.title.y' by 270 degrees, for symmetry
##'  # rotation can be turned off with 'axis.title.y.rhs' option
##' Source: http://stackoverflow.com/questions/18989001/how-can-i-put-a-transformed-scale-on-the-right-side-of-a-ggplot2
##'  
ggplot_dual_axis <- function(lhs, rhs, axis.title.y.rhs = "rotate") {
  # 1. Fix the right y-axis label justification
  rhs <- rhs + theme(axis.text.y = element_text(hjust = 0))
  # 2. Rotate the right y-axis label by 270 degrees by default
  if (missing(axis.title.y.rhs) | 
        axis.title.y.rhs %in% c("rotate", "rotated")) {
    rhs <- rhs + theme(axis.title.y = element_text(angle = 270)) 
  }
  # 3a. Use only major grid lines for the left axis
  lhs <- lhs + theme(panel.grid.minor = element_blank())
  # 3b. Use only major grid lines for the right axis
  #     force transparency of the backgrounds to allow grid lines to show
  rhs <- rhs + theme(panel.grid.minor = element_blank(), 
                     panel.background = element_rect(fill = "transparent", colour = NA), 
                     plot.background = element_rect(fill = "transparent", colour = NA))
  # Process gtable objects
  # 4. Extract gtable
  library("gtable") # loads the grid package
  g1 <- ggplot_gtable(ggplot_build(lhs))
  g2 <- ggplot_gtable(ggplot_build(rhs))
  # 5. Overlap the panel of the rhs plot on that of the lhs plot
  pp <- c(subset(g1$layout, name == "panel", se = t:r))
  g <- gtable_add_grob(g1, 
                       g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)
  # Tweak axis position and labels
  ia <- which(g2$layout$name == "axis-l")
  ga <- g2$grobs[[ia]]
  ax <- ga$children[["axis"]]  # ga$children[[2]]
  ax$widths <- rev(ax$widths)
  ax$grobs <- rev(ax$grobs)
  ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
  g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
  g <- gtable_add_grob(g, ax, pp$t, length(g$widths) - 1, pp$b)
  g <- gtable_add_grob(g, g2$grobs[[7]], pp$t, length(g$widths), pp$b)
  # add legend on top
  if ("guide-box" %in% g1$layout$name){
    dimGB1 <- c(subset(g1$layout, name == "guide-box", se = t:r))
    g <- gtable_add_grob(g, 
                         g1$grobs[[which(g1$layout$name == "guide-box")]], 
                         dimGB1$t, dimGB1$l, dimGB1$b, dimGB1$l, z=-Inf)
  }
  # Display plot with arrangeGrob wrapper arrangeGrob(g)
  library("gridExtra")
  grid.newpage()
  return(arrangeGrob(g))
}