专注收集和自写可发表的科研图形的数据和代码分享，该系列的数据均可从以下链接下载：
百度云盘链接: https://pan.baidu.com/s/1M4vgU1ls0tilt0oSwFbqYQ
提取码: 请关注WX公zhong号 生信学习者 后台发送 科研绘图 获取提取码
介绍
金字塔图（Pyramid plot）是一种用于展示人口统计数据的图表，特别是用于展示不同年龄段的人口数量。这种图表通常用于展示人口结构，比如性别和年龄的分布。
特点：
年龄分层：金字塔图按年龄分层，每一层代表一个年龄组。
性别区分：通常，男性和女性的数据会被分别展示在金字塔的两侧，形成对比。
数量表示：每个层级的高度或面积代表该年龄组的人口数量。
时间序列：可以展示不同时间点的人口结构，形成时间序列的对比。
说明问题：
人口结构：展示不同年龄段的人口数量和比例。
性别差异：比较同一年龄段内男性和女性的数量差异。
人口趋势：通过时间序列的对比，可以观察到人口增长、减少或老龄化的趋势。
社会经济影响：人口结构的变化可以影响到劳动力市场、教育需求、医疗保健等方面。
适合的数据类型：
人口统计数据：年龄、性别等基础人口统计信息。
时间序列数据：可以展示不同年份或时间段的人口结构变化。
比较数据：适合比较不同地区或国家的人口结构。
加载R包
knitr::opts_chunk$set(message = FALSE, warning = FALSE)
library(tidyverse)
library(patchwork)
rm(list = ls())
options(stringsAsFactors = F)
options(future.globals.maxSize = 10000 * 1024^2)
导入数据
data <- data.frame(
age_group = c("< 5 years", "5 - 9", "10 - 14",
"15 - 19", "20 - 24", "25 - 29", "30 - 34", "35 - 44",
"45 - 54", "55 - 64", "65 - 74", "75 - 84", "85 +"),
males = c(6, 6, 7, 6, 7, 7, 8, 17, 15, 11, 6, 3, 1),
females = c(6, 5, 6, 6, 6, 7, 7, 16, 15, 12, 7, 4, 2))
head(data)
| age_group | males | females |
|---|---|---|
| < 5 years | 6 | 6 |
| 5 - 9 | 6 | 5 |
| 10 - 14 | 7 | 6 |
| 15 - 19 | 6 | 6 |
| 20 - 24 | 7 | 6 |
| 25 - 29 | 7 | 7 |
数据预处理
设置分组的颜色
sort设置排序方案设置坐标轴的大小
bar_colors <- c("#1F77B4", "#FF7F0E")
sort <- "no" # "no", "descending", "ascending"
plotdata <- data %>%
tidyr::gather(key = "Gender", value = "Value", -c(age_group))
groups <- plotdata %>%
dplyr::pull(Gender) %>%
unique()
names(bar_colors) <- groups
if (sort != "no") {
order <- plotdata %>%
split(plotdata[['Gender']]) %>%
lapply(function(x) x[['Value']]) %>%
(function(list) list[[1]] + list[[2]])
if (sort == "ascending") {
order <- -order
}
} else {
order <- seq_len(nrow(plotdata) / 2)
}
limit <- plotdata %>%
dplyr::pull(Value) %>%
abs() %>%
max()
画图
主题：左右两侧的主题各部相同
pyramid_theme <- function(side = c("left", "right")) {
side <- match.arg(side)
if (side == "left") {
axis_text_y <- element_blank()
plot_margin <- margin(5, 0, 5, 5)
plot_title_hjust <- 1
} else {
axis_text_y <- element_text(
hjust = .5,
color = "black",
margin = margin(l = 10, r = 10)
)
plot_margin <- margin(5, 5, 5, 0)
plot_title_hjust <- 0
}
theme_minimal(base_size = 13) +
theme(
axis.title.y = element_blank(),
axis.text.y = axis_text_y,
axis.title.x = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = plot_margin,
strip.text = element_text(hjust = 0, size = 14, face = "bold"),
panel.grid = element_blank(),
plot.title = element_text(hjust = plot_title_hjust, margin = margin()),
axis.ticks = element_line(color = "darkgray"),
axis.line.x = element_line(color = "darkgray")
)
}
画图：分别画左右两侧的图形，然后再组合
sides <- c("left", "right")
num_hjust <- c(-0.5, 1)
plots <- vector("list", 2L)
for (i in 1:2) {
if (i == 1L) {
y_scale <- scale_y_reverse(
limits = c(limit, 0),
expand = expansion(mult = c(.05, 0)))
} else {
y_scale <- scale_y_continuous(
limits = c(0, limit),
expand = expansion(mult = c(0, .05)))
}
plots[[i]] <- plotdata %>%
dplyr::filter(Gender == groups[i]) %>%
dplyr::mutate(age_group := reorder(age_group, order)) %>%
ggplot(aes(x = age_group, y = Value)) +
geom_col(fill = bar_colors[i], width = .7) +
scale_x_discrete(expand = expansion(add = .5)) +
geom_text(aes(label = Value), hjust = num_hjust[i], size = 4) +
y_scale +
coord_flip() +
pyramid_theme(sides[i]) +
ggtitle(groups[i])
}
pl <- plots[[1]] + plots[[2]] +
patchwork::plot_annotation(
caption = "No. of Subjects",
title = "Subjects in each Age group of Gender",
theme = theme(plot.title = element_text(hjust = .5, size = 16, face = "bold"),
plot.caption = element_text(hjust = .5, size = 13)))
pl
结果：金字塔图展示了不同分组的同一水平数据对比，通过该图可以获取不同水平的差异信息。
参考
https://github.com/thomas-neitmann/ggcharts/blob/master/R/pyramid_chart.R
