创建多列构面函数

时间：2019-11-02 02:51:45

标签： r ggplot2 facet facet-wrap ggproto

我正在尝试创建一个facet_multi_col()函数，类似于facet_col()中的ggforce函数-该函数允许带空格参数的构面布局（在{{中不可用1}}）-但超过多列。就像下面的最后一个图（用facet_wrap()创建），我不希望这些小平面必须在行之间对齐，因为每个小平面的高度将根据我希望使用的分类grid.arrange()变量而变化。

y阅读扩展名guide后，我发现自己已经步入深度。我认为最好的方法是传递一个布局矩阵来指示在哪里断开数据对应子集的列，并建立ggproto in ggforce来包含一个空间参数-参见问题末尾

快速说明我的不满意选项

没有面

facet_col

enter image description here 我想按大洲细分情节。我不要这么长的身材。

facet_wrap（）

library(tidyverse)
library(gapminder)
global_tile <- ggplot(data = gapminder, mapping = aes(x = year, y = fct_rev(country), fill = lifeExp)) +
  geom_tile()
global_tile

enter image description here global_tile + facet_wrap(facets = "continent", scales = "free") 没有空格参数，这表示各大洲的磁贴大小不同，使用facet_wrap()会引发错误

ggforce中的

facet_col（）

coord_equal()

enter image description here 就像侧面的条子一样。 library(ggforce) global_tile + facet_col(facets = "continent", scales = "free", space = "free", strip.position = "right") + theme(strip.text.y = element_text(angle = 0)) 参数将所有图块设置为相同大小。仍然太长而无法容纳在页面上。

gridExtra中的grid.arrange（）

在各大洲应放置的数据中添加一列

space

使用d <- gapminder %>% as_tibble() %>% mutate(col = as.numeric(continent), col = ifelse(test = continent == "Europe", yes = 2, no = col), col = ifelse(test = continent == "Oceania", yes = 3, no = col)) head(d) # # A tibble: 6 x 7 # country continent year lifeExp pop gdpPercap col # <fct> <fct> <int> <dbl> <int> <dbl> <dbl> # 1 Afghanistan Asia 1952 28.8 8425333 779. 3 # 2 Afghanistan Asia 1957 30.3 9240934 821. 3 # 3 Afghanistan Asia 1962 32.0 10267083 853. 3 # 4 Afghanistan Asia 1967 34.0 11537966 836. 3 # 5 Afghanistan Asia 1972 36.1 13079460 740. 3 # 6 Afghanistan Asia 1977 38.4 14880372 786. 3 tail(d) # # A tibble: 6 x 7 # country continent year lifeExp pop gdpPercap col # <fct> <fct> <int> <dbl> <int> <dbl> <dbl> # 1 Zimbabwe Africa 1982 60.4 7636524 789. 1 # 2 Zimbabwe Africa 1987 62.4 9216418 706. 1 # 3 Zimbabwe Africa 1992 60.4 10704340 693. 1 # 4 Zimbabwe Africa 1997 46.8 11404948 792. 1 # 5 Zimbabwe Africa 2002 40.0 11926563 672. 1 # 6 Zimbabwe Africa 2007 43.5 12311143 470. 1 绘制每一列的图

facet_col()

