R语言可视化：使用ggplot2绘制人口金字塔

　　人口金字塔是进行人口数据可视化时常用的一种统计图形，可以形象地描述人口年龄和性别的分布情况。最近工作上经常处理人口数据，于是试着使用ggplot2绘制了一下。在这里记录一下，顺便也熟悉一下ggplot2的用法。

　　上图所示的人口金字塔是根据我国2010年人口普查的相关数据进行绘制的，绘制过程主要分为以下三部分，（1）数据爬取，（2）分面设置以及（3）图形绘制。

１、数据爬取

　　如下图所示，人口普查的相关数据可以从统计局网站上找到。

　　由于网站是frame结构构建的动态网页，我们这里使用RSelenium包进行了爬取。这里值得注意的是，frame的切换需要逐层进行，我们这里使用switchToFrame、goBack和goForward函数实现了不同frame之间的切换。其中使用RSelenium包进行爬虫需安装java和Selenium，可参考R语言爬取动态网页：使用RSelenium包和Rwebdriver包的前期准备。

　　爬虫相关程序如下：

library(RSelenium)
library(rvest)
## 打开浏览器
remDr <- remoteDriver(browserName ="chrome")
remDr$open() 
## 打开网页
url <- 'http://www.stats.gov.cn/tjsj/pcsj/rkpc/6rp/indexch.htm'
remDr$navigate(url)
## 切换frame链接到数据页面
remDr$switchToFrame(1)
xpath <- '//tbody/tr[3]/th/ul/ul[1]/ul[3]/li[1]/a'
nextBtn <- remDr$findElement(using ='xpath',
                             value = xpath)
nextBtn$clickElement()
## 切换到数据frame
remDr$goBack()
remDr$goForward()
remDr$switchToFrame(2)
## 读取数据
webpage <- read_html(remDr$getPageSource()[[1]][1])
data_temp <- html_table(webpage, fill = TRUE)[[1]]
## 数据清洗
data <- data_temp[grep('岁', data_temp[, 1]), ]
colnames(data) <- paste(data_temp[4,], data_temp[5,])
data_use <- cbind(1: nrow(data), data[, c(1, 3, 4)])
data_use[, 3] <- (data_use[, 3] %>% as.numeric()) * -1 / 10000
data_use[, 4] <- (data_use[, 4] %>% as.numeric()) / 10000
colnames(data_use) <- c('group', 'group_name', 'male', 'female')

　　数据清洗后最终得到的数据如下所示：

 

２、分面设置

　　ggplot2中没有专门绘制人口金字塔的函数，本文开头给出的人口金字塔图其实是由四部分作图得到的，即标题、标签、男性人口、女性人口。

　　然而常用的分面函数par(mfrow)和layout在ggplot2中不能使用，我们这里参考ggplot2 3.0 分面、一页多图的做法，使用grid包中的viewport函数实现ggplot2的分面操作。

vplayout <- function(x, y){
  viewport(layout.pos.row = x, layout.pos.col = y)
}
# 分面画图
grid.newpage()  ##新建页面
pushViewport(viewport(layout = grid.layout(12, 11))) 
print(p_1, vp = vplayout(2:12, 1:5))
print(p_2, vp = vplayout(2:12, 7:11))
print(p_3, vp = vplayout(2:12, 6))
print(p_4, vp = vplayout(1, 1:11))

３、图形绘制

　　在这里，人口分布的条形图使用geom_bar函数实现，标题和标签则使用geom_text函数在空白背景上直接添加。代码如下：

