Erstellen einer mehrspaltigen Facettenfunktion

11

Ich versuche, eine facet_multi_col()Funktion zu erstellen , die der facet_col()Funktion in ähnelt ggforce- die ein Facettenlayout mit einem Leerzeichenargument ermöglicht (das in nicht verfügbar ist)facet_wrap() ) -, jedoch über mehrere Spalten. Wie im letzten Diagramm unten (erstellt mit grid.arrange()) möchte ich nicht, dass die Facetten notwendigerweise über Zeilen hinweg ausgerichtet werden, da die Höhen in jeder Facette basierend auf einer kategorialen yVariablen variieren , die ich verwenden möchte.

Ich bin mit ggprotodem Lesen der Erweiterungsanleitung überfordert . Ich denke, der beste Ansatz besteht darin, eine Layoutmatrix zu übergeben, um facet_col festzulegen , wo Spalten für entsprechende Teilmengen der Daten aufgebrochen werden sollen, und in ggforce einen Leerzeichenparameter einzuschließen - siehe Ende der Frage.

Ein kurzes Beispiel für meine unbefriedigenden Möglichkeiten

Keine Facette

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

Geben Sie hier die Bildbeschreibung ein Ich möchte die Handlung nach Kontinenten aufteilen. Ich will keine so lange Figur.

facet_wrap ()

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

Geben Sie hier die Bildbeschreibung ein facet_wrap()hat kein Leerzeichenargument, was bedeutet, dass die Kacheln auf jedem Kontinent unterschiedlich groß sind und coord_equal()einen Fehler auslösen

facet_col () in ggforce

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

Geben Sie hier die Bildbeschreibung ein Wie die Streifen an der Seite. spaceArgument setzt alle Kacheln auf die gleiche Größe. Immer noch zu lang, um auf eine Seite zu passen.

grid.arrange () in gridExtra

Fügen Sie eine Datenspalte zu den Daten hinzu, für die jeder Kontinent platziert werden soll

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

Verwenden Sie facet_col()für die Darstellung für jede Spalte

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 = "")
}

Erstellen Sie eine Legende mit get_legend()incowplot

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

Erstellen Sie eine Layoutmatrix mit Höhen basierend auf der Anzahl der Länder in jeder Spalte.

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

Bringen Sie gund legzusammen mit grid.arrange()ingridExtra

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

Geben Sie hier die Bildbeschreibung ein Dies ist fast das, wonach ich suche, aber ich bin nicht zufrieden, da a) die Kacheln in verschiedenen Spalten unterschiedliche Breiten haben, da die Länge der längsten Länder- und Kontinentnamen nicht gleich ist und b) es eine Menge Code gibt, der jeweils angepasst werden muss Wenn ich eine solche Handlung machen möchte - mit anderen Daten möchte ich die Facetten nach Regionen ordnen, z. B. "Westeuropa" anstatt nach Kontinenten oder die Anzahl der Länderänderungen -, gibt es keine zentralasiatischen Länder in der gapminder Daten enthalten.

Fortschritte beim Erstellen einer facet_multi_cols () -Funktion

Ich möchte eine Layoutmatrix an eine Facettenfunktion übergeben, wobei sich die Matrix auf jede Facette bezieht, und die Funktion könnte dann die Höhen basierend auf der Anzahl der Leerzeichen in jedem Bedienfeld ermitteln. Für das obige Beispiel wäre die Matrix:

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

Wie oben erwähnt, habe ich mich aus dem Code angepasst facet_col(), um zu versuchen, eine facet_multi_col()Funktion zu erstellen . Ich habe ein layoutArgument hinzugefügt , um eine Matrix wie my_layoutoben bereitzustellen , mit der Idee, dass beispielsweise die vierte und fünfte Ebene der Variablen, die dem facetsArgument gegeben wird, in der dritten Spalte dargestellt sind.

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

Ich denke, ich muss etwas für den compute_layoutTeil schreiben , aber ich habe Mühe herauszufinden, wie das geht.

gjabel
quelle
Haben Sie stattdessen versucht, eine Liste von Plots zu erstellen, einen für jeden Kontinent, und diese mit einem der Pakete wie Cowplot oder Patchwork abzustimmen? Könnte einfacher sein , als ein ggproto Aufbau
camille
@camille habe ich irgendwie gemacht ... im grid.arrangeobigen Beispiel ... es sei denn du meinst etwas anderes? Ich denke, die gleichen Probleme würden mit unterschiedlichen Etikettenlängen in jeder Spalte bestehen?
Gjabel
Ich stelle mir etwas Ähnliches vor, aber diese Layout-Pakete könnten bei der Ausrichtung besser helfen als grid.arrange. Es ist ein sehr langer Beitrag, daher ist es schwierig, alles zu verfolgen, was Sie versucht haben. Ein bisschen hacky, aber Sie könnten versuchen, eine Monospace / näher an gleichmäßig verteilten Schriftarten für die Etiketten zu verwenden, damit deren Länge vorhersehbarer ist. Sie können auch dann Beschriftungen mit Leerzeichen auffüllen, um sicherzustellen, dass der Text näher an der gleichen Länge liegt.
Camille

