การสร้างฟังก์ชั่นหลายแง่มุมคอลัมน์


11

ฉันพยายามที่จะสร้างfacet_multi_col()ฟังก์ชั่นคล้ายกับfacet_col()ฟังก์ชั่นในggforce- ที่ช่วยให้รูปแบบ facet กับอาร์กิวเมนต์พื้นที่ (ซึ่งไม่สามารถใช้ได้facet_wrap()) - แต่มากกว่าหลายคอลัมน์ ดังในพล็อตสุดท้ายด้านล่าง (สร้างด้วยgrid.arrange()) ฉันไม่ต้องการให้ facets จัดแนวข้ามแถวอย่างเหมาะสมเนื่องจากความสูงในแต่ละ facet จะแตกต่างกันไปตามyตัวแปรหมวดหมู่ที่ฉันต้องการใช้

ผมกำลังหาดีออกจากความลึกของฉันกับggprotoที่มีการอ่านนามสกุลคู่มือ ฉันคิดว่าวิธีที่ดีที่สุดคือการส่งโครงร่างเมทริกซ์เพื่อกำหนดตำแหน่งที่จะแบ่งคอลัมน์สำหรับชุดย่อยของข้อมูลที่สอดคล้องกันและสร้างfacet_col ใน ggforceเพื่อรวมพารามิเตอร์ช่องว่าง - ดูจุดสิ้นสุดของคำถาม

ภาพประกอบสั้น ๆ เกี่ยวกับตัวเลือกที่ไม่น่าพอใจของฉัน

ไม่มีแง่มุม

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

ป้อนคำอธิบายรูปภาพที่นี่ ฉันต้องการที่จะพังพล็อตตามทวีป ฉันไม่ต้องการร่างที่ยาวขนาดนี้

facet_wrap ()

global_tile +
  facet_wrap(facets = "continent", scales = "free")

ป้อนคำอธิบายรูปภาพที่นี่ facet_wrap()ไม่มีอาร์กิวเมนต์ช่องว่างซึ่งหมายความว่าแผ่นกระเบื้องมีขนาดแตกต่างกันในแต่ละทวีปโดยใช้การcoord_equal()โยนข้อผิดพลาด

facet_col () ใน ggforce

library(ggforce)
global_tile +
  facet_col(facets = "continent", scales = "free", space = "free", strip.position = "right") +
  theme(strip.text.y = element_text(angle = 0)) 

ป้อนคำอธิบายรูปภาพที่นี่ ชอบแถบด้านข้าง spaceอาร์กิวเมนต์ตั้งค่าไทล์ทั้งหมดเป็นขนาดเดียวกัน ยังยาวเกินไปที่จะพอดีกับหน้า

grid.arrange () ใน gridExtra

เพิ่มคอลัมน์คอลัมน์ให้กับข้อมูลที่ควรวางแต่ละทวีป

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

library(gridExtra)
grid.arrange(g[[1]], g[[2]], g[[3]], leg, layout_matrix = m, widths=c(0.32, 0.32, 0.32, 0.06))

ป้อนคำอธิบายรูปภาพที่นี่ นี่เป็นสิ่งที่ฉันเกือบจะตามหลัง แต่ฉันไม่พอใจเหมือนกัน) ก. กระเบื้องในคอลัมน์ต่าง ๆ มีความกว้างต่างกันเนื่องจากความยาวของประเทศที่ยาวที่สุดและชื่อทวีปไม่เท่ากันและ b) รหัสจำนวนมากที่ต้องถูก tweaked เวลาที่ฉันต้องการที่จะทำให้พล็อตแบบนี้ - กับข้อมูลอื่น ๆ ที่ฉันต้องการที่จะจัดให้แง่มุมตามภูมิภาคเช่น "ยุโรปตะวันตก" มากกว่าทวีปหรือจำนวนของการเปลี่ยนแปลงประเทศ - ไม่มีประเทศเอเชียกลางในgapminderข้อมูล

ความก้าวหน้าในการสร้างฟังก์ชั่น facet_multi_cols ()

ฉันต้องการส่งเมทริกซ์โครงร่างไปยังฟังก์ชัน facet โดยที่เมทริกซ์จะอ้างถึงแต่ละแง่มุมจากนั้นฟังก์ชันจะสามารถคำนวณความสูงตามจำนวนช่องว่างในแต่ละแผง สำหรับตัวอย่างข้างต้นเมทริกซ์จะเป็น:

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)
    # ???
)

ฉันคิดว่าฉันต้องเขียนอะไรบางอย่างเพื่อcompute_layoutส่วน แต่ฉันพยายามดิ้นรนเพื่อหาวิธีการทำเช่นนี้


คุณได้ลองทำรายการของแปลงหนึ่งรายการสำหรับแต่ละทวีปและจัดแนวกับแพคเกจเช่น cowplot หรือ patchwork หรือไม่? อาจจะง่ายกว่าการสร้างขึ้น ggproto
คามิลล์

@ คามิลล์ฉันทำอย่างนั้น ... ในgrid.arrangeตัวอย่างด้านบน .. เว้นแต่คุณจะหมายถึงบางสิ่งที่แตกต่างออกไป? ฉันคิดว่าปัญหาเดียวกันนี้จะเกิดขึ้นกับความยาวฉลากที่แตกต่างกันในแต่ละคอลัมน์หรือไม่
gjabel

