创建极地热图但留下扇形 space 以使用 R 注释每个环表示的内容
Creating polar heatmap but leaving a fan-shaped space to annotate what each ring indicates using R
我想创建一个极地热图,就像柳叶刀论文中的热图“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:
请注意,颜色图例位于中央并且是弯曲的。如何做到这一点?
谢谢。
下面是一些示例代码,说明如何塑造图例之类的东西并将其添加到情节中。由于 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 创建
我想创建一个极地热图,就像柳叶刀论文中的热图“1985 年至 2019 年 200 个国家和地区的学龄儿童和青少年的身高和体重指数轨迹:对 6500 万参与者的 2181 项基于人群的研究的汇总分析”:
我很欣赏通过创建极地热图的扇形开口(手动用红色圈出)来注释每一层环代表的年龄(5 到 19 岁)的想法。我在下文中将 5-19 称为 Y 轴标签。
下面是@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:
请注意,颜色图例位于中央并且是弯曲的。如何做到这一点?
谢谢。
下面是一些示例代码,说明如何塑造图例之类的东西并将其添加到情节中。由于 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 创建