Antworten:

4

Haftungsausschluss

Ich habe noch nie eine entwickelt facet , aber ich fand die Frage interessant und herausfordernd genug, also habe ich es versucht. Es ist noch nicht perfekt und bei weitem nicht mit allen Feinheiten getestet, die je nach Handlung auftreten können, aber es ist ein erster Entwurf, an dem Sie arbeiten können.

Idee

facet_wraplegt die Paneele in einer Tabelle dar und jede Reihe hat eine bestimmte Höhe, die das Paneel vollständig einnimmt. gtable_add_grobsagt:

Im gtable-Modell füllen Grobs immer die gesamte Tabellenzelle aus. Wenn Sie eine benutzerdefinierte Begründung wünschen, müssen Sie möglicherweise die Grob-Dimension in absoluten Einheiten definieren oder in eine andere gtable einfügen, die dann anstelle der grob zur grt-Tabelle hinzugefügt werden kann.

Dies könnte eine interessante Lösung sein. Ich war mir jedoch nicht sicher, wie ich das verfolgen sollte. Daher habe ich einen anderen Ansatz gewählt:

  1. Erstellen Sie ein benutzerdefiniertes Layout basierend auf dem übergebenen Layoutparameter
  2. Lassen facet_wrap alle Bedienfelder im Layout rendern
  3. Verwenden gtable_filter diese Option, um die Platte einschließlich ihrer Achsen und Streifen zu greifen
  4. Erstellen Sie eine Layoutmatrix. Ich habe zwei Ansätze ausprobiert: Verwenden einer minimalen Anzahl von Zeilen und Spielen mit Höhenunterschieden. Und fügen Sie einfach ungefähr so ​​viele Zeilen hinzu, wie es Häkchen auf der y-Achse gibt. Beide funktionieren ähnlich, letzteres erzeugt saubereren Code, also würde ich diesen verwenden.
  5. Verwenden Sie gridExtra::arrangeGrobdiese Option, um die Bedienfelder gemäß dem übergebenen Design und der erstellten Layoutmatrix anzuordnen

Ergebnisse

Der vollständige Code ist etwas langwierig, kann aber unten gefunden werden. Hier sind einige Grafiken:

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 5Beispiel 1 Beispiel 2 Beispiel 3 Beispiel 4 Beispiel 5

Beschränkungen

Der Code ist alles andere als narrensicher. Einige Probleme sehe ich bereits:

  • Wir gehen (stillschweigend) davon aus, dass jede Spalte im Entwurf mit einem Nicht-NA-Wert beginnt (im Allgemeinen muss für einen produktiven Code das übergebene Layout sorgfältig überprüft werden (passen die Abmessungen? Gibt es so viele Einträge wie Panels? Usw.)?
  • Sehr kleine Paneele rendern nicht gut, daher musste ich abhängig von der Position der Streifen einen Mindestwert für die Höhe hinzufügen
  • Die Wirkung des Verschiebens oder Hinzufügens von Achsen oder Streifen ist noch nicht getestet.

Code: eine Zeile pro Tick

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

Code: Zeilen mit unterschiedlichen Höhen

## 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)
thothal
quelle
Vielen Dank dafür. Ich habe einige andere Daten ausprobiert - mit Regionen anstatt mit Kontinenten (die ich in der Frage erwähnt habe) ... ich habe den Code hier eingefügt ... gist.github.com/gjabel/3e4fb31214b5932aa0978dc6d3258dc1 ... es wirft einige wirklich auf seltsames Verhalten, das ich nicht herausfinden kann?
Gjabel
Können Sie die Daten freigeben (eine Momentaufnahme davon)? Ich habe das Wesentliche untersucht, kann das Problem aber aus offensichtlichen Gründen nicht reproduzieren ...
7.
Die Daten befinden sich im Paket wpp2019, das sich auf CRAN befindet
gjabel
Ach, tut mir leid, mein schlechtes. werde es versuchen.
Thothal
1
Den Fehler gefunden, im Grunde muss das Layout nach PANEL sortiert sein, sonst funktioniert es nicht. Ihr Beispiel wird jetzt gut gerendert.
Thothal
1

Wie in den Kommentaren vorgeschlagen, kann eine Kombination aus Cowplot und Patchwork Sie ziemlich weit bringen. Siehe meine Lösung unten.

Die Grundidee ist:

  • um zuerst einen Skalierungsfaktor basierend auf der Anzahl der Zeilen zu berechnen,
  • Erstellen Sie dann eine Reihe von einspaltigen Gittern, in denen ich leere Diagramme verwende, um die Höhe der Diagramme mit dem berechneten Skalierungsfaktor zu beschränken. (und entferne die Legenden)
  • dann füge ich diese in ein Raster ein und füge auch eine Legende hinzu.
  • Am Anfang berechne ich auch ein Maximum für die Füllskala.
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]])

Erstellt am 06.11.2019 durch das reprex-Paket (v0.3.0)

Bernd Konfuzius
quelle