所有作品合集传送门： Tidy Tuesday
2018 年合集传送门： 2018
Australian Salaries by Gender
欢迎来到ggplot2的世界！
ggplot2是一个用来绘制统计图形的 R 软件包。它可以绘制出很多精美的图形，同时能避免诸多的繁琐细节，例如添加图例等。
用 ggplot2 绘制图形时，图形的每个部分可以依次进行构建，之后还可以进行编辑。ggplot2 精心挑选了一系列的预设图形，因此在大部分情形下可以快速地绘制出许多高质量的图形。如果在格式上还有额外的需求，也可以利用 ggplot2 中的主题系统来进行定制, 无需花费太多时间来调整图形的外观，而可以更加转注地用图形来展现你的数据。
棒棒糖图因其形状和棒棒糖相似而得名，具体来看实际上是一个散点和一条线段的组合。棒棒糖图是散点图的一种变体，又与柱状图非常相似，但其在清晰展示数据的同时，减少了图形量，使得读者能够更加关注于数据本身而非图形。棒棒糖图能够帮助将数值与类别对齐，非常适合比较多个类别的值之间的差异。
在 R 中我们也可以直接使用ggalt包中 geom_dumbbell() 函数绘制，可以参考 20180423-B 这篇文章示例。
1. 一些环境设置
# 设置为国内镜像, 方便快速安装模块
options("repos" = c(CRAN = "https://mirrors.tuna.tsinghua.edu.cn/CRAN/"))
2. 设置工作路径
wkdir <- '/home/user/R_workdir/TidyTuesday/2018/2018-04-23_Australian_Salaries_by_Gender/src-a'
setwd(wkdir)
3. 加载 R 包
library(scales)
library(tidyverse)
library(patchwork)
library(RColorBrewer)
library(wesanderson)
# 导入字体设置包
library(showtext)
# font_add_google() showtext 中从谷歌字体下载并导入字体的函数
# name 中的是字体名称, 用于检索, 必须严格对应想要字体的名字
# family 后面的是代码后面引用时的名称, 自己随便起
# 需要能访问 Google, 也可以注释掉下面这行, 影响不大
# font_families_google() 列出所有支持的字体, 支持的汉字不多
# http://www.googlefonts.net/
font_add_google(name = "Merienda", family = "Merienda")
font_add_google(name = "Gochi Hand", family = "gchi")
font_add_google(name = "ZCOOL XiaoWei", family = "zxw")
# 后面字体均可以使用导入的字体
showtext_auto()
4. 加载数据
df_input <- read.csv("../data/week4_australian_salary.csv")
# 简要查看数据内容
glimpse(df_input)
## Rows: 2,197
## Columns: 6
## $ X <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, …
## $ gender_rank <int> 795, 881, 699, 828, 641, 760, 200, 136, 157, 99…
## $ occupation <chr> "Abattoir process worker; Meat process worker; …
## $ gender <chr> "Female", "Male", "Female", "Male", "Falbert", "…
## $ individuals <int> 5961, 17241, 1386, 636, 1878, 903, 78380, 77112…
## $ average_taxable_income <int> 36359, 40954, 40926, 44077, 43545, 47833, 71552…
# 检查数据的列名
colnames(df_input)
## [1] "X" "gender_rank" "occupation"
## [4] "gender" "individuals" "average_taxable_income"
5. 数据预处理
# 分别计算男性和女性的平均工资水平
avg_female <- mean(df_input$average_taxable_income[df_input$gender == "Female"])
avg_male <- mean(df_input$average_taxable_income[df_input$gender == "Male"])
# 文件中有些字符不兼容, 防止报错, 我们提前替换掉
df_input$occupation <- str_replace(df_input$occupation, "\x96", "/")
# 选择职业, 性别和平均收入
df_tidy <- df_input %>%
select(occupation, gender, average_taxable_income) %>%
# spread() 数据裂变、从窄表到宽表
spread(key = gender, value = average_taxable_income) %>%
dplyr::mutate(diff = Male - Female)
# 去除缺失值
df_tidy <- na.omit(df_tidy)
# 取前后十五
df_plot_top_15 <- df_tidy %>% top_n(15)
df_plot_bottom_15 <-df_tidy %>% top_n(-15)
# 简要查看数据内容
glimpse(df_plot_top_15)
## Rows: 15
## Columns: 4
## $ occupation <chr> "Cardiologist", "Cardiothoracic surgeon", "Cricketer", "Der…
## $ Female <int> 215920, 175500, 42744, 195030, 180695, 264628, 99997, 32368…
## $ Male <int> 453253, 358043, 257527, 383880, 386003, 446507, 286530, 577…
## $ diff <int> 237333, 182543, 214783, 188850, 205308, 181879, 186533, 253…
6. 利用 ggplot2 绘图
6.1 绘制前十五的图
# 自定义配色方案
palette <- colorRampPalette(brewer.pal(9, "Set1"))(20)
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
gg.top <- df_plot_top_15 %>% ggplot(aes(x=fct_reorder(occupation, diff), y = Female, col = occupation))
# geom_segment() 添加线段 x,y 表示线段的起点; xend, yend 表示线段的终点
gg.top <- gg.top + geom_segment(aes(x = fct_reorder(occupation, diff),
xend = fct_reorder(occupation, diff),
y = Female,
yend = Male))
# geom_point() 绘制散点图, 这里是在线段的两端标记点
gg.top <- gg.top + geom_point(aes(x = occupation, y = Male), col = "blue", size = 1.2)
gg.top <- gg.top + geom_point(aes(x = occupation, y = Female), col = "red", size = 1.2)
# coord_flip() 横纵坐标位置转换
gg.top <- gg.top + coord_flip()
# scale_y_continuous() 对连续变量设置坐标轴显示范围
gg.top <- gg.top + scale_y_continuous(labels = comma)
# scale_color_manual() 采取的是手动赋值的方法, 也就是直接把颜色序列赋值给它的参数 value
gg.top <- gg.top + scale_color_manual(values = palette)
# annotate() 可以在已有图形基础上, 添加任意几何对象 (如 rect, point,text 等)
gg.top <- gg.top + annotate("text", x = 3:4, y = 510000, label = c("Male", "Female"), hjust = 0)
gg.top <- gg.top + annotate("point", x = 4, y = 495000, size = 1.2, col = "red")
gg.top <- gg.top + annotate("point", x = 3, y = 495000, size = 1.2, col = "blue")
# labs() 对图形添加注释和标签（包含标题 title、子标题 subtitle、坐标轴 x & y 和引用 caption 等注释)
gg.top <- gg.top + labs(title = "不同职位男女薪水差异前15",
subtitle = NULL,
x = NULL,
y = NULL,
caption = "graph by 数绘小站")
# theme_minimal() 去坐标轴边框的最小化主题
gg.top <- gg.top + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
gg.top <- gg.top + theme(
# panel.grid.major 主网格线, 这一步表示删除主要网格线
panel.grid.major = element_blank(),
# panel.grid.minor 次网格线, 这一步表示删除次要网格线
panel.grid.minor = element_blank(),
# axis.text.x X-坐标轴文本
axis.text.x = element_text(color = "black", size = 10, family = "gchi", face = "bold"),
# axis.text.y Y-坐标轴文本
axis.text.y = element_text(color = "black", size = 10, family = "Merienda", face = "bold"),
# plot.title 主标题
plot.title = element_text(color = "black", size = 20, family = "zxw", face = "bold"),
# plot.caption 说明文字
plot.caption = element_text(hjust = 0.85, vjust = -1.4, color = 'red', family = "zxw"),
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = "none",
# plot.background 图片背景 element_blank() 指的是去掉外边框和背景色
plot.background = element_blank())
6.1 绘制后十五的图
# 自定义配色方案
palette <- colorRampPalette(brewer.pal(9, "Set1"))(20)
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
gg.bottom <- df_plot_bottom_15 %>% ggplot(aes(x=fct_reorder(occupation, diff), y = Female, col = occupation))
# geom_segment() 添加线段 x,y 表示线段的起点; xend, yend 表示线段的终点
gg.bottom <- gg.bottom + geom_segment(aes(x = fct_reorder(occupation, diff),
xend = fct_reorder(occupation, diff),
y = Female,
yend = Male))
# geom_point() 绘制散点图, 这里是在线段的两端标记点
gg.bottom <- gg.bottom + geom_point(aes(x = occupation, y = Male), col = "blue", size = 1.2)
gg.bottom <- gg.bottom + geom_point(aes(x = occupation, y = Female), col = "red", size = 1.2)
# coord_flip() 横纵坐标位置转换
gg.bottom <- gg.bottom + coord_flip()
# scale_y_continuous() 对连续变量设置坐标轴显示范围
gg.bottom <- gg.bottom + scale_y_continuous(labels = comma)
# scale_color_manual() 采取的是手动赋值的方法, 也就是直接把颜色序列赋值给它的参数 value
gg.bottom <- gg.bottom + scale_color_manual(values = palette)
# annotate() 可以在已有图形基础上, 添加任意几何对象 (如 rect, point,text 等)
gg.bottom <- gg.bottom + annotate("text", x = 3:4, y = 210000, label = c("Male", "Female"), hjust = 0)
gg.bottom <- gg.bottom + annotate("point", x = 4, y = 200000, size = 1.2, col = "red")
gg.bottom <- gg.bottom + annotate("point", x = 3, y = 200000, size = 1.2, col = "blue")
# labs() 对图形添加注释和标签（包含标题 title、子标题 subtitle、坐标轴 x & y 和引用 caption 等注释)
gg.bottom <- gg.bottom + labs(title = "不同职位男女薪水差异后15",
subtitle = NULL,
x = NULL,
y = NULL,
caption = "· 资料来源: data.gov.au")
# theme_minimal() 去坐标轴边框的最小化主题
gg.bottom <- gg.bottom + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
gg.bottom <- gg.bottom + theme(
# panel.grid.major 主网格线, 这一步表示删除主要网格线
panel.grid.major = element_blank(),
# panel.grid.minor 次网格线, 这一步表示删除次要网格线
panel.grid.minor = element_blank(),
# axis.text.x X-坐标轴文本
axis.text.x = element_text(color = "black", size = 10, family = "gchi", face = "bold"),
# axis.text.y Y-坐标轴文本
axis.text.y = element_text(color = "black", size = 10, family = "Merienda", face = "bold"),
# plot.title 主标题
plot.title = element_text(color = "black", size = 20, family = "zxw", face = "bold"),
# plot.caption 说明文字
plot.caption = element_text(hjust = 0.85),
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = "none",
# plot.background 图片背景 element_blank() 指的是去掉外边框和背景色
plot.background = element_blank())
7. 保存图片到 PDF 和 PNG
gg.top + gg.bottom + plot_layout(ncol = 1, nrow = 2)
filename = '20180423-A-01'
ggsave(filename = paste0(filename, ".pdf"), width = 9.2, height = 6.0, device = cairo_pdf)
ggsave(filename = paste0(filename, ".png"), width = 9.2, height = 6.0, dpi = 100, device = "png")
8. session-info
sessionInfo()
## R version 4.2.1 (2022-06-23)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.5 LTS
##
## Matrix products: default
## BLAS: /usr/lib/x86_64-linux-gnu/openblas-pthread/libblas.so.3
## LAPACK: /usr/lib/x86_64-linux-gnu/openblas-pthread/liblapack.so.3
##
## locale:
## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
## [9] LC_ADDRESS=C LC_TELEPHONE=C
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] showtext_0.9-5 showtextdb_3.0 sysfonts_0.8.8 wesanderson_0.3.6
## [5] RColorBrewer_1.1-3 patchwork_1.1.2 forcats_0.5.2 stringr_1.4.1
## [9] dplyr_1.0.10 purrr_0.3.4 readr_2.1.2 tidyr_1.2.1
## [13] tibble_3.1.8 ggplot2_3.3.6 tidyverse_1.3.2 scales_1.2.1
##
## loaded via a namespace (and not attached):
## [1] lubridate_1.8.0 assertthat_0.2.1 digest_0.6.29
## [4] utf8_1.2.2 R6_2.5.1 cellranger_1.1.0
## [7] backports_1.4.1 reprex_2.0.2 evaluate_0.16
## [10] highr_0.9 httr_1.4.4 pillar_1.8.1
## [13] rlang_1.0.5 curl_4.3.2 googlesheets4_1.0.1
## [16] readxl_1.4.1 rstudioapi_0.14 jquerylib_0.1.4
## [19] rmarkdown_2.16 textshaping_0.3.6 labeling_0.4.2
## [22] googledrive_2.0.0 munsell_0.5.0 broom_1.0.1
## [25] compiler_4.2.1 modelr_0.1.9 xfun_0.32
## [28] systemfonts_1.0.4 pkgconfig_2.0.3 htmltools_0.5.3
## [31] tidyselect_1.1.2 fansi_1.0.3 crayon_1.5.1
## [34] tzdb_0.3.0 dbplyr_2.2.1 withr_2.5.0
## [37] grid_4.2.1 jsonlite_1.8.0 gtable_0.3.1
## [40] lifecycle_1.0.1 DBI_1.1.3 magrittr_2.0.3
## [43] cli_3.3.0 stringi_1.7.8 cachem_1.0.6
## [46] farver_2.1.1 fs_1.5.2 xml2_1.3.3
## [49] bslib_0.4.0 ragg_1.2.3 ellipsis_0.3.2
## [52] generics_0.1.3 vctrs_0.4.1 tools_4.2.1
## [55] glue_1.6.2 hms_1.1.2 fastmap_1.1.0
## [58] yaml_2.3.5 colorspace_2.0-3 gargle_1.2.1
## [61] rvest_1.0.3 knitr_1.40 haven_2.5.1
## [64] sass_0.4.2
测试数据
配套数据下载：week4_australian_salary.csv
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
