所有作品合集传送门： 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             <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16…
## $ RouteID          <dbl> 1282087, 1282113, 1282118, 1282120, 1282123, 1282125,…
## $ PaymentPlan      <chr> "Casual", "Subscriber", "Subscriber", "Subscriber", "…
## $ StartHub         <chr> "NE Sandy at 16th", NA, "NW Kearney at 23rd", NA, NA,…
## $ StartLatitude    <dbl> 45.52441, 45.53150, 45.52914, 45.50248, NA, 45.50469,…
## $ StartLongitude   <dbl> -122.6498, -122.6597, -122.6987, -122.6723, NA, -122.…
## $ StartDate        <chr> "7/19/2016", "7/19/2016", "7/19/2016", "7/19/2016", "…
## $ StartTime        <time> 10:22:00, 10:28:00, 10:30:00, 10:31:00, 10:32:00, 10…
## $ EndHub           <chr> NA, NA, "SW 5th at Oak", "SE 2nd Pl at Tilikum Way", …
## $ EndLatitude      <dbl> 45.53506, 45.50248, 45.52117, 45.50624, NA, 45.52117,…
## $ EndLongitude     <dbl> -122.6546, -122.6723, -122.6764, -122.6633, NA, -122.…
## $ EndDate          <chr> "7/19/2016", "7/19/2016", "7/19/2016", "7/19/2016", "…
## $ EndTime          <time> 10:48:00, 10:47:00, 12:37:00, 10:37:00, 10:37:00, 11…
## $ TripType         <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ BikeID           <dbl> 6083, 6238, 7271, 6875, 7160, 6590, 6582, 6534, 6573,…
## $ BikeName         <chr> "0468 BIKETOWN", "0774 BIKETOWN", "0359 BIKETOWN", "0…
## $ Distance_Miles   <dbl> 1.19, 2.95, 13.46, 0.53, 0.00, 3.35, 3.35, 1.22, 1.48…
## $ Duration         <chr> "00:25:46", "00:18:44", "02:06:19", "00:05:21", "00:0…
## $ RentalAccessPath <chr> "keypad", "mobile", "mobile", "keypad", "keypad", "ke…
## $ MultipleRental   <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALS…

# 检查数据的列名
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             <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16…
## $ RouteID          <dbl> 1282087, 1282113, 1282118, 1282120, 1282123, 1282125,…
## $ PaymentPlan      <chr> "Casual", "Subscriber", "Subscriber", "Subscriber", "…
## $ StartHub         <chr> "NE Sandy at 16th", NA, "NW Kearney at 23rd", NA, NA,…
## $ StartLatitude    <dbl> 45.52441, 45.53150, 45.52914, 45.50248, NA, 45.50469,…
## $ StartLongitude   <dbl> -122.6498, -122.6597, -122.6987, -122.6723, NA, -122.…
## $ StartDate        <date> 2016-07-19, 2016-07-19, 2016-07-19, 2016-07-19, 2016…
## $ StartTime        <time> 10:22:00, 10:28:00, 10:30:00, 10:31:00, 10:32:00, 10…
## $ EndHub           <chr> NA, NA, "SW 5th at Oak", "SE 2nd Pl at Tilikum Way", …
## $ EndLatitude      <dbl> 45.53506, 45.50248, 45.52117, 45.50624, NA, 45.52117,…
## $ EndLongitude     <dbl> -122.6546, -122.6723, -122.6764, -122.6633, NA, -122.…
## $ EndDate          <date> 2016-07-19, 2016-07-19, 2016-07-19, 2016-07-19, 2016…
## $ EndTime          <time> 10:48:00, 10:47:00, 12:37:00, 10:37:00, 10:37:00, 11…
## $ TripType         <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ BikeID           <dbl> 6083, 6238, 7271, 6875, 7160, 6590, 6582, 6534, 6573,…
## $ BikeName         <chr> "0468 BIKETOWN", "0774 BIKETOWN", "0359 BIKETOWN", "0…
## $ Distance_Miles   <dbl> 1.19, 2.95, 13.46, 0.53, 0.00, 3.35, 3.35, 1.22, 1.48…
## $ Duration         <time> 00:26:00, 00:19:00, 02:07:00, 00:06:00, 00:05:00, 00…
## $ RentalAccessPath <chr> "keypad", "mobile", "mobile", "keypad", "keypad", "ke…
## $ MultipleRental   <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALS…
## $ Start            <dttm> 2016-07-19 10:22:00, 2016-07-19 10:28:00, 2016-07-19…
## $ Hour             <fct> 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 1…
## $ Weekday          <ord> Tue, Tue, Tue, Tue, Tue, Tue, Tue, Tue, Tue, Tue, Tue…

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