【问题标题】:How to add lines on combined ggplots, from points on one plot to points on the other?如何在组合 ggplots 上添加线,从一个图上的点到另一个图上的点?
【发布时间】:2020-01-03 21:42:40
【问题描述】:

我需要在 ggplot 中重现 InDesign 中生成的绘图以实现重现性。

在这个特定的示例中,我将两个图组合成一个复合图(为此我使用了包 {patchwork})。

然后我需要将连接一个绘图上的关键点的线与底部绘图上的相应点重叠。

这两个图是从相同的数据生成的,具有相同的 x 轴值,但不同的 y 轴值。

我在 Stack Overflow 上看到了这些示例,但这些示例涉及跨方面绘制线条,这在此处不起作用,因为我试图在单独的图中绘制线条:

我尝试了几种方法,到目前为止我最接近的是:

  1. 使用 {grid} 包添加带有 grobs 的行
  2. 使用 {gtable} 将第二个绘图转换为 gtable,并将面板的剪辑设置为关闭,以便我可以将线条向上延伸到绘图面板之外。
  3. 使用{patchwork} 再次将这些图组合成一个图像。

问题出现在最后一步,因为 x 轴现在不再像添加线并将剪辑设置为关闭之前那样排列(参见代码中的示例)。

我还尝试将这些图与ggarrange{cowplot}{egg}{patchwork} 最接近。

以下是我对可以创建的最佳最小代表的尝试,但仍然捕捉到我想要实现的细微差别。

library(ggplot2)
library(dplyr)
library(tidyr)
library(patchwork)
library(gtable)
library(grid)

# DATA
x <- 1:20
data <- data.frame(
  quantity = x,
  curve1 = 10 + 50*exp(-0.2 * x),
  curve2 = 5 + 50*exp(-0.5 * x),
  profit = c(seq(10, 100, by = 10),
             seq(120, -240, by = -40))
)

data_long <- data %>%
  gather(key = "variable", value = "value", -quantity)

# POINTS AND LINES
POINTS <- data.frame(
  label = c("B", "C"),
  quantity = c(5, 10),
  value = c(28.39397, 16.76676),
  profit = c(50, 100)
)

GROB <- linesGrob()

# Set maximum y-value to extend lines to outside of plot area
GROB_MAX <- 200

# BASE PLOTS
# Plot 1
p1 <- data_long %>%
  filter(variable != "profit") %>%
  ggplot(aes(x = quantity, y = value)) +
  geom_line(aes(color = variable)) +
  labs(x = "") +
  coord_cartesian(xlim = c(0, 20), ylim = c(0, 30), expand = FALSE) +
  theme(legend.justification = "top")
p1

# Plot 2
p2 <- data_long %>%
  filter(variable == "profit") %>%
  ggplot(aes(x = quantity, y = value)) +
  geom_line(color = "darkgreen") +
  coord_cartesian(xlim = c(0, 20), ylim = c(-100, 120), expand = FALSE) +
  theme(legend.position = "none")
p2

# PANEL A
panel_A <- p1 + p2 + plot_layout(ncol = 1)
panel_A

# PANEL B
# ATTEMPT - adding grobs to plot 1 that end at x-axis of p1
p1 <- p1 +
  annotation_custom(GROB,
                    xmin = 0,
                    xmax = POINTS$quantity[POINTS$label == "B"],
                    ymin = POINTS$value[POINTS$label == "B"],
                    ymax = POINTS$value[POINTS$label == "B"]) +
  annotation_custom(GROB,
                    xmin = POINTS$quantity[POINTS$label == "B"],
                    xmax = POINTS$quantity[POINTS$label == "B"],
                    ymin = 0,
                    ymax = POINTS$value[POINTS$label == "B"]) +
  geom_point(data = POINTS %>% filter(label == "B"), size = 1)

# ATTEMPT - adding grobs to plot 2 that extend up to meet plot 1
p2 <- p2 + annotation_custom(GROB,
                             xmin = POINTS$quantity[POINTS$label == "B"],
                             xmax = POINTS$quantity[POINTS$label == "B"],
                             ymin = POINTS$profit[POINTS$label == "B"],
                             ymax = GROB_MAX)

# Create gtable from ggplot
g2 <- ggplotGrob(p2)

# Turn clip off for panel so that line can extend above
g2$layout$clip[g2$layout$name == "panel"] <- "off"

panel_B <- p1 + g2 + plot_layout(ncol = 1)
panel_B
# Problems:
# 1. Note the shift in axes when turning the clip off so now they do not line up anymore.
# 2. Turning the clip off mean plot 2 extends below the axis. Tried experimenting with various clips.

期望 panel_B 中的图仍应像 panel_A 中一样显示,但有连接线连接图之间的点。

我正在寻求解决上述问题的帮助,或者尝试其他替代方法。

作为不运行上述代码的参考 - 我无法发布图片链接。

