web-dev-qa-db-fra.com

Comment ajouter des lignes sur des ggplots combinés, de points sur un tracé à des points sur l'autre?

J'ai besoin de reproduire des tracés générés dans InDesign dans ggplot pour la reproductibilité.

Dans cet exemple particulier, j'ai deux tracés qui sont combinés en un seul tracé composite (j'ai utilisé le package {patchwork} pour ça).

J'ai ensuite besoin de superposer des lignes joignant des points clés sur un tracé avec les points correspondants sur le tracé inférieur.

Les deux tracés sont générés à partir des mêmes données, ont les mêmes valeurs d'axe x, mais des valeurs d'axe y différentes.

J'ai vu ces exemples sur Stack Overflow, mais ceux-ci traitent de tracer des lignes sur plusieurs facettes, ce qui ne fonctionne pas ici car j'essaie de tracer des lignes sur des tracés distincts:

J'ai essayé plusieurs approches, et ma plus proche à ce jour a été de:

  1. Ajoutez les lignes avec des grobs en utilisant {grid} paquet
  2. Convertissez le deuxième tracé en une table à l'aide de {gtable} et désactivez le clip du panneau afin de pouvoir étendre les lignes vers le haut au-delà du panneau de l'intrigue.
  3. Regroupez les tracés en une seule image avec {patchwork}.

Le problème survient à la dernière étape car les axes x ne s'alignent plus comme ils le faisaient avant d'ajouter les lignes et de désactiver le clip (voir l'exemple dans le code).

J'ai également essayé de combiner les tracés avec ggarrange, {cowplot} et {Egg} et {patchwork} vient le plus près.

Voici ma tentative de la meilleure représentation minimale que je puisse créer, mais toujours en capturant les nuances de ce que je veux réaliser.

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.

L'attente est que les tracés dans panel_B doivent toujours apparaître comme ils le font dans panel_A mais ont des lignes de jonction reliant les points entre les tracés.

Je cherche de l'aide pour résoudre ce qui précède, ou bien d'autres approches à essayer.

Comme référence sans exécuter le code ci-dessus - des liens vers des images car je ne peux pas les publier.

Panneau A

enter image description here

Panneau B: à quoi il ressemble actuellement

enter image description here

Panneau B: à quoi je veux qu'il ressemble!

enter image description here

rggplot2plotgtable
10
Megan Beckett

Ma solution est un peu ad hoc, mais elle semble fonctionner. Je l'ai basé sur la réponse précédente suivante Aligner à gauche deux bords de graphique (ggplot) .

Je briserai la solution en trois parties pour aborder séparément certains des problèmes auxquels vous faisiez face.

La solution qui correspond à ce que vous voulez est la troisième!

Premier essai

Ici, j'aligne l'axe en utilisant la même approche que cette réponse Aligner à gauche deux bords de graphique (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)

enter image description here

Deuxième procès

Le problème est maintenant que la ligne du tracé inférieur s'étend au-delà de la zone du tracé. Pour résoudre ce problème, vous pouvez remplacer coord_cartesian() par scale_y_continuous() et scale_x_continuous() car cela supprimera les données qui tombent hors de la zone de traçage.

# 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)

enter image description here

Troisième procès

Le problème est maintenant que la ligne ne s'étend pas jusqu'au fond de l'axe y (car le point en dessous de y = -100 a été supprimé). La façon dont j'ai résolu cela (très ad hoc) était d'interpoler le point à y = -100 et de l'ajouter au bloc de données.

# 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)

enter image description here

5
kikoralston

Cela utilise facet_grid pour forcer l'axe des x à correspondre.

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)

La légende et les échelles ne correspondent pas à la sortie souhaitée.

enter image description here

2
Cole