所有作品合集传送门： Tidy Tuesday
2018 年合集传送门： 2018
NFL Positional Salaries
NFL Positional Salaries
Tidy Tuesday 在 GitHub 上的传送地址：
Thomas Mock (2022). Tidy Tuesday: A weekly data project aimed at the R ecosystem. https://github.com/rfordatascience/tidytuesday
gganimate 让你的统计图动起来！动态交互图的绘制在 R 实际工作中应用的比较多，在 R 中我们可以使用 gganimate 包来快速完成一张动态图的绘制。
1. 一些环境设置
# 设置为国内镜像, 方便快速安装模块
options("repos" = c(CRAN = "https://mirrors.tuna.tsinghua.edu.cn/CRAN/"))
2. 设置工作路径
wkdir <- '/home/user/R_workdir/TidyTuesday/2018/2018-04-09_NFL_Positional_Salaries/src-b'
setwd(wkdir)
3. 加载 R 包
library(tidyverse)
library(lubridate)
library(gganimate)
library(ggridges)
library(ggtext)
library(ggimage)
library(patchwork)
library(magick)
library(gifski)
library(showtext)
# 在 Ubuntu 系统上测试的, 不加这个我画出来的汉字会乱码 ~
showtext_auto()
4. 加载数据
df_input <- readxl::read_excel("../data/nfl_salary.xlsx")
# 简要查看数据内容
glimpse(df_input)
## Rows: 800
## Columns: 11
## $ year <dbl> 2011, 2011, 2011, 2011, 2011, 2011, 2011, 2011, 20…
## $ Cornerback <dbl> 11265916, 11000000, 10000000, 10000000, 10000000, …
## $ `Defensive Lineman` <dbl> 17818000, 16200000, 12476000, 11904706, 11762782, …
## $ Linebacker <dbl> 16420000, 15623000, 11825000, 10083333, 10020000, …
## $ `Offensive LALBERT` <dbl> 15960000, 12800000, 11767500, 10358200, 10000000, …
## $ Quarterback <dbl> 17228125, 16000000, 14400000, 14100000, 13510000, …
## $ `Running Back` <dbl> 12955000, 10873833, 9479000, 7700000, 7500000, 703…
## $ Safety <dbl> 8871428, 8787500, 8282500, 8000000, 7804333, 76527…
## $ `Special Teamer` <dbl> 4300000, 3725000, 3556176, 3500000, 3250000, 32250…
## $ `Tight End` <dbl> 8734375, 8591000, 8290000, 7723333, 6974666, 61333…
## $ `Wide Receiver` <dbl> 16250000, 14175000, 11424000, 11415000, 10800000, …
# 检查数据的列名
colnames(df_input)
## [1] "year" "Cornerback" "Defensive Lineman"
## [4] "LneALBERTr" "Offensive Lineman" "Quarterback"
## [7] "Running Back" "Safety" "Special Teamer"
## [10] "Tight End" "Wide Receiver"
5. 数据预处理
# 整理数据, 从宽数据透视到长数据转换
df_tidy <- df_input %>% gather(key = position, value = salary, -year)
# 创建 进攻 Offense 和 防守 Defense 类别
# 建议使用 dplyr::mutate 形式调用函数, 不然容易与 plyr 中的函数冲突 (因为我自己就报错了...)
df_tidy <- df_tidy %>% mutate(salary = salary / 10**6,
year = year(as.Date.character(year, format = "%Y")),
status = case_when(
position %in%
c("Cornerback", "Defensive Lineman", "Linebacker", "Safety", "Special Teamer") ~ "Defense",
position %in% c("Quarterback", "Offensive Lineman", "Running Back", "Tight End", "Wide Receiver") ~ "Offense")) %>%
group_by(position, year) %>%
top_n(50, salary)
# 删除缺失值的观测
df_plot <- na.omit(df_tidy)
glimpse(df_plot)
## Rows: 4,010
## Columns: 4
## Groups: position, year [80]
## $ year <dbl> 2011, 2011, 2011, 2011, 2011, 2011, 2011, 2011, 2011, 2011, 2…
## $ position <chr> "Cornerback", "Cornerback", "Cornerback", "Cornerback", "Corn…
## $ salary <dbl> 11.265916, 11.000000, 10.000000, 10.000000, 10.000000, 9.2441…
## $ status <chr> "Defense", "Defense", "Defense", "Defense", "Defense", "alertb…
6. 绘制第一张动图 (Defense)
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
gg <- ggplot(data = df_plot %>% filter(status == "Defense"),
aes(x = salary, y = fct_reorder(position, salary, median), fill = position))
# geom_density_ridges() 绘制峰峦图
# scale值小于1可以防止重叠
gg <- gg + geom_density_ridges(scale = .95,
size = .25,
na.rm = TRUE,
alpha = .75,
rel_min_height = 0.05,
quantile_lines = TRUE,
show.legend = FALSE)
gg <- gg + scale_x_continuous(breaks = seq(0, 20, 5), limits = c(0, 20), labels = function(l) {paste0("$",round(l,1), "M")})
gg <- gg + scale_y_discrete(limits = rev)
# transition_states() 按照给定的列分成不同时态的数据动态显示
gg <- gg + transition_states(year, transition_length = 3, state_length = 1)
# ease_aes() 控制 gganimate 中美学或变量的动作, quadratic-in-out 二次进与出
gg <- gg + ease_aes('quadratic-in-out')
# enter_fade() 淡入
gg <- gg + enter_fade()
# exit_fade() 淡出
gg <- gg + exit_fade()
gg <- gg + ggthemes::theme_fivethirtyeight()
gg <- gg + labs(title = "<br>",
subtitle = "<br>防守 Defense",
x = NULL,
y = NULL,
caption = '<br>')
# theme_minimal() 去坐标轴边框的最小化主题
gg <- gg + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
gg <- gg + theme(
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = "none",
# plot.title.position 设置主标题位置
plot.title.position = 'plot',
# plot.title 主标题
plot.title = element_markdown(face = "bold", size = 18, hjust = 1),
# plot.subtitle 次要标题
plot.subtitle = element_markdown(face = "italic", size = 10, colour = "azure4", hjust = .5),
# plot.caption 说明文字
plot.caption = element_markdown(colour = "dodgerblue4", size = 10, hjust = 1),
# axis.text.x X-坐标轴文本
axis.text.x = element_text(size = 10),
# axis.text.y Y-坐标轴文本
axis.text.y = element_text(size = 10))
gg.gif <- animate(gg, renderer=gifski_renderer(), width = 395.136, height = 444.528, duration = length(unique(df_plot$year)))
7. 绘制第二张动图 (Offense)
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
hh <- ggplot(data = df_plot %>% filter(status == "Offense"),
aes(x = salary, y = fct_reorder(position, salary, median), fill = position))
# geom_density_ridges() 绘制峰峦图
# scale值小于1可以防止重叠
hh <- hh + geom_density_ridges(scale = .95,
size = .25,
na.rm = TRUE,
alpha = .75,
rel_min_height = 0.05,
quantile_lines = TRUE,
show.legend = FALSE)
hh <- hh + scale_x_continuous(breaks = seq(0, 20, 5), limits = c(0, 20), labels = function(l) {paste0("$",round(l,1), "M")})
hh <- hh + scale_y_discrete(limits = rev, position ='right')
# transition_states() 按照给定的列分成不同时态的数据动态显示
hh <- hh + transition_states(year, transition_length = 3, state_length = 1)
# ease_aes() 控制 gganimate 中美学或变量的动作, quadratic-in-out 二次进与出
hh <- hh + ease_aes('quadratic-in-out')
# enter_fade() 淡入
hh <- hh + enter_fade()
# exit_fade() 淡出
hh <- hh + exit_fade()
hh <- hh + geom_image(aes(x = 17.5, y = 5.3, image = "../data/icon.png"), size = 0.08)
hh <- hh + ggthemes::theme_fivethirtyeight()
hh <- hh + labs(title = "<br>{closest_state}年·橄榄球队球员的薪酬水平",
subtitle = "<br>防守 Defense",
x = NULL,
y = NULL,
caption = "<br><span>NFL·Quarterback·Salaries<br><br>graph·by·萤火之森</span>")
# theme_minimal() 去坐标轴边框的最小化主题
hh <- hh + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
hh <- hh + theme(
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = "none",
# plot.title 主标题
plot.title = element_markdown(face = "bold", size = 18, hjust = 1),
# plot.subtitle 次要标题
plot.subtitle = element_markdown(face = "italic", size = 10, colour = "azure4", hjust = .5),
# plot.caption 说明文字
plot.caption = element_markdown(colour = "dodgerblue4", size = 10, hjust = 1),
# axis.text.x X-坐标轴文本
axis.text.x = element_text(size = 10),
# axis.text.y Y-坐标轴文本
axis.text.y = element_text(size = 10))
hh.gif <- animate(hh, renderer=gifski_renderer(), width = 395.136, height = 444.528, duration = length(unique(df_plot$year)))
8 合并动图
gg.mgif <- image_read(gg.gif)
hh.mgif <- image_read(hh.gif)
new.gif <- image_append(c(gg.mgif[1], hh.mgif[1]))
for(i in 2:69){
merge.gif <- image_append(c(gg.mgif[i], hh.mgif[i]))
new.gif <- c(new.gif, merge.gif)
}
new.gif
9. 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 gifski_1.6.6-1
## [5] magick_2.7.3 patchwork_1.1.2 ggimage_0.3.1 ggtext_0.1.2
## [9] ggridges_0.5.4 gganimate_1.0.8 lubridate_1.8.0 forcats_0.5.2
## [13] stringr_1.4.1 dplyr_1.0.10 purrr_0.3.4 readr_2.1.2
## [17] tidyr_1.2.1 tibble_3.1.8 ggplot2_3.3.6 tidyverse_1.3.2
##
## loaded via a namespace (and not attached):
## [1] httr_1.4.4 sass_0.4.2 jsonlite_1.8.0
## [4] modelr_0.1.9 bslib_0.4.0 assertthat_0.2.1
## [7] highr_0.9 yulab.utils_0.0.5 googlesheets4_1.0.1
## [10] cellranger_1.1.0 yaml_2.3.5 progress_1.2.2
## [13] pillar_1.8.1 backports_1.4.1 glue_1.6.2
## [16] digest_0.6.29 gridtext_0.1.5 rvest_1.0.3
## [19] colorspace_2.0-3 ggfun_0.0.7 htmltools_0.5.3
## [22] pkgconfig_2.0.3 broom_1.0.1 haven_2.5.1
## [25] scales_1.2.1 ggplotify_0.1.0 tweenr_2.0.2
## [28] tzdb_0.3.0 googledrive_2.0.0 generics_0.1.3
## [31] farver_2.1.1 ellipsis_0.3.2 cachem_1.0.6
## [34] withr_2.5.0 cli_3.3.0 magrittr_2.0.3
## [37] crayon_1.5.1 readxl_1.4.1 evaluate_0.16
## [40] fs_1.5.2 fansi_1.0.3 xml2_1.3.3
## [43] ggthemes_4.2.4 tools_4.2.1 prettyunits_1.1.1
## [46] hms_1.1.2 gargle_1.2.1 lifecycle_1.0.1
## [49] munsell_0.5.0 reprex_2.0.2 compiler_4.2.1
## [52] jquerylib_0.1.4 gridGraphics_0.5-1 rlang_1.0.5
## [55] grid_4.2.1 rstudioapi_0.14 rmarkdown_2.16
## [58] gtable_0.3.1 DBI_1.1.3 markdown_1.1
## [61] R6_2.5.1 knitr_1.40 fastmap_1.1.0
## [64] utf8_1.2.2 stringi_1.7.8 Rcpp_1.0.9
## [67] vctrs_0.4.1 dbplyr_2.2.1 tidyselect_1.1.2
## [70] xfun_0.32
测试数据
配套数据下载：nfl_salary.xlsx
1015
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
