How to add titles between plots - r

For the sake of simplicity, let's assume I have four graphs:
data("midwest", package = "ggplot2")
p1<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
p2<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
p3<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
p4<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
grid.arrange(p1,p2,p3,p4,ncol=2)
Now, I want to create a title (TITLE 1, TITLE 2) between each two titles,, as presented below:
Any ideas how to do it?

Here is a gtable solution to your problem. There might be easier solutions out there, but this should work.
First we'll bake in some titles in the leftmost plots
library(grid) # needed later for plotting
data("midwest", package = "ggplot2")
p1<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point() + ggtitle("Title 1")
p2<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
p3<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point() + ggtitle("Title 2")
p4<-ggplot(midwest, aes(x=area, y=poptotal)) + geom_point()
Then we can cbind and rbind the plots together as we see fit.
p12 <- cbind(ggplotGrob(p1), ggplotGrob(p2), size = "first")
p34 <- cbind(ggplotGrob(p3), ggplotGrob(p4), size = "first")
all <- rbind(p12, p34, size = "first")
grid.newpage(); grid.draw(all)
Note that we'd have to work with grid.newpage() and grid.draw() to get our plots, since we've left the ggplot sphere and are now in the realm of gtables and grid. Anyway, resulting plot looks like the following:
From your example I expect that you want these titles to be centered. This will be a bit more finicky:
# Decide what is a title
is_title <- grep("^title$", all$layout$name)
# Grab all titles
titles <- all$grobs[is_title]
# Exclude empty titles
is_title <- is_title[!sapply(titles, inherits, "zeroGrob")]
# Center title
all$grobs[is_title] <- lapply(all$grobs[is_title], function(title) {
title$children[[1]]$hjust <- 0.5
title$children[[1]]$x <- unit(0.5, "npc")
title
})
# Spread title over all panels
# You can see the number you'd need from the l/r coordinates of the 'panel' grobs
# which you can find by printing `all` or `all$layout`.
all$layout[is_title, "r"] <- 14
grid.newpage(); grid.draw(all)
EDIT: added example for adding extra titles
You can add extra titles, but you would need the gtable package for this.
library(gtable)
# First make extra titles
left <- textGrob("Left Title", gp = gpar(fontsize = 13.2, col = "black",
lineheight = 0.9, font = 1))
right <- textGrob("Right Title", gp = gpar(fontsize = 13.2, col = "black",
lineheight = 0.9, font = 1))
# Find a height that was 0, assign new height based on extra title
all$heights[[2]] <- unit(1, "grobheight", left)
# Add the titles (t = top position, l = left position)
all <- gtable_add_grob(all, left, t = 2, l = 5, clip = "off")
all <- gtable_add_grob(all, right, t = 2, l = 14, clip = "off")
grid.newpage(); grid.draw(all)

Related

adjust heights of two plots (nrow=1) with ggarrange

