R 语言绘图展示欧洲各国领导人在任时间

上次我们使用 Stata 绘制一幅图展示欧洲各国领导人的在任时间，今天我们使用 R 语言试试。

首先我们可以使用 hablar::set_wd_to_script_path() 函数把工作目录切换到我们的 R 脚本所在的文件夹里面。

# 设置本脚本文件所在的文件夹为工作目录
hablar::set_wd_to_script_path()

加载所需的 R 包：

library(tidyverse)
library(lubridate)
# devtools::install_github("coolbutuseless/ggblur")
library(ggblur)
library(ggtext)
library(hrbrthemes)

# 生成不重叠的文本
# remotes::install_github("hms-dbmi/repel")
library(repel)

其中 ggnlur 包用于生成带有昏影的散点图，repel 包用于生成互不重叠的文本标签坐标。

然后我们设置字体：

# 设置字体
library(showtext)
showtext_auto(enable = TRUE)
font_add("songti",
         regular = "song.otf",
         bold = "思源宋体.otf",
         italic = "腾祥嘉丽超细圆简.ttf")
cnfont <- "songti"

这些字体文件都在附件中。

读取数据：

read_tsv("data.tsv") -> df
df %>%
  mutate(eindate = startdate,
         eoutdate = if_else(is.na(enddate), ymd("2022-1-13"), enddate)) %>%
  select(leader, eindate, eoutdate) %>%
  mutate(gap = as.numeric((eoutdate - eindate) / 365)) %>%
  mutate(x0 = eindate,
         y0 = 0,
         x1 = eoutdate,
         y1 = gap) -> df
df
#> # A tibble: 382 × 8
#>    leader   eindate    eoutdate     gap x0            y0 x1            y1
#>    <chr>    <date>     <date>     <dbl> <date>     <dbl> <date>     <dbl>
#>  1 Thatcher 1979-05-04 1990-11-28 11.6  1979-05-04     0 1990-11-28 11.6
#>  2 Major    1990-11-28 1997-05-02  6.43 1990-11-28     0 1997-05-02  6.43
#>  3 Blair    1997-05-02 2007-06-27 10.2  1997-05-02     0 2007-06-27 10.2
#>  4 Brown    2007-06-27 2010-05-11  2.87 2007-06-27     0 2010-05-11  2.87
#>  5 Cameron  2010-05-11 2016-07-13  6.18 2010-05-11     0 2016-07-13  6.18
#>  6 May      2016-07-13 2019-07-24  3.03 2016-07-13     0 2019-07-24  3.03
#>  7 Johnson  2019-07-24 2022-01-13  2.48 2019-07-24     0 2022-01-13  2.48
#>  8 Haughey  1987-03-10 1992-02-11  4.93 1987-03-10     0 1992-02-11  4.93
#>  9 Reynolds 1992-02-11 1994-12-15  2.84 1992-02-11     0 1994-12-15  2.84
#> 10 Bruton   1994-12-15 1997-06-26  2.53 1994-12-15     0 1997-06-26  2.53
#> # … with 372 more rows

这里的 x0、y0、x1 和 y1 就是每个领导人在任时间线的起点和终点。

生成标签：

df %>%
  mutate(year0 = as.character(year(eindate)),
         year1 = as.character(year(eoutdate))) %>%
  mutate(year1 = if_else(eoutdate == ymd("2022-1-13"), "至今", year1)) %>%
  mutate(label = glue::glue("<b style='font-size:12pt;'>{leader}</b><br><span style='font-size:8pt;'>({year0}–{year1})</span><br><i style='color:#646464;font-size:8pt;'>")) -> df

不过如果把所有的标签都标在图上，会非常拥挤，我们可以使用 repel 包计算选择部分标签：

# 生成标签不重叠的文本
df %>%
  select(x1, y1, leader) %>%
  set_names(c("x", "y", "label")) %>%
  mutate(x = as.numeric(x)) %>%
  repel_text(max.overlaps = 1) %>%
  as_tibble() %>%
  select(-label) %>%
  mutate(x = lubridate::as_date(x)) %>%
  bind_cols(df) %>%
  dplyr::filter(too_many_overlaps == F) %>%
  mutate(label = str_replace_all(label, "ğ", "g")) -> df_text
df_text
#> # A tibble: 27 × 14
#>    x              y too_many_overlaps leader    eindate    eoutdate     gap
#>    <date>     <dbl> <lgl>             <chr>     <date>     <date>     <dbl>
#>  1 1990-08-10  11.4 FALSE             Thatcher  1979-05-04 1990-11-28  11.6
#>  2 2008-05-19  10.9 FALSE             Ahern     1997-06-26 2008-05-07  10.9
#>  3 1994-10-22  11.7 FALSE             Lubbers   1982-11-04 1994-08-22  11.8
#>  4 2022-01-12  11.1 FALSE             Rutte     2010-10-14 2022-01-13  11.3
#>  5 1992-01-31  10.2 FALSE             Martens   1981-12-17 1992-03-07  10.2
#>  6 2013-12-03  18.9 FALSE             Juncker   1995-01-20 2013-12-04  18.9
#>  7 1995-04-11  14.1 FALSE             Mitterand 1981-05-21 1995-05-17  14.0
#>  8 2007-05-16  12.0 FALSE             Chirac    1995-05-17 2007-05-16  12.0
#>  9 1996-07-10  13.3 FALSE             Marquez   1982-12-02 1996-05-05  13.4
#> 10 2016-03-27  10.1 FALSE             Silva     2006-03-09 2016-03-09  10.0
#> # … with 17 more rows, and 7 more variables: x0 <date>, y0 <dbl>, x1 <date>,
#> #   y1 <dbl>, year0 <chr>, year1 <chr>, label <chr>

