Related
I am trying to combine facet strips across two adjacent panels (there is always two adjacent ones with the same first ID variable, but with two different scenarios, let's call them "A" and "B"). I am not particularly wedded to the gtable + grid solution I tried, but sadly I cannot use the facet_nested() from the ggh4x package (I cannot install it on my company's server due to various restrictions that are in place and needed dependencies - I looked at using only the relevant code, but that again is not easy due to the dependencies).
A minimum viable example of the basic plot I want to make easier to read by indicating which panels "belong together" by combining the top facet strips looks like this:
library(tidyverse)
library(gtable)
library(grid)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_wrap(~id + id2, nrow = 4, ncol=8)
The strips with the "1"s, the ones with the "2"s etc. should be combined (in reality it's a somewhat longer text, but this is just for illustration). I was trying to adapt an answer for a similar scenario (https://stackoverflow.com/a/40316170/7744356 - thank you #markus for finding it again), but this is what I tried. As you can see below, the height of what I produce seems wrong. I assume this must be some trivial thing I am overlooking/not understanding.
# Combine strips for a ID
g <- ggplot_gtable(ggplot_build(p1))
strip <- gtable_filter(g, "strip-t", trim = FALSE)
stript <- which(grepl('strip-t', g$layout$name))
stript2 = stript[idx*2-1]
top <- strip$layout$t[idx*2-1]
# # Using the $b below instead of b = top[i]+1, also seems not to work
#bot <- strip$layout$b[idx*2-1]
l <- strip$layout$l[idx*2-1]
r <- strip$layout$r[idx*2]
mat <- matrix(vector("list",
length = length(idx)*3),
nrow = length(idx))
mat[] <- list(zeroGrob())
res <- gtable_matrix("toprow", mat,
unit(c(1, 0, 1), "null"),
unit( rep(1, length(idx)),
"null"))
for (i in 1:length(stript2)){
if (i==1){
zz <- res %>%
gtable_add_grob(g$grobs[[stript2[i]]]$grobs[[1]], 1, 1, 1, 3) %>%
gtable_add_grob(g, .,
t = top[i],
l = l[i],
b = top[i]+1,
r = r[i],
name = c("add-strip"))
} else {
zz <- res %>%
gtable_add_grob(g$grobs[[stript2[i]]]$grobs[[1]], 1, 1, 1, 3) %>%
gtable_add_grob(zz, .,
t = top[i],
l = l[i],
b = top[i]+1,
r = r[i],
name = c("add-strip"))
}
}
grid::grid.draw(zz)
------------ Update with a ggh4x implementation -----------------
This may solve this type of problem for many, but has its downsides (e.g. axes alignment across rows gets a bit manual, probably need to manually remove x-axes and ensure the limits are the same, add a unified y-axis label, requires installation of a package from github: devtools::install_github("teunbrand/ggh4x#v0.1") for a specific version, plus cowplot interacts badly with e.g. ggtern). So I'd love it, if someone still managed to do a pure gtable + grid version.
library(tidyverse)
library(ggh4x)
library(cowplot)
plots = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n()),
plotrow=(id-1)%/%4+1) %>%
group_by(plotrow) %>%
group_map( ~ ggplot(data=.,
aes(x=x,y=y)) +
geom_jitter() +
facet_nested( ~ id + id2, ))
plot_grid(plotlist = plots, nrow = 4, ncol=1)
I'm a bit late to this game, but ggh4x now has a facet_nested_wrap() implementation that should greatly simplify this problem (disclaimer: I wrote ggh4x).
library(tidyverse)
library(ggh4x)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_nested_wrap(~id + id2, nrow = 4, ncol=8)
p1
Created on 2020-08-12 by the reprex package (v0.3.0)
Keep in mind that there might still be a few bugs in this. Also, I'm aware that this doesn't help the OP because his package versions are constrained, but I thought I mention this here anyway.
Here's a reprex of a somewhat pedestrian way to do it in grid. I have made the "parent" facet somewhat darker to emphasise the nesting, but if you prefer the color to match just change the rectGrob fill color to "gray85".
# Set up plot as per example
library(tidyverse)
library(gtable)
library(grid)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_wrap(~id + id2, nrow = 4, ncol=8)
g <- ggplot_gtable(ggplot_build(p1))
# Code to produce facet strips
stript <- grep("strip", g$layout$name)
grid_cols <- sort(unique(g$layout[stript,]$l))
t_vals <- rep(sort(unique(g$layout[stript,]$t)), each = length(grid_cols)/2)
l_vals <- rep(grid_cols[seq_along(grid_cols) %% 2 == 1], length = length(t_vals))
r_vals <- rep(grid_cols[seq_along(grid_cols) %% 2 == 0], length = length(t_vals))
labs <- levels(as.factor(p1$data$id))
for(i in seq_along(labs))
{
filler <- rectGrob(y = 0.7, height = 0.6, gp = gpar(fill = "gray80", col = NA))
tg <- textGrob(label = labs[i], y = 0.75, gp = gpar(cex = 0.8))
g <- gtable_add_grob(g, filler, t = t_vals[i], l = l_vals[i], r = r_vals[i],
name = paste0("filler", i))
g <- gtable_add_grob(g, tg, t = t_vals[i], l = l_vals[i], r = r_vals[i],
name = paste0("textlab", i))
}
grid.newpage()
grid.draw(g)
And to demonstrate changing the rectGrob to 50% height and "gray85":
Or if you wanted you could assign a different fill for each cycle of the loop:
Obviously the above method might take a few tweaks to fit other plots with different numbers of levels etc.
Created on 2020-07-04 by the reprex package (v0.3.0)
Maybe this can not tackle the issue, but I would like to post because it could help to present results in a different plot keeping the same structure. You will have to define the number of columns for the plot in plot_layout(ncol = 4). This code uses patchwork package. Hope this can be useful.
library(tidyverse)
library(gtable)
library(grid)
library(patchwork)
idx = 1:16
#Data
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n()))
#Split data
List <- split(p1,p1$id)
#Sketch function
myplot <- function(x)
{
d <- ggplot(x,aes(x=x,y=y)) +
geom_jitter() +
facet_wrap(~id2, nrow = 1, ncol=2)+
ggtitle(unique(x$id))+
theme(plot.title = element_text(hjust = 0.5))
return(d)
}
#List of plots
Lplots <- lapply(List,myplot)
#Concatenate plots
#Create chain for plots
chain <- paste0('Lplots[[',1:length(Lplots),']]',collapse = '+')
#Evaluate the object and create the plot
Plot <- eval(parse(text = chain))+plot_layout(ncol = 4)+
plot_annotation(title = 'A nice plot')&theme(plot.title = element_text(hjust=0.5))
#Display
Plot
You will end up with a plot like this:
I have data I'd like to plot the distribution density of. The data are from three groups, where for each there are three states, each with a probability, and these probabilities sum to 1.
I'm trying to use R's plotly to plot, for each group, the density of the probabilities, color coded by state, and add some text annotation to each such group plot. Finally I'm trying to combine all of these group plots using plotly::subplot.
Here's the code to generate the data and a list of group plots:
library(dplyr)
library(reshape2)
library(plotly)
set.seed(1)
plot.list <- lapply(1:3,function(g){
if(g == 1){
show.legend <- T
} else{
show.legend <- F
}
df <- data.frame(id=LETTERS,t(sapply(1:length(LETTERS),function(x){
probs <- runif(3,0,1)
return(probs/sum(probs))
}))) %>% dplyr::rename(S1=X1,S2=X2,S3=X3) %>%
reshape2::melt() %>% dplyr::rename(state=variable,probability=value)
df$state <- factor(df$state,levels=c("S1","S2","S3"))
density.df <- do.call(rbind,lapply(levels(df$state),function(s){
dens <- density(dplyr::filter(df,state == s)$probability)
return(data.frame(x=dens$x,y=dens$y,state=s,stringsAsFactors=F))
}))
density.df$state <- factor(density.df$state,levels=levels(df$state))
dens.plot <- plot_ly(x=~density.df$x,y=~density.df$y,type='scatter',mode='lines',color=~density.df$state,showlegend=show.legend) %>%
layout(xaxis=list(title="Probability",zeroline=F),yaxis=list(title="Count",zeroline=F)) %>%
add_annotations(x=0.75,y="top",text=paste0("text: ",g))
if(show.legend) dens.plot <- dens.plot %>% add_annotations(text="State",xref="paper",yref="paper",x=1.02,xanchor="left",y=1.02,yanchor="top",legendtitle=T,showarrow=F)
return(dens.plot)
})
Note that I'm only adding the legend to the first group so it appears only once in the final grouped plot (there's probably a more elegant way of achieving that).
And here's the plotly::subplot command I'm using:
subplot(plot.list,nrows=3,shareX=T,shareY=T,titleX=T,titleY=T)
Which gives:
As you can see the text annotation is stuck at "top" of the first plot rather than at the top of each individual plot.
Any idea how do I get each annotation to be located at the top of its corresponding sub-plot?
Preamble. For reasons that are not entirely obvious to me (but relating to how values for annotations are scaled when running subplot), annotations seem to go awry with vertically stacked subplots. To see this, run the MWE at https://plot.ly/r/text-and-annotations/#subplot-annotations, but change
subplot(p1, p2, titleX = TRUE, titleY = TRUE)
to
subplot(p1, p2, titleX = TRUE, titleY = TRUE, nrows = 2)
In the vertically stacked version, the annotations are not where we would expect them to be. To achieve your desired outcome would require some post-processing of the subplot output. Now, on to your main question.
First, in add_annotations, add xref and yref arguments that correspond to each subplot. In each element of plot.list, I also add an additional element y_anno to keep track of where we would like the annotation to go (at the maximum value of the densities in each subplot).
plot.list <- lapply(1:3,function(g){
if(g == 1){
show.legend <- T
} else{
show.legend <- F
}
df <- data.frame(id=LETTERS,t(sapply(1:length(LETTERS),function(x){
probs <- runif(3,0,1)
return(probs/sum(probs))
}))) %>% dplyr::rename(S1=X1,S2=X2,S3=X3) %>%
reshape2::melt() %>% dplyr::rename(state=variable,probability=value)
df$state <- factor(df$state,levels=c("S1","S2","S3"))
density.df <- do.call(rbind,lapply(levels(df$state),function(s){
dens <- density(dplyr::filter(df,state == s)$probability)
return(data.frame(x=dens$x,y=dens$y,state=s,stringsAsFactors=F))
}))
density.df$state <- factor(density.df$state,levels=levels(df$state))
dens.plot <- plot_ly(x=~density.df$x,
y=~density.df$y,
type='scatter',
mode='lines',
color=~density.df$state,
showlegend=show.legend) %>%
layout(xaxis=list(title="Probability",zeroline=F),yaxis=list(title="Count",zeroline=F)) %>%
add_annotations(x = 0.75,
y = max(density.df$y),
text = paste0("text: ", g),
xref = paste0("x", g), # add this
yref = paste0("y", g), # add this
ax = 0,
ay = 0)
if(show.legend) dens.plot <- dens.plot %>% add_annotations(text="State",xref="paper",yref="paper",x=1.02,xanchor="left",y=1.02,yanchor="top",legendtitle=T,showarrow=F)
dens.plot$y_anno <- max(density.df$y) # add this
return(dens.plot)
})
Now if we run subplot(plot.list,nrows=3,shareX=T,shareY=T,titleX=T,titleY=T), the text will be in each subplot, but not at the top (due to the phenomenon I described in the preamble). To fix this, we can post-process the subplot output:
p <- subplot(plot.list, nrows = 3,shareX = T,shareY = T,titleX = T,titleY = T)
for (i in seq_along(plot.list)) {
for (j in seq_along(p$x$layout$annotations)) {
if (p$x$layout$annotations[[j]]$yref == paste0("y", i))
p$x$layout$annotations[[j]]$y <- plot.list[[i]]$y_anno
}
}
Now p gives us
which is close to what we want.
When making faceted plots in ggplot and changing the aspect ratio, usually there is a lot of white space either left and right or above and below the graph. E.g:
library(ggplot2)
df <- data.frame(x=rep(1,3), y=rep(1,3), z=factor(letters[1:3]))
p <- ggplot(df, aes(x, y)) + geom_point() + coord_fixed(ratio=1) + facet_grid(z ~ .)
ggsave("plot.jpg", p, scale=1, device="jpeg")
Is there a way to autocrop the graph?
This is what I came up with. I tested it on your sample & it seems to work okay there, but apologies in advance if it breaks somewhere else. I had to dig into the grob version for the width/height information, and depending on whether the plot is faceted or not, the attribute information for "unit" is located at different places.
Hopefully someone more well-versed with the grid package's unit object can chip in, but here's what I've got:
# Note that you need to set an upper limit to the maximum height/width
# that the plot can occupy, in the max.dimension parameter (defaults to
# 10 inches in this function)
ggsave_autosize <- function(filename, plot = last_plot(), device = NULL, path = NULL, scale = 1,
max.dimension = 10, units = c("in", "cm", "mm"),
dpi=300, limitsize = TRUE){
sumUnitNull <- function(x){
res <- 0
for(i in 1:length(x)){
check.unit <- ifelse(!is.null(attr(x[i], "unit")), attr(x[i], "unit"),
ifelse(!is.null(attr(x[i][[1]], "unit")), attr(x[i][[1]], "unit"), NA))
if(!is.na(check.unit) && check.unit == "null") res <- res + as.numeric(x[i])
}
return(res)
}
# get width/height information from the plot object (likely in a mixture of different units)
w <- ggplotGrob(plot)$widths
h <- ggplotGrob(plot)$heights
# define maximum dimensions
w.max <- grid::unit(max.dimension, units) %>% grid::convertUnit("in") %>% as.numeric()
h.max <- grid::unit(max.dimension, units) %>% grid::convertUnit("in") %>% as.numeric()
# sum the inflexible size components of the plot object's width/height
# these components have unit = "in", "mm", "pt", "grobheight", etc
w.in <- w %>% grid::convertUnit("in") %>% as.numeric() %>% sum()
h.in <- h %>% grid::convertUnit("in") %>% as.numeric() %>% sum()
# obtain the amount of space available for the flexible size components
w.avail <- w.max - w.in
h.avail <- h.max - h.in
# sum the flexible sized components of the plot object's width/height
# these components have unit = "null"
w.f <- sumUnitNull(w)
h.f <- sumUnitNull(h)
# shrink the amount of avilable space based on what the flexible components would actually take up
if(w.f/h.f > w.avail/h.avail) h.avail <- w.avail/w.f*h.f else w.avail <- h.avail/h.f*w.f
w <- w.in + w.avail
h <- h.in + h.avail
ggsave(filename, plot = plot, device = device, path = path, scale = scale,
width = w, height = h, units = units, dpi = dpi, limitsize = limitsize)
}
p <- ggplot(mpg, aes(displ, cty)) + geom_point() + coord_fixed(ratio=1)
p <- p + facet_grid(. ~ cyl)
ggsave("pOriginal.png", p + ggtitle("original"))
ggsave_autosize("pAutoSize.png", p + ggtitle("auto-resize"))
ggsave_autosize("pAutoSize8.png", p + ggtitle("auto-resize, max dim = 8in x 8in"), max.dimension = 8, units = "in")
Original version w/o cropping. There's black space on the left / right:
Automatically cropped version. Height = 10 inches:
Automatically cropped version. Height = 8 inches (so the font looks slightly larger):
I am trying to plot celestial object on the sky (basically with coordinates equivalent to latitude/longitude). I successfully plotted all my points using the "aitoff" projection of the coord_map function, but in this case, the grid is badly displayed, i.e. residual horizontal lines are still displayed for latitudes non equal to zero along with their correct projections.
How could I remove these lines?
Here is code that reproduces the behavior:
library(ggplot2)
library(mapproj)
sky2 = data.frame(RA=0, Dec=0)
skyplot2 <- qplot(RA,Dec,data=sky2,xlim=c(0,360),ylim=c(-89.999,89.999),
xlab="R.A.(°)", ylab="Decl. (°)",main="Source repartition on the sky")
skyplot2 + coord_map(projection="aitoff",orientation=c(89.999,180,0)) +
scale_y_continuous(breaks=(-2:2)*30,limits=c(-89.999,89.999)) +
scale_x_continuous(breaks=(0:8)*45,limits=c(0,360),
labels=c("","","","","","","","",""))
Definitely this is a bug in ggplot2 so could you please file this bug?
https://github.com/hadley/ggplot2/issues?state=open Filed as a bug.
Here is a quick and dirty hack.
f <- function(x, y, ...) {
if (any(is.na(x))) {
id <- rle(!is.na(x))$length
id <- rep(seq_along(id), id)
df <- data.frame(x, y, id)
df <- df[order(df$id, df$x), ]
} else if (any(is.na(y))) {
id <- rle(!is.na(y))$length
id <- rep(seq_along(id), id)
df <- data.frame(x, y, id)
}
polylineGrob(df$x, df$y, id = df$id, gp = gpar(col = "white"))
}
skyplot2 <- qplot(RA,Dec,data=sky2,xlim=c(0,360),ylim=c(-89.999,89.999),
xlab="R.A.(°)", ylab="Decl. (°)",main="Source repartition on the sky")
skyplot2 + coord_map(projection="aitoff",orientation=c(89.999,180,0)) +
scale_y_continuous(breaks=(-2:2)*30,limits=c(-89.999,89.999)) +
scale_x_continuous(breaks=(0:8)*45,limits=c(0,360),
labels=c("","","","","","","","","")) +
opts(panel.grid.major = f)
Note that this may work only with the aitoff projection.
You just need to add:
+ opts(axis.ticks = theme_blank())
Consider the following ggplot2 graph with long facet/strip text
broken in two lines.
The text goes outside the area devoted to facet titles.
library(ggplot2)
x <- c(1:3, 1:3)
y <- c(3:1, 1:3)
grp <- c(0, 0, 0, 1, 1, 1)
p <- qplot(x=x, y=y) + geom_line() + facet_wrap(~ grp)
grob <- ggplotGrob(p)
strip.elem.y <- grid.ls(getGrob(grob, "strip.text.x",
grep=TRUE, global=TRUE))$name
grob <- geditGrob(grob, strip.elem.y[1],
label="First line and\n second line" )
grid.draw(grob)
Is there a way to increase the height of the strip text area ?
ggplot2 supports a built in way of doing this using label_wrap_gen.
x <- c(1:3, 1:3)
y <- c(3:1, 1:3)
grp = c(rep("group 1 with a long name",3),rep("group 2 with a long name",3))
d = data.frame(x = x, y =y, grp = grp)
ggplot(d, aes(x=x,y=y)) + geom_line() + facet_wrap(~ grp, labeller = label_wrap_gen(width=10))
You can use a 2-line label:
grp <- c(rep("foo\nbar",3), 1, 1, 1)
qplot(x=x, y=y) + geom_line() + facet_wrap(~ grp)
I tried this a variety of ways but was frustrated getting the paste(strwrap(text, width=40), collapse=" \n") to give me results for the single row of data and not concatenate the each bit of text from the entire list.
I came up with a solution that worked best for me. I wrote a function like the one below. Given a dataframe data with column text
wrapit <- function(text) {
wtext <- paste(strwrap(text,width=40),collapse=" \n ")
return(wtext)
}
data$wrapped_text <- llply(data$text, wrapit)
data$wrapped_text <- unlist(data$wrapped_text)
After I called this function, I just applied my labeller function to the wrapped_text column instead of the text column.
Expanding on the useful example from #groceryheist we can use the argument multi_line = True with label_wrap_gen() to get the desired effect without having to specify a fixed width.
library(ggplot2)
x = c(1:3, 1:3)
y = c(3:1, 1:3)
grp = c(rep("group 1 with a very very very long name",3),
rep("group 2 with an even longer name",3))
df = data.frame(x = x, y =y, grp = grp)
ggplot(df, aes(x,y)) +
geom_line() +
facet_wrap(~ grp,
labeller = label_wrap_gen(multi_line = TRUE))
Ref: https://ggplot2.tidyverse.org/reference/labellers.html