加载R包
library(tidyverse)
library(remotes)
# remotes::install_local("bstfun-main.zip",upgrade = F,dependencies = T)
library(bstfun)
library(gt)
library(gtExtras)
library(MetBrewer)## R version 4.4.0 (2024-04-24)
## Platform: aarch64-apple-darwin20
## Running under: macOS Sonoma 14.5
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRlapack.dylib; LAPACK version 3.12.0
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## time zone: Asia/Shanghai
## tzcode source: internal
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] MetBrewer_0.2.0 gtExtras_0.5.0 gt_0.10.1.9000 bstfun_0.5.1.9002
## [5] remotes_2.5.0 lubridate_1.9.3 forcats_1.0.0 stringr_1.5.1
## [9] dplyr_1.1.4 purrr_1.0.2 readr_2.1.5 tidyr_1.3.1
## [13] tibble_3.2.1 ggplot2_3.5.1 tidyverse_2.0.0
##
## loaded via a namespace (and not attached):
## [1] sass_0.4.9 utf8_1.2.4 generics_0.1.3
## [4] prettydoc_0.4.1 gtsummary_1.7.2 xml2_1.3.6
## [7] stringi_1.8.4 hms_1.1.3 digest_0.6.35
## [10] magrittr_2.0.3 evaluate_0.24.0 grid_4.4.0
## [13] timechange_0.3.0 fastmap_1.2.0 rprojroot_2.0.4
## [16] broom.helpers_1.15.0 jsonlite_1.8.8 rematch2_2.1.2
## [19] fansi_1.0.6 scales_1.3.0 jquerylib_0.1.4
## [22] cli_3.6.3 rlang_1.1.4 munsell_0.5.1
## [25] withr_3.0.0 cachem_1.1.0 yaml_2.3.8
## [28] tools_4.4.0 tzdb_0.4.0 colorspace_2.1-0
## [31] here_1.0.1 paletteer_1.6.0 vctrs_0.6.5
## [34] R6_2.5.1 lifecycle_1.0.4 fontawesome_0.5.2
## [37] pkgconfig_2.0.3 pillar_1.9.0 bslib_0.7.0
## [40] gtable_0.3.5 glue_1.7.0 xfun_0.44
## [43] tidyselect_1.2.1 highr_0.11 rstudioapi_0.16.0
## [46] knitr_1.47 htmltools_0.5.8.1 rmarkdown_2.27
## [49] compiler_4.4.0注：bstfun在线安装比较困难，因此使用本地安装的方法压缩文件内会有编译好的R安装包
数据清洗
# 定义表格的颜色调色板
gt_palette <- scales::col_numeric(c("#004714","#35669D","#93A198","#FEF2F2"), # 定义颜色范围
domain = NULL, alpha = 0.75) # 设置颜色透明度
# 从.tsv文件读取数据集并进行过滤
df <- read_tsv("GBD_ASDR_Male.xls") %>% # 读取.tsv文件
filter(location=="Global", # 过滤全球数据
age %in% c("<5 years","5-9 years","10-14 years","15-19 years", # 选择特定年龄组
"20-24 years","25-29 years","30-34 years","35-39 years",
"40-44 years","45-49 years","50-54 years","55-59 years",
"60-64 years","65-69 years","70-74 years","75-79 years",
"80-84 years","85-89 years","90-94 years","95+ years")) %>%
mutate(val=round(val,digits = 2)) %>% # 将值四舍五入到小数点后两位
select(year, val, age) # 选择表格的相关列
# 创建1990年的表格
year_1990 <- df %>%
filter(year=="1990") %>% select(-year) %>% # 过滤1990年的数据并移除'year'列
select(2,1) %>% # 重新排列列顺序，将'age'放在前，'val'放在后
gt() %>% # 创建gt表格对象
cols_label(val = "") %>% # 自定义列标签
tab_style(locations = cells_column_labels(columns = everything()), # 设置列标签样式
style= list(cell_borders(sides = "bottom",
weight = px(3)), # 设置底部边框粗细
cell_text(weight = "bold"))) %>% # 设置文本为粗体
tab_style(locations = cells_title(groups = "title"), # 设置表格标题样式
style = list(cell_text(weight = "bold", # 设置文本为粗体
size = 24))) %>% # 设置字体大小
data_color(columns = c(val), colors = gt_palette) %>% # 将调色板应用于'val'列
cols_align(align = "left", columns = c(val)) %>% # 设置'val'列文本左对齐
cols_align(align = "center", columns = c(age)) %>% # 设置'age'列文本居中对齐
cols_width(c(age) ~ px(145), c(val) ~ px(70)) %>% # 设置列宽
tab_options(
column_labels.border.top.width = px(3), # 设置列标签顶部边框宽度
column_labels.border.top.color = "transparent", # 设置列标签顶部边框颜色为透明
table.border.top.color = "transparent", # 设置表格顶部边框颜色为透明
table.border.bottom.color = "transparent", # 设置表格底部边框颜色为透明
data_row.padding = px(10), # 设置数据行填充
source_notes.font.size = 12, # 设置来源注释字体大小
heading.align = "left") # 设置标题左对齐
# 创建2019年的表格
year_2019 <- df %>%
filter(year=="2019") %>% select(-year) %>% # 过滤2019年的数据并移除'year'列
gt() %>% # 创建gt表格对象
cols_label(val = "") %>% # 自定义列标签
tab_style(locations = cells_column_labels(columns = everything()), # 设置列标签样式
style= list(cell_borders(sides = "bottom",
weight = px(3)), # 设置底部边框粗细
cell_text(weight = "bold"))) %>% # 设置文本为粗体
tab_style(locations = cells_title(groups = "title"), # 设置表格标题样式
style = list(cell_text(weight = "bold", # 设置文本为粗体
size = 24))) %>% # 设置字体大小
data_color(columns = c(val), colors = gt_palette) %>% # 将调色板应用于'val'列
cols_align(align = "left", columns = c(val)) %>% # 设置'val'列文本左对齐
cols_align(align = "center", columns = c(age)) %>% # 设置'age'列文本居中对齐
cols_width(c(age) ~ px(145), c(val) ~ px(70)) %>% # 设置列宽
tab_options(
column_labels.border.top.width = px(3), # 设置列标签顶部边框宽度
column_labels.border.top.color = "transparent", # 设置列标签顶部边框颜色为透明
table.border.top.color = "transparent", # 设置表格顶部边框颜色为透明
table.border.bottom.color = "transparent", # 设置表格底部边框颜色为透明
data_row.padding = px(10), # 设置数据行填充
source_notes.font.size = 12, # 设置来源注释字体大小
heading.align = "left") # 设置标题左对齐绘制中部折线
df$age <- factor(df$age,levels = df$age %>% unique())
# 按年龄组分组数据并计算每个年龄组的全球死亡率列表
lines <- df %>%
group_by(age) %>% # 按年龄组分组
dplyr::summarize(`Global Mortality Rates by Age Group (1990-2019)` = list(val), .groups = "drop") %>% # 汇总每个年龄组的死亡率，并将其转换为列表
select(2) %>% # 选择第二列，即全球死亡率
gt() %>% # 创建gt表格对象
gt_plt_sparkline("Global Mortality Rates by Age Group (1990-2019)", # 为每个年龄组添加火花线图
label=F, same_limit=F, type="points", # 不显示标签，不使用相同的限制，类型为点
fig_dim = c(20,150), # 设置图形尺寸
palette = paste(met.brewer("VanGogh1", n=5, type="continuous"))) %>% # 设置调色板
tab_options(
column_labels.border.top.width = px(20), # 设置列标签顶部边框宽度
column_labels.border.top.color = "transparent", # 设置列标签顶部边框颜色为透明
table.border.top.color = "transparent", # 设置表格顶部边框颜色为透明
table.border.bottom.color = "transparent", # 设置表格底部边框颜色为透明
row.striping.include_table_body = FALSE, # 禁用条纹行
table_body.hlines.width = px(0), # 移除表格主体部分的横线
table_body.vlines.width = px(0), # 移除表格主体部分的竖线
heading.border.bottom.width = px(0), # 设置标题底部边框宽度
data_row.padding = px(-10), # 设置数据行填充
source_notes.font.size = 30, # 设置来源注释字体大小
heading.align = "left") %>% # 设置标题左对齐
tab_style(
style = cell_text(size = px(32)), # 设置字体大小
locations = cells_column_labels(columns = vars(`Global Mortality Rates by Age Group (1990-2019)`)) # 设置列标签的位置
)格式转换
tbl_1990_ggplot <- bstfun::as_ggplot(year_1990)
tbl_2019_ggplot <- bstfun::as_ggplot(year_2019)
line <- bstfun::as_ggplot(lines) 拼图
library(patchwork)
(tbl_1990_ggplot+line+tbl_2019_ggplot)注：若拼图出现Error in save(plot, file = filename) : reached elapsed time limit Graphics error: Plot rendering error,执行dev.off()关闭画布后重新执行拼图
图形解读
此图主要展示某种疾病下全球不同年龄段1990-2019年度死亡率情况，通过表格与折线图组合的形式来展示数据，左右两侧分别为1990，2019的数据，中间通过折线图的形式来看30年间数据的变化趋势。图表均由R代码生成。