所有作品合集传送门： Tidy Tuesday
2018 年合集传送门： 2018
Biketown Bikeshare
欢迎来到ggplot2的世界！
ggplot2是一个用来绘制统计图形的 R 软件包。它可以绘制出很多精美的图形，同时能避免诸多的繁琐细节，例如添加图例等。
用 ggplot2 绘制图形时，图形的每个部分可以依次进行构建，之后还可以进行编辑。ggplot2 精心挑选了一系列的预设图形，因此在大部分情形下可以快速地绘制出许多高质量的图形。如果在格式上还有额外的需求，也可以利用 ggplot2 中的主题系统来进行定制, 无需花费太多时间来调整图形的外观，而可以更加专注地用图形来展现你的数据。
1. 一些环境设置
# 设置为国内镜像, 方便快速安装模块
options("repos" = c(CRAN = "https://mirrors.tuna.tsinghua.edu.cn/CRAN/"))
2. 设置工作路径
wkdir <- '/home/user/R_workdir/TidyTuesday/2018/2018-06-05_Biketown_Bikeshare/src-a'
setwd(wkdir)
3. 加载 R 包
library(glue)
library(ggmap)
library(Hmisc)
library(tidyverse)
library(lubridate)
library(patchwork)
# 导入字体设置包
library(showtext)
# font_add_google() showtext 中从谷歌字体下载并导入字体的函数
# name 中的是字体名称, 用于检索, 必须严格对应想要字体的名字
# family 后面的是代码后面引用时的名称, 自己随便起
# 需要能访问 Google, 也可以注释掉下面这行, 影响不大
# font_families_google() 列出所有支持的字体, 支持的汉字不多
# http://www.googlefonts.net/
font_add_google(name = "Karantina", family = "ka")
font_add_google(name = "Cutive", family = "albert")
font_add_google(name = "ZCOOL XiaoWei", family = "zxw")
# 后面字体均可以使用导入的字体
showtext_auto()
4. 加载数据
df_input <- readr::read_csv("../data/week10_biketown.csv", show_col_types = FALSE)
# 简要查看数据内容
glimpse(df_input)
## Rows: 523,588
## Columns: 20
## $ ...1
## $ RouteID
## $ PaymentPlan
## $ StartHub
## $ StartLatitude
## $ StartLongitude
## $ StartDate
## $ StartTime
## $ EndHub
## $ EndLatitude
## $ EndLongitude
## $ EndDate
## $ EndTime
## $ TripType
## $ BikeID
## $ BikeName
## $ Distance_Miles
## $ Duration
## $ RentalAccessPath
## $ MultipleRental
# 检查数据的列名
colnames(df_input)
## [1] "...1" "RouteID" "PaymentPlan" "StartHub"
## [5] "StartLatitude" "StartLongitude" "StartDate" "StartTime"
## [9] "EndHub" "EndLatitude" "EndLongitude" "EndDate"
## [13] "EndTime" "TripType" "BikeID" "BikeName"
## [17] "Distance_Miles" "Duration" "RentalAccessPath" "MultipleRental"
5. 数据预处理
# 载入数据, 并对数据日期进行处理
df_trip <- df_input %>%
# filter() 根据条件过滤数据, 过滤掉没有时间记录的观测
filter(StartDate != "", StartTime != "") %>%
# mutate() 主要用于在数据框中添加新的变量, 这些变量是通过对现有的变量进行操作而形成的
dplyr::mutate(StartDate = mdy(StartDate),
# mdy() 将字符串转换成日期时间
EndDate = mdy(EndDate),
# parse_date_time() 日期时间解析函数
Start = parse_date_time(glue("{StartDate} {StartTime}"), "Ymd HMS"),
Hour = parse_factor(as.character(hour(Start)), as.character(c(0, 23:1))),
Weekday = fct_relevel(wday(Start, label = TRUE), c("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")),
Duration = hms::as_hms(round((EndTime - StartTime))))
# 简要查看数据内容
glimpse(df_trip)
## Rows: 519,500
## Columns: 23
## $ ...1
## $ RouteID
## $ PaymentPlan
## $ StartHub
## $ StartLatitude
## $ StartLongitude
## $ StartDate
## $ StartTime
## $ EndHub
## $ EndLatitude
## $ EndLongitude
## $ EndDate
## $ EndTime
## $ TripType
## $ BikeID
## $ BikeName
## $ Distance_Miles
## $ Duration
## $ RentalAccessPath
## $ MultipleRental
## $ Start
## $ Hour
## $ Weekday
6. 利用 ggplot2 绘图
6.1 绘制每周旅游情况热图
df_albert <- df_trip %>%
# count() 根据分组计算观测
count(Weekday, Hour) %>%
# 剔除凌晨 1, 2, 3, 4 时间的观测, 因为这个点为休息时间, 几乎没什么旅行
filter(!Hour %in% c(1, 2, 3, 4))
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
gg <- df_albert %>% ggplot(aes(x = Weekday, y = Hour, fill = n))
gg <- gg + geom_tile()
gg <- gg + scale_x_discrete(position = "top")
gg <- gg + scale_y_discrete(labels = c("12 AM", glue("{c(11:1, 12)} PM"), glue("{11:5} AM")))
gg <- gg + scale_fill_gradient(low = "#00FF7F", high = "#FF0000")
gg <- gg + annotate("segment", y = 21, yend = 21, x = -Inf, xend = Inf, color = "#696969", size = .3)
gg <- gg + annotate("segment", y = 0, yend = 0, x = -Inf, xend = Inf, color = "#696969", size = .3)
# labs() 对图形添加注释和标签（包含标题 title、子标题 subtitle、坐标轴 x & y 和引用 caption 等注释)
gg <- gg + labs(title = "每周中, 每天/小时的行程热图",
subtitle = NULL,
x = NULL,
y = NULL,
caption = "资料来源: Biketown Bikeshare · graph by 数绘小站")
# theme_minimal() 去坐标轴边框的最小化主题
gg <- gg + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
gg <- gg + theme(
# panel.grid.major 主网格线, 这一步表示删除主要网格线
panel.grid.major = element_blank(),
# panel.grid.minor 次网格线, 这一步表示删除次要网格线
panel.grid.minor = element_blank(),
# plot.margin 调整图像边距, 上-右-下-左
plot.margin = margin(2, 1, 2, .5),
# plot.title 主标题
plot.title = element_text(hjust = 0.5, color = "black", size = 20, face = "bold", family = 'zxw'),
# plot.caption 说明文字
plot.caption = element_text(hjust = 0.85, size = 10),
# axis.text 坐标轴刻度文本
axis.text = element_text(size = 8, hjust = 0, face = "bold", family = "albert"),
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = 'none')
gg
6.2 绘制每周旅游情况峦峰图
df_albert <- df_trip %>%
# floor_date() 将时间向前归一化到 10 分钟的整数倍
mutate(floor_week = floor_date(Start, "weeks")) %>%
# count() 根据分组计算观测
count(floor_week, PaymentPlan) %>%
# group_by() 以指定的列进行分组
group_by(floor_week) %>%
# mutate() 主要用于在数据框中添加新的变量, 这些变量是通过对现有的变量进行操作而形成的
dplyr::mutate(Sum = sum(n)) %>%
# filter() 根据条件过滤数据
filter(PaymentPlan %in% "Subscriber")
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
hh <- df_albert %>% ggplot()
hh <- hh + geom_ribbon(aes(x = floor_week, ymin = 0, ymax = Sum), fill = "#123456", color = "#808080")
hh <- hh + geom_ribbon(aes(x = floor_week, ymin = 0, ymax = n), fill = "#FF4500", color = "#808080")
hh <- hh + scale_x_datetime(date_labels = "%b %y",
breaks = seq(as_datetime("2016-08-01"),
as_datetime("2018-02-01"), "6 months"))
hh <- hh + scale_y_continuous(labels = glue("{seq(0, 15, 5)}K"))
# labs() 对图形添加注释和标签（包含标题 title、子标题 subtitle、坐标轴 x & y 和引用 caption 等注释)
hh <- hh + labs(title = "每周中旅行次数峦峰图",
subtitle = NULL,
x = NULL,
y = NULL)
# theme_minimal() 去坐标轴边框的最小化主题
hh <- hh + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
hh <- hh + theme(
# panel.grid.minor 次网格线, 这一步表示删除次要网格线
panel.grid.minor = element_blank(),
# plot.title 主标题
plot.title = element_text(hjust = 0.5, color = "black", size = 20, face = "bold", family = 'zxw'),
# axis.text 坐标轴刻度文本
axis.text = element_text(size = 12, hjust = 0, face = "bold", family = "albert"),
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = 'none')
hh
6.3 添加一些统计信息
df_alt <- df_trip %>%
# select() 选择需要使用的列, 获得旅行的目的地信息
select(EndLongitude, EndHub, EndLatitude) %>%
# drop_na() 去除含有缺失值的观测
drop_na() %>%
# count() 根据分组计算观测, 默认生成`n`, 用于存放计数结果
count(EndHub, EndLatitude, EndLongitude) %>%
# arrange() 根据 change 列进行排序, 默认是升序; arrange + desc() 表示改为降序排列
arrange(desc(n)) %>%
# top_n() 表示选择前多少个观测
top_n(150, n)
# 根据上一步获得数据集, 挑选在其中的值
df_alb <- df_trip %>% filter(EndHub %in% df_alt$EndHub)
ntrip <- nrow(df_alt)
avgTime <- mean(df_alt$Duration, na.rm = TRUE) %>%
as.duration() %>% as.numeric("minutes") %>% round()
# 生成文本框所需要的数据
DF <- data.frame(x = c(0, 1.1),
xend = c(1, 2.1),
y = c(0, 0),
yend = c(1, 1)/2,
txt = c(paste0("行程次数\n", ntrip), paste0("行程平均持续时间\n", avgTime, " 分钟")))
# PS: 方便讲解, 我这里进行了拆解, 具体使用时可以组合在一起
ii <- ggplot()
ii <- ii + geom_rect(DF, mapping = aes(xmin = x, xmax = xend, ymin = y, ymax = yend),
fill = "#FFFFFF", color = "#000000", alpha = 0.5)
ii <- ii + geom_text(DF, mapping = aes(x = (x + xend)/2, y = (y + yend)/2, label = txt), size = 4)
ii <- ii + coord_fixed()
ii <- ii + theme_void()
ii
6.4 绘制旅行目的地图
# 查看目的地经纬度信息
range(df_alt$EndLatitude)
## [1] 45.49429 45.56283
range(df_alt$EndLongitude)
## [1] -122.7007 -122.6232
top <- mean(df_alt$EndLatitude) + 0.05
bottom <- mean(df_alt$EndLatitude) - 0.05
left <- mean(df_alt$EndLongitude) - 0.1
right <- mean(df_alt$EndLongitude) + 0.1
# 根据经纬度获取地图
portland <- ggmap::get_map(location = c(top = top, bottom = bottom, left = left, right = right))
# https://stackoverflow.com/q/31316076/9421451
# ggmap() 实现地图背景的绘制
jj <- ggmap(portland)
# geom_point() 绘制散点图
jj <- jj + geom_point(data = df_alt, aes(x = EndLongitude, y = EndLatitude, size = n),
color = "white", fill = "#f94d1f", shape = 21)
# scale_x_continuous() 对连续变量设置坐标轴显示范围
jj <- jj + scale_x_continuous(limits = c(left + 0.04, right - 0.08))
# scale_y_continuous() 对连续变量设置坐标轴显示范围
jj <- jj + scale_y_continuous(limits = c(bottom + 0.00005, top - 0.00005))
# labs() 对图形添加注释和标签（包含标题 title、子标题 subtitle、坐标轴 x & y 和引用 caption 等注释)
jj <- jj + labs(title = "旅程目的地")
# theme_minimal() 白色背景和浅灰色网格线, 无边框
jj <- jj + theme_minimal()
# theme() 实现对非数据元素的调整, 对结果进行进一步渲染, 使之更加美观
jj <- jj + theme(
# axis.text 坐标轴刻度文本
axis.text = element_blank(),
# axis.title 坐标轴标题
axis.title = element_blank(),
# legend.position 设置图例位置, "none" 表示不显示图例
legend.position = "none",
# plot.title 主标题
plot.title = element_text(family = "zxw", size = 20, face = "bold"),
# plot.margin 调整图像边距, 上-右-下-左
plot.margin = margin(.5, 0, 0, 0, "cm"))
jj
7. 保存图片到 PDF 和 PNG
jj + (hh + ii + gg + plot_layout(ncol = 1, heights = c (6, 4, 12))) + plot_layout(ncol = 2)
filename = '20180605-A-01'
ggsave(filename = paste0(filename, ".pdf"), width = 10.2, height = 9.2, device = cairo_pdf)
ggsave(filename = paste0(filename, ".png"), width = 10.2, height = 9.2, dpi = 100, device = "png", bg = 'white')
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 patchwork_1.1.2
## [5] lubridate_1.8.0 forcats_0.5.2 stringr_1.4.1 dplyr_1.0.10
## [9] purrr_0.3.4 readr_2.1.2 tidyr_1.2.1 tibble_3.1.8
## [13] tidyverse_1.3.2 Hmisc_4.7-1 Formula_1.2-4 survival_3.4-0
## [17] lattice_0.20-45 ggmap_3.0.0 ggplot2_3.3.6 glue_1.6.2
##
## loaded via a namespace (and not attached):
## [1] bitops_1.0-7 fs_1.5.2 bit64_4.0.5
## [4] RColorBrewer_1.1-3 httr_1.4.4 tools_4.2.1
## [7] backports_1.4.1 bslib_0.4.0 utf8_1.2.2
## [10] R6_2.5.1 rpart_4.1.16 DBI_1.1.3
## [13] colorspace_2.0-3 nnet_7.3-17 withr_2.5.0
## [16] sp_1.5-0 tidyselect_1.1.2 gridExtra_2.3
## [19] bit_4.0.4 curl_4.3.2 compiler_4.2.1
## [22] textshaping_0.3.6 cli_3.4.1 rvest_1.0.3
## [25] htmlTable_2.4.1 xml2_1.3.3 labeling_0.4.2
## [28] sass_0.4.2 scales_1.2.1 checkmate_2.1.0
## [31] systemfonts_1.0.4 digest_0.6.29 foreign_0.8-82
## [34] rmarkdown_2.16 base64enc_0.1-3 jpeg_0.1-9
## [37] pkgconfig_2.0.3 htmltools_0.5.3 highr_0.9
## [40] dbplyr_2.2.1 fastmap_1.1.0 htmlwidgets_1.5.4.9000
## [43] rlang_1.0.6 readxl_1.4.1 rstudioapi_0.14
## [46] farver_2.1.1 jquerylib_0.1.4 generics_0.1.3
## [49] jsonlite_1.8.2 vroom_1.5.7 googlesheets4_1.0.1
## [52] magrittr_2.0.3 interp_1.1-3 Matrix_1.5-1
## [55] Rcpp_1.0.9 munsell_0.5.0 fansi_1.0.3
## [58] lifecycle_1.0.3 stringi_1.7.8 yaml_2.3.5
## [61] plyr_1.8.7 grid_4.2.1 parallel_4.2.1
## [64] crayon_1.5.1 deldir_1.0-6 haven_2.5.1
## [67] splines_4.2.1 hms_1.1.2 knitr_1.40
## [70] pillar_1.8.1 rjson_0.2.21 reprex_2.0.2
## [73] evaluate_0.16 latticeExtra_0.6-30 data.table_1.14.2
## [76] modelr_0.1.9 png_0.1-7 vctrs_0.4.2
## [79] tzdb_0.3.0 RgoogleMaps_1.4.5.3 cellranger_1.1.0
## [82] gtable_0.3.1 assertthat_0.2.1 cachem_1.0.6
## [85] xfun_0.32 broom_1.0.1 ragg_1.2.3
## [88] googledrive_2.0.0 gargle_1.2.1 cluster_2.1.4
## [91] ellipsis_0.3.2
测试数据
配套数据下载：Biketown Bikeshare
精彩链接
您阅读本篇文章共花了：
发表评论