画一幅更好看的杠铃图！

关注公众号，发送R语言，获取学习资料！

     Try to learn everything about something! 

今天学习一幅比较复杂的条形图（或者叫 杠铃图/哑铃图/dumbbell chart）的画法。

这种图形之前的推文中也模仿过，点击链接查看：

R语言画dumbbell chart

不过之前的比较简单，而且是用bbplot中的geom_dumbbell函数直接完成的，今天学习一个复杂的，直接用ggplot2手撸！

使用的数据也是前几天的erasmus数据，想要数据的小伙伴直接公众号后台回复20220317即可获得。

这个erasmus是欧盟的一个交换生项目，有兴趣的小伙伴可以自己了解下。

“

为了促进欧洲高等教育改革，欧盟委员会于2003年提出一个称为Erasmus Mundus的高等教育项目计划。该项目计划于2003年经欧洲议会和欧洲理事会批准通过。Erasmus Mundus 项目计划定位在“硕士”层次的高等教育交流，通过建立100个跨大学的“欧洲硕士专业”点和提供近上万个奖学金和访问学者名额的方法，吸引更多外国教师和学生在欧洲的大学学习，加强欧盟成员国大学之间的学术联系，提高欧洲高等教育的质量和竞争力，扩大欧洲高等教育在世界上的影响。该项目既面向欧洲学生，也面向第三国(欧洲以外)的留学生和访问学者。

这个数据主要是记录了最近几年这个项目的一些数据，比如哪些国家、每个国家每年派出去多少学生、每年接收多少学生等。

前几天使用这个数据画了一幅网络图，今天用另一种方式展示这个数据。

我们想看一下从2014-2015年间，到2019-2020年间，每个国家接收/派出的学生数量是增加还是减少？具体数量是多少？

加载数据和R包

library(tidyverse)
## -- Attaching packages ----------------------------- tidyverse 1.3.1 --
## v ggplot2 3.3.5     v purrr   0.3.4
## v tibble  3.1.6     v dplyr   1.0.8
## v tidyr   1.2.0     v stringr 1.4.0
## v readr   2.0.1     v forcats 0.5.1
## -- Conflicts -------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
library(ggplot2)
library(countrycode)

load(file = "erasmus.Rdata")
# readRDS("erasmus.rds")

简单查看下数据情况

dim(erasmus) # 164635行，24列，数据很大，转为csv会乱码
## [1] 164635     24

glimpse(erasmus)
## Rows: 164,635
## Columns: 24
## $ project_reference                   <chr> "2014-1-AT02-KA347-000139", "2014-~
## $ academic_year                       <chr> "2014-2015", "2014-2015", "2014-20~
## $ mobility_start_month                <chr> "2014-11", "2014-11", "2014-11", "~
## $ mobility_end_month                  <chr> "2014-11", "2014-11", "2014-11", "~
## $ mobility_duration                   <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1~
## $ activity_mob                        <chr> "National youth meetings", "Nation~
## $ field_of_education                  <chr> "? Unknown ?", "? Unknown ?", "? U~
## $ participant_nationality             <chr> "AT", "AT", "AT", "AT", "AT", "AT"~
## $ education_level                     <chr> "??? - ? Unknown ?", "??? - ? Unkn~
## $ participant_gender                  <chr> "Female", "Female", "Female", "Mal~
## $ participant_profile                 <chr> "Learner", "Learner", "Learner", "~
## $ special_needs                       <chr> "No", "No", "No", "No", "No", "No"~
## $ fewer_opportunities                 <chr> "Yes", "Yes", "Yes", "Yes", "Yes",~
## $ group_leader                        <chr> "No", "No", "No", "No", "No", "No"~
## $ participant_age                     <dbl> 13, 14, 15, 14, 15, 15, 16, 17, 18~
## $ sending_country_code                <chr> "AT", "AT", "AT", "AT", "AT", "AT"~
## $ sending_city                        <chr> "Dornbirn", "Dornbirn", "Dornbirn"~
## $ sending_organization                <chr> "bOJA - Bundesweites Netzwerk Offe~
## $ sending_organisation_erasmus_code   <chr> "-", "-", "-", "-", "-", "-", "-",~
## $ receiving_country_code              <chr> "AT", "AT", "AT", "AT", "AT", "AT"~
## $ receiving_city                      <chr> "Dornbirn", "Dornbirn", "Dornbirn"~
## $ receiving_organization              <chr> "bOJA - Bundesweites Netzwerk Offe~
## $ receiving_organisation_erasmus_code <chr> "-", "-", "-", "-", "-", "-", "-",~
## $ participants                        <dbl> 2, 3, 3, 4, 2, 2, 1, 3, 1, 2, 1, 2~