面板 A

面板 B:目前的样子

面板 B:我想要它的样子!

【问题讨论】:

    标签: r ggplot2 plot gtable


    【解决方案1】:

    我的解决方案有点临时,但它似乎有效。我基于以下先前的答案Left align two graph edges (ggplot)

    我将把解决方案分成三个部分来分别解决您面临的一些问题。

    与你想要的匹配的解决方案是第三个!

    一审

    在这里,我使用与此答案 Left align two graph edges (ggplot) 相同的方法对齐轴。

    # first trial 
    # plots are aligned but line in bottom plot extends to the bottom
    #
    p1_1 <- p1 +
      annotation_custom(GROB,
                        xmin = 0,
                        xmax = POINTS$quantity[POINTS$label == "B"],
                        ymin = POINTS$value[POINTS$label == "B"],
                        ymax = POINTS$value[POINTS$label == "B"]) +
      annotation_custom(GROB,
                        xmin = POINTS$quantity[POINTS$label == "B"],
                        xmax = POINTS$quantity[POINTS$label == "B"],
                        ymin = 0,
                        ymax = POINTS$value[POINTS$label == "B"]) +
      geom_point(data = POINTS %>% filter(label == "B"), size = 1)
    
    p2_1 <- p2 + annotation_custom(GROB,
                                   xmin = POINTS$quantity[POINTS$label == "B"],
                                   xmax = POINTS$quantity[POINTS$label == "B"],
                                   ymin = POINTS$profit[POINTS$label == "B"],
                                   ymax = GROB_MAX)
    
    # Create gtable from ggplot
    gA <- ggplotGrob(p1_1)
    gB <- ggplotGrob(p2_1)
    
    # Turn clip off for panel so that line can extend above
    gB$layout$clip[gB$layout$name == "panel"] <- "off"
    
    # get max width of left axis between both plots
    maxWidth = grid::unit.pmax(gA$widths[2:5], gB$widths[2:5])
    
    # set maxWidth to both plots (to align left axis)
    gA$widths[2:5] <- as.list(maxWidth)
    gB$widths[2:5] <- as.list(maxWidth)
    
    # now apply all widths from plot A to plot B 
    # (this is specific to your case because we know plot A is the one with the legend)
    gB$widths <- gA$widths
    
    grid.arrange(gA, gB, ncol=1)
    

    二审

    现在的问题是底部图中的线超出了绘图区域。解决此问题的一种方法是将coord_cartesian() 更改为scale_y_continuous()scale_x_continuous(),因为这将删除掉出绘图区域的数据。

    # second trial 
    # using scale_y_continuous and scale_x_continuous to remove data out of plot limits
    # (this could resolve the problem of the bottom plot, but creates another problem)
    #
    p1_2 <- p1_1 
    
    p2_2 <- data_long %>%
      filter(variable == "profit") %>%
      ggplot(aes(x = quantity, y = value)) +
      geom_line(color = "darkgreen") +
      scale_x_continuous(limits = c(0, 20), expand = c(0, 0)) +
      scale_y_continuous(limits=c(-100, 120), expand=c(0,0)) +
      theme(legend.position = "none") + 
      annotation_custom(GROB,
                        xmin = POINTS$quantity[POINTS$label == "B"],
                        xmax = POINTS$quantity[POINTS$label == "B"],
                        ymin = POINTS$profit[POINTS$label == "B"],
                        ymax = GROB_MAX)
    
    # Create gtable from ggplot
    gA <- ggplotGrob(p1_2)
    gB <- ggplotGrob(p2_2)
    
    # Turn clip off for panel so that line can extend above
    gB$layout$clip[gB$layout$name == "panel"] <- "off"
    
    
    # get max width of left axis between both plots
    maxWidth = grid::unit.pmax(gA$widths[2:5], gB$widths[2:5])
    
    # set maxWidth to both plots (to align left axis)
    gA$widths[2:5] <- as.list(maxWidth)
    gB$widths[2:5] <- as.list(maxWidth)
    
    # now apply all widths from plot A to plot B 
    # (this is specific to your case because we know plot A is the one with the legend)
    gB$widths <- gA$widths
    
    # but now the line does not go all the way to the bottom y axis
    grid.arrange(gA, gB, ncol=1)
    
    

    三审

    现在的问题是这条线没有一直延伸到 y 轴的底部(因为 y=-100 下面的点被删除了)。我解决这个问题的方法(非常特别)是在 y=-100 处插入点并将其添加到数据框中。

    # third trial 
    # modify the data set so value data stops at bottom of plot
    # 
    p1_3 <- p1_1 
    
    # use approx() function to interpolate value of x when y value == -100
    xvalue <- approx(x=data_long$value, y=data_long$quantity, xout=-100)$y
    
    p2_3 <- data_long %>%
      filter(variable == "profit") %>%
      # add row with interpolated point!
      rbind(data.frame(quantity=xvalue, variable = "profit", value=-100)) %>%
      ggplot(aes(x = quantity, y = value)) +
      geom_line(color = "darkgreen") +
      scale_x_continuous(limits = c(0, 20), expand = c(0, 0)) +
      scale_y_continuous(limits=c(-100, 120), expand=c(0,0)) +
      theme(legend.position = "none") + 
      annotation_custom(GROB,
                        xmin = POINTS$quantity[POINTS$label == "B"],
                        xmax = POINTS$quantity[POINTS$label == "B"],
                        ymin = POINTS$profit[POINTS$label == "B"],
                        ymax = GROB_MAX)
    
    # Create gtable from ggplot
    gA <- ggplotGrob(p1_3)
    gB <- ggplotGrob(p2_3)
    
    # Turn clip off for panel so that line can extend above
    gB$layout$clip[gB$layout$name == "panel"] <- "off"
    
    
    # get max width of left axis between both plots
    maxWidth = grid::unit.pmax(gA$widths[2:5], gB$widths[2:5])
    
    # set maxWidth to both plots (to align left axis)
    gA$widths[2:5] <- as.list(maxWidth)
    gB$widths[2:5] <- as.list(maxWidth)
    
    # now apply all widths from plot A to plot B 
    # (this is specific to your case because we know plot A is the one with the legend)
    gB$widths <- gA$widths
    
    # Now line goes all the way to the bottom y axis
    grid.arrange(gA, gB, ncol=1)
    

    【讨论】:

    • 感谢@kikoralston 的回复和帮助——它对我的数据非常有效!深入研究ggplot 的内部运作真的很有趣。
    • 出于好奇,注释行怎么会有缺口
    • 其实我之前没有注意到。当我在 R studio 中看到绘图时,没有出现小间隙。但是当我将绘图保存为 png 时,如果我使用较低的分辨率(这些图像就是这种情况),就会出现间隙。底部段一直到 y=200(GROB_MAX 变量)。我认为,根据分辨率,y=200 可能不够“高”,无法到达顶部。
    • 另外,我的答案中有一个小错字已修复。我将gB$layout$clip[g2$layout$name == "panel"] &lt;- "off" 更改为gB$layout$clip[gB$layout$name == "panel"] &lt;- "off"
    • @Cole,是的,要弄清楚将底线延伸到多高以使其到达顶线,这需要反复试验。它不是一条连续的线,而是由两条从每个图表上的相关点开始延伸到另一条的线组成。
    【解决方案2】:

    这利用facet_grid 来强制x 轴匹配。

    grobbing_lines <- tribble(
      ~facet,   ~x, ~xend,       ~y,    ~yend,
      'profit',  5,     5,       50,      Inf,
      # 'curve',   5,     5,     -Inf, 28.39397
      'curve',   -Inf,     5, 28.39397, 28.39397
    )
    
    grobbing_points <- tribble(
      ~facet,   ~x,        ~y,    
      'curve',   5,  28.39397 
    )
    
    data_long_facet <- data_long%>%
      mutate(facet = if_else(variable == 'profit', 'profit', 'curve'))
    
    p <- ggplot(data_long_facet, aes(x = quantity, y = value)) +
      geom_line(aes(color = variable))+
      facet_grid(rows = vars(facet), scales = 'free_y')+
      geom_segment(data = grobbing_lines, aes(x = x, xend = xend, y = y, yend = yend),inherit.aes = F)+
      geom_point(data = grobbing_points, aes(x = x, y = y), size = 3, inherit.aes = F)
    
    pb <- ggplot_build(p)
    pg <- ggplot_gtable(pb)
    
    #formulas to determine points in x and y locations
    data2npc <- function(x, panel = 1L, axis = "x") {
      range <- pb$layout$panel_params[[panel]][[paste0(axis,".range")]]
      scales::rescale(c(range, x), c(0,1))[-c(1,2)]
    }
    
    data_y_2npc <- function(y, panel, axis = 'y') {
      range <- pb$layout$panel_params[[panel]][[paste0(axis,".range")]]
      scales::rescale(c(range, y), c(0,1))[-c(1,2)]
    }
    
    
    # add the new grob
    pg <- gtable_add_grob(pg,
                          segmentsGrob(x0 = data2npc(5),
                                       x1 = data2npc(5),
                                       y0=data_y_2npc(50, panel = 2)/2,
                                       y1 = data_y_2npc(28.39397, panel = 1L)+ 0.25) ,
                          t = 7, b = 9, l = 5)
    
    #print to page
    grid.newpage()
    grid.draw(pg)
    

    图例和比例与您的预期输出不匹配。

    【讨论】:

      猜你喜欢
      • 2016-03-30
      • 1970-01-01
      • 2021-07-28
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 2017-06-24
      相关资源
      最近更新 更多