Visualizing the decrease of Artic sea ice extent

R
Author

Philippe Massicotte

Published

August 23, 2019

file <- "ftp://sidads.colorado.edu/DATASETS/NOAA/G02135/north/daily/data/N_seaice_extent_daily_v3.0.csv"

raw_data <- curl_fetch_memory(file)
sea_ice_extent <- rawToChar(raw_data$content)
sea_ice_extent <- sea_ice_extent %>%
  read_csv(
    skip = 2,
    col_names = c("year", "month", "day", "extent", "missing", "source")
  ) %>%
  dplyr::select(year:extent) %>%
  mutate(day = parse_number(day)) %>%
  mutate(month = parse_number(month)) %>%
  mutate(month2 = month.name[month]) %>%
  mutate(month2 = factor(month2, month.name))

Arctic sea ice extent

It is well known that the Arctic sea ice extent is decreasing at an increasing pace. As stated by the National Snow & Ice Data Center:

According to scientific measurements, both the thickness and extent of summer sea ice in the Arctic have shown a dramatic decline over the past thirty years. This is consistent with observations of a warming Arctic.

Thanks to the NSIDC, their data is available for download. For this post, I was interested in visualizing these scientific measurements.

Icebirg floating in the Arctic

Photo by Annie Spratt on Unsplash

The data

The data consist of four variables:

  • Year, Month, Day: Period of the measurements.
  • Extent: Sea ice extent in millions km2.
sea_ice_extent %>%
  head(10) %>%
  select(-month2) %>%
  rename_all(str_to_title) %>%
  kable(caption = "Few observations of the downloaded data.", booktabs = TRUE, format = "html") %>%
  kable_styling()
Few observations of the downloaded data.
Year Month Day Extent
1978 10 26 10.231
1978 10 28 10.420
1978 10 30 10.557
1978 11 1 10.670
1978 11 3 10.777
1978 11 5 10.968
1978 11 7 11.080
1978 11 9 11.189
1978 11 11 11.314
1978 11 13 11.460

Temporal evolution of the Arctic sea ice extent

For the following visualization, I calculated the average and the standard deviation of sea ice extent for each month and each year.

p <- sea_ice_extent %>%
  group_by(month2, year) %>%
  summarise(mean_extent = mean(extent), sd_extent = sd(extent)) %>%
  ggplot(aes(x = year, y = mean_extent)) +
  geom_pointrange(aes(ymin = mean_extent - sd_extent, ymax = mean_extent + sd_extent), size = 0.25, colour = "#F2B701") +
  # geom_line() +
  facet_wrap(~month2, scales = "free_y", ncol = 3) +
  xlab(NULL) +
  ylab(bquote("Ice extent" ~ (km^2 %*% 10^6))) +
  labs(
    title = sprintf(
      "Sea ice extent between %d and %d",
      min(sea_ice_extent$year),
      max(sea_ice_extent$year)
    ),
    subtitle = "The vertical bar at each point show the standard deviation around the mean.",
    caption = paste("Source:", file)
  ) +
  theme(
    plot.caption = element_text(size = 8, color = "white"),
    plot.margin = unit(c(5.5, 10, 5.5, 5.5), "points"),
    panel.background = element_rect(fill = "#173f50"),
    strip.background = element_rect(fill = "#173f50"),
    strip.text = element_text(colour = "white", size = 12, face = "bold"),
    panel.grid = element_blank()
  )

p

Rate of change of the Arctic sea ice extent

The previous graph has shown that Arctic sea ice is undoubtedly decreasing for the past few decades. But at which rate is it decreasing? Is the decreasing rate the same for all the months? The average decreasing rate of sea ice extent can be calculated by using the slope of a linear regression between year and sea ice extent.

p +
  geom_smooth(method = "lm", se = FALSE) +
  labs(subtitle = str_wrap(
    "The vertical bar at each point shows the standard deviation around the mean. The blue lines show the linear regressions.", 90
  ))

Now, we can visualize the yearly average sea ice extent decrease for each month.

ice_trend <- sea_ice_extent %>%
  group_by(month2) %>%
  nest() %>%
  mutate(mod = map(data, ~ lm(extent ~ year, data = .))) %>%
  mutate(slope = map_dbl(mod, c(1, 2))) %>%
  mutate(r2 = map2_dbl(mod, data, modelr::rsquare)) %>%
  ungroup()

ice_trend %>%
  mutate(slope = -slope) %>%
  mutate(slope = slope * 1e6) %>%
  mutate(month2 = fct_reorder(month2, slope)) %>%
  ggplot(aes(x = month2, y = slope)) +
  geom_col(fill = "#F2B701") +
  coord_flip() +
  scale_y_continuous(expand = expand_scale(mult = c(0, 0.1)), labels = scales::comma) +
  xlab(NULL) +
  ylab(bquote("Sea ice extent decrease" ~ (km^2 ~ year^{
    -1
  }))) +
  labs(
    title = str_wrap(
      sprintf(
        "Average yearly decrease of sea ice extent by month between %d and %d",
        min(sea_ice_extent$year),
        max(sea_ice_extent$year)
      ),
      45
    ),
    subtitle = str_wrap(
      "The averages correspond to the slopes of the linear regressions between year and sea ice extent calculated by month",
      75
    ),
    caption = paste("Source:", file)
  ) +
  theme(
    panel.border = element_blank(),
    axis.title.x = element_text(face = "bold"),
    plot.caption = element_text(size = 8, color = "white"),
    panel.background = element_rect(fill = "#173f50")
  ) +
  geom_text(
    aes(
      label = paste(round(slope, 0), "~km^2~year^{-1}")
    ),
    color = "black",
    hjust = 1.1,
    parse = TRUE,
    size = 4
  )

Another way of visualizing the decrease in sea ice extent consists of using heat maps. In the following graphs, the minimum and maximum sea ice extent for each combination of month/year are presented. The graphs show that both the minimum and maximum sea ice extent are decreasing over time, which is more striking for the September month.

p1 <- sea_ice_extent %>%
  filter(between(year, 1980, 2018)) %>%
  group_by(year, month2) %>%
  # summarise(extent = mean(extent)) %>%
  filter(extent == min(extent)) %>%
  ungroup() %>%
  ggplot(aes(x = year, y = month2, fill = extent)) +
  geom_tile() +
  scale_fill_viridis_c(option = "inferno") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_discrete(expand = c(0, 0)) +
  xlab(NULL) +
  ylab(NULL) +
  theme(
    panel.border = element_blank()
  ) +
  labs(
    fill = bquote(atop("Sea ice extent", ("in millions" ~ km^2))),
    title = "Minimum sea ice extent by year and month"
  )

p2 <- sea_ice_extent %>%
  filter(between(year, 1980, 2018)) %>%
  group_by(year, month2) %>%
  filter(extent == max(extent)) %>%
  ungroup() %>%
  ggplot(aes(x = year, y = month2, fill = extent)) +
  geom_tile() +
  scale_fill_viridis_c(option = "inferno") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_discrete(expand = c(0, 0)) +
  xlab(NULL) +
  ylab(NULL) +
  theme(
    panel.border = element_blank(),
    plot.caption = element_text(size = 8, color = "white")
  ) +
  labs(
    fill = bquote(atop("sea ice extent", ("in millions" ~ km^2))),
    title = "Minimum sea ice extent by year and month",
    caption = paste("Source:", file)
  )


p1 / p2