提供了编程的基础技术教程

zl程序教程

您现在的位置是：首页 >  其他

当前栏目

R语言ggplot2做漂亮的抖动散点图（geom_jitter）的一个实例

语言 数据
2023-04-18 14:55:02 时间

在网上偶然间发现的一个R语言ggplot2做数据可视化的实例，提供数据和代码，今天的推文把代码拆解一下

实例数据下载链接

https://www.kaggle.com/berkeleyearth/climate-change-earth-surface-temperature-data?select=GlobalLandTemperaturesByCountry.csv

下载这个数据需要注册kaggle

代码链接

https://github.com/cnicault/30DayChartChallenge/blob/main/day12/day12_strips.Rmd

结果图

image.png

这个图展示的是法国1980年前后的温度差异，数据里提供很多个国家的数据，可以自己更改成其他国家的数据试试

首先是读取数据

这里接触了两个新的R包

  • vroom
  • here
climate <- vroom::vroom(here::here("GlobalLandTemperaturesByCountry.csv"))

关于lubridate包中的函数的一些用法 

lubridate::year("1743-11-01")
lubridate::month("1743-11-01")
lubridate::month("1743-11-01",label = T)
lubridate::month("1743-11-01",label = F)
lubridate::day("1743-11-01")

构建作图的数据集 

library(tidyverse)
monthly <- climate %>%
  filter(Country == "France", !is.na(AverageTemperature)) %>%
  mutate(year = lubridate::year(dt),
         month = lubridate::month(dt, label = TRUE),
         pos = lubridate::month(dt, label = FALSE),
         color = ifelse(year > 1980, "Recent", "Past")) %>%
  filter(year >=1900)

他这里先做了一个空白的热图

注释里写的是为了得到一个矩形的图例

library(ggplot2)
ggplot() +
  # empty tile to get a legend with rectangle key
  geom_tile(data = monthly, 
            aes(x = 0, y =0, width =0, 
                height = 0, fill = color))

image.png

接下来是添加线段 

seg <- tibble(x = c(0, 0, 10, 0, 9, 3, 8, 5, 6),
              xend = c(12.5, 3, 12.5, 5, 12.5, 6, 11, 10, 8),
              y = c(0, 5, 5, 10, 10, 15, 15, 20, 25),
              yend = c(0, 5, 5, 10, 10, 15, 15, 20, 25))

ggplot() +
  # empty tile to get a legend with rectangle key
  geom_tile(data = monthly, 
            aes(x = 0, y =0, 
                width =0, 
                height = 0, 
                fill = color)) +
  # y-axis
  geom_segment(data = seg, 
               aes(x = x, xend = xend,
                   y = y, yend = yend), 
               color = "red", 
               linetype = "12")

image.png

添加文本注释 

seg_lab <- tibble(x = c(0, 0, 0, 3, 5, 6),
                  y = seq(0,25, 5))
ggplot() +
  # empty tile to get a legend with rectangle key
  geom_tile(data = monthly, 
            aes(x = 0, y =0, 
                width =0, 
                height = 0, 
                fill = color)) +
  # y-axis
  geom_segment(data = seg, 
               aes(x = x, xend = xend,
                   y = y, yend = yend), 
               color = "black", linetype = "12") +
  geom_text(data = seg_lab, aes(x = x, y = y, 
                                label = glue::glue("{y} °C")), 
            color = "black", nudge_y = 1, 
            family = "serif", hjust = 0)

image.png

添加抖动的散点 

ggplot() +
  # empty tile to get a legend with rectangle key
  geom_tile(data = monthly, 
            aes(x = 0, y =0, 
                width =0, 
                height = 0, 
                fill = color)) +
  # y-axis
  geom_segment(data = seg, 
               aes(x = x, xend = xend, 
                   y = y, yend = yend), 
               color = "white", 
               linetype = "12") +
  geom_text(data = seg_lab, 
            aes(x = x, y = y, 
                label = glue::glue("{y} °C")), 
            color = "white", nudge_y = 1, 
            family = "serif", hjust = 0) +
  # show.legend = FALSE to remove the shape of the point in the legend
  geom_jitter(data = filter(monthly, color == "Recent"), 
              aes(x = pos+0.2, y = AverageTemperature, 
                  fill = color), width = 0.15,
              height =0, size = 3, shape = 21, 
              stroke = 0.3, color = "#FFDADC", 
              show.legend = FALSE) +
  geom_jitter(data = filter(monthly, color == "Past"), 
              aes(x = pos-0.2, y = AverageTemperature, 
                  fill = color), width = 0.15,
              height =0, size = 2.5, shape = 21, 
              stroke = 0.3, color = "#93E2F5", 
              show.legend = FALSE)

image.png

接下来就是对细节的调整了 

axis_labels <- tibble(month = lubridate::month(seq(1,12,1), 
                                               label = TRUE),
                      pos = seq(1,12,1))



txt_clr <- "white"
pal1 <- c("#105182", "#1a7bc5", "#42a2f1", "#E9F1F2", "#ff9193", "#f1434a", "#c91022", "#8d0613", "#4D030A")



monthly_plt <- ggplot() +
  # empty tile to get a legend with rectangle key
  geom_tile(data = monthly, 
            aes(x = 0, y =0, 
                width =0, height = 0, 
                fill = color)) +
  # y-axis
  geom_segment(data = seg, 
               aes(x = x, xend = xend, 
                   y = y, yend = yend), 
               color = "white", linetype = "12") +
  geom_text(data = seg_lab, 
            aes(x = x, y = y, label = glue::glue("{y} °C")), 
            color = "white", nudge_y = 1, 
            family = "serif", hjust = 0) +
  # show.legend = FALSE to remove the shape of the point in the legend
  geom_jitter(data = filter(monthly, color == "Recent"), 
              aes(x = pos+0.2, y = AverageTemperature, fill = color), 
              width = 0.15, height =0, size = 3, 
              shape = 21, stroke = 0.3, color = "#FFDADC", show.legend = FALSE) +
  geom_jitter(data = filter(monthly, color == "Past"), 
              aes(x = pos-0.2, y = AverageTemperature, fill = color), 
              width = 0.15, height =0, size = 2.5, 
              shape = 21, stroke = 0.3, color = "#93E2F5", 
              show.legend = FALSE) +
  # x-axis labels
  geom_text(data = axis_labels, 
            aes(x = pos, y = -2, label = month), 
            color = "white", vjust = 0, 
            angle = 90, size = 5, family = "serif")+
  # scales
  scale_fill_manual(values = c("Recent" = "#f1434a", "Past" = "#1a7bc5"), 
                    labels = c("Recent" = "> 1980", "Past" = "<= 1980")) +
  scale_y_continuous(limits = c(-4,26), 
                     breaks = seq(0,25,5)) +
  labs(fill = "Observations") +
  theme_void() +
  guides(fill = guide_legend(label.position = "top",
                             title.hjust = 0.5,
                             keyheight = unit(1, "line"),
                             keywidth = unit(4, "line"),
                             nrow = 1),
         color = FALSE) +
  theme(plot.background = element_rect(fill = "grey40", color = NA),
        legend.position = c(0.13, 0.85),
        legend.text = element_text(face = "bold", 
                                   size = 12, color = txt_clr),
        legend.title = element_text(face = "bold", size = 14, color = txt_clr))

monthly_plt

image.png

推文用到的示例数据和代码可以自己到推文开头提到的两个链接去下载

相关文章