Створення функції фасети з декількома стовпцями


11

Я намагаюся створити facet_multi_col()функцію, схожу на facet_col()функцію в ggforce-, яка дозволяє розмістити фасетку з аргументом пробілу (який недоступний у facet_wrap()), але в декількох стовпцях. Як і в останньому сюжеті нижче (створеному з grid.arrange()), я не хочу, щоб грані обов’язково вирівнювались між рядками, оскільки висоти в кожній грані будуть змінюватися залежно від категоріальної 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))

введіть тут опис зображення Це майже те, що я переживаю, але мене не влаштовує а) плитки в різних стовпцях мають різну ширину, оскільки довжина найменувань країни та континенту не дорівнює, і б) її безліч кодів, які потрібно виправити кожен час я хочу зробити подібний сюжет - з іншими даними я хочу впорядкувати аспекти за регіонами, наприклад, "Західна Європа", а не континенти чи кількість країн, - у цих gapminderданих немає країн Центральної Азії .

Прогрес у створенні функції facet_multi_cols ()

Я хочу передати матрицю компонування до функції фасета, де матриця посилатиметься на кожну грань, а потім функція могла б визначити висоти на основі кількості пробілів на кожній панелі. Для наведеного вище прикладу матриця буде:

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частини, але я намагаюся зрозуміти, як це зробити.


Ви спробували натомість скласти список сюжетів, по одному для кожного континенту, і вирівняти їх з одним із пакетів, наприклад, ковзаня чи лоскут? Може бути простіше , ніж будувати вгору ggproto
Каміллу

@camille Я щось робив ... у grid.arrangeприкладі вище .. хіба ти маєш на увазі щось інше? Я думаю, що однакові проблеми існуватимуть з різною довжиною міток у кожному стовпці?
gjabel

Я уявляю щось подібне до цього, але ці пакети компонувань можуть допомогти вирівняти краще grid.arrange. Це дійсно довгий пост, тому важко стежити за всім, що ви спробували. Трохи хакі, але ви можете спробувати монопростір / ближче до рівномірно розташованих шрифтів для міток, щоб їх довжина була більш передбачуваною. Можна навіть тоді наклеювати ярлики з порожніми пробілами, щоб переконатися, що текст наближений до тієї ж довжини.
Камілла

Відповіді:


4

Відмова від відповідальності

Я ніколи не розробляв жодного facet, але мені здалося, що питання цікаве і достатньо складне, тому я спробував це. Він ще не ідеальний і на сьогодні не перевірений усіма тонкощами, які можуть виникнути залежно від вашого сюжету, але це перший проект, над яким можна працювати.

Ідея

facet_wrapвикладає панелі в таблицю, і кожен ряд має певну висоту, яку панель повністю займає. gtable_add_grobкаже:

У моделі gtable grobs завжди заповнює повну комірку таблиці. Якщо ви хочете користувальницького обґрунтування, можливо, вам потрібно буде визначити розмір могили в абсолютних одиницях або помістити її в інший gtable, який потім може бути доданий до gtable замість grob.

Це може бути цікавим рішенням. Однак я не був впевнений, як це зробити. Таким чином, я застосував інший підхід:

  1. Створіть нестандартний макет, грунтуючись на наданому параметрі макета
  2. Нехай facet_wrapвізуалізує всі панелі wrt до макета
  3. Використовуйте gtable_filterдля захоплення панелі, включаючи її осі та смуги
  4. Створіть матрицю макета. Я спробував 2 підходи: використовувати мінімальну кількість рядків і грати з перепадами по висоті. І просто додати приблизно стільки ж рядків, скільки є галочки на осі у. Обидві працюють аналогічно, останній видає чистіший код, тому я би використовував цей.
  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

ах вибачте, моя погана. спробує.
thothal

1
Знайдена помилка, в основному макет повинен бути відсортований відповідно до PANEL, інакше він не працюватиме. ваш зразок тепер справді добре.
thothal

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]])

Створено 2019-11-06 пакетом reprex (v0.3.0)

Використовуючи наш веб-сайт, ви визнаєте, що прочитали та зрозуміли наші Політику щодо файлів cookie та Політику конфіденційності.
Licensed under cc by-sa 3.0 with attribution required.