R语言可视化（三十二）：金字塔图绘制
2020-10-31 本文已影响0人
Davey1220
32. 金字塔图绘制
清除当前环境中的变量
rm(list=ls())
设置工作目录
setwd("C:/Users/Dell/Desktop/R_Plots/32pyramid/")
使用plotrix包绘制人口金字塔图
# 安装并加载所需的R包
#install.packages("plotrix")
library(plotrix)
# 构建示例数据
xy.pop<-c(3.2,3.5,3.6,3.6,3.5,3.5,3.9,3.7,3.9,3.5,
3.2,2.8,2.2,1.8,1.5,1.3,0.7,0.4)
xx.pop<-c(3.2,3.4,3.5,3.5,3.5,3.7,4,3.8,3.9,3.6,3.2,
2.5,2,1.7,1.5,1.3,1,0.8)
agelabels<-c("0-4","5-9","10-14","15-19","20-24","25-29","30-34",
"35-39","40-44","45-49","50-54","55-59","60-64",
"65-69","70-74","75-79","80-44","85+")
mcol<-color.gradient(c(0,0,0.5,1),c(0,0,0.5,1),c(1,1,0.5,1),18)
fcol<-color.gradient(c(1,1,0.5,1),c(0.5,0.5,0.5,1),c(0.5,0.5,0.5,1),18)
head(xy.pop)
## [1] 3.2 3.5 3.6 3.6 3.5 3.5
head(xx.pop)
## [1] 3.2 3.4 3.5 3.5 3.5 3.7
head(agelabels)
## [1] "0-4" "5-9" "10-14" "15-19" "20-24" "25-29"
head(mcol)
## [1] "#0000FFFF" "#0000FFFF" "#0000FFFF" "#0000FFFF" "#0000FFFF" "#0000FFFF"
head(fcol)
## [1] "#FF8080FF" "#FF8080FF" "#FF8080FF" "#FF8080FF" "#FF8080FF" "#FF8080FF"
# 使用pyramid.plot函数绘制人口金字塔图
par(mar=pyramid.plot(xy.pop,xx.pop,labels=agelabels,
main="Australian population pyramid 2002",
lxcol=mcol,rxcol=fcol,
gap=0.5,show.values=TRUE))
image.png
# three column matrices
avtemp<-c(seq(11,2,by=-1),rep(2:6,each=2),seq(11,2,by=-1))
malecook<-matrix(avtemp+sample(-2:2,30,TRUE),ncol=3)
femalecook<-matrix(avtemp+sample(-2:2,30,TRUE),ncol=3)
# group by age
agegrps<-c("0-10","11-20","21-30","31-40","41-50","51-60",
"61-70","71-80","81-90","91+")
head(malecook)
## [,1] [,2] [,3]
## [1,] 13 0 11
## [2,] 11 0 10
## [3,] 9 1 9
## [4,] 10 3 10
## [5,] 5 4 7
## [6,] 8 4 6
head(femalecook)
## [,1] [,2] [,3]
## [1,] 12 0 13
## [2,] 9 2 10
## [3,] 11 1 10
## [4,] 7 4 10
## [5,] 6 4 6
## [6,] 7 6 7
head(agegrps)
## [1] "0-10" "11-20" "21-30" "31-40" "41-50" "51-60"
oldmar<-pyramid.plot(malecook,femalecook,labels=agegrps,
unit="Bowls per month",
lxcol=c("#ff0000","#eeee88","#0000ff"),
rxcol=c("#ff0000","#eeee88","#0000ff"),
laxlab=c(0,10,20,30),
raxlab=c(0,10,20,30),
top.labels=c("Males","Age","Females"),
gap=4,
do.first="plot_bg(\"#eedd55\")")
# give it a title
mtext("Porridge temperature by age and sex of bear",3,2,cex=1.5)
# stick in a legend
legend(par("usr")[1],11,legend = c("Too hot","Just right","Too cold"),
fill=c("#ff0000","#eeee88","#0000ff"))
# don't forget to restore the margins and background
par(mar=oldmar,bg="transparent")
image.png
使用DescTools包绘制人金字塔图
# 安装并加载所需的R包
#install.packages("DescTools")
library(DescTools)
# 构建示例数据
d.sda <- data.frame(
kt_x = c("ZH","BL","ZG","SG","LU","AR","SO","GL","SZ",
"NW","TG","UR","AI","OW","GR","BE","SH","AG",
"BS","FR","GE","JU","NE","TI","VD","VS"),
apo_n = c(18,16,13,11,9,12,11,8,9,8,11,9,7,9,24,19,
19,20,43,27,41,31,37,62,38,39),
sda_n = c(235,209,200,169,166,164,162,146,128,127,
125,121,121,110,48,34,33,0,0,0,0,0,0,0,0,0)
)
head(d.sda)
## kt_x apo_n sda_n
## 1 ZH 18 235
## 2 BL 16 209
## 3 ZG 13 200
## 4 SG 11 169
## 5 LU 9 166
## 6 AR 12 164
# 使用PlotPyramid函数绘制人口金字塔图
PlotPyramid(lx=d.sda[,"apo_n"],
rx=d.sda[,"sda_n"],
ylab=d.sda$kt_x,
col=c("lightslategray", "orange2"),
border = NA, ylab.x=0,
xlim=c(-110,250),
gapwidth = NULL,
cex.lab = 0.8, cex.axis=0.8,
xaxt = TRUE,
lxlab="Drugstores",
rxlab="General practitioners",
main="Density of general practitioners and drugstores in CH (2010)",
space=0.5, args.grid=list(lty=1))
image.png
op <- par(mfrow=c(1,3))
m.pop<-c(3.2,3.5,3.6,3.6,3.5,3.5,3.9,3.7,3.9,3.5,
3.2,2.8,2.2,1.8,1.5,1.3,0.7,0.4)
f.pop<-c(3.2,3.4,3.5,3.5,3.5,3.7,4,3.8,3.9,3.6,3.2,
2.5,2,1.7,1.5,1.3,1,0.8)
age <- c("0-4","5-9","10-14","15-19","20-24","25-29",
"30-34","35-39","40-44","45-49","50-54",
"55-59","60-64","65-69","70-74","75-79","80-44","85+")
# 查看数据
head(m.pop)
## [1] 3.2 3.5 3.6 3.6 3.5 3.5
head(f.pop)
## [1] 3.2 3.4 3.5 3.5 3.5 3.7
head(age)
## [1] "0-4" "5-9" "10-14" "15-19" "20-24" "25-29"
# 左侧图
PlotPyramid(m.pop, f.pop,
ylab = age, space = 0,
col = c("cornflowerblue", "indianred"),
main="Age distribution at baseline of HELP study",
lxlab="male", rxlab="female" )
# 中间图
PlotPyramid(m.pop, f.pop,
ylab = age, space = 1,
col = c("blue", "red"),
xlim=c(-5,5),
main="Age distribution at baseline of HELP study",
lxlab="male", rxlab="female",
gapwidth=0, ylab.x=-5 )
# 右侧图
PlotPyramid(c(1,3,5,2,0.5), c(2,4,6,1,0),
ylab = LETTERS[1:5], space = 0.3,
col = rep(rainbow(5), each=2),
xlim=c(-10,10), args.grid=NA,
cex.names=1.5, adj=1,
lxlab="Group A", rxlab="Group B",
gapwidth=1, ylab.x=-8, xaxt="n")
par(op)
image.png
使用ggplot2包绘制金字塔图
library(ggplot2)
library(plyr)
# 构建示例数据
mov <-c(23.2,33.5,43.6,33.6,43.5,43.5,43.9,33.7,53.9,43.5,
43.2,42.8,22.2,51.8,41.5,31.3,60.7,50.4)
mob<-c(13.2,9.4,13.5,13.5,13.5,23.7,8,3.18,3.9,3.16,23.2,
22.5,22,12.7,12.5,12.3,10,0.8)
fov<-c(13.2,9.4,13.5,13.5,13.5,23.7,8,3.18,3.9,3.16,23.2,
22.5,22,12.7,12.5,12.3,10,0.8)
fob<-c(23.2,33.5,43.6,33.6,43.5,23.5,33.9,33.7,23.9,43.5,
18.2,22.8,22.2,31.8,25.5,25.3,31.7,28.4)
labs<-c("uk","scotland","france","ireland","germany","sweden","norway",
"iceland","portugal","austria","switzerland","australia",
"new zealand","dubai","south africa","finland","italy","morocco")
df = data.frame(labs=rep(labs,4), values=c(mov, mob, fov, fob),
sex=rep(c("Male", "Female"), each=2*length(fov)),
bmi = rep(rep(c("Overweight", "Obese"), each=length(fov)),2))
head(df)
## labs values sex bmi
## 1 uk 23.2 Male Overweight
## 2 scotland 33.5 Male Overweight
## 3 france 43.6 Male Overweight
## 4 ireland 33.6 Male Overweight
## 5 germany 43.5 Male Overweight
## 6 sweden 43.5 Male Overweight
# Order countries by overall percent overweight/obese
labs.order = ddply(df, .(labs), summarise, sum=sum(values))
labs.order = labs.order$labs[order(labs.order$sum,decreasing = T)]
# 设置因子进行排序
df$labs = factor(df$labs, levels=labs.order)
# 绘制金字塔图
ggplot(df, aes(x=labs)) +
geom_bar(data=subset(df,sex=="Male"), aes(y=values, fill=bmi), stat="identity") +
geom_bar(data=subset(df,sex=="Female"), aes(y=-values, fill=bmi), stat="identity") +
geom_hline(yintercept=0, colour="white", lwd=2) +
theme_bw()+
coord_flip(ylim=c(-100,100)) +
scale_fill_brewer(palette='Set1') +
scale_y_continuous(breaks=seq(-100,100,50), labels=c(100,50,0,50,100)) +
labs(y="Percent", x="Country") +
ggtitle("Female Male") +
theme(plot.title = element_text(hjust = 0.5))
image.png
sessionInfo()
## R version 3.6.0 (2019-04-26)
## Platform: x86_64-w64-mingw32/x64 (64-bit)
## Running under: Windows 10 x64 (build 18363)
##
## Matrix products: default
##
## locale:
## [1] LC_COLLATE=Chinese (Simplified)_China.936
## [2] LC_CTYPE=Chinese (Simplified)_China.936
## [3] LC_MONETARY=Chinese (Simplified)_China.936
## [4] LC_NUMERIC=C
## [5] LC_TIME=Chinese (Simplified)_China.936
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] plyr_1.8.4 ggplot2_3.2.0 DescTools_0.99.38 plotrix_3.7-6
##
## loaded via a namespace (and not attached):
## [1] Rcpp_1.0.5 RColorBrewer_1.1-2 compiler_3.6.0
## [4] pillar_1.4.2 class_7.3-15 tools_3.6.0
## [7] boot_1.3-23 digest_0.6.20 lifecycle_0.2.0
## [10] evaluate_0.14 tibble_2.1.3 rootSolve_1.8.2.1
## [13] gtable_0.3.0 lattice_0.20-38 pkgconfig_2.0.2
## [16] rlang_0.4.7 Matrix_1.2-17 rstudioapi_0.10
## [19] yaml_2.2.0 mvtnorm_1.0-11 expm_0.999-5
## [22] xfun_0.8 e1071_1.7-4 withr_2.1.2
## [25] dplyr_1.0.2 stringr_1.4.0 knitr_1.23
## [28] generics_0.0.2 vctrs_0.3.2 tidyselect_1.1.0
## [31] gld_2.6.2 grid_3.6.0 glue_1.4.2
## [34] R6_2.4.0 lmom_2.8 rmarkdown_1.13
## [37] purrr_0.3.2 magrittr_1.5 scales_1.0.0
## [40] htmltools_0.3.6 MASS_7.3-51.4 Exact_2.1
## [43] colorspace_1.4-1 stringi_1.4.3 lazyeval_0.2.2
## [46] munsell_0.5.0 crayon_1.3.4
