创建极地热图但留下扇形 space 以使用 R 注释每个环表示的内容

Question

我想创建一个极地热图，就像柳叶刀论文中的热图“1985 年至 2019 年 200 个国家和地区的学龄儿童和青少年的身高和体重指数轨迹：对 6500 万参与者的 2181 项基于人群的研究的汇总分析”：

我很欣赏通过创建极地热图的扇形开口（手动用红色圈出）来注释每一层环代表的年龄（5 到 19 岁）的想法。我在下文中将 5-19 称为 Y 轴标签。

下面是@Cyrus Mohammadian 描述的代码。我在下面复制了 Cyrus Mohammadian 的代码：

library(grid)
library(gtable)
library(reshape)
library(ggplot2)
library(plyr)

nba <- read.csv("http://datasets.flowingdata.com/ppg2008.csv")

nba$Name <- with(nba, reorder(Name, PTS))
nba.m <- melt(nba)

nba.m <- ddply(nba.m, .(variable), transform, value = scale(value))

# Convert the factor levels (variables) to numeric + quanity to determine    size   of hole.
nba.m$var2 = as.numeric(nba.m$variable) + 15

# Labels and breaks need to be added with scale_y_discrete.
y_labels = levels(nba.m$variable)
y_breaks = seq_along(y_labels) + 15


nba.labs <- subset(nba.m, variable==levels(nba.m$variable)    [nlevels(nba.m$variable)])

nba.labs <- nba.labs[order(nba.labs$Name),]
nba.labs$ang <- seq(from=(360/nrow(nba.labs))/1.5, to=(1.5* (360/nrow(nba.labs)))-360, length.out=nrow(nba.labs))+80
nba.labs$hjust <- 0
nba.labs$hjust[which(nba.labs$ang < -90)] <- 1
nba.labs$ang[which(nba.labs$ang < -90)] <- (180+nba.labs$ang)[which(nba.labs$ang < -90)]

p<-ggplot(nba.m, aes(x=Name, y=var2, fill=value)) +
  geom_tile(colour="white") +
  geom_text(data=nba.labs, aes(x=Name, y=var2+1.5,
                           label=Name, angle=ang, hjust=hjust), size=2.5) +
  scale_fill_gradient(low = "white", high = "steelblue") +
  ylim(c(0, 50)) +
  coord_polar(theta="x") +
  theme(panel.background=element_blank(),
    axis.title=element_blank(),
    panel.grid=element_blank(),
    axis.text.x=element_blank(),
    axis.ticks=element_blank(),
    axis.text.y=element_text(size=5))+ theme(axis.title.y=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks.y=element_blank())
lab = textGrob((paste("G  MIN  PTS  FGM  FGA  FGP  FTM  FTA  FTP  X3PM X3PA X3PP ORB DRB  TRB  AST  STL  BLK  TO  PF")),
   x = unit(.1, "npc"), just = c("left"), 
   gp = gpar(fontsize = 7))

gp = ggplotGrob(p)
gp = gtable_add_rows(gp, unit(10, "grobheight", lab), -1)
gp = gtable_add_grob(gp, lab, t = -2, l = gp$layout[gp$layout$name == "panel",]$l)

grid.newpage()
grid.draw(gp)

这是结果图：

Y 轴标签放置在热图的底部，而不是像柳叶刀纸那样紧挨着每一层环放置。因此，我问是否可以修改 Cyrus Mohammadian 的图，使 Y 轴标签位于环的每一层旁边，而不是显示在热图之外？另外最好能控制扇形开口的大小，这样可以根据Y-AXIS LABEL文字的长度来定制。

第二个要求是将颜色图例放在热图的中心并使其弯曲。下图举例，来自《中国儿童青少年传染病：2008-2017年全国监测数据分析》论文图3：

请注意，颜色图例位于中央并且是弯曲的。如何做到这一点？

谢谢。

Answer 1

下面是一些示例代码，说明如何塑造图例之类的东西并将其添加到情节中。由于 annotation_custom() 在极坐标方面的一些限制，我决定使用 github 的 patchwork 开发版本来使用新的 inset_element() 函数（devtools::install_github("thomasp85/patchwork")）。


library(ggplot2)
library(patchwork)

df <- reshape2::melt(volcano[1:20, 1:20])
breaks <- scales::extended_breaks()(df$value)
breaks <- scales::discard(breaks, range(df$value))

main <- ggplot(df, aes(Var1, Var2, fill = value)) +
  geom_tile() +
  scale_y_continuous(limits = c(-20, NA)) +
  guides(fill = "none") +
  coord_polar()


legend <- ggplot() +
  geom_tile(
    aes( 
    x = seq(min(df$value), max(df$value), length.out = 255),
    y = 1, fill = after_stat(x)
    )
  ) +
  annotate(
    "text", x = breaks, y = -0.1, label = breaks, size = 3
  ) +
  annotate(
    "segment", x = breaks, xend = breaks, y = 0.5, yend = 0.7, 
    colour = "white", size = 1
  ) +
  annotate(
    "segment", x = breaks, xend = breaks, y = 1.5, yend = 1.3, 
    colour = "white", size = 1
  ) +
  guides(fill = "none") +
  scale_y_continuous(limits = c(-2, 2)) +
  scale_x_continuous(expand = c(0.1, 0)) +
  coord_polar() +
  theme_void()

legend <- ggplotGrob(legend)

main + inset_element(legend, 0.3, 0.3, 0.7, 0.7) &
  theme(plot.background = element_blank())

^{由 reprex package (v0.3.0)}

于 2020-11-06 创建

创建极地热图但留下扇形 space 以使用 R 注释每个环表示的内容

Creating polar heatmap but leaving a fan-shaped space to annotate what each ring indicates using R

r

ggplot2

data-visualization

heatmap

polar-coordinates