Отказ от ответственности
Я никогда не разрабатывал facet, но я нашел вопрос интересным и достаточно сложным, поэтому я попробовал. Он еще не идеален и далеко не проверен со всеми тонкостями, которые могут возникнуть в зависимости от вашего сюжета, но это первый набросок, с которым вы можете работать.
Идея
facet_wrap устанавливает панели в таблице, и каждая строка имеет определенную высоту, которую панель полностью занимает. gtable_add_grob говорит:
В модели gtable grobs всегда заполняют всю ячейку таблицы. Если вам нужно пользовательское обоснование, вам может потребоваться определить размер grob в абсолютных единицах или поместить его в другой gtable, который затем можно добавить в gtable вместо grob.
Этот может будет интересным решением. Тем не менее, я не был уверен, как добиться этого. Таким образом, я выбрал другой подход:
- Создание пользовательского макета на основе переданного параметра макета
- Пусть
facet_wrap отображает все панели в макете - Используйте
gtable_filter, чтобы захватить панель, включая ее оси и полосы - Создать матрицу макета. Я попробовал 2 подхода: использовать минимальное количество рядов и играть с разницей в высоте. И просто добавляем примерно столько строк, сколько есть галочек на оси Y. Оба работают аналогично, последний производит более чистый код, поэтому я бы использовал этот.
- Используйте
gridExtra::arrangeGrob, чтобы расположить панели в соответствии с пройденным дизайном и созданной матрицей макета
Результаты
Полный коднемного долго, но можно найти ниже. Вот некоторые графики:
my_layout1 <- matrix(c(1, NA, 2, 3, 4, 5), nrow = 2)
my_layout2 <- matrix(c(1, 2, 3, 4, 5, NA), ncol = 2)
## Ex1
global_tile + facet_multi_col("continent", my_layout1, scales = "free_y",
space = "free", strip.position = "top")
## Ex 2
global_tile + facet_multi_col("continent", my_layout1, scales = "free_y",
space = "free", strip.position = "right")
## Ex 3 - shows that we need a minimum space for any plot
global_tile + facet_multi_col("continent", my_layout1, scales = "free_y",
space = "free", strip.position = "top", min_prop = 0)
## Ex 4
global_tile + facet_multi_col("continent", my_layout1, scales = "free_y",
space = "fixed", strip.position = "right")
## Ex 5
global_tile + facet_multi_col("continent", my_layout2, scales = "free_y",
space = "free")
Пример 1 
Пример 2 
Пример 3 
Пример 4 
Пример 5 
Ограничения
Код не является надежным. Некоторые проблемы, которые я уже вижу:
- Мы (молча) предполагаем, что каждый столбец в дизайне начинается со значения, отличного от NA (как правило, для производительного кода переданный макет необходимо тщательно проверить (выполнитеразмеры соответствуют? Есть ли столько записей, сколько панелей? и т. д.)
- Очень маленькие панели плохо рендерится, поэтому мне пришлось добавить минимальное значение для высоты в зависимости от положения полос
- Эффект перемещения или добавления осей или полос еще не проверен.
Код: один ряд на тик
## get strip and axis of a given panel
## Assumptions:
## - axis are adjacent to the panel, that is exactly +1/-1 positions to the t/b/l/r ...
## - ... unless there is a strip then it is +2/-2
get_whole_panel <- function(panel_name,
table_layout) {
target <- table_layout$layout %>%
dplyr::filter(name == panel_name) %>%
dplyr::select(row = t, col = l)
stopifnot(NROW(target) == 1)
pos <- unlist(target)
dirs <- list(t = c(-1, 0),
b = c(1, 0),
l = c(0, -1),
r = c(0, 1))
filter_elems <- function(dir,
type = c("axis", "strip")) {
type <- match.arg(type)
new_pos <- pos + dir
res <- table_layout$layout %>%
dplyr::filter(grepl(type, name),
l == new_pos["col"],
t == new_pos["row"]) %>%
dplyr::pull(name)
if (length(res)) res else NA
}
strip <- purrr::map_chr(dirs, filter_elems, type = "strip")
strip <- strip[!is.na(strip)]
dirs[[names(strip)]] <- 2 * dirs[[names(strip)]]
axes <- purrr::map_chr(dirs, filter_elems, type = "axis")
gtable::gtable_filter(table_layout, paste(c(panel_name, axes, strip), collapse = "|"))
}
facet_multi_col <- function(facets, layout, scales = "fixed", space = "fixed",
shrink = TRUE, labeller = "label_value",
drop = TRUE, strip.position = "top",
min_prop = ifelse(strip.position %in% c("top", "bottom"),
0.12, 0.1)) {
space <- match.arg(space, c("free", "fixed"))
if (space == "free") {
## if we ask for free space we need scales everywhere, so make sure they are included
scales <- "free"
}
facet <- facet_wrap(facets, ncol = 1, scales = scales, shrink = shrink,
labeller = labeller, drop = drop, strip.position = strip.position)
params <- facet$params
params$space_free <- space == "free"
params$layout <- layout
params$parent <- facet
params$min_prop <- min_prop
ggproto(NULL, FacetMultiCol, shrink = shrink, params = params)
}
render <- function(self, panels, layout,
x_scales, y_scales, ranges,
coord, data, theme, params) {
combined <- ggproto_parent(FacetWrap, self)$draw_panels(panels, layout,
x_scales, y_scales, ranges,
coord, data, theme, params)
if (params$space_free) {
panel_names <- combined$layout$name
panels <- lapply(panel_names[grepl("panel", panel_names)],
get_whole_panel,
table_layout = combined)
## remove zeroGrob panels
zG <- sapply(panels, function(tg) all(sapply(tg$grobs, ggplot2:::is.zero)))
panels <- panels[!zG]
## calculate height for each panel
heights <- matrix(NA, NROW(params$layout), NCOL(params$layout))
## store the rounded range in the matrix cell corresponding to its position
## allow for a minimum space in dependence of the overall number of rows to
## render small panels well
heights[as.matrix(layout[, c("ROW", "COL")])] <- vapply(ranges, function(r)
round(diff(r$y.range), 0), numeric(1))
## 12% should be the minimum height used by any panel if strip is on top otherwise 10%
## these values are empirical and can be changed
min_height <- round(params$min_prop * max(colSums(heights, TRUE)), 0)
heights[heights < min_height] <- min_height
idx <- c(heights)
idx[!is.na(idx)] <- seq_along(idx[!is.na(idx)])
len_out <- max(colSums(heights, TRUE))
i <- 0
layout_matrix <- apply(heights, 2, function(col) {
res <- unlist(lapply(col, function(n) {
i <<- i + 1
mark <- idx[i]
if (is.na(n)) {
NA
} else {
rep(mark, n)
}
}))
len <- length(res)
if (len < len_out) {
res <- c(res, rep(NA, len_out - len))
}
res
})
## set width of left axis to maximum width to align plots
max_width <- max(do.call(grid::unit.c, lapply(panels, function(gt) gt$widths[1])))
panels <- lapply(panels, function(p) {
p$widths[1] <- max_width
p
})
combined <- gridExtra::arrangeGrob(grobs = panels,
layout_matrix = layout_matrix,
as.table = FALSE)
## add name, such that find_panel can find the plotting area
combined$layout$name <- paste("panel_", layout$LAB)
}
combined
}
layout <- function(data, params) {
parent_layout <- params$parent$compute_layout(data, params)
msg <- paste0("invalid ",
sQuote("layout"),
". Falling back to ",
sQuote("facet_wrap"),
" layout")
if (is.null(params$layout) ||
!is.matrix(params$layout)) {
warning(msg)
parent_layout
} else {
## smash layout into vector and remove NAs all done by sort
layout <- params$layout
panel_numbers <- sort(layout)
if (!isTRUE(all.equal(sort(as.numeric(as.character(parent_layout$PANEL))),
panel_numbers))) {
warning(msg)
parent_layout
} else {
## all good
indices <- cbind(ROW = c(row(layout)),
COL = c(col(layout)),
PANEL = c(layout))
indices <- indices[!is.na(indices[, "PANEL"]), ]
## delete row and col number from parent layout
parent_layout$ROW <- parent_layout$COL <- NULL
new_layout <- merge(parent_layout,
indices,
by = "PANEL") %>%
dplyr::arrange(PANEL)
new_layout$PANEL <- factor(new_layout$PANEL)
labs <- new_layout %>%
dplyr::select(-PANEL,
-SCALE_X,
-SCALE_Y,
-ROW,
-COL) %>%
dplyr::mutate(sep = "_") %>%
do.call(paste, .)
new_layout$LAB <- labs
new_layout
}
}
}
FacetMultiCol <- ggproto("FacetMultiCol", FacetWrap,
compute_layout = layout,
draw_panels = render)
Код: строки разной высоты
## get strip and axis of a given panel
## Assumptions:
## - axis are adjacent to the panel, that is exactly +1/-1 positions to the t/b/l/r ...
## - ... unless there is a strip then it is +2/-2
get_whole_panel <- function(panel_name,
table_layout) {
target <- table_layout$layout %>%
dplyr::filter(name == panel_name) %>%
dplyr::select(row = t, col = l)
stopifnot(NROW(target) == 1)
pos <- unlist(target)
dirs <- list(t = c(-1, 0),
b = c(1, 0),
l = c(0, -1),
r = c(0, 1))
filter_elems <- function(dir,
type = c("axis", "strip")) {
type <- match.arg(type)
new_pos <- pos + dir
res <- table_layout$layout %>%
dplyr::filter(grepl(type, name),
l == new_pos["col"],
t == new_pos["row"]) %>%
dplyr::pull(name)
if (length(res)) res else NA
}
strip <- purrr::map_chr(dirs, filter_elems, type = "strip")
strip <- strip[!is.na(strip)]
dirs[[names(strip)]] <- 2 * dirs[[names(strip)]]
axes <- purrr::map_chr(dirs, filter_elems, type = "axis")
gtable::gtable_filter(table_layout, paste(c(panel_name, axes, strip), collapse = "|"))
}
facet_multi_col <- function(facets, layout, scales = "fixed", space = "fixed",
shrink = TRUE, labeller = "label_value",
drop = TRUE, strip.position = "top") {
space <- match.arg(space, c("free", "fixed"))
if (space == "free") {
## if we ask for free space we need scales everywhere, so make sure they are included
scales <- "free"
}
facet <- facet_wrap(facets, ncol = 1, scales = scales, shrink = shrink,
labeller = labeller, drop = drop, strip.position = strip.position)
params <- facet$params
params$space_free <- space == "free"
params$layout <- layout
params$parent <- facet
ggproto(NULL, FacetMultiCol, shrink = shrink, params = params)
}
render <- function(self, panels, layout,
x_scales, y_scales, ranges,
coord, data, theme, params) {
combined <- ggproto_parent(FacetWrap, self)$draw_panels(panels, layout,
x_scales, y_scales, ranges,
coord, data, theme, params)
if (params$space_free) {
panel_names <- combined$layout$name
panels <- lapply(panel_names[grepl("panel", panel_names)],
get_whole_panel,
table_layout = combined)
## remove zeroGrob panels
zG <- sapply(panels, function(tg) all(sapply(tg$grobs, ggplot2:::is.zero)))
panels <- panels[!zG]
## calculate height for each panel
heights <- matrix(NA, NROW(params$layout), NCOL(params$layout))
## need to add a minimum height as otherwise the space is too narrow
heights[as.matrix(layout[, c("ROW", "COL")])] <- vapply(layout$PANEL, function(i)
max(diff(ranges[[i]]$y.range), 8), numeric(1))
heights_cum <- sort(unique(unlist(apply(heights, 2,
function(col) cumsum(col[!is.na(col)])))))
heights_units <- unit(c(heights_cum[1], diff(heights_cum)), "null")
## set width of left axis to maximum width to align plots
max_width <- max(do.call(grid::unit.c, lapply(panels, function(gt) gt$widths[1])))
panels <- lapply(panels, function(p) {
p$widths[1] <- max_width
p
})
mark <- 0
## create layout matrix
layout_matrix <- apply(heights, 2, function(h) {
idx <- match(cumsum(h),
cumsum(c(heights_units)))
idx <- idx[!is.na(idx)]
res <- unlist(purrr::imap(idx, function(len_out, pos) {
mark <<- mark + 1
offset <- if (pos != 1) idx[pos - 1] else 0
rep(mark, len_out - offset)
}))
len_out <- length(res)
if (len_out < length(heights_units)) {
res <- c(res, rep(NA, length(heights_units) - len_out))
}
res
})
combined <- gridExtra::arrangeGrob(grobs = panels,
layout_matrix = layout_matrix,
heights = heights_units,
as.table = FALSE)
## add name, such that find_panel can find the plotting area
combined$layout$name <- paste("panel_", layout$LAB)
}
combined
}
layout <- function(data, params) {
parent_layout <- params$parent$compute_layout(data, params)
msg <- paste0("invalid ",
sQuote("layout"),
". Falling back to ",
sQuote("facet_wrap"),
" layout")
if (is.null(params$layout) ||
!is.matrix(params$layout)) {
warning(msg)
parent_layout
} else {
## smash layout into vector and remove NAs all done by sort
layout <- params$layout
panel_numbers <- sort(layout)
if (!isTRUE(all.equal(sort(as.numeric(as.character(parent_layout$PANEL))),
panel_numbers))) {
warning(msg)
parent_layout
} else {
## all good
indices <- cbind(ROW = c(row(layout)),
COL = c(col(layout)),
PANEL = c(layout))
indices <- indices[!is.na(indices[, "PANEL"]), ]
## delete row and col number from parent layout
parent_layout$ROW <- parent_layout$COL <- NULL
new_layout <- merge(parent_layout,
indices,
by = "PANEL") %>%
dplyr::arrange(PANEL)
new_layout$PANEL <- factor(new_layout$PANEL)
labs <- new_layout %>%
dplyr::select(-PANEL,
-SCALE_X,
-SCALE_Y,
-ROW,
-COL) %>%
dplyr::mutate(sep = "_") %>%
do.call(paste, .)
new_layout$LAB <- labs
new_layout
}
}
}
FacetMultiCol <- ggproto("FacetMultiCol", FacetWrap,
compute_layout = layout,
draw_panels = render)