在g <- list() for(i in unique(d$col)){ g[[i]] <- d %>% filter(col == i) %>% ggplot(mapping = aes(x = year, y = fct_rev(country), fill = lifeExp)) + geom_tile() + facet_col(facets = "continent", scales = "free_y", space = "free", strip.position = "right") + theme(strip.text.y = element_text(angle = 0)) + # aviod legends in every column guides(fill = FALSE) + labs(x = "", y = "") } 中使用get_legend()创建图例

cowplot

根据每列中的国家/地区创建一个具有高度的布局矩阵。

library(cowplot)
gg <- ggplot(data = d, mapping = aes(x = year, y = country, fill = lifeExp)) +
  geom_tile()
leg <- get_legend(gg)

在m <- d %>% group_by(col) %>% summarise(row = n_distinct(country)) %>% rowwise() %>% mutate(row = paste(1:row, collapse = ",")) %>% separate_rows(row) %>% mutate(row = as.numeric(row), col = col, p = col) %>% xtabs(formula = p ~ row + col) %>% cbind(max(d$col) + 1) %>% ifelse(. == 0, NA, .) head(m) # 1 2 3 # 1 1 2 3 4 # 2 1 2 3 4 # 3 1 2 3 4 # 4 1 2 3 4 # 5 1 2 3 4 # 6 1 2 3 4 tail(m) # 1 2 3 # 50 1 2 NA 4 # 51 1 2 NA 4 # 52 1 2 NA 4 # 53 NA 2 NA 4 # 54 NA 2 NA 4 # 55 NA 2 NA 4 中使用g将leg和grid.arrange() 

gridExtra

enter image description here 这几乎是我想要的，但是我不满意，因为a）不同列中的图块具有不同的宽度，因为最长的国家和大洲名称的长度不相等，并且b）每个都需要调整很多代码我想绘制这样的图的时候-我想用其他数据按区域排列构面，例如“西欧”而不是大洲或国家/地区数目发生了变化-library(gridExtra) grid.arrange(g[[1]], g[[2]], g[[3]], leg, layout_matrix = m, widths=c(0.32, 0.32, 0.32, 0.06)) 数据中没有中亚国家。

创建facet_multi_cols（）函数的进度

我想将布局矩阵传递给构面函数，该矩阵将引用每个构面，然后该函数可以根据每个面板中的空格数来确定高度。对于上面的示例，矩阵为：

gapminder

如上所述，我一直在适应my_layout <- matrix(c(1, NA, 2, 3, 4, 5), nrow = 2) my_layout # [,1] [,2] [,3] # [1,] 1 2 4 # [2,] NA 3 5 中的代码来尝试构建facet_col()函数。我添加了一个facet_multi_col()参数以提供诸如以上的layout之类的矩阵，例如，给定my_layout参数的变量的第四级和第五级被绘制在第三列。

facets

我认为我需要为facet_multi_col <- function(facets, layout, scales = "fixed", space = "fixed", shrink = TRUE, labeller = "label_value", drop = TRUE, strip.position = 'top') { # add space argument as in facet_col space <- match.arg(space, c('free', 'fixed')) facet <- facet_wrap(facets, col = col, dir = dir, scales = scales, shrink = shrink, labeller = labeller, drop = drop, strip.position = strip.position) params <- facet$params params <- facet$layout params$space_free <- space == 'free' ggproto(NULL, FacetMultiCols, shrink = shrink, params = params) } FacetMultiCols <- ggproto('FacetMultiCols', FacetWrap, # from FacetCols to allow for space argument to work draw_panels = 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) { widths <- vapply(layout$PANEL, function(i) diff(ranges[[i]]$x.range), numeric(1)) panel_widths <- unit(widths, "null") combined$widths[panel_cols(combined)$l] <- panel_widths } combined } # adapt FacetWrap layout to set position on panels following the matrix given to layout in facet_multi_col(). compute_layout = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { layout <- ggproto_parent(FacetWrap, self)$compute_layout(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) # ??? ) 部分写点东西，但是我正在努力寻找方法。

2 个答案:

答案 0 :(得分：4)

免责声明

我从未开发过任何facet，但是我发现这个问题很有趣并且充满挑战，因此我尝试了一下。它还不是完美的，到目前为止还没有对所有可能会根据您的情节进行的微妙测试，但这是您可以进行研究的初稿。

想法

facet_wrap在表格中列出面板，并且每一行都有一定的高度，该高度完全占据面板。 gtable_add_grob说：

  

在gtable模型中，grob总是会填满   完整的表格单元格。如果要自定义对齐，则可能需要以绝对单位定义grob尺寸，或将其放入另一个gtable中，然后可以将其添加到gtable中，而不是grob中。

这可能是一个有趣的解决方案。但是，我不确定如何实现这一目标。因此，我采取了另一种方法：

  1. 根据传递的布局参数创建自定义布局
  2. 让facet_wrap渲染所有面板到布局
  3. 使用gtable_filter抓取面板，包括其轴和条带
  4. 创建布局矩阵。我尝试了两种方法：使用最少的行数并使用高度差进行游戏。并简单地添加与y轴上的刻度线一样多的行。两者工作相似，后者产生更清晰的代码，因此我将使用此代码。
  5. 使用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")

Ex 1 Example 1 Ex 2 Example 2 Ex 3 Example 3 Ex 4 Example 4 Ex 5 Example 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)

答案 1 :(得分：1)

正如评论中所建议的那样，牛图和拼凑而成的组合可以使您走得很远。请参阅下面的解决方案。

基本思想是：

  • 首先要基于行数来计算比例因子
    • 然后创建一系列单列网格，在这里我使用空图用计算的比例因子约束图的高度。 （并删除图例）
  • 然后将它们添加到网格中，并添加图例。
  • 在一开始，我还计算了填充比例的最大值。
library(tidyverse)
library(gapminder)
library(patchwork)
max_life <- max(gapminder$lifeExp)
generate_plot <- function(data, title){
  ggplot(data = data, mapping = aes(x = year, y = fct_rev(country), fill = lifeExp)) +
    geom_tile()+
    scale_fill_continuous(limits = c(0, max_life)) +
    ggtitle(title)
}
scale_plot <- function(plot, ratio){
  plot + theme(legend.position="none") + 
    plot_spacer() + 
    plot_layout(ncol = 1,
                heights = c(
                  ratio,
                  1-ratio
                )
    )
}
df <- gapminder %>% 
  group_by(continent) %>% 
  nest() %>% 
  ungroup() %>% 
  arrange(continent) %>% 
  mutate(
    rows = map_dbl(data, nrow),
    rel_height = (rows/max(rows)),
    plot = map2(
      data,
      continent,
      generate_plot
    ),
    spaced_plot = map2(
      plot,
      rel_height,
      scale_plot
        )
  )
wrap_plots(df$spaced_plot) + cowplot::get_legend(df$plot[[1]])

由reprex package（v0.3.0）于2019-11-06创建

相关问题
最新问题