Сдвиньте легенду в пустые грани граненого сюжета в ggplot2

Рассмотрим следующий сюжет:

library(ggplot2)

p <- ggplot(diamonds, 
            aes(x = carat, fill = cut)) +
  geom_density(position = "stack") +
  facet_wrap(~ color)

facet_wrap функция обертывание последовательности граненых панелей примерно в прямоугольный дисплей nrow строк и ncol столбцов. Тем не менее, в зависимости от данных, фактическое количество панелей часто составляет несколько панелей, если не nrow * ncol, что оставляет часть nrow * ncol пространства на графике.

Если сюжет включает в себя легенду (ы), ситуация усугубляется, потому что теперь у нас есть еще больше потерянного пространства из-за легенды, будь то справа (положение легенды по умолчанию) или в одном из трех других направлений.

Чтобы сэкономить место, я хотел бы переместить легенду (и) в пространство, созданное незаполненными гранями.

Следующее работает в качестве меры экономии места, но легенда привязана к углу области графика, с потенциально большим количеством места, оставленного на одной стороне, создавая несбалансированный вид:

p +
  theme(legend.position = c(1, 0),
        legend.justification = c(1, 0))

Сдвиг легенды к центру области пустого пространства путем ручной настройки legend.position/legend.justification является legend.justification проб и ошибок, и его трудно масштабировать, если у вас есть много граненых графиков для работы.

Итак, я хочу метод, который:

Смещает легенду (и) граненого сюжета в пространство, созданное из-за пустых граней.
В результате получается довольно симпатичный сюжет.
Легко автоматизируется для обработки множества участков.

Это повторяющийся вариант использования для меня, и я решил опубликовать его вместе со своим рабочим решением здесь на тот случай, если кто-то еще посчитает его полезным. Я не видел, чтобы этот сценарий спрашивали/отвечали в другом месте на переполнении стека. Если у кого-то есть, пожалуйста, оставьте комментарий, и я буду рад ответить там вместо этого или пометить это как дубликат, в зависимости от обстоятельств.

Ответ 1

Следующее является продолжением ответа, который я написал для предыдущего вопроса об использовании пространства из пустых фасетных панелей, но я думаю, что он достаточно отличается, чтобы гарантировать свое собственное пространство.

По сути, я написал функцию, которая принимает объект ggplot/grob, преобразованный с помощью ggplotGrob(), преобразует его в grob, если он не равен единице, и копает в базовые элементы grob, чтобы переместить элемент легенды в ячейки, соответствующие пустому пространству.,

Функция:

library(gtable)
library(cowplot)

shift_legend <- function(p){

  # check if p is a valid object
  if(!"gtable" %in% class(p)){
    if("ggplot" %in% class(p)){
      gp <- ggplotGrob(p) # convert to grob
    } else {
      message("This is neither a ggplot object nor a grob generated from ggplotGrob. Returning original plot.")
      return(p)
    }
  } else {
    gp <- p
  }

  # check for unfilled facet panels
  facet.panels <- grep("^panel", gp[["layout"]][["name"]])
  empty.facet.panels <- sapply(facet.panels, function(i) "zeroGrob" %in% class(gp[["grobs"]][[i]]))
  empty.facet.panels <- facet.panels[empty.facet.panels]
  if(length(empty.facet.panels) == 0){
    message("There are no unfilled facet panels to shift legend into. Returning original plot.")
    return(p)
  }

  # establish extent of unfilled facet panels (including any axis cells in between)
  empty.facet.panels <- gp[["layout"]][empty.facet.panels, ]
  empty.facet.panels <- list(min(empty.facet.panels[["t"]]), min(empty.facet.panels[["l"]]),
                             max(empty.facet.panels[["b"]]), max(empty.facet.panels[["r"]]))
  names(empty.facet.panels) <- c("t", "l", "b", "r")

  # extract legend & copy over to location of unfilled facet panels
  guide.grob <- which(gp[["layout"]][["name"]] == "guide-box")
  if(length(guide.grob) == 0){
    message("There is no legend present. Returning original plot.")
    return(p)
  }
  gp <- gtable_add_grob(x = gp,
                        grobs = gp[["grobs"]][[guide.grob]],
                        t = empty.facet.panels[["t"]],
                        l = empty.facet.panels[["l"]],
                        b = empty.facet.panels[["b"]],
                        r = empty.facet.panels[["r"]],
                        name = "new-guide-box")

  # squash the original guide box row / column (whichever applicable)
  # & empty its cell
  guide.grob <- gp[["layout"]][guide.grob, ]
  if(guide.grob[["l"]] == guide.grob[["r"]]){
    gp <- gtable_squash_cols(gp, cols = guide.grob[["l"]])
  }
  if(guide.grob[["t"]] == guide.grob[["b"]]){
    gp <- gtable_squash_rows(gp, rows = guide.grob[["t"]])
  }
  gp <- gtable_remove_grobs(gp, "guide-box")

  return(gp)
}

Результат:

library(grid)

grid.draw(shift_legend(p))

Хороший результат, если мы воспользуемся направлением пустого пространства, чтобы расположить легенду по горизонтали:

