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
Related
I would like to align the area of several plots, each of them created by separate chunks in an RMarkdown document (preferably .html) "nicely". My problem: Because of the different lengths of the y-axis texts. The plotted area doesn't overlap perfectly (A pity because my actual x-axis is months).
Setting the fig.width= and out.width= don't help here as they consider the axis text lengths.
Dummy Data chunk:
require(ggplot2)
df = expand.grid(y = LETTERS,
x = paste0('A', 1:10),
stringsAsFactors = FALSE)
set.seed(42)
df$fill = rnorm(nrow(df))
df2 = df
df2$y = unlist(lapply(lapply(df2$y, function(x) rep(x, 10)), paste0, collapse = ''))
Plot-Chunk1:
gg1 = ggplot(df, aes(y = y, x = x, fill = fill)) +
geom_tile()
gg1
Plot-Chunk2:
gg2 = ggplot(df2, aes(y = y, x = x, fill = fill)) +
geom_tile()
gg2
The plots in the RMarkdown document should look like that (red lines highlight the desired alignment):
I achieved this with the patchwork package. However, like this I can only use one chunk and not multiple.
Patchwork-Plot-Chunk:
require(patchwork)
gg1 / gg2 +
plot_annotation(tag_levels = 'A')
Edited (tidier?) solution: cowplot::align_plots
Having a bit of a play around with cowplot::align_plots, it would be possible to set a standard panel width to use across all graphs. But to do this across chunks when you're constructing each graph 'blind' to the forthcoming ones, you could create a 'template' plot with labels as wide as needed (gg_set below). Each subsequent graph would then adopt the sizing of this unused plot:
require(ggplot2)
df <- expand.grid(y = LETTERS,
x = paste0('A', 1:10),
stringsAsFactors = FALSE)
set.seed(42)
df$fill = rnorm(nrow(df))
df2 <- df
df2$y <-
unlist(lapply(lapply(df2$y, function(x)
rep(x, 5)), paste0, collapse = ''))
# df for setting max size needed - might need experimented with
dfset <- df
dfset$y <-
unlist(lapply(lapply(df$y, function(x)
rep(x, 10)), paste0, collapse = ''))
# 'template' plot
gg_set <- ggplot(dfset, aes(y = y, x = x, fill = fill)) +
geom_tile()
require(cowplot)
# Chunk 1
gg1 <- ggplot(df, aes(y = y, x = x, fill = fill)) +
geom_tile()
ggs <- align_plots(gg_set, gg1, align = "v")
# Only extracting relevant graph.
ggdraw(ggs[[2]])
# Chunk 2
gg2 <- ggplot(df2, aes(y = y, x = x, fill = fill)) +
geom_tile()
ggs <- align_plots(gg_set, gg2, align = "v")
ggdraw(ggs[[2]])
Created on 2021-12-17 by the reprex package (v2.0.1)
Untidy former solution
I've previously used an admittedly messy solution, which really just involves padding all labels with blank rows above and below to greater than the max length:
require(ggplot2)
#> Loading required package: ggplot2
df <- expand.grid(y = LETTERS,
x = paste0('A', 1:10),
stringsAsFactors = FALSE)
set.seed(42)
df$fill = rnorm(nrow(df))
df2 <- df
df2$y <-
unlist(lapply(lapply(df2$y, function(x)
rep(x, 10)), paste0, collapse = ''))
df$y <-
paste0(paste0(rep(" ", 40), collapse = ""), "\n", df$y, "\n", paste0(rep(" ", 40)))
df2$y <-
paste0(paste0(rep(" ", 40), collapse = ""), "\n", df2$y, "\n", paste0(rep(" ", 40)))
gg1 <- ggplot(df, aes(y = y, x = x, fill = fill)) +
geom_tile()
gg1
gg2 <- ggplot(df2, aes(y = y, x = x, fill = fill)) +
geom_tile()
gg2
I would hope their is a more formal solution which allows a static panel sizing, and I look forward to hearing other answers. But had used this as a quick fix!
Created on 2021-12-17 by the reprex package (v2.0.1)
The patchwork package also includes the function align_patches() which works similar to cowplot::align_plots().
gg_l = patchwork::align_patches(gg1,
gg2)
Plot-Chunk1:
gg_l[[1]]
Plot-Chunk2:
gg_l[[2]]
Data from question.
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 am trying to display some data, where I don't only need to display a point using geom_point, but also want to trace a line to it from the axis. I figured I can do it with geom_segment, but I want to display a sequence of discrete dots instead.
Say I have a data like this:
df2 <- data_frame(x = c("a", "b", "c" ,"d"), y = c(3:6))
# A tibble: 4 × 2
x y
<chr> <int>
1 a 3
2 b 4
3 c 5
4 d 6
What I want to get is like the graph below, only having a dot in each of 4 variables between 0 and their value (with the desired points marked manually in red):
ggplot(df2, aes(x=x)) + geom_point(aes(y=y)) + geom_point(aes(y=0))
This works... you could wrap it up in a function to make it more generalizable if needed.
First we use expand.grid to create all combinations of x and 1:(max(y) - 1), join it to the original data, and filter out the unnecessary ones.
library(dplyr)
df3 = left_join(expand.grid(x = unique(df2$x), i = 1:max(df2$y - 1)),
df2) %>%
filter(i < y)
Once the data is constructed, the plotting is easy:
ggplot(df2, aes(x=x)) +
geom_point(aes(y=y)) +
geom_point(y = 0) +
geom_point(data = df3, aes(y = i), color = "red") +
expand_limits(y = 0)
I'm not sure if you actually want the dots to be red - if you want them to all look the same then you could use 1:max(df2$y) (omit the -1) and use <= in the filter to and then only use the resulting data frame.
If you wanted to use a data.table approach, using a similar expansion methodology you could use:
dt <- setDT(df2)
dt_expand<-dt[rep(seq(nrow(dt)),dt$y),]
dt_expand[,y2:=(1:.N),by=.(x)]
ggplot(dt_expand, aes(x=x)) + geom_point(aes(y=y2)) + geom_point(aes(y=0))
Note I didn't include the red coloring, but that is easily done if you want it
Here a solution in base R. The idea is to create 2 different datasets , one for red points:
dat1 <- do.call(rbind,Map(function(x,y)data.frame(x=x,y=seq(0,y)),df2$x,df2$y))
And another for the black points
dat2 <- do.call(rbind,Map(function(x,y)data.frame(x=x,y=c(0,y)),df2$x,df2$y))
Then the plot is just the juxtopsition of 2 layers of the same plot but with different datas:
library(ggplot2)
ggplot(data=dat1,aes(x=x,y=y)) +
geom_point(col="red") +
geom_point(data=dat2)
Yet another option, which is similar to #Gregor's, in that it's creating a new data vector.
d <- data.frame(x = c("a", "b", "c" ,"d"), y = c(3:6))
new_points <- mapply(seq, 0, d$y)
new <- data.frame(new = unlist(lapply(new_points, as.data.frame)),
x = rep(letters[1:4], d$y + 1),
group = 1)
d <- merge(d, new, by = "x")
d$group <- as.factor(ifelse(d$y == d$new|d$new == 0, 2, d$group))
ggplot(d, aes(x, new, color = group)) +
geom_point() +
scale_color_manual(values = c("red", "black")) +
theme(legend.position = "none")
I want to plot some lines and have them differentiated on color and linetype. If I differentiate on color alone, it's fine. If I add linetype, the line for group 14 vanishes.
(ggplot2_2.1.0, R version 3.3.1)
library(ggplot2)
g <- paste("Group", 1:14)
group <- factor(rep(g, each=14), levels=g)
x <- rep(1:14, length.out=14*14)
y <- c(runif(14*13), rep(0.55, 14))
d <- data.frame(group, x, y, stringsAsFactors=FALSE)
# Next 2 lines work fine - check the legend for Group 14
ggplot(d, aes(x, y, color=group)) +
geom_line()
# Add linetype
ggplot(d, aes(x, y, color=group, linetype=group)) +
geom_line()
# Group 14 is invisible!
What's going on?
You can solve it by defining a form of each line manually with hex strings (see ?linetype).
?linetype says;
..., the string "33" specifies three units on followed by three off
and "3313" specifies three units on followed by three off followed by
one on and finally three off.
HEX <- c(1:9, letters[1:6]) # can't use 0
## make linetype with (two- or) four‐digit number of hex
# In this example, I made them randomly
set.seed(1); HEXs <- matrix(sample(HEX, 4*14, replace = T), ncol = 4)
my_val <- apply(HEXs, 1, function(x) paste0(x[1], x[2], x[3], x[4]))
# example data
group <- factor(rep(paste("Group", 1:14), each = 20), levels=paste("Group", 1:14))
data <- data.frame(x = 1:20, y = rep(1:14, each=20), group = group)
ggplot(data, aes(x = x, y = y, colour = group, linetype = group)) +
geom_line() +
scale_linetype_manual(values = my_val)
I am looking for ways to fully fill in the contour generated by ggplot2's stat_contour. The current result is like this:
# Generate data
library(ggplot2)
library(reshape2) # for melt
volcano3d <- melt(volcano)
names(volcano3d) <- c("x", "y", "z")
v <- ggplot(volcano3d, aes(x, y, z = z))
v + stat_contour(geom="polygon", aes(fill=..level..))
The desired result can be produced by manually modifying the codes as follows.
v + stat_contour(geom="polygon", aes(fill=..level..)) +
theme(panel.grid=element_blank())+ # delete grid lines
scale_x_continuous(limits=c(min(volcano3d$x),max(volcano3d$x)), expand=c(0,0))+ # set x limits
scale_y_continuous(limits=c(min(volcano3d$y),max(volcano3d$y)), expand=c(0,0))+ # set y limits
theme(panel.background=element_rect(fill="#132B43")) # color background
My question: is there a way to fully fill the plot without manually specifying the color or using geom_tile()?
As #tonytonov has suggested this thread, the transparent areas can be deleted by closing the polygons.
# check x and y grid
minValue<-sapply(volcano3d,min)
maxValue<-sapply(volcano3d,max)
arbitaryValue=min(volcano3d$z-10)
test1<-data.frame(x=minValue[1]-1,y=minValue[2]:maxValue[2],z=arbitaryValue)
test2<-data.frame(x=minValue[1]:maxValue[1],y=minValue[2]-1,z=arbitaryValue)
test3<-data.frame(x=maxValue[1]+1,y=minValue[2]:maxValue[2],z=arbitaryValue)
test4<-data.frame(x=minValue[1]:maxValue[1],y=maxValue[2]+1,z=arbitaryValue)
test<-rbind(test1,test2,test3,test4)
vol<-rbind(volcano3d,test)
w <- ggplot(vol, aes(x, y, z = z))
w + stat_contour(geom="polygon", aes(fill=..level..)) # better
# Doesn't work when trying to get rid of unwanted space
w + stat_contour(geom="polygon", aes(fill=..level..))+
scale_x_continuous(limits=c(min(volcano3d$x),max(volcano3d$x)), expand=c(0,0))+ # set x limits
scale_y_continuous(limits=c(min(volcano3d$y),max(volcano3d$y)), expand=c(0,0)) # set y limits
# work here!
w + stat_contour(geom="polygon", aes(fill=..level..))+
coord_cartesian(xlim=c(min(volcano3d$x),max(volcano3d$x)),
ylim=c(min(volcano3d$y),max(volcano3d$y)))
The problem remained with this tweak is finding methods aside from trial and error to determine the arbitaryValue.
[edit from here]
Just a quick update to show how I am determining the arbitaryValue without having to guess for every datasets.
BINS<-50
BINWIDTH<-(diff(range(volcano3d$z))/BINS) # reference from ggplot2 code
arbitaryValue=min(volcano3d$z)-BINWIDTH*1.5
This seems to work well for the dataset I am working on now. Not sure if applicable with others. Also, note that the fact that I set BINS value here requires that I will have to use bins=BINS in stat_contour.
Thanks for #chengvt's answer. I sometimes needs this technique, so I made a generalized function().
test_f <- function(df) {
colname <- names(df)
names(df) <- c("x", "y", "z")
Range <- as.data.frame(sapply(df, range))
Dim <- as.data.frame(t(sapply(df, function(x) length(unique(x)))))
arb_z = Range$z[1] - diff(Range$z)/20
df2 <- rbind(df,
expand.grid(x = c(Range$x[1] - diff(Range$x)/20, Range$x[2] + diff(Range$x)/20),
y = seq(Range$y[1], Range$y[2], length = Dim$y), z = arb_z),
expand.grid(x = seq(Range$x[1], Range$x[2], length = Dim$x),
y = c(Range$y[1] - diff(Range$y)/20, Range$y[2] + diff(Range$y)/20), z = arb_z))
g <- ggplot(df2, aes(x, y, z = z)) + labs(x = colname[1], y = colname[2], fill = colname[3]) +
stat_contour(geom="polygon", aes(fill=..level..)) +
coord_cartesian(xlim=c(Range$x), ylim=c(Range$y), expand = F)
return(g)
}
library(ggplot2); library(reshape2)
volcano3d <- melt(volcano)
names(volcano3d) <- c("xxx", "yyy", "zzz")
test_f(volcano3d) + scale_fill_gradientn(colours = terrain.colors(10))