如何在组合的 ggplots 上添加线条，从一个图上的点到另一个图上的点？
How to add lines on combined ggplots, from points on one plot to points on the other?
我需要在 ggplot 中重现 InDesign 中生成的绘图以实现重现性。
在这个特定的示例中，我将两个图组合成一个复合图（为此我使用了包 {patchwork}）。
然后我需要将一个图上的关键点连接线与底部图上的对应点重叠。
这两个图是从相同的数据生成的，具有相同的 x-axis 值，但不同的 y-axis 值。
我在 Stack Overflow 上看过这些示例，但这些示例处理的是跨面画线，这在这里不起作用，因为我试图在不同的绘图上画线：
我尝试了几种方法，目前最接近的方法是：
- 使用
{grid}包 添加带有grobs的行
- 使用
{gtable} 将第二个图转换为 gtable 并将面板的剪辑设置为关闭，以便我可以将线条向上延伸到图的面板之外。
- 使用
{patchwork}. 再次将绘图组合成单个图像
问题出现在最后一步，因为 x-axes 现在不再像在添加线条和将剪辑设置为关闭之前那样排列（参见代码中的示例）。
我也试过将这些图与 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 中那样出现，但是在地块之间有连接点的连接线。
我正在寻求解决上述问题的帮助，或者尝试其他方法。
作为没有 运行 上面代码的参考 - 图像链接，因为我不能 post 它们。
面板 A
面板 B：目前的样子
B 组：我想要的样子！
我的解决方案有点特别，但似乎可行。我基于以下先前的答案 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)
这利用 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)
图例和比例与您的预期输出不符。
我需要在 ggplot 中重现 InDesign 中生成的绘图以实现重现性。
在这个特定的示例中，我将两个图组合成一个复合图（为此我使用了包 {patchwork}）。
然后我需要将一个图上的关键点连接线与底部图上的对应点重叠。
这两个图是从相同的数据生成的，具有相同的 x-axis 值，但不同的 y-axis 值。
我在 Stack Overflow 上看过这些示例，但这些示例处理的是跨面画线，这在这里不起作用，因为我试图在不同的绘图上画线：
我尝试了几种方法，目前最接近的方法是：
- 使用
{grid}包 添加带有grobs的行
- 使用
{gtable}将第二个图转换为 gtable 并将面板的剪辑设置为关闭，以便我可以将线条向上延伸到图的面板之外。 - 使用
{patchwork}. 再次将绘图组合成单个图像
问题出现在最后一步，因为 x-axes 现在不再像在添加线条和将剪辑设置为关闭之前那样排列（参见代码中的示例）。
我也试过将这些图与 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 中那样出现，但是在地块之间有连接点的连接线。
我正在寻求解决上述问题的帮助，或者尝试其他方法。
作为没有 运行 上面代码的参考 - 图像链接，因为我不能 post 它们。
面板 A
面板 B：目前的样子
B 组：我想要的样子！
我的解决方案有点特别，但似乎可行。我基于以下先前的答案 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)
这利用 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)
图例和比例与您的预期输出不符。