Включить автономную легенду в ggpairs (дубль 2)

Question

tl;dr не может получить отдельную легенду (описывающую общие цвета по всему графику) в ggpairs к моему удовлетворению.

Извините за длину.

Я пытаюсь нарисовать (нижний треугольный) график пары, используя GGally::ggpairs (пакет расширения для рисования различных видов матриц ggplot2). По сути, это тот же вопрос, что и Как добавить внешнюю легенду в ggpairs ()?, но я не удовлетворен эстетическим ответом на этот вопрос, поэтому я публикую его как расширение (если это предложено / рекомендовано комментаторами, я удалю этот вопрос и вместо этого предложу вознаграждение по этому вопросу). В частности, я бы хотел, чтобы легенда появлялась вне фрейма суб-сюжета, либо помещая его в один виртуальный субплот, но оставляя для него дополнительную ширину, либо (в идеале) помещая его в отдельный (пустой) субплот. Как я покажу ниже, оба моих частичных решения имеют проблемы.

Поддельные данные:

set.seed(101)
dd <- data.frame(x=rnorm(100),
                 y=rnorm(100),
                 z=rnorm(100),
                 f=sample(c("a","b"),size=100,replace=TRUE))
library(GGally)

Базовая функция сюжета:

ggfun <- function(...) {
   ggpairs(dd,mapping = ggplot2::aes(color = f),
    columns=1:3,
    lower=list(continuous="points"),
    diag=list(continuous="blankDiag"),
    upper=list(continuous="blank"),
    ...)
}

Функция для обрезки верхней / правой колонки:

trim_gg <- function(gg) {
    n <- gg$nrow
    gg$nrow <- gg$ncol <- n-1
    v <- 1:n^2
    gg$plots <- gg$plots[v>n & v%%n!=0]
    gg$xAxisLabels <- gg$xAxisLabels[-n]
    gg$yAxisLabels <- gg$yAxisLabels[-1]
    return(gg)
}

gg0 <- trim_gg(ggfun(legends=TRUE))

Избавьтесь от легенд в левой колонке (как в связанном вопросе выше):

library(ggplot2)  ## for theme()
for (i in 1:2) {
   inner <- getPlot(gg0,i,1)
   inner <- inner + theme(legend.position="none")
   gg0 <- putPlot(gg0,inner,i,1)
}
inner <- getPlot(gg0,2,2)
inner <- inner + theme(legend.position="right")
gg0 <- putPlot(gg0,inner,2,2)

Проблемы:

• пустая панель за легендой на самом деле маскирует некоторые точки; Я не знаю, почему это не за пределами панели, как обычно, я предполагаю, что это то, что ggpairs делается
• если бы это было за пределами панели (сверху или справа), я бы хотел оставить некоторое дополнительное пространство, чтобы сами панели были одинакового размера. Тем не мение, ggmatrix/ggpairs выглядит очень негибким об этом.

Единственная альтернатива, которую я смог попробовать - это следовать отдельной легенде и сюжету ggplot, извлекая легенду и используя gridExtra::grid.arrange():

g_legend <- function(a.gplot){
   tmp <- ggplot_gtable(ggplot_build(a.gplot))
   leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
   legend <- tmp$grobs[[leg]]
   return(legend)
}

library(gridExtra)
grid.arrange(getPlot(gg0,1,1),
             g_legend(getPlot(gg0,2,2)),
             getPlot(gg0,2,1),
             getPlot(gg0,2,2)+theme(legend.position="none"),
   nrow=2)

Проблемы:

• оси и метки подавляются ggpairs вернулись...

Я также подумал о создании панели со специальным сюжетом, который содержал бы только легенду (т.е. пытался использовать theme(SOMETHING=element.blank) подавить сам сюжет, но не мог понять, как это сделать.

В крайнем случае, я мог бы самостоятельно подрезать оси, но это практически переосмысливает ggpairs делает в первую очередь...

Answer 1

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

data(state)
dd <- data.frame(state.x77,
             State = state.name,
             Abbrev = state.abb,
             Region = state.region,
             Division = state.division) 

columns <- c(3, 5, 6, 7)
colour <- "Region"

library(GGally)
library(ggplot2)  ## for theme()

# Base plot
ggfun <- function(data = NULL, columns = NULL, colour = NULL, legends = FALSE) {
   ggpairs(data, 
     columns = columns,
     mapping = ggplot2::aes_string(colour = colour),
     lower = list(continuous = "points"),
     diag = list(continuous = "blankDiag"),
     upper = list(continuous = "blank"),
    legends = legends)
}

# Remove the diagonal elements
trim_gg <- function(gg) {
    n <- gg$nrow
    gg$nrow <- gg$ncol <- n-1
    v <- 1:n^2
    gg$plots <- gg$plots[v > n & v%%n != 0]
    gg$xAxisLabels <- gg$xAxisLabels[-n]
    gg$yAxisLabels <- gg$yAxisLabels[-1]
    return(gg)
}

# Get the plot
gg0 <- trim_gg(ggfun(dd, columns, colour))

# For plot in position (1,1), draw its legend in the empty panels to the right
inner <- getPlot(gg0, 1, 1)

inner <- inner + 
   theme(legend.position = c(1.01, 0.5), 
         legend.direction = "horizontal",
         legend.justification = "left") +
   guides(colour = guide_legend(title.position = "top"))  

gg0 <- putPlot(gg0, inner, 1, 1)
gg0