p.new <- p +
  guides(fill = guide_legend(title.position = "top",
                             label.position = "bottom",
                             nrow = 1)) +
  theme(legend.direction = "horizontal")
grid.draw(shift_legend(p.new))

Некоторые другие примеры:

# example 1: 1 empty panel, 1 vertical legend
p1 <- ggplot(economics_long, 
             aes(date, value, color = variable)) +
  geom_line() +
  facet_wrap(~ variable, 
             scales = "free_y", nrow = 2, 
             strip.position = "bottom") +
  theme(strip.background = element_blank(), 
        strip.placement = "outside")
grid.draw(shift_legend(p1))

# example 2: 2 empty panels (vertically aligned) & 2 vertical legends side by side
p2 <- ggplot(mpg,
             aes(x = displ, y = hwy, color = fl, shape = factor(cyl))) +
  geom_point(size = 3) +
  facet_wrap(~ class, dir = "v") +
  theme(legend.box = "horizontal")
grid.draw(shift_legend(p2))

# example 3: facets in polar coordinates
p3 <- ggplot(mtcars, 
             aes(x = factor(1), fill = factor(cyl))) +
  geom_bar(width = 1, position = "fill") + 
  facet_wrap(~ gear, nrow = 2) +
  coord_polar(theta = "y") +
  theme_void()
grid.draw(shift_legend(p3))

Ответ 2

Хорошие вопросы и ответы!

Я нашел что-то похожее по этой ссылке. Итак, я подумал, что это было бы хорошим дополнением к вашей функции.

Точнее, функция reposition_legend() от lemon кажется, вполне то, что вам нужно, за исключением того, что она не ищет пустые места.

Я черпал вдохновение в вашей функции, чтобы найти имена пустых панелей, которые передаются в reposition_legend() с помощью arg panel.

Пример данных и библиотек:

library(ggplot2)
library(gtable)
library(lemon)

p <- ggplot(diamonds, 
            aes(x = carat, fill = cut)) +
  geom_density(position = "stack") +
  facet_wrap(~ color) +
  theme(legend.direction = "horizontal")

Конечно, я снял все проверки (if дела, которые должны быть одинаковыми), чтобы сосредоточиться на важных вещах.

shift_legend2 <- function(p) {
  # ...
  # to grob
  gp <- ggplotGrob(p)
  facet.panels <- grep("^panel", gp[["layout"]][["name"]])
  empty.facet.panels <- sapply(facet.panels, function(i) "zeroGrob" %in% class(gp[["grobs"]][[i]]))
  empty.facet.panels <- facet.panels[empty.facet.panels]

  # establish name of empty panels
  empty.facet.panels <- gp[["layout"]][empty.facet.panels, ]
  names <- empty.facet.panels$name
  # example of names:
  #[1] "panel-3-2" "panel-3-3"

# now we just need a simple call to reposition the legend
  reposition_legend(p, 'center', panel=names)
}

shift_legend2(p)

Обратите внимание, что это все еще может потребовать доработки, я просто подумал, что это стоит того, чтобы им поделиться.

На данный момент поведение кажется нормальным, а функция на несколько строк короче.

Другие случаи.

Первый пример:

p1 <- ggplot(economics_long, 
             aes(date, value, color = variable)) +
  geom_line() +
  facet_wrap(~ variable, 
             scales = "free_y", nrow = 2, 
             strip.position = "bottom") +
  theme(strip.background = element_blank(), 
        strip.placement = "outside")

shift_legend2(p1)

Второй пример:

p2 <- ggplot(mpg,
             aes(x = displ, y = hwy, color = fl, shape = factor(cyl))) +
  geom_point(size = 3) +
  facet_wrap(~ class, dir = "v") +
  theme(legend.box = "horizontal")

#[1] "panel-2-3" "panel-3-3" are the names of empty panels in this case
shift_legend2(p2)

Третий пример:

p3 <- ggplot(mtcars, 
             aes(x = factor(1), fill = factor(cyl))) +
  geom_bar(width = 1, position = "fill") + 
  facet_wrap(~ gear, nrow = 2) +
  coord_polar(theta = "y") +
  theme_void()
shift_legend2(p3)

Полная функция:

shift_legend2 <- function(p) {
  # check if p is a valid object
  if(!(inherits(p, "gtable"))){
    if(inherits(p, "ggplot")){
      gp <- ggplotGrob(p) # convert to grob
    } else {
      message("This is neither a ggplot object nor a grob generated from ggplotGrob. Returning original plot.")
      return(p)
    }
  } else {
    gp <- p
  }

  # check for unfilled facet panels
  facet.panels <- grep("^panel", gp[["layout"]][["name"]])
  empty.facet.panels <- sapply(facet.panels, function(i) "zeroGrob" %in% class(gp[["grobs"]][[i]]), 
                               USE.NAMES = F)
  empty.facet.panels <- facet.panels[empty.facet.panels]

  if(length(empty.facet.panels) == 0){
    message("There are no unfilled facet panels to shift legend into. Returning original plot.")
    return(p)
  }

  # establish name of empty panels
  empty.facet.panels <- gp[["layout"]][empty.facet.panels, ]
  names <- empty.facet.panels$name

  # return repositioned legend
  reposition_legend(p, 'center', panel=names)
}