ฉันจินตนาการสิ่งที่คล้ายกับที่ grid.arrangeแต่รูปแบบแพคเกจเหล่านั้นอาจช่วยให้มีการจัดตำแหน่งที่ดีกว่า มันเป็นโพสต์ที่ยาวมาก ๆ ดังนั้นจึงยากที่จะติดตามทุกสิ่งที่คุณได้ลอง แฮ็คเล็ก ๆ น้อย ๆ แต่คุณอาจลองแบบอักษรอวกาศ / ใกล้เคียงกับแบบอักษรที่เว้นระยะอย่างสม่ำเสมอสำหรับฉลากดังนั้นความยาวของฉลากจึงสามารถคาดเดาได้มากขึ้น คุณยังสามารถวางป้ายกำกับด้วยช่องว่างเพื่อให้แน่ใจว่าข้อความนั้นใกล้เคียงกับความยาวเท่ากัน
คามิลล์

คำตอบ:


4

คำปฏิเสธ

ฉันไม่เคยพัฒนาเลยfacetแต่ฉันพบคำถามที่น่าสนใจและท้าทายพอฉันจึงลองทำดู มันยังไม่สมบูรณ์และยังไม่ผ่านการทดสอบกับรายละเอียดปลีกย่อยทั้งหมดที่อาจเกิดขึ้นขึ้นอยู่กับพล็อตของคุณ แต่มันเป็นร่างแรกที่คุณสามารถทำงานได้

ความคิด

facet_wrapกำหนดแผงในตารางและแต่ละแถวมีความสูงที่แผงครอบครองอย่างเต็มที่ gtable_add_grobพูดว่า:

ในรุ่น gtable ร่องจะเติมเซลล์ของตารางที่สมบูรณ์เสมอ หากคุณต้องการเหตุผลที่กำหนดเองคุณอาจต้องกำหนดมิติ grob ในหน่วยสัมบูรณ์หรือใส่ไว้ใน gtable อื่นที่สามารถเพิ่มไปยัง gtable แทน grob

นี่อาจเป็นทางออกที่น่าสนใจ อย่างไรก็ตามฉันไม่แน่ใจว่าจะทำอย่างไร ดังนั้นฉันจึงใช้วิธีที่แตกต่าง:

  1. สร้างโครงร่างที่กำหนดเองตามพารามิเตอร์โครงร่างที่ส่งผ่าน
  2. อนุญาตให้facet_wrapแสดงพาเนลทั้งหมด wrt ไปยังโครงร่าง
  3. ใช้gtable_filterเพื่อยึดพาเนลรวมถึงแกนและแถบ
  4. สร้างเมทริกซ์โครงร่าง ฉันลอง 2 วิธี: ใช้จำนวนแถวขั้นต่ำและเล่นกับความแตกต่างของความสูง และเพิ่มแถวประมาณเท่าที่มีเครื่องหมายขีดบนแกน 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 Ex 2 Ex 3 Ex 4 Ex 5ตัวอย่างที่ 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)

ขอบคุณมากสำหรับสิ่งนี้ ฉันได้ลองกับข้อมูลอื่น ๆ - ด้วยภูมิภาคมากกว่าทวีป (ที่ฉันกล่าวถึงในคำถาม) ... ฉันใส่รหัสที่นี่ ... gist.github.com/gjabel/3e4fb31214b5932aa0978dc6d3258dc1 ... มันพ่นบางอย่างจริงๆ พฤติกรรมแปลก ๆ ที่ฉันคิดไม่ออก?
gjabel

คุณสามารถแบ่งปันข้อมูล (ภาพรวม) ได้หรือไม่ ฉันมองเข้าไปในส่วนสำคัญ แต่ไม่สามารถสร้างปัญหาขึ้นใหม่ได้ด้วยเหตุผลที่ชัดเจน ...
thothal

ข้อมูลอยู่ในแพ็คเกจ wpp2019 .. ซึ่งอยู่ใน CRAN
gjabel

ขอโทษที่ไม่ดีของฉัน จะลองดู
ธ ธ

1
พบข้อบกพร่องโดยทั่วไปเค้าโครงจะต้องเรียงตาม PANEL มิฉะนั้นจะไม่ทำงาน ตัวอย่างของคุณแสดงผลได้ดีในตอนนี้
ธ ธ

1

ตามที่แนะนำในความคิดเห็นการรวมกันของ cowplot และการเย็บปะติดปะต่อกันจะทำให้คุณได้รับความเป็นธรรม ดูโซลูชันของฉันด้านล่าง

แนวคิดพื้นฐานคือ:

  • ในการคำนวณตัวประกอบสเกลแรกโดยพิจารณาจากจำนวนแถว
  • จากนั้นสร้างชุดของกริดคอลัมน์เดี่ยวที่ฉันใช้พล็อตเปล่าเพื่อจำกัดความสูงของพล็อตด้วยปัจจัยการปรับสเกล (และลบตำนาน)
  • จากนั้นฉันจะเพิ่มสิ่งเหล่านี้ลงในตารางและยังเพิ่มคำอธิบาย
  • ในการเริ่มต้นฉันยังคำนวณสูงสุดสำหรับระดับการเติม
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]])

สร้างเมื่อ 2019-11-06 โดยแพ็คเกจ reprex (v0.3.0)

โดยการใช้ไซต์ของเรา หมายความว่าคุณได้อ่านและทำความเข้าใจนโยบายคุกกี้และนโยบายความเป็นส่วนตัวของเราแล้ว
Licensed under cc by-sa 3.0 with attribution required.