数据处理

我们需要分别计算2014-2015年、2019年-2020年，每个国家派出了多少学生，接受了多少学生。

# 先计算2019-2020年间的

# 计算派出的数量
sending_2020 <- erasmus %>% 
  filter(academic_year == "2019-2020") %>% 
  select(sending_country_code, academic_year) %>% 
  group_by(sending_country_code, academic_year) %>% 
  rename(country = sending_country_code) %>% 
  summarise(sending=n()) %>% 
  ungroup()
## `summarise()` has grouped output by 'country'. You can override using
## the `.groups` argument.

# 计算接收的数量
receiving_2020 <- erasmus %>% 
  filter(academic_year == "2019-2020") %>% 
  select(receiving_country_code, academic_year) %>% 
  group_by(receiving_country_code, academic_year) %>% 
  rename(country = receiving_country_code) %>% 
  summarise(receiving=n()) %>% 
  ungroup()
## `summarise()` has grouped output by 'country'. You can override using
## the `.groups` argument.

# 合并数据
data_2020 <- inner_join(sending_2020, receiving_2020) %>% 
  mutate(total_2020=sending+receiving) %>% 
  select(country, total_2020)
## Joining, by = c("country", "academic_year")

# 再计算2014-2015年间的

# 计算派出的数量
sending_2014 <- erasmus %>% 
  filter(academic_year == "2014-2015") %>% 
  select(sending_country_code, academic_year) %>% 
  group_by(sending_country_code, academic_year) %>% 
  rename(country = sending_country_code) %>% 
  summarise(sending=n()) %>% 
  ungroup()
## `summarise()` has grouped output by 'country'. You can override using
## the `.groups` argument.

# 计算接收的数量
receiving_2014 <- erasmus %>% 
  filter(academic_year == "2014-2015") %>% 
  select(receiving_country_code, academic_year) %>% 
  group_by(receiving_country_code, academic_year) %>% 
  rename(country = receiving_country_code) %>% 
  summarise(receiving=n()) %>% 
  ungroup()
## `summarise()` has grouped output by 'country'. You can override using
## the `.groups` argument.

# 合并数据
data_2014 <- inner_join(sending_2014, receiving_2014) %>% 
  mutate(total_2014=sending+receiving) %>% 
  select(country, total_2014)
## Joining, by = c("country", "academic_year")

# 把2个年间的数据合并
data_final<-inner_join(data_2014, data_2020, by='country') %>% 
  drop_na()

# 把国家代码变成国家名字，使用countrycode这个神奇R包
data_final <- data_final %>% 
  mutate(countryName = countrycode(data_final$country, origin='iso2c', destination = 'country.name')) %>% 
  
  # EL和UK手动转换一下
  mutate(countryName = replace(countryName, country=='EL', 'Greece')) %>% 
  mutate(countryName = replace(countryName, country=='UK', 'United Kingdom'))

这样我们需要的数据基本就搞定了，接下来再计算一下总数、差数以及增加一个颜色映射列。

data_final <- data_final %>% 
  mutate(diff = total_2020 - total_2014) %>% 
  mutate(balance_category =
           case_when(diff >= 0 ~ "Positive",
                     diff < 0 ~ "Negative")) %>% 
  mutate(sum_total = total_2014 + total_2020)

data_final
## # A tibble: 27 x 7
##    country total_2014 total_2020 countryName  diff balance_category sum_total
##    <chr>        <int>      <int> <chr>       <int> <chr>                <int>
##  1 AT             175       1579 Austria      1404 Positive              1754
##  2 BG             287       1287 Bulgaria     1000 Positive              1574
##  3 CY              44        710 Cyprus        666 Positive               754
##  4 CZ             234       1105 Czechia       871 Positive              1339
##  5 DE            1227       6170 Germany      4943 Positive              7397
##  6 DK              36        278 Denmark       242 Positive               314
##  7 EE             631       1356 Estonia       725 Positive              1987
##  8 EL             139       1219 Greece       1080 Positive              1358
##  9 ES             613       4977 Spain        4364 Positive              5590
## 10 FR            1377       4720 France       3343 Positive              6097
## # ... with 17 more rows

