r - 如何在热图的一个图 block 上显示两个分类变量 - 三角形图 block

Question

我有一个类似于下面示例的数据集

df <- structure(list(Species = structure(c(1L, 2L, 3L, 1L, 2L, 3L, 1L, 2L,3L, 
1L, 2L, 3L), .Label = c("setosa", "versicolor", "virginica"), class = 
"factor"), flower_att = c("Sepal.Length", "Sepal.Length", "Sepal.Length", 
"Sepal.Width", "Sepal.Width", "Sepal.Width", "Petal.Length", "Petal.Length", 
"Petal.Length", "Petal.Width", "Petal.Width", "Petal.Width"), measurement = 
c(5.1, 7, 6.3, 3.5, 3.2, 3.3, 1.4, 4.7, 6, 0.2, 1.4, 2.5), month = 
c("January", "February", "January", "February", "January", "February", 
"January", "February", "January", "February", "January", "February")), 
row.names = c(NA,-12L), class = "data.frame")

我想并排显示每个物种和月份的萼片长度和宽度。我希望在热图中使用对角线拆分单元格来实现这一点，该单元格具有 2 种不同的颜色图例，即红色代表长度，蓝色代表宽度。如果可能的话，我希望该值显示在单元格段内。到目前为止，我的搜索找到了最接近的 example但我正在寻找一个可行的 ggplot 版本。

我自己的尝试目前如下所示。我不知道如何分解细胞。

ggplot(df, aes(x=month, y=Species)) +   geom_tile(aes(fill=measurement), 
color="black") +   theme(axis.text.x = element_text(angle=45, hjust = .5)) +   
geom_text(aes(label = round(measurement, .1))) +   scale_fill_gradient(low = 
"white", high = "red")

更新

在互联网上认真挖掘之后，我发现了一个使用 geom_segment 和 geom_text_repel 的潜在选项，请参见下文。谁能告诉我这是否是一个可行的选择？如果可以，我怎样才能让它满足上述要求？

我愿意将 scale_fill_gradient 切换为 scale_fill_manual 或其他替代方案，我的主要目标是并排显示所有数据

ggplot(df, aes(x=month, y=Species)) +
geom_tile(aes(fill=measurement), color="black") +
theme(axis.text.x = element_text(angle=45, hjust = .5)) +
geom_text_repel(aes(label = round(measurement, .1))) +
scale_fill_gradient(low = "white", high = "red")

gb <- ggplot_build(p)

p + geom_segment(data=gb$data[[1]],
aes(x=xmin, xend=xmax, y=ymin, yend=ymax), color="black")

Answer 1

这有点 hacky，但老实说，如果不创建专用的 geom，我不认为你可以减少它的 hacky - 创建一个 geom 也会变得有点 hacky :)

• 使用 sapply 为每个 x/y 坐标创建三角形多边形。我想您可以在未来的 StatSplitTile 中为您的 compute_group 层使用这种方法。
• 为了获得正确的顺序，扰乱因素是必不可少的罪恶。如果您想要 y 轴上的特定顺序，您还需要先分解 Species。
• 使用 ggnewscale 以非常简单的方式获得多个填充比例。
• 为更好的可比性设置相同的限制
• coord_equal 让它看起来更好

library(tidyverse)

mydat <- structure(list(Species = structure(c(1L, 2L, 3L, 1L, 2L, 3L, 1L, 2L, 3L, 1L, 2L, 3L), .Label = c("setosa", "versicolor", "virginica"), class = "factor"), flower_att = c("Sepal.Length", "Sepal.Length", "Sepal.Length", "Sepal.Width", "Sepal.Width", "Sepal.Width", "Petal.Length", "Petal.Length", "Petal.Length", "Petal.Width", "Petal.Width", "Petal.Width"), measurement = c(5.1, 7, 6.3, 3.5, 3.2, 3.3, 1.4, 4.7, 6, 0.2, 1.4, 2.5), month = c("January", "February", "January", "February", "January", "February", "January", "February", "January", "February", "January", "February")),
  row.names = c(NA, -12L), class = "data.frame"
)

make_triangles <- function(x, y, point = "up") {
  x <- as.integer(as.factor((x)))
  y <- as.integer(as.factor((y)))

  if (point == "up") {
    newx <- sapply(x, function(x) {
      c(x - 0.5, x - 0.5, x + 0.5)
    }, simplify = FALSE)
    newy <- sapply(y, function(y) {
      c(y - 0.5, y + 0.5, y + 0.5)
    }, simplify = FALSE)
  } else if (point == "down") {
    newx <- sapply(x, function(x) {
      c(x - 0.5, x + 0.5, x + 0.5)
    }, simplify = FALSE)
    newy <- sapply(y, function(y) {
      c(y - 0.5, y - 0.5, y + 0.5)
    }, simplify = FALSE)
  }
  data.frame(x = unlist(newx), y = unlist(newy))
}

# required, otherwise you cannot use the values as fill
mydat_wide <- mydat %>% pivot_wider(names_from = "flower_att", values_from = "measurement")
# making your ordered months factor
mydat_wide$month <- droplevels(factor(mydat_wide$month, levels = month.name))
# The actual triangle computation
newcoord_up <- make_triangles(mydat_wide$month, mydat_wide$Species)
newcoord_down <- make_triangles(mydat_wide$month, mydat_wide$Species, point = "down")
# just a dirty trick for renaming
newcoord_down <- newcoord_down %>% select(xdown = x, ydown = y)
# you need to repeat each row of your previous data frame 3 times
repdata <- map_df(1:nrow(mydat_wide), function(i) mydat_wide[rep(i, 3), ])
newdata <- bind_cols(repdata, newcoord_up, newcoord_down)

ggplot(newdata) +
  geom_polygon(aes(x = x, y = y, fill = Sepal.Length, group = interaction(Species, month)), color = "black") +
  scale_fill_gradient(low = "white", high = "red", limits = c(0, 10)) +
  ggnewscale::new_scale_fill() +
  geom_polygon(aes(x = xdown, y = ydown, fill = Sepal.Width, group = interaction(Species, month)), color = "black") +
  scale_fill_gradient(low = "white", high = "red", limits = c(0, 10)) +
  scale_x_continuous(breaks = seq_along(unique(mydat_wide$month)), 
                     labels = unique(levels(mydat_wide$month))) +
  scale_y_continuous(breaks = seq_along(unique(mydat_wide$Species)),
                     labels = unique(mydat_wide$Species))+
  coord_equal()

^{由 reprex package 创建于 2021-01-27 (v0.3.0)}