ggh4x how to stretch strip across layers
I'm working on a facet_nested_wrap plot (see image below) where I happen to have one of the aspect (CENT) having only one level, as opposed to two, as in the other (TELO).
Is there a way to increase the height/stretch that strip so that it has the same height of those in the other facet combined? I share a head() and tail() of the df, but basically for the variable ARM the CENT category has NA.
head(all)
HAP CHR `Length (in bps)` REG ARM
<chr> <fct> <dbl> <chr> <chr>
1 hap1 chr1 4535 TELO p-arm
2 hap1 chr1 4435 TELO p-arm
3 hap1 chr1 4335 TELO p-arm
4 hap1 chr1 4235 TELO p-arm
5 hap1 chr1 4135 TELO p-arm
6 hap1 chr1 4035 TELO p-arm
tail(all)
HAP CHR `Length (in bps)` REG ARM
<chr> <fct> <dbl> <chr> <chr>
1 hap1 chr21 1761195 CENT NA
2 hap2 chr21 2093093 CENT NA
3 hap1 chr22 3272138 CENT NA
4 hap2 chr22 4103205 CENT NA
5 hap1 chrX 4394450 CENT NA
6 hap2 chrX 2887908 CENT NA
So, far what I attained with my code was to only suppress the bottom layer with element_blank(); however, I couldn't figure out how to selectively control strips height. Any help is much appreciated, thanks!
CODE
library(ggh4x)
library(scales)
library(ggplot2)
library(extrafont)
library(paletteer)
library(elementalist)
t_col <- function(color, percent = 75, name = NULL) {
rgb.val <- col2rgb(color)
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
max = 255,
alpha = (100 - percent) * 255 / 100,
names = name)
invisible(t.col)
}
legend_fill <- t_col("white", perc=25, name="lt.fill")
fancy_scientific <- function(l) {
l <- format(l, scientific = TRUE)
l <- gsub("^(.*)e", "'\\1'e", l)
l <- gsub("e", "%*%10^", l)
parse(text=l)
}
strips_2 <- strip_nested(
background_y = list(element_rect(fill="#8e9295"),
element_rect(fill="#8e9295"),
element_blank(),
element_rect(fill="#2a52be"),
element_rect("#4169e1")),
text_y = list(element_text(face="bold", color="white", size=12),
element_text(face="bold", color="white", size=12),
element_blank(),
element_text(color="white", size=10),
element_text(color="white", size=10)),
by_layer_y = FALSE
)
my_palette <- paletteer_d("wesanderson::Darjeeling1")[c(2,4)]
facet_both <- ggplot(all, aes(fill=HAP, x=CHR, y=`Length (in bps)`)) +
geom_col(position="dodge", width=.4, alpha=.75, color="black", linewidth=0.1) +
theme_bw() + facet_nested_wrap(~REG + ARM, ncol=1, dir="h", strip=strips_2, strip.position="left", scales="free_y") +
theme(legend.box.background=element_rect_round(color="black",
fill=legend_fill,
linetype="solid",
radius=unit(1,"mm")),
legend.background=element_rect(fill="transparent"),
legend.position.inside=c(0.951,0.94), legend.box='horizontal',
text=element_text(family="Arial"), panel.grid=element_blank(), legend.title=element_blank(),
axis.text=element_text(size=12), axis.text.x=element_text(angle=45, hjust = 1), axis.title.x=element_blank(),
axis.title.y=element_text(size=16), legend.text=element_text(size=8), plot.margin=unit(c(.3, .5, .2, .2), "cm"),
panel.border = element_rect(colour="black", fill=NA, linewidth=1.5)
) +
guides(fill=guide_legend(ncol=2, keywidth=1, position="inside")) + scale_fill_manual(values=(my_palette)) +
scale_y_continuous(labels=function(x) ifelse(x == 0, "0", fancy_scientific(x)), limits=c(0, NA), expand=c(0, 0), position="right")
facet_both + facetted_pos_scales(
y = list(
REG == "CENT" ~ scale_y_continuous(labels=function(x) ifelse(x == 0, "0", fancy_scientific(x)), limits=c(0, 1.5e+07), expand=c(0, 0), position="right"),
REG == "TELO" ~ scale_y_continuous(labels=function(x) ifelse(x == 0, "0", fancy_scientific(x)), limits=c(0, 25000), expand=c(0, 0), position="right",
breaks=c(0, 8000, 16000, 24000))
)
)
Solution
Here's an approach using {patchwork} by creating separate plot for each facet and then combining them. I have created a sample dataset shared at the end.
library(patchwork)
p_cent <- ggplot(all[all$REG == "CENT", ],
aes(fill=HAP, x=CHR, y=`Length (in bps)`)) +
geom_col(position="dodge", width=.4, alpha=.75, color="black", linewidth=0.1) +
theme_bw() +
facet_wrap(~REG, ncol=1, strip.position="left", scales="free_y") +
theme(
legend.box.background=element_rect_round(color="black",
fill=legend_fill,
linetype="solid",
radius=unit(1,"mm")),
legend.background=element_rect(fill="transparent"),
legend.position.inside=c(0.951,0.94), legend.box='horizontal',
strip.background.y = element_rect(fill="#8e9295", color="black"),
strip.text.y.left = element_text(face="bold", color="white", size=12, angle=0),
text=element_text(family="Arial"),
panel.grid=element_blank(),
axis.text=element_text(size=12),
axis.text.x=element_text(angle=45, hjust=1),
axis.title.x=element_blank(),
legend.title=element_blank(),
plot.margin=unit(c(.3, .5, .2, .2), "cm"),
panel.border=element_rect(colour="black", fill=NA, linewidth=1.5)
) +
guides(fill=guide_legend(ncol=2, keywidth=1, position="inside")) +
scale_fill_manual(values=my_palette, drop=FALSE) +
scale_x_discrete(drop=FALSE) +
scale_y_continuous(labels=function(x) ifelse(x == 0, "0", fancy_scientific(x)),
limits=c(0, 1.5e+07), expand=c(0, 0), position="right")
strips_telo <- strip_nested(
background_y = list(
element_rect(fill="#8e9295"),
element_rect(fill="#2a52be"),
element_rect(fill="#4169e1")
),
text_y = list(
element_text(face="bold", color="white", size=12),
element_text(color="white", size=10),
element_text(color="white", size=10)
),
by_layer_y = FALSE
)
p_telo <- ggplot(all[all$REG == "TELO", ],
aes(fill=HAP, x=CHR, y=`Length (in bps)`)) +
geom_col(position="dodge", width=.4, alpha=.75, color="black", linewidth=0.1) +
theme_bw() +
facet_nested_wrap(~REG + ARM, ncol=1, dir="h", strip=strips_telo,
strip.position="left", scales="free_y") +
theme(
text=element_text(family="Arial"),
panel.grid=element_blank(),
legend.position="none",
axis.text=element_text(size=12),
axis.text.x=element_text(angle=45, hjust=1),
axis.title.x=element_blank(),
legend.title=element_blank(),
plot.margin=unit(c(.3, .5, .2, .2), "cm"),
panel.border=element_rect(colour="black", fill=NA, linewidth=1.5)
) +
scale_fill_manual(values=my_palette, drop=FALSE) +
scale_x_discrete(drop=FALSE) +
scale_y_continuous(labels=function(x) ifelse(x == 0, "0", fancy_scientific(x)),
limits=c(0, 25000), expand=c(0, 0), position="right",
breaks=c(0, 8000, 16000, 24000))
p_cent / p_telo +
plot_layout(heights=c(1, 2), axes = "collect")
Sample data:
all <- structure(list(HAP = c("hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2", "hap1",
"hap2", "hap1", "hap2", "hap1", "hap2", "hap1", "hap2"), CHR = structure(c(1L,
1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L,
3L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 5L, 5L, 5L, 6L, 6L, 6L,
6L, 6L, 6L, 7L, 7L, 7L, 7L, 7L, 7L, 8L, 8L, 8L, 8L, 8L, 8L, 9L,
9L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L, 10L, 10L), levels = c("chr1",
"chr2", "chr3", "chr4", "chr5", "chr6", "chr7", "chr8", "chr9",
"chr10"), class = "factor"), `Length (in bps)` = c(7901.86048299074, 19919.3232506514,
10815.4461234808, 22192.4176961184, 23571.2148230523, 2093.35598535836,
13674.5317131281, 22418.0570654571, 14234.4403471798, 11958.7536472827,
23964.0002883971, 11880.0197485834, 17261.6952508688, 14743.2016469538,
3470.19238397479, 22595.7992896438, 6906.10562451184, 2009.42880474031,
8870.09726278484, 23908.0875795335, 22348.9435855299, 17627.2817477584,
16372.1635304391, 24862.4746389687, 16736.9391787797, 18004.7312360257,
14057.5845930725, 15259.4084907323, 7939.83369506896, 4530.72753548622,
24112.5815808773, 22655.1770828664, 17576.9266821444, 20091.2180244923,
1590.72842821479, 12467.1033062041, 19203.0289005488, 6193.7904600054,
8636.34418323636, 6559.01884846389, 2999200.31335205, 6803648.70140329,
6792140.56814089, 6163836.31294593, 3134226.46839172, 2943284.88828614,
4262477.39233077, 7523474.30353984, 4723616.96511507, 13009588.0148001,
1641636.33342832, 7190801.03887245, 12184947.8390068, 2706589.63965252,
8853271.77261934, 3891439.45463002, 2785443.10340658, 11546310.1002388,
13530635.0281462, 6242478.86240482), REG = structure(c(2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), levels = c("CENT", "TELO"
), class = "factor"), ARM = c("p-arm", "p-arm", "p-arm", "p-arm",
"p-arm", "p-arm", "p-arm", "p-arm", "p-arm", "p-arm", "p-arm",
"p-arm", "p-arm", "p-arm", "p-arm", "p-arm", "p-arm", "p-arm",
"p-arm", "p-arm", "q-arm", "q-arm", "q-arm", "q-arm", "q-arm",
"q-arm", "q-arm", "q-arm", "q-arm", "q-arm", "q-arm", "q-arm",
"q-arm", "q-arm", "q-arm", "q-arm", "q-arm", "q-arm", "q-arm",
"q-arm", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
NA, NA, NA, NA, NA, NA, NA)), class = c("tbl_df", "tbl", "data.frame"
), row.names = c(NA, -60L))
- How to find correct projection of the shapefile data for leaflet map in r?
- How to use regex in R to shorten strings by one space
- R CRAN Check fail when using parallel functions
- Replacing several rows of data in a column efficiently using condition in a pipeline
- Iterate over vectors from an imported dataframe row-wise
- Split the legend into three rows with headings for a nested facet_wrap
- Why replace works with a boolean mask?
- Not able properly rasterize polygon dataset using terra::rasterize()
- Less than symbol ("<") in cloze schoice in Canvas (html select dropdown) shows as &lt;
- R/exams docx output does not include images
- How to have primitive discard additional arguments
- Functions Causing Objects to Disappear
- How to repel texts equidistantly on a secondary y-axis of a facet_grid?
- How can I add some text to a ggplot2 graph in R outside the plot area?
- Extracting Exact p-values from the "did" Package Output in R
- How can I set column types of several columns in empty R data frame?
- Adjust vertical line based on maximum value in graph plotly
- Combining Two Dataframes Based on Multiple Conditions & Removing Rows that Don't Match
- independent sample t-test in R using test statistics (mean, std. dev, count)
- How do I load a package without installing it in R?
- survcheck: 'x' must be an array of at least two dimensions
- Insert variable names and their specific values between the last column of facets and the strips of a facet_grid in R
- Use a recorded plot for officer
- Errors when using RStudio's Git tools
- Orientation of an irregular window changes the distance r over which secondary summary statistics are estimated
- Elegant way to check for missing packages and install them?
- How to create tmap labels along lines with rotated crs?
- How to access the value of a reactive output inside the browser console with jQuery?
- Convert excel column names to numbers
- How to adjust a node width in a Sankey plot in R?