画图

有了数据，画图不过就是使用正确的元素进行叠加图层，再调整一下细节。

不过这幅图确实细节很多，值的好好学习！

plot <- ggplot(data_final, 
               aes(y = reorder(countryName, sum_total), color=balance_category))+
  
  # 画线，加粗，变颜色，这部分是灰色背景线
  geom_segment(aes(x = -800, xend = total_2020, yend = countryName), 
               size = 5, 
               color = "grey70", 
               alpha = 0.5)+ 
  
  # 淡蓝色线条
  geom_segment(aes(x = total_2020, xend = total_2014, yend = countryName), 
               size = 5, 
               alpha =0.6)+
  
  # 两边加点
  geom_point(aes(x = total_2020), size = 4.5, alpha = 1)+
  geom_point(aes(x = total_2014), size = 4.5, alpha = 1)+
  
  xlim(-800, 7000)+
  
  # 打标签，这一步非常重要，后面再去掉纵坐标！
  geom_text(aes(label = countryName), x = -800, hjust = 0, size = 3.5, fontface = "bold")+
  
  scale_color_manual(values = c("firebrick2", "steelblue4"), guide = "none")+
  
  # 加点注释
  labs(title = "ERASMUS项目参与人数明显上升",
       subtitle = "2020年与2014年相比，大多数欧洲国家都派出/接收了更多的学生",
       x = "派出或接收的学生数量",
       caption = "数据来源: Data.Europe\n这幅图展示了2014-2015学年到2019-2020学年ERASMUS项目中每个国家派出/接收的学生数量",
       y=NULL)+
  
  # 自定义图例
  geom_rect(xmax = 5800, ymax = 8, xmin = 3600, ymin = 4, alpha = 0.1, fill = "aliceblue", color = "steelblue4")+
  geom_point(x = 4130, y = 7, size = 4.5, color = "steelblue4")+
  geom_point(x = 4130, y = 6, size = 4.5, color = "firebrick2")+
  geom_text(x = 4200, y = 7, label = "Increase", color = "steelblue4", hjust = 0, size = 3.5, fontface = "bold")+
  geom_text(x = 4200, y = 6, label = "Decreaset", color = "firebrick2", hjust = 0, size = 3.5, fontface = "bold")+
  geom_point(x = 3930, y = 5, size = 4.5, color = "grey30")+
  geom_point(x = 4120, y = 5, size = 4.5, color = "grey30")+
  geom_segment(x = 4120, xend = 3930, y = 5, yend = 5, color = "grey30", size = 5)+
  geom_text(label = "Change from 2014 to 2020 ", y = 5, x = 4200, hjust = 0, color = "grey30")+
  
  # 细节调整
  theme(
    panel.background = element_rect(fill = "aliceblue"),
    plot.background = element_rect(fill = "aliceblue"),
    panel.grid = element_blank(),
    panel.grid.major.x = element_line(color = "steelblue2", linetype = "dashed"),
    
    plot.title = element_text(size = 20, hjust = 0, color = "steelblue4", face = "bold"),
    plot.subtitle = element_text(size = 14, color = "firebrick4", hjust = 0),
    plot.caption = element_text(color = "firebrick4", hjust=0),
    
    axis.line.x = element_line(color = "steelblue2", size = 0.5),
    axis.text = element_text(size = 10, color = "steelblue4", face = "bold"),
    axis.title = element_text(color = "steelblue4", face = "bold"),
    axis.line.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y= element_blank(),
    axis.ticks.x = element_blank())

ggsave("1.jpg", plot = plot, heigh=8, width = 12, unit='in')

大功告成，出图如下：

这样一幅图是不是感觉非常高大上呢！

以上就是今天的内容，希望对你有帮助哦！欢迎点赞、在看、关注、转发！

欢迎在评论区留言或直接添加我的微信！

完

欢迎关注公众号：医学和生信笔记

“

医学和生信笔记 公众号主要分享：1.医学小知识、肛肠科小知识；2.R语言和Python相关的数据分析、可视化、机器学习等；3.生物信息学学习资料和自己的学习笔记！

往期回顾