### 人口金字塔
library(ggplot2)
library(grid)
## 作图
# 函数
vplayout <- function(x, y){
  viewport(layout.pos.row = x, layout.pos.col = y)
}
# 参数
v_max <- 6500
dig_temp <- nchar(as.character(v_max))
lim_1 <- c(-v_max, 0)
lim_2 <- c(0, v_max)
by <- round(v_max/(5 * 10^(dig_temp - 2))) * 10^(dig_temp - 2)
bre_1 <- seq(from = 0, to = -v_max, by = -by)
bre_2 <- seq(from = 0, to = v_max, by = by)
lab_1 <- seq(from = 0, to = v_max, by = by)
lab_2 <- seq(from = 0, to = v_max, by = by)
mg_1 <- unit(c(0, 0.0, 0.3, 0.5), "lines")  # 上右下左
mg_2 <- unit(c(0, 0.5, 0.3, 0.0), "lines")
mg_3 <- unit(c(0, 0.0, 2.3, 0.0), "lines")
mg_l <- margin(0, 0, 0, 0, 'lines')
text_x <- rep(2, nrow(data_use))
text_y <- 1:nrow(data_use)
text_lab <- gsub('岁', '', data_use$group_name)
text_lab <- gsub('及以上', '+', text_lab)
title_x <- 2
title_y <- 2
title_lab <- '2010年人口普查'

# 图形
p_1 <- ggplot(data_use) +
  geom_bar(aes(group, male), fill = 'skyblue', stat="identity", position="dodge") +
  scale_y_continuous(limits = lim_1, breaks = bre_1, labels = lab_1) +
  scale_x_continuous(limits = c(0, (nrow(data_use) + 1)), breaks = 1:nrow(data_use), labels = NULL, expand = expand_scale(), position = 'top') +
  theme(plot.margin = mg_1, axis.text = element_text(margin = mg_l)) +
  xlab(NULL) +
  ylab('男（万人）') +
  coord_flip() + 
  guides(fill = FALSE)

p_2 <- ggplot(data_use) +
  geom_bar(aes(group, female), fill = 'firebrick1', stat="identity", position="dodge") +
  scale_y_continuous(limits = lim_2, breaks = bre_2, labels = lab_2) +
  scale_x_continuous(limits = c(0, (nrow(data_use) + 1)), breaks = 1:nrow(data_use), labels = NULL, expand = expand_scale()) +
  theme(plot.margin = mg_2, axis.text = element_text(margin = mg_l)) +
  xlab(NULL) +
  ylab('女（万人）') +
  coord_flip() +
  guides(fill = FALSE)

p_3 <- ggplot() + 
  geom_text(aes(x = text_x, y= text_y, label = text_lab), size = 3.6) +
  scale_x_continuous(limits = c(0, 4), breaks = NULL, expand = expand_scale()) +
  scale_y_continuous(limits = c(0, (nrow(data_use) + 1)), breaks = NULL, expand = expand_scale()) +
  labs(x = NULL, y = NULL) + 
  theme(plot.margin = mg_3,
        axis.text = element_text(margin = mg_l),
        panel.grid.major =element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank()) 

p_4 <- ggplot() + 
  geom_text(aes(x = title_x, y= title_y, label = title_lab), size = 6) +
  scale_x_continuous(limits = c(0, 4), breaks = NULL, expand = expand_scale()) +
  scale_y_continuous(limits = c(0, 4), breaks = NULL, expand = expand_scale()) +
  labs(x = NULL, y = NULL) + 
  theme(plot.margin = mg_l,
        axis.text = element_text(margin = mg_l),
        panel.grid.major =element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank()) 

# 分面画图
grid.newpage()  ##新建页面
pushViewport(viewport(layout = grid.layout(12, 11))) 
print(p_1, vp = vplayout(2:12, 1:5))
print(p_2, vp = vplayout(2:12, 7:11))
print(p_3, vp = vplayout(2:12, 6))
print(p_4, vp = vplayout(1, 1:11))

　　我们对上面代码中用到的函数简单进行一下总结：

　　coord_flip函数用于使条形图横向分布；

　　scale_x_continuous和scale_y_continuous函数用于设置坐标轴标签，其中limits、breaks、labels参数分别表示坐标轴的取值范围、标签位置以及标签文字，expand参数表示实际作图时坐标轴在limits的基础上向外扩展的大小。

　　xlab和ylab函数用于设置坐标轴标题，无标题需填NULL。

　　theme函数用于对绘图的整体进行调整，其中参数plot.margin设置作图的边界,axis.text设置坐标轴标签的文本格式，panel.grid.minor和       panel.grid.major设置绘图背景网格线，panel.background设置背景颜色。