在不对称矩阵图中可视化对角线

Question

我有许多相同维度的对称矩阵，我希望以一种优雅的方式（我将在下面更精确地描述）可视化这些矩阵中每个单元格中值的均值和方差，利用对称字符。

让我先做一些数据来说明。下面创建 10 个 9x9 矩阵，聚合均值和方差，并转换为长格式以准备绘图：

library(dplyr, warn.conflicts = FALSE)
library(tidyr)

make_matrix <- function(n) {
  m <- matrix(NA, nrow = n, ncol = n)
  m[lower.tri(m)] <- runif((n^2 - n) / 2)
  m <- pmax(m, t(m), na.rm = TRUE)
  diag(m) <- runif(n)
  rownames(m) <- colnames(m) <- letters[1:n]
  m
}

matrices <- replicate(10, make_matrix(9))
means <- apply(matrices, 1:2, mean) %>% 
  as_tibble(rownames = "row") %>%
  pivot_longer(-1, names_to = "col", values_to = "mean")
vars <- apply(matrices, 1:2, var) %>%
  as_tibble(rownames = "row") %>%
  pivot_longer(-1, names_to = "col", values_to = "var")
df <- full_join(means, vars, by = c("row", "col"))

head(df)
#> # A tibble: 6 x 4
#>   row   col    mean    var
#>   <chr> <chr> <dbl>  <dbl>
#> 1 a     a     0.548 0.111 
#> 2 a     b     0.507 0.0914
#> 3 a     c     0.374 0.105 
#> 4 a     d     0.350 0.0976
#> 5 a     e     0.525 0.0752
#> 6 a     f     0.452 0.0887

现在，我可以简单地使用geom_tile 制作一张均值图和一张方差图。但是考虑到两者都是对称的，这样会浪费很多空间，也无法将对称的角色传达给观众。

为了解决这个问题，我一直在使用ggasym 包来创建不对称矩阵图。以下是对ggasymvignette稍作修改：

library(ggasym)
library(ggplot2)

ggplot(df, aes(x = col, y = row)) +
  geom_asymmat(aes(fill_diag = mean, fill_tl = mean, fill_br = var)) +
  scale_fill_diag_gradient(limits = c(0, 1), low = "lightpink", high = "tomato") +
  scale_fill_tl_gradient(limits = c(0, 1), low = "lightpink", high = "tomato") +
  scale_fill_br_gradient(low = "lightblue1", high = "dodgerblue") +
  geom_text(data = filter(df, row == col), aes(label = signif(var, 2)))

^{由reprex package (v0.3.0) 于 2020 年 6 月 27 日创建}

让我烦恼的是对角线。在上面，我已将对角线的填充映射到均值，并用文本覆盖方差，这可行，但似乎不太好。具体来说，我想把这里的所有信息都映射起来，这样就去掉了文字。我看到了一些关于如何做到这一点的选项，但我不确定如何实现它们中的任何一个：

• 分割对角单元格的填充，以便（在上面的示例中）对角线上每个单元格的右下角是适当的蓝色阴影，而左上角是一些红色阴影。
• 分别绘制上下矩阵（每个都有对角线），然后以某种方式“叠加”这些图，使它们以适当的方式彼此相邻。换句话说，这会将对角线绘制两次。

对于如何以干净的方式完成此任务，我愿意接受其他建议。让我强调一下，我不需要在 ggasym 上构建解决方案，这只是迄今为止我所能得到的最接近的解决方案。不过，我想要某种基于ggplot 的解决方案。

Answer 1

以下是我对“拆分填充”策略的看法。如果您不介意将您的东西参数化为多边形，您可以在 ggplot 中绘制大部分您想要的东西。我们让 ggnewscale 包为我们处理双填充映射。

首先，我们不再自动命名矩阵，因为我们不会使用 dimnames。

suppressPackageStartupMessages({
  library(ggplot2)
  library(tidyr)
  library(dplyr)
  library(ggnewscale)
})

make_matrix <- function(n) {
  m <- matrix(NA, nrow = n, ncol = n)
  m[lower.tri(m)] <- runif((n^2 - n) / 2)
  m <- pmax(m, t(m), na.rm = TRUE)
  diag(m) <- runif(n)
  # rownames(m) <- colnames(m) <- letters[1:n]
  m
}

下面是一个函数，它接受一个矩阵，将其参数化为一个多边形并切掉一半。

halfmat <- function(mat, side) {
  side <- match.arg(side, c("upper", "lower", "both"))
  # Convert to long format
  dat <- data.frame(
    x = as.vector(row(mat)),
    y = as.vector(col(mat)),
    id = seq_along(mat),
    value = as.vector(mat)
  )
  # Parameterise as polygon
  poly <- with(dat, data.frame(
    x = c(x - 0.5, x + 0.5, x + 0.5, x - 0.5),
    y = c(y - 0.5, y - 0.5, y + 0.5, y + 0.5),
    id = rep(id, 4),
    value = rep(value, 4)
  ))
  # Slice off one of the triangles
  if (side == "upper") {
    poly <- filter(poly, y >= x)
  } else if (side == "lower") {
    poly <- filter(poly, x >= y)
  }
  poly
}

然后我们生成数据，计算均值和方差并重新参数化它们。

matrices <- replicate(10, make_matrix(9))
means <- apply(matrices, 1:2, mean) %>% halfmat("upper")
vars <- apply(matrices, 1:2, var) %>% halfmat("lower")

然后我们将均值和方差作为两个单独的多边形层放入，因为我们需要用new_scale_fill() 分隔填充映射。需要对尺度进行一些额外的调整，因为它们现在是连续的而不是离散的，但还不错。

ggplot(means, aes(x, y, fill = value, group = id)) +
  geom_polygon() +
  scale_fill_distiller(palette = "Reds", name = "Mean") +
  # Be sure to call new_scale_fill() only after you've set up a fill scale 
  # for the upper part
  new_scale_fill() +
  geom_polygon(data = vars, aes(fill = value)) +
  scale_fill_distiller(palette = "Blues", name = "Variance") +
  scale_x_continuous(breaks = function(x){seq(x[1] + 0.5, x[2] - 0.5, by = 1)},
                     labels = function(x){letters[x]},
                     expand = c(0,0), name = "col") +
  scale_y_continuous(breaks = function(x){seq(x[1] + 0.5, x[2] - 0.5, by = 1)},
                     labels = function(x){letters[x]},
                     expand = c(0,0), name = "row")

^{由reprex package (v0.3.0) 于 2020 年 6 月 27 日创建}