Related
I need to reproduce plots generated in InDesign in ggplot for reproducibility.
In this particular example, I have two plots that are combined into one composite plot (I have used the package {patchwork} for this).
I then need to overlay lines joining key points on one plot with the corresponding points on the bottom plot.
The two plots are generated from the same data, have the same x-axis values, but different y-axis values.
I have seen these examples on Stack Overflow, but these deal with drawing lines across facets, which doesn't work here as I'm attempting to draw lines across separate plots:
ggplot, drawing multiple lines across facets
ggplot, drawing line between points across facets
I've tried several approaches, and my closest so far has been to:
Add the lines with grobs using {grid} package
Convert the second plot to a gtable using {gtable} and set the clip of the panel to off so that I can extend the lines upwards beyond the panel of the plot.
Combine the plots again into a single image with {patchwork}.
The problem comes in the last step as the x-axes now do not line up anymore as they did before adding the lines and setting the clip to off (see example in code).
I have also tried combining the plots with ggarrange, {cowplot} and {egg} and {patchwork} comes the closest.
Following is my attempt at the best minimal reprex I can create, but still capturing the nuances of what it is I want to achieve.
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.
The expectation is that the plots in panel_B should still appear as they do in panel_A but have the joining lines linking points between the plots.
I am looking for help with solving the above, or else, alternative approaches to try out.
As a reference without running the code above - links to images as I can't post them.
Panel A
Panel B: What it currently looks like
Panel B: What I want it to look like!
My solution is a little ad hoc, but it seems to work. I based it on the following previous answer Left align two graph edges (ggplot).
I will break the solution in three parts to address some of the issues you were facing separately.
The solution that matches what you want is the third one!
First trial
Here I get the axis aligned using the same approach as this answer 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)
Second trial
The problem now is that the line in the bottom plot extends beyond the plot area. One way to deal with this is to change coord_cartesian() to scale_y_continuous() and scale_x_continuous() because this will remove data that falls out of the plot area.
# 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)
Third trial
The problem now is that the line does not extend all the way to the bottom of the y-axis (because the point below y=-100 was removed). The way I solved this (very ad hoc) was to interpolate the point at y=-100 and add this to the data frame.
# 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)
This makes use of facet_grid to force the x-axis to match.
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)
The legend and the scales are what do not match your intended output.
I am having a hard time making the title of a legend center-aligned relative to the legend keys when the legend title is long. There is a question from a year ago that works for short titles, but it doesn't seem to work for long ones.
Example, first with a short legend title:
library(ggplot2)
ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width, color=Petal.Width)) + geom_point(size = 3) +
scale_color_distiller(palette = "YlGn", type = "seq", direction = -1,
name = "A") +
theme(legend.title.align = 0.5)
Everything is as expected, the legend title is centered above the legend key.
Now the same with a long legend title:
ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width, color=Petal.Width)) + geom_point(size = 3) +
scale_color_distiller(palette = "YlGn", type = "seq", direction = -1,
name = "Long legend heading\nShould be centered") +
theme(legend.title.align = 0.5)
We can see that the text is center aligned to itself but not relative to the legend key. I have tried modifying other theme options, such as legend.justification = "center", but none seem to move the key from its left-most position in the legend box.
A couple of comments:
I'm running the development version of ggplot2, v2.2.1.9000 from a few days ago.
I specifically need a solution for a continuous colorscale palette.
I hacked the source code similar to the way described by baptiste in one of the above comments: put the colour bar / label / ticks grobs into a child gtable, & position it to have the same row span / column span (depending on the legend's direction) as the title.
It's still a hack, but I'd like to think of it as a 'hack once for the whole session' approach, without having to repeat the steps manually for every plot.
Demonstration with different title widths / title positions / legend directions:
plot.demo <- function(title.width = 20,
title.position = "top",
legend.direction = "vertical"){
ggplot(iris,
aes(x=Sepal.Length, y=Sepal.Width, color=Petal.Width)) +
geom_point(size = 3) +
scale_color_distiller(palette = "YlGn",
name = stringr::str_wrap("Long legend heading should be centered",
width = title.width),
guide = guide_colourbar(title.position = title.position),
direction = -1) +
theme(legend.title.align = 0.5,
legend.direction = legend.direction)
}
cowplot::plot_grid(plot.demo(),
plot.demo(title.position = "left"),
plot.demo(title.position = "bottom"),
plot.demo(title.width = 10, title.position = "right"),
plot.demo(title.width = 50, legend.direction = "horizontal"),
plot.demo(title.width = 10, legend.direction = "horizontal"),
ncol = 2)
This works with multiple colourbar legends as well:
ggplot(iris,
aes(x=Sepal.Length, y=Sepal.Width,
color=Petal.Width, fill = Petal.Width)) +
geom_point(size = 3, shape = 21) +
scale_color_distiller(palette = "YlGn",
name = stringr::str_wrap("Long legend heading should be centered",
width = 20),
guide = guide_colourbar(title.position = "top"),
direction = -1) +
scale_fill_distiller(palette = "RdYlBu",
name = stringr::str_wrap("A different heading of different length",
width = 40),
direction = 1) +
theme(legend.title.align = 0.5,
legend.direction = "vertical",
legend.box.just = "center")
(Side note: legend.box.just = "center" is required to align the two legends properly. I was worried for a while since only "top", "bottom", "left", and "right" are currently listed as acceptable parameter values, but it turns out both "center" / "centre" are accepted as well, by the underlying grid::valid.just. I'm not sure why this isn't mentioned explicitly in the ?theme help file; nonetheless, it does work.)
To change the source code, run:
trace(ggplot2:::guide_gengrob.colorbar, edit = TRUE)
And change the last section of code from this:
gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights,
"cm"))
... # omitted
gt
}
To this:
# create legend gtable & add background / legend title grobs as before (this part is unchanged)
gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm"))
gt <- gtable_add_grob(gt, grob.background, name = "background",
clip = "off", t = 1, r = -1, b = -1, l = 1)
gt <- gtable_add_grob(gt, justify_grobs(grob.title, hjust = title.hjust,
vjust = title.vjust, int_angle = title.theme$angle,
debug = title.theme$debug), name = "title", clip = "off",
t = 1 + min(vps$title.row), r = 1 + max(vps$title.col),
b = 1 + max(vps$title.row), l = 1 + min(vps$title.col))
# create child gtable, using the same widths / heights as the original legend gtable
gt2 <- gtable(widths = unit(widths[1 + seq.int(min(range(vps$bar.col, vps$label.col)),
max(range(vps$bar.col, vps$label.col)))], "cm"),
heights = unit(heights[1 + seq.int(min(range(vps$bar.row, vps$label.row)),
max(range(vps$bar.row, vps$label.row)))], "cm"))
# shift cell positions to start from 1
vps2 <- vps[c("bar.row", "bar.col", "label.row", "label.col")]
vps2[c("bar.row", "label.row")] <- lapply(vps2[c("bar.row", "label.row")],
function(x) x - min(unlist(vps2[c("bar.row", "label.row")])) + 1)
vps2[c("bar.col", "label.col")] <- lapply(vps2[c("bar.col", "label.col")],
function(x) x - min(unlist(vps2[c("bar.col", "label.col")])) + 1)
# add bar / ticks / labels grobs to child gtable
gt2 <- gtable_add_grob(gt2, grob.bar, name = "bar", clip = "off",
t = min(vps2$bar.row), r = max(vps2$bar.col),
b = max(vps2$bar.row), l = min(vps2$bar.col))
gt2 <- gtable_add_grob(gt2, grob.ticks, name = "ticks", clip = "off",
t = min(vps2$bar.row), r = max(vps2$bar.col),
b = max(vps2$bar.row), l = min(vps2$bar.col))
gt2 <- gtable_add_grob(gt2, grob.label, name = "label", clip = "off",
t = min(vps2$label.row), r = max(vps2$label.col),
b = max(vps2$label.row), l = min(vps2$label.col))
# add child gtable back to original legend gtable, taking tlrb reference from the
# rowspan / colspan of the title grob if title grob spans multiple rows / columns.
gt <- gtable_add_grob(gt, justify_grobs(gt2, hjust = title.hjust,
vjust = title.vjust),
name = "bar.ticks.label", clip = "off",
t = 1 + ifelse(length(vps$title.row) == 1,
min(vps$bar.row, vps$label.row),
min(vps$title.row)),
b = 1 + ifelse(length(vps$title.row) == 1,
max(vps$bar.row, vps$label.row),
max(vps$title.row)),
r = 1 + ifelse(length(vps$title.col) == 1,
min(vps$bar.col, vps$label.col),
max(vps$title.col)),
l = 1 + ifelse(length(vps$title.col) == 1,
max(vps$bar.col, vps$label.col),
min(vps$title.col)))
gt
}
To reverse the change, run:
untrace(ggplot2:::guide_gengrob.colorbar)
Package version used: ggplot2 3.2.1.
Update Oct. 4, 2019:
A while back I wrote a fairly general function based on the original idea I posted here almost two years ago. The function is on github here but it's not part of any officially published package. It is defined as follows:
align_legend <- function(p, hjust = 0.5)
{
# extract legend
g <- cowplot::plot_to_gtable(p)
grobs <- g$grobs
legend_index <- which(sapply(grobs, function(x) x$name) == "guide-box")
legend <- grobs[[legend_index]]
# extract guides table
guides_index <- which(sapply(legend$grobs, function(x) x$name) == "layout")
# there can be multiple guides within one legend box
for (gi in guides_index) {
guides <- legend$grobs[[gi]]
# add extra column for spacing
# guides$width[5] is the extra spacing from the end of the legend text
# to the end of the legend title. If we instead distribute it by `hjust:(1-hjust)` on
# both sides, we get an aligned legend
spacing <- guides$width[5]
guides <- gtable::gtable_add_cols(guides, hjust*spacing, 1)
guides$widths[6] <- (1-hjust)*spacing
title_index <- guides$layout$name == "title"
guides$layout$l[title_index] <- 2
# reconstruct guides and write back
legend$grobs[[gi]] <- guides
}
# reconstruct legend and write back
g$grobs[[legend_index]] <- legend
g
}
The function is quite flexible and general. Here are a few examples of how it can be used:
library(ggplot2)
library(cowplot)
#>
#> ********************************************************
#> Note: As of version 1.0.0, cowplot does not change the
#> default ggplot2 theme anymore. To recover the previous
#> behavior, execute:
#> theme_set(theme_cowplot())
#> ********************************************************
library(colorspace)
# single legend
p <- ggplot(iris, aes(Sepal.Width, Sepal.Length, color = Petal.Width)) + geom_point()
ggdraw(align_legend(p)) # centered
ggdraw(align_legend(p, hjust = 1)) # right aligned
# multiple legends
p2 <- ggplot(mtcars, aes(disp, mpg, fill = hp, shape = factor(cyl), size = wt)) +
geom_point(color = "white") +
scale_shape_manual(values = c(23, 24, 21), name = "cylinders") +
scale_fill_continuous_sequential(palette = "Emrld", name = "power (hp)", breaks = c(100, 200, 300)) +
xlab("displacement (cu. in.)") +
ylab("fuel efficiency (mpg)") +
guides(
shape = guide_legend(override.aes = list(size = 4, fill = "#329D84")),
size = guide_legend(
override.aes = list(shape = 21, fill = "#329D84"),
title = "weight (1000 lbs)")
) +
theme_half_open() + background_grid()
# works but maybe not the expected result
ggdraw(align_legend(p2))
# more sensible layout
ggdraw(align_legend(p2 + theme(legend.position = "top", legend.direction = "vertical")))
Created on 2019-10-04 by the reprex package (v0.3.0)
Original answer:
I found a solution. It requires some digging into the grob tree, and it may not work if there are multiple legends, but otherwise this seems a reasonable solution until something better comes along.
library(ggplot2)
library(gtable)
library(grid)
p <- ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width, color=Petal.Width)) +
geom_point(size = 3) +
scale_color_distiller(palette = "YlGn", type = "seq", direction = -1,
name = "Long legend heading\nShould be centered") +
theme(legend.title.align = 0.5)
# extract legend
g <- ggplotGrob(p)
grobs <- g$grobs
legend_index <- which(sapply(grobs, function(x) x$name) == "guide-box")
legend <- grobs[[legend_index]]
# extract guides table
guides_index <- which(sapply(legend$grobs, function(x) x$name) == "layout")
guides <- legend$grobs[[guides_index]]
# add extra column for spacing
# guides$width[5] is the extra spacing from the end of the legend text
# to the end of the legend title. If we instead distribute it 50:50 on
# both sides, we get a centered legend
guides <- gtable_add_cols(guides, 0.5*guides$width[5], 1)
guides$widths[6] <- guides$widths[2]
title_index <- guides$layout$name == "title"
guides$layout$l[title_index] <- 2
# reconstruct legend and write back
legend$grobs[[guides_index]] <- guides
g$grobs[[legend_index]] <- legend
grid.newpage()
grid.draw(g)
you'd have to change the source code. Currently it computes the widths for the title grob and the bar+labels, and left-justifies the bar+labels in the viewport (gtable). This is hard-coded.
I'm trying to draw a border around two plots that have been aligned with plot_grid from the cowplot package. Please see the following example (modified from the "Changing the axis positions" vignette):
require(gtable)
require(cowplot)
# top plot
p1 <- ggplot(mtcars, aes(mpg, disp)) + geom_line(colour = 'blue') +
background_grid(minor = 'none')
g1 <- switch_axis_position(p1, 'xy') # switch both axes
g1 <- gtable_squash_rows(g1, length(g1$height)) # set bottom row to 0 height
# bottom plot
p2 <- ggplot(mtcars, aes(mpg, qsec)) + geom_line(colour = 'green') + ylim(14, 25) +
background_grid(minor = 'none')
g2 <- ggplotGrob(p2)
g2 <- gtable_add_cols(g2, g1$widths[5:6], 4) # add the two additional columns that g1 has
g2 <- gtable_squash_rows(g2, 1:2) # set top two rows to 0 height
plot_grid(g1, g2, ncol = 1, align = 'v') +
annotate("rect", xmin = 0.1, xmax = 0.9, ymin = 0.1, ymax = 0.9,
color = "red", fill = NA)
Now, instead of the arbitrarily chosen coordinates for the red box, I'd like to have it aligned with the axis lines. I assume these coordinates can be extracted from the plot_grid output, but I have no idea how.
Based on my understanding of grobs, I'd say it's easier to get the coordinates for each plot & add the border segments before combining the plots using plot_grid.
Example data:
library(gtable)
library(cowplot)
# sample plots
# (note: the cowplot function switch_axis_position has been deprecated, as its
# creator notes ggplot2 now natively supports axes on either side of the plot.)
p1 <- ggplot(mtcars, aes(mpg, disp)) +
geom_line(colour = 'blue') +
scale_x_continuous(position = "top") +
scale_y_continuous(position = "right") +
background_grid(minor = 'none'); p1
p2 <- ggplot(mtcars, aes(mpg, qsec)) +
geom_line(colour = 'green') +
ylim(14, 25) +
background_grid(minor = 'none'); p2
# convert to grob objects
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(p2)
Function to add appropriate border segments for each plot grob, where:
grob is the grob object created via ggplotGrob;
sides is a character string containing any combination of "t" / "l" / "b" / "r" in any order to indicate the desired sides for border placement;
col is the desired border colour (defaults to red);
... is for any other parameters to be passed to gpar() in segmentsGrob()
.
library(grid)
add.segments <- function(grob, sides = "tlbr", col = "red", ...){
# get extent of gtable cells to be surrounded by border
panel.coords <- g1[["layout"]][g1[["layout"]][["name"]] == "panel", ]
t <- if(grepl("t", sides)) panel.coords[["t"]] else 1
b <- if(grepl("b", sides)) panel.coords[["b"]] else length(grob[["heights"]])
l <- if(grepl("l", sides)) panel.coords[["l"]] else 1
r <- if(grepl("r", sides)) panel.coords[["r"]] else length(grob[["widths"]])
# define border coordinates, & filter for the desired border sides
coords <- data.frame(direction = c("t", "b", "l", "r"),
x0 = c(0, 0, 0, 1), y0 = c(1, 0, 0, 0),
x1 = c(1, 1, 0, 1), y1 = c(1, 0, 1, 1),
stringsAsFactors = FALSE)
coords <- coords[sapply(coords$direction, grepl, sides), ]
# add desired border sides as segments to the grob at specific gtable cells
grob <- gtable_add_grob(x = grob,
grobs = segmentsGrob(
x0 = coords[["x0"]], y0 = coords[["y0"]],
x1 = coords[["x1"]], y1 = coords[["y1"]],
gp = gpar(col = col, ...)
),
t = t, l = l, b = b, r = r,
clip = "off", name = "segments")
return(grob)
}
Usage:
plot_grid(add.segments(g1, "tlr"),
add.segments(g2, "lbr"),
ncol = 1, align = "v")
Another example, for aligning two plots horizontally (okay, there's no point to align these particular plots side by side, but you get the idea):
plot_grid(add.segments(g2, "tlb", col = "gold2", lty = 2, lwd = 5),
add.segments(g1, "trb", col = "gold2", lty = 2, lwd = 5),
nrow = 1, align = "h")
Is there a way to fill the strips of facets created with facet_wrap based on a variable supplied with the data frame?
Example data:
MYdata <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")), farm = rep(c(0,1,3,6,9,12), each=6), weight = rnorm(36, 10000, 2500), size=rep(c("small", "large")))
Example plot:
p1 = ggplot(data = MYdata, aes(x = farm, y = weight)) + geom_jitter(position = position_jitter(width = 0.3), aes(color = factor(farm)), size = 2.5, alpha = 1) + facet_wrap(~fruit)
I know how to change the background color of the strips (e.g. to orange):
p1 + theme(strip.background = element_rect(fill="orange"))
Is there a way to pass on the values in the variable size in MYdata to the parameter fill in element_rect?
Basically, instead of 1 color for all strips I would like the strip background color of small fruits (apple, plum, pear) to be green and the background color of large fruits (orange, banana, grape) to be red.
With a little bit of work, you can combine your plot with a dummy gtable that has the right grobs,
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal()
library(gtable)
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip_t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
grid.newpage()
grid.draw(new_strips)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
## ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
You can find an updated answer to this question here.
g <- ggplot_gtable(ggplot_build(p))
stripr <- which(grepl('strip-r', g$layout$name))
fills <- c("red","green","blue","yellow")
k <- 1
for (i in stripr) {
j <- which(grepl('rect', g$grobs[[i]]$grobs[[1]]$childrenOrder))
g$grobs[[i]]$grobs[[1]]$children[[j]]$gp$fill <- fills[k]
k <- k+1
}
grid::grid.draw(g)
If you want to have different fills to the strip backgrounds, you can use facets in ggh4x to set a more complicated strip with strip_themed(). No hassle with gtables and your plot remains a ggplot, so you can add the usual layers/scales/theme options etc afterwards.
library(ggh4x)
#> Loading required package: ggplot2
# Only colour strips in x-direction
strip <- strip_themed(background_x = elem_list_rect(fill = rainbow(7)))
# Wrap variant
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
facet_wrap2(~ class, strip = strip)
It works for the grid layout too, but if you want to colour the vertical strips, you'd need to set the background_y argument in strip_themed() too.
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
facet_grid2(year ~ cyl, strip = strip)
Created on 2023-01-04 by the reprex package (v2.0.1)
Disclaimer: I'm the author of ggh4x
I would love to know how to do that, it is a great idea. One idea is to generate each chart independently with a different color as you do and then use something like multiplot or viewports to show then side by side - it will require a bit more work.
if you want to extract the legend, which you will need for this approach - here is some code from Hadley that I found a while back
g_legend<-function(a.gplot){
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
return(legend)}
see how it is extracted it from chart p, and then I took it out of the plot
legend <- g_legend(p)
lwidth <- sum(legend$width) #if you want to define the viewport based on this
p <- p + theme(legend.position="none")
then you eventually draw it
grid.newpage()
vp <- viewport(width = 1, height = 1)
#print(p, vp = vp)
submain <- viewport(width = 0.9, height = 0.9, x = 0.5, y = 1,just=c("center","top"))
print(p, vp = submain)
sublegend <- viewport(width = 0.5, height = 0.2, x = 0.5, y = 0.0,just=c("center","bottom"))
print(arrangeGrob(legend), vp = sublegend)
Good luck
It's not directly for differently coloring your facets but here you have another (very quick and simpler) solution, based on facet by two variables (size ~ fruit) instead one (~ fruit):
ggplot(data = MYdata, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(size ~ fruit)
Is there a way to fill the strips of facets created with facet_wrap based on a variable supplied with the data frame?
Example data:
MYdata <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")), farm = rep(c(0,1,3,6,9,12), each=6), weight = rnorm(36, 10000, 2500), size=rep(c("small", "large")))
Example plot:
p1 = ggplot(data = MYdata, aes(x = farm, y = weight)) + geom_jitter(position = position_jitter(width = 0.3), aes(color = factor(farm)), size = 2.5, alpha = 1) + facet_wrap(~fruit)
I know how to change the background color of the strips (e.g. to orange):
p1 + theme(strip.background = element_rect(fill="orange"))
Is there a way to pass on the values in the variable size in MYdata to the parameter fill in element_rect?
Basically, instead of 1 color for all strips I would like the strip background color of small fruits (apple, plum, pear) to be green and the background color of large fruits (orange, banana, grape) to be red.
With a little bit of work, you can combine your plot with a dummy gtable that has the right grobs,
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal()
library(gtable)
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip_t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
grid.newpage()
grid.draw(new_strips)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
## ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
You can find an updated answer to this question here.
g <- ggplot_gtable(ggplot_build(p))
stripr <- which(grepl('strip-r', g$layout$name))
fills <- c("red","green","blue","yellow")
k <- 1
for (i in stripr) {
j <- which(grepl('rect', g$grobs[[i]]$grobs[[1]]$childrenOrder))
g$grobs[[i]]$grobs[[1]]$children[[j]]$gp$fill <- fills[k]
k <- k+1
}
grid::grid.draw(g)
If you want to have different fills to the strip backgrounds, you can use facets in ggh4x to set a more complicated strip with strip_themed(). No hassle with gtables and your plot remains a ggplot, so you can add the usual layers/scales/theme options etc afterwards.
library(ggh4x)
#> Loading required package: ggplot2
# Only colour strips in x-direction
strip <- strip_themed(background_x = elem_list_rect(fill = rainbow(7)))
# Wrap variant
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
facet_wrap2(~ class, strip = strip)
It works for the grid layout too, but if you want to colour the vertical strips, you'd need to set the background_y argument in strip_themed() too.
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
facet_grid2(year ~ cyl, strip = strip)
Created on 2023-01-04 by the reprex package (v2.0.1)
Disclaimer: I'm the author of ggh4x
I would love to know how to do that, it is a great idea. One idea is to generate each chart independently with a different color as you do and then use something like multiplot or viewports to show then side by side - it will require a bit more work.
if you want to extract the legend, which you will need for this approach - here is some code from Hadley that I found a while back
g_legend<-function(a.gplot){
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
return(legend)}
see how it is extracted it from chart p, and then I took it out of the plot
legend <- g_legend(p)
lwidth <- sum(legend$width) #if you want to define the viewport based on this
p <- p + theme(legend.position="none")
then you eventually draw it
grid.newpage()
vp <- viewport(width = 1, height = 1)
#print(p, vp = vp)
submain <- viewport(width = 0.9, height = 0.9, x = 0.5, y = 1,just=c("center","top"))
print(p, vp = submain)
sublegend <- viewport(width = 0.5, height = 0.2, x = 0.5, y = 0.0,just=c("center","bottom"))
print(arrangeGrob(legend), vp = sublegend)
Good luck
It's not directly for differently coloring your facets but here you have another (very quick and simpler) solution, based on facet by two variables (size ~ fruit) instead one (~ fruit):
ggplot(data = MYdata, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(size ~ fruit)