如何在R中使用ggplot2/plotly复现展示性别盈余的人口金字塔

我们可以通过数据预处理、图层堆叠的逻辑完成图表绘制，以下是完整实现步骤：

1 依赖包安装与数据预处理 #

首先加载所需工具包，从wpp2019中提取目标国家的分性别年龄人口数据，做格式适配：

# 加载所需依赖包
library(tidyverse)
library(wpp2019)
library(plotly)

# 加载分性别人口数据集
data(popM) # 男性人口数据
data(popF) # 女性人口数据

# 筛选美国2020年分年龄人口数据（数据单位：千人）
usa_male <- popM %>% 
  filter(name == "United States of America") %>% 
  select(age, `2020`) %>% 
  rename(pop = `2020`) %>% 
  mutate(gender = "男", pop = -pop) # 男性人口设为负值，展示在金字塔左侧

usa_female <- popF %>% 
  filter(name == "United States of America") %>% 
  select(age, `2020`) %>% 
  rename(pop = `2020`) %>% 
  mutate(gender = "女")

# 合并男女数据集
usa_pyramid <- bind_rows(usa_male, usa_female)

# 计算各年龄组性别盈余（正数为女性人口盈余，负数为男性人口盈余）
gender_surplus <- usa_pyramid %>% 
  pivot_wider(names_from = gender, values_from = pop) %>% 
  mutate(surplus = 女 + 男)

2 ggplot2静态图表实现 #

通过堆叠条形图加坐标翻转完成绘制，自动适配人口金字塔的展示逻辑：

ggplot(usa_pyramid, aes(x = age, y = pop, fill = gender)) +
  geom_col(position = "stack", alpha = 0.8) +
  # 标注各年龄组性别盈余数值
  geom_text(data = gender_surplus, 
            aes(x = age, y = ifelse(surplus > 0, 女 + 100, 男 - 100), 
                label = abs(round(surplus, 0))),
            inherit.aes = FALSE, size = 3) +
  # 翻转坐标得到纵向年龄分组的金字塔效果
  coord_flip() +
  # 调整y轴刻度，将负值显示为正人口数
  scale_y_continuous(labels = abs, limits = c(-20000, 20000),
                     breaks = seq(-20000, 20000, 5000)) +
  scale_fill_manual(values = c("男" = "#1f77b4", "女" = "#ff7f0e")) +
  labs(x = "年龄组", y = "人口数（千人）", fill = "性别",
       title = "美国2020年人口金字塔（含性别盈余）") +
  theme_minimal() +
  theme(plot.title = element_text(hjust = 0.5))

3 plotly交互式图表实现 #

如果需要悬停查看详情、缩放等交互能力，可以用plotly实现：

plot_ly() %>%
  # 添加男性人口条形层
  add_trace(data = filter(usa_pyramid, gender == "男"),
            x = ~pop, y = ~age, type = 'bar', orientation = 'h',
            name = '男', marker = list(color = '#1f77b4'),
            hovertext = ~paste("年龄组：", age, "<br>男性人口：", abs(pop), "千人")) %>%
  # 添加女性人口条形层
  add_trace(data = filter(usa_pyramid, gender == "女"),
            x = ~pop, y = ~age, type = 'bar', orientation = 'h',
            name = '女', marker = list(color = '#ff7f0e'),
            hovertext = ~paste("年龄组：", age, "<br>女性人口：", pop, "千人")) %>%
  # 添加性别盈余标注层
  add_trace(data = gender_surplus,
            x = ~surplus, y = ~age, type = 'scatter', mode = 'text',
            text = ~abs(round(surplus, 0)),
            hovertext = ~paste("年龄组：", age, "<br>性别盈余：", ifelse(surplus>0, "女多", "男多"), abs(round(surplus,0)), "千人"),
            showlegend = FALSE) %>%
  layout(barmode = 'relative',
         xaxis = list(title = "人口数（千人）",
                      tickvals = seq(-20000,20000,5000),
                      ticktext = abs(seq(-20000,20000,5000))),
         yaxis = list(title = "年龄组"),
         title = "美国2020年人口金字塔（含性别盈余）",
         legend = list(orientation = 'h', x = 0.5, xanchor = 'center'))

常用参数调整说明 #

• 如需切换国家：修改filter(name == "xxx")中的国家名为wpp2019收录的标准国名即可
• 如需切换统计年份：替换数据筛选时的2020为数据集支持的其他年份即可
• 如需修改配色：调整scale_fill_manual（ggplot2）或marker参数（plotly）中的色值即可
• 如需切换人口单位：将pop列统一乘以对应换算系数即可

内容的提问来源于stack exchange，提问作者Brad