由于 ggplot2 的 x 轴标签不支持渐变色效果，所以我们等下使用标签图层绘制一个，这里先准备好数据：

tibble(
  x = paste0(seq(1982, 2022, by = 5), "-01-01") %>% ymd(),
  y = rep(-1, 9),
  label = seq(1982, 2022, by = 5)
) -> df_labs
df_labs

#> # A tibble: 9 × 3
#>   x              y label
#>   <date>     <dbl> <dbl>
#> 1 1982-01-01    -1  1982
#> 2 1987-01-01    -1  1987
#> 3 1992-01-01    -1  1992
#> 4 1997-01-01    -1  1997
#> 5 2002-01-01    -1  2002
#> 6 2007-01-01    -1  2007
#> 7 2012-01-01    -1  2012
#> 8 2017-01-01    -1  2017
#> 9 2022-01-01    -1  2022

另外 ggplot2 的 x 轴也不支持渐变色的效果，所以我们可以使用一个散点图层绘制：

tibble(
  x = ymd("1979-01-01") + 1:16000,
  y = rep(0, 16000)
) -> df_points

由于复杂的图表通常会反复使用同种属性的映射，所以还需要使用 ggnewscale 包：

library(ggnewscale)

然后就可以画图了：

df %>%
  ggplot() +
  geom_segment(aes(x = x0, y = y0, xend = x1, yend = y1,
                   color = gap),
               size = 0.1) +
  geom_point_blur(aes(x = x1, y = y1,
                      color = gap, size = gap)) +
  geom_point(aes(x = x1, y = y1,
                 color = gap, size = gap)) +
  geom_richtext(
    data = df_text,
    aes(x = x - 500, y = y - 1,
        label = label, color = gap),
    fill = NA,
    family = cnfont,
    label.color = NA,
    vjust = 0.85, hjust = 0
  ) +
  scale_color_gradientn(colors = viridis::cividis(100, begin = 0.1),
                        guide = "none") +
  scale_fill_gradientn(colors = viridis::cividis(100, begin = 0.1),
                       guide = "none") +
  scale_blur_size_continuous(range = c(1, 15),
                             guide = "none") +
  scale_size(range = c(.001, 2),
             guide = "none") +
  scale_alpha(range = c(.33, 1),
              guide = "none") +
  new_scale_color() +
  geom_richtext(data = df_labs, aes(x, y + 0.5, label = label,color = x),
                size = 3, family = cnfont,
                fill = NA, label.color = NA, vjust = 0.85) +
  geom_text(data = df_labs, aes(x, y + 1, color = x), label = "|",
            size = 2, family = cnfont, vjust = 1) +
  geom_point(data = df_points, aes(x, y, color = x), size = 0.001,
             shape = 20) +
  scale_color_gradientn(colors = viridis::cividis(100, begin = 0.5),
                        guide = "none") +
  geom_textbox(
    data = tibble(
      x = ymd("1983-01-01"), y = 17,
      label = "<span style='font-size:20pt;line-height:2pt;'>欧洲各国领导人的在任时间</span><br><i>数据来源：Archigos database
& New York Times<br>绘制：微信公众号 RStata<br><br>图中展示了 1979 年以来欧洲各国 382 位领导人的上任、<br>卸任时间以及在任时长，其中卢卡申科（Lukashenko）在<br>任时间最长，从 1994 年上台以来，他已经担任了将近 28<br>年的白俄罗斯总统；普京（Puting）在任时长仅次于卢卡申<br>科，其于 1999 年上任，至今已经担任了超过 22 年的俄<br>罗斯总统。也有很多在任时长非常短的总统，例如博鲁塞维<br>奇（Borusewicz）他仅仅在 2020 年 7 月 8 日这天当了<br>一天的波兰领导人。</i>"
    ),
    aes(x, y, label = label),
    inherit.aes = F,
    family = cnfont, color = "grey70",
    lineheight = 1.7, width = unit(6.2, "inch"),
    hjust = .2, vjust = 0,
    fill = NA, box.colour = NA
  ) +
  theme_ipsum(base_family = cnfont, grid = F) +
  theme(
    plot.background = element_rect(fill = "black"),
    plot.caption = element_text(family = cnfont, color = "grey50",
                                size = 18,  hjust = .5, lineheight = 1.1,
                                margin = margin(t = 90)),
    plot.caption.position = "plot",
    axis.text.y = element_blank(),
    axis.text.x = element_blank()
  )

ggsave("leader.pdf", device = cairo_pdf, width = 10, height = 10)
ggsave("leader.png", device = png, width = 10, height = 10)

点击这里跳转到 RStata 短书平台获取附件：R 语言绘图展示欧洲各国领导人在任时间