How can I display two plots in one row with R function ggarrange() so that they have the same dimensions, in particular the same height?
In this example, the second plot is a bit higher than the first plot. I would like to increase the size of a1_plot, so that it matches the size of a2_plot.
# required packages
library(ggplot2)
library(ggbreak)
library(directlabels)
library(ggpubr)
# make dataframe
df1 <- data.frame(first_column=c("value_1","value_2","value_3","value_4","value_4","value_5"),
second_column=c("123","123","325","325","656","656"),
third_column=c(12,13,1,19,200,360),
fourth_column=c(1,124,155,3533,5533,6666))
# plot 1
a1_plot <-
ggplot(df1, aes(x=third_column, y=fourth_column, colour=second_column)) +
scale_x_continuous(breaks = c(0,50,100,150,200,250,300)) +
ylab("Fourth column")+ xlab("Third column") +
scale_x_break(breaks = c(210,400)) +
geom_dl(mapping=aes(x=third_column, y=fourth_column, label=second_column),
method = list(dl.trans(x = x + 0.1), dl.combine("last.points"))) +
theme(legend.position = "none")
# plot 2
a2_plot <-
ggplot(data=df1)+
geom_point(aes(x=second_column, y=fourth_column) +
xlab("X axis")+ ylab("Y axis") +
theme(legend.position = "none")
# merge plot1 and plot2
ggarrange(print(a1_plot), print(a2_plot), labels = c('a1', 'a2'))
I was unable to change the height of plot 1. By adjusting the margins of plot 2, the problem has been solved.
theme(legend.position = "none", plot.margin = unit(x=c(3.6,5,3.9,0), units = "mm"))

cowplot, shared legend, spacing goes wrong when output to png

I have a problem with combining ggplots using cowplot and ggpubr which is driving me crazy.
The problem is with the legend. When it's displayed with its original graph on its own, the spacing between the elements of the legend (guide title, key, key-label) are absolutely fine.
However, if I extract the legend from the original plot, and then display it in a combined plot (using either plot_grid from cowplot or ggarrange from ggpubr) then the spacing goes haywire. The longer the text, the more the spacing expands.
What is wrong here, and how do I fix it so that the legend in the combined plot looks exactly like the one in the original individual plot?
Example
This example uses ggarrange from ggpubr; my results with get_legend and plot_grid using cowplot are similar. Treatment names are entirely made up.
library(survival)
library(broom)
library(dplyr)
library(foreach)
library(ggpubr)
fit <- survfit(Surv(time,status == 2) ~ trt + sex, data=pbc)
time.xticks <- seq(0, 4000, 1000)
delta <- 0.00001
# Survival plot
kmdata <- tidy(fit) %>%
mutate(trt=factor(gsub('trt=(.*),.*','\\1',strata)),
sex=factor(gsub('.*sex=(.*)','\\1',strata), levels=levels(pbc$sex)))
p1 <- ggplot(data=filter(kmdata, time<=max(time.xticks)), aes(x=time, y=estimate, colour=sex, linetype=trt)) + geom_step() +
scale_x_continuous(breaks = time.xticks,
limits = c(min(time.xticks), max(time.xticks))) +
scale_colour_discrete(name="Sex", labels=c("Male","Female")) +
scale_linetype_discrete(name="Treatment group", labels=c("Zyxatrxilbroh 35 mg", "Placebo 35 mg")) +
theme(legend.position = "bottom", legend.box = "horizontal",
legend.background = element_rect(fill="grey90", colour="black", size=0),
legend.key.height=unit(0.2, "cm"),
text=element_text(size=18))
tardata <- foreach(s=unique(kmdata$strata), .combine="rbind") %do% {
filter(kmdata, strata==s)[findInterval(pmax(0, time.xticks-delta), filter(kmdata, strata==s)$time)+1,] %>%
bind_cols(tibble(time.xticks))
} %>%
mutate(ypos = -((as.integer(sex)-1)*(length(unique(pbc$trt))+2) + as.integer(trt) + 1))
tarheads <- tibble(xpos=0,
ypos=-(((1:length(unique(pbc$sex))) - 1)*(length(unique(pbc$trt)) + 2) + 1),
lab=levels(pbc$sex))
risk.yticks <- sort(unique(tardata$ypos))
risk.ylabels <- rep(rev(paste("trt =",levels(kmdata$trt))), length(unique(kmdata$sex)))
# Number-at-risk table
p2 <- ggplot(data=tardata, aes(x=time.xticks, y=ypos, label=n.risk, colour=sex)) + geom_text() +
geom_text(data=tarheads, aes(x=xpos, y=ypos, label=lab), colour="black", hjust="left") +
scale_x_continuous(breaks = time.xticks,
limits = c(min(time.xticks), max(time.xticks))) +
scale_y_continuous(breaks = risk.yticks,
labels = risk.ylabels) +
theme(text=element_text(size=18))
# put the two together
p.comb <- ggarrange(p1, p2, heights = c(2, 0.8), ncol=1,
align="v", common.legend = TRUE, legend="bottom")
# alternate version with guide headings at the top left instead of at the side
p1.a <- p1 + guides(colour = guide_legend(order=1,
title.position = "top",
title.hjust = 0),
linetype = guide_legend(order=1,
title.position = "top",
title.hjust = 0))
p.comb.a <- ggarrange(p1.a, p2, heights = c(2, 0.8), ncol=1,
align="v", common.legend = TRUE, legend="bottom")
# send to png
png("test-p1.png", width=8, height=4.5, units="in", res=200, type="cairo")
plot(p1)
dev.off()
png("test-pcomb.png", width=8, height=4.5, units="in", res=200, type="cairo")
plot(p.comb)
dev.off()
Results
Individual plot with correct legend spacing:
[
Combined plot with legend spacing expanded so much that the legend no longer fits in the image:

Efficient way to map data to legend text color in ggplot2

I'm wondering if there's an efficient way to map data onto legend text color in ggplot2, just like we can do with axis text. Reproducible example follows.
First, let's make a plot:
library(ggplot2)
library(dplyr)
drv_counts <- mutate(mpg,
drv = case_when(drv == "r" ~ "rear wheel drive",
drv == "4" ~ "4 wheel drive",
drv == "f" ~ "front wheel drive"),
model_drv = interaction(model, drv)) %>%
group_by(model_drv) %>%
summarize(model = model[1], drv = drv[1], count = n()) %>%
arrange(drv, count) %>%
mutate(model = factor(model, levels = model))
p <- ggplot(drv_counts, aes(x=model, y=count, fill=drv)) +
geom_col() + coord_flip() + guides(fill = guide_legend(reverse=T)) +
theme_minimal()
p
Now let's color the axis labels by drive train. This is very easy:
# ggplot2 colors
cols <- c("4 wheel drive" = "#F8766D", "front wheel drive" = "#00BA38", "rear wheel drive" = "#619CFF")
p2 <- p + theme(axis.text.y = element_text(color = cols[drv_counts$drv]))
p2
Now let's try the same trick on the legend. It doesn't work:
p2 + theme(legend.text = element_text(color = cols))
The reason this doesn't work for legend text but does work for axis text is that all the axis labels are drawn in one grob, and hence we can give that grob a vector of colors, but the legend labels are drawn in separate grobs.
We can go in and color all the grobs manually, but that's super ugly and cumbersome:
g <- ggplotGrob(p2)
g$grobs[[15]]$grobs[[1]]$grobs[[9]]$children[[1]]$gp$col <- cols[g$grobs[[15]]$grobs[[1]]$grobs[[9]]$children[[1]]$label]
g$grobs[[15]]$grobs[[1]]$grobs[[10]]$children[[1]]$gp$col <- cols[g$grobs[[15]]$grobs[[1]]$grobs[[10]]$children[[1]]$label]
g$grobs[[15]]$grobs[[1]]$grobs[[11]]$children[[1]]$gp$col <- cols[g$grobs[[15]]$grobs[[1]]$grobs[[11]]$children[[1]]$label]
grid::grid.newpage()
grid::grid.draw(g)
My question is: Can somebody think of a way of getting this effect without having to dig down into the grob tree? I'm Ok with a patch to ggplot2 if it's only a few modified lines. Alternatively, can the digging down into the grob tree be automated so I don't have to access child grobs by manually setting list indices that will change the moment I make a minor change to the figure?
Update: A related question can be found here. To make my question distinct, let's add the requirement that colors aren't copied over from the symbols but rather can be set to any arbitrary values. This added requirement has real-world relevance because I usually use a darker color for text than for symbols.
Here's a pretty mediocre method of hacking grobs together to make a legend. I setup a palette based on the unique values of the drv variable (so it can be scaled to larger datasets or more colors). Then I mapped over the values of the palette to make each legend item: a rectGrob and a textGrob, both with the corresponding color from the palette. These could definitely be tweaked to look better. All of these get arranged into a new grob and stuck alongside the plot with cowplot. It isn't gorgeous but it might be a start.
library(tidyverse)
library(grid)
library(gridExtra)
pal <- colorspace::qualitative_hcl(n = length(unique(drv_counts$drv)), l = 60, c = 70) %>%
setNames(unique(drv_counts$drv))
p2 <- ggplot(drv_counts, aes(x=model, y=count, fill=drv)) +
geom_col() +
coord_flip() +
theme_minimal() +
scale_fill_manual(values = pal, guide = F) +
theme(axis.text.y = element_text(color = pal[drv_counts$drv]))
legend <- pal %>%
imap(function(col, grp) {
rect <- rectGrob(x = 0, width = unit(0.5, "line"), height = unit(0.5, "line"), gp = gpar(col = col, fill = col), hjust = 0)
label <- textGrob(label = grp, gp = gpar(col = colorspace::darken(col, 0.4), fontsize = 10), x = 0, hjust = 0)
cowplot::plot_grid(rect, label, nrow = 1, rel_widths = c(0.12, 1))
}) %>%
arrangeGrob(grobs = rev(.), padding = unit(0.1, "line"), heights = rep(unit(1.1, "line"), 3))
cowplot::plot_grid(p2, legend, rel_widths = c(1, 0.45))
Created on 2018-05-26 by the reprex package (v0.2.0).

ggplot2: Using gtable to move strip labels to top of panel for facet_grid

I am creating a graphic using facet_grid to facet a categorical variable on the y-axis. I decided not to use facet_wrap because I need space = 'free' and labeller = label_parsed. My labels are long and I have a legend on the right so I would like to move the labels from the right of the panel to the top of the panel.
Here is an example to show where I'm getting stuck.
library(ggplot2)
library(gtable)
mt <- ggplot(mpg, aes(x = cty, y = model)) + geom_point() +
facet_grid(manufacturer ~ ., scales = 'free', space = 'free') +
theme_minimal() +
theme(panel.margin = unit(0.5, 'lines'), strip.text.y = element_text(angle = 0))
Now I would like to move the strip text from the right of each panel to the top of each panel. I can store the grobs for the strip labels and remove them from the plot:
grob <- ggplotGrob(mt)
strips.y <- gtable_filter(grob, 'strip-right')
grob2 <- grob[,-5]
But now I'm stuck when it comes to rbind-ing the grobs back so the labels go to the top of the panels.
Another possible solution would be to use facet_wrap and then re-size the panels as discussed in another question, but in that case I would have to manually change the labels on the facets because there is no labeller = label_parsed for facet_wrap.
I'd appreciate suggestions on either approach!
Thanks for reading,
Tom
This takes your first approach. It inserts a row above each of the panels, grabs the strip grobs (on the right), and inserts them into the new rows.
library(ggplot2)
library(gtable)
library(grid)
mt <- ggplot(mpg, aes(x = cty, y = model)) + geom_point() +
facet_grid(manufacturer ~ ., scales = 'free', space = 'free') +
theme(panel.spacing = unit(0.5, 'lines'),
strip.text.y = element_text(angle = 0))
# Get the gtable
gt <- ggplotGrob(mt)
# Get the position of the panels in the layout
panels <-c(subset(gt$layout, grepl("panel", gt$layout$name), se=t:r))
# Add a row above each panel
for(i in rev(panels$t-1)) gt = gtable_add_rows(gt, unit(.5, "lines"), i)
# Get the positions of the panels and the strips in the revised layout
panels <-c(subset(gt$layout, grepl("panel", gt$layout$name), se=t:r))
strips <- c(subset(gt$layout, grepl("strip-r", gt$layout$name), se=t:r))
# Get the strip grobs
stripText = gtable_filter(gt, "strip-r")
# Insert the strip grobs into the new rows
for(i in 1:length(strips$t)) gt = gtable_add_grob(gt, stripText$grobs[[i]]$grobs[[1]], t=panels$t[i]-1, l=4)
# Remove the old strips
gt = gt[,-5]
# For this plot - adjust the heights of the strips and the empty row above the strips
for(i in panels$t) {
gt$heights[i-1] = unit(0.8, "lines")
gt$heights[i-2] = unit(0.2, "lines")
}
# Draw it
grid.newpage()
grid.draw(gt)
OR, you can achieve the second approach using a facet_wrap_labeller function available from here.
library(ggplot2)
library(gtable)
mt <- ggplot(mpg, aes(x = cty, y = model)) + geom_point() +
facet_wrap(~ manufacturer, scales = "free_y", ncol = 1) +
theme(panel.margin = unit(0.2, 'lines'))
facet_wrap_labeller <- function(gg.plot, labels=NULL) {
require(gridExtra)
g <- ggplotGrob(gg.plot)
gg <- g$grobs
strips <- grep("strip_t", names(gg))
for(ii in seq_along(labels)) {
modgrob <- getGrob(gg[[strips[ii]]], "strip.text",
grep=TRUE, global=TRUE)
gg[[strips[ii]]]$children[[modgrob$name]] <- editGrob(modgrob,label=labels[ii])
}
g$grobs <- gg
class(g) = c("arrange", "ggplot",class(g))
return(g)
}
## Number of y breaks in each panel
g <- ggplot_build(mt)
N <- sapply(lapply(g$panel$ranges, "[[", "y.major"), length)
# Some arbitrary strip texts
StripTexts = expression(gamma[1], sqrt(gamma[2]), C, `A really incredibly very very very long label`, gamma[5], alpha[1], alpha[2], `Land Rover`, alpha[1], beta[2], gamma^2, delta^2, epsilon[2], zeta[3], eta[4] )
# Apply the facet_wrap_labeller function
gt = facet_wrap_labeller(mt, StripTexts)
# Get the position of the panels in the layout
panels <- gt$layout$t[grepl("panel", gt$layout$name)]
# Replace the default panel heights with relative heights
gt$heights[panels] <- lapply(N, unit, "null")
# Draw it
gt
I was struggling with a similar problem but putting the labels on the bottom. I've used a code adaptation of this answer. And recently found that
ggplot2 ver.2.2.1.0 (http://docs.ggplot2.org/current/facet_grid.html)
~facet_grid(.~variable,switch='x')
option which has worked beautifully for me.

How to display strip labels below the plot when faceting?

It seems that the strips are always above the plot created by ggplot2. Can they be moved below the plot?
For example:
library(ggplot2)
qplot(hwy, cty, data = mpg) + facet_grid( . ~ manufacturer)
displays the car information on top. Can they be displayed be at the bottom?
Update: Using ggplot2 version 2.1.0, consider using switch = 'x'. See ?facet_grid for details.
Using gtable functions, it is easy to move the strip. (Or see here for anther version - swapping x-axis and strip)
library(ggplot2)
library(gtable)
library(grid)
p <- ggplot(mpg, aes(hwy, cty)) + geom_point() + facet_grid( . ~ manufacturer) +
theme(strip.text.x = element_text(angle = 90, vjust = 1),
strip.background = element_rect(fill = NA))
# Convert the plot to a grob
gt <- ggplotGrob(p)
# Get the positions of the panels in the layout: t = top, l = left, ...
panels <-c(subset(gt$layout, grepl("panel", gt$layout$name), select = t:r))
# Add a row below the x-axis tick mark labels,
# the same height as the strip
gt = gtable_add_rows(gt, gt$height[min(panels$t)-1], max(panels$b) + 2)
# Get the strip grob
stripGrob = gtable_filter(gt, "strip-t")
# Insert the strip grob into the new row
gt = gtable_add_grob(gt, stripGrob, t = max(panels$b) + 3, l = min(panels$l), r = max(panels$r))
# remove the old strip
gt = gt[-(min(panels$t)-1), ]
grid.newpage()
grid.draw(gt)

Resources