Merge pull request epiforecasts#386 from RichardMN/hexisticker-regions

Hexisticker - with region colouring using natural earth data and mapshaper for geometry manipulation

R/get_available_datasets.R

@@ -54,7 +54,7 @@ get_available_datasets <- function(type, render = FALSE,
       bind_rows()
     country_data <- available_country_data
   } else {
-    country_data <- all_country_data
+    country_data <- covidregionaldata::all_country_data
   }
   if (!missing(type)) {
     target_type <- match.arg(

README.Rmd

@@ -23,6 +23,8 @@ knitr::opts_chunk$set(
 ### Design 3
 ![design 3](man/figures/logo3.png)
 
+### Design 5
+![design 5](man/figures/logo5.png)
 
 # Subnational data for the COVID-19 outbreak
 

README.md

@@ -13,6 +13,10 @@
 
 ![design 3](man/figures/logo3.png)
 
+### Design 5
+
+![design 5](man/figures/logo5.png)
+
 # Subnational data for the COVID-19 outbreak
 
 [![Lifecycle:

inst/make_hexsticker.R

@@ -1,30 +1,38 @@
+library(covidregionaldata)
 library(hexSticker)
 library(showtext)
 library(ggplot2)
 library(dplyr)
 library(maps)
+library(countrycode)
 library(sf)
+library(rnaturalearth)
+library(rmapshaper)
 
 # font setup
 font_add_google("Zilla Slab Highlight", "useme")
 
 # get countries we have data for
 regional_countries <- get_available_datasets() %>%
-  filter(type == "regional")
+  filter(.data$type == "regional")
 
 regional_countries_l2 <- regional_countries %>%
-  filter(!(is.na(level_2_region)))
+  filter(!(is.na(.data$level_2_region)))
+
+regional_countries_l1 <- regional_countries %>%
+  filter(is.na(.data$level_2_region))
 
 # get world data
 world <- spData::world %>%
   st_as_sf()
 
+
 # mark supported countries from the world data
 supported_countries <- world %>%
   mutate(
     fill = case_when(
-      name_long %in% countryname(regional_countries_l2[["origin"]], , destination = "country.name.en") ~ "Level 2",
-      name_long %in% countryname(regional_countries[["origin"]], , destination = "country.name.en") ~ "Level 1",
+      name_long %in% countryname(regional_countries_l2[["origin"]], destination = "country.name.en") ~ "Level 2",
+      name_long %in% countryname(regional_countries[["origin"]], destination = "country.name.en") ~ "Level 1",
       TRUE ~ "Unsupported"
     )
   )
@@ -86,6 +94,70 @@ covid_map_2 <- ggplot() +
 
 print(covid_map_2)
 
+# Approach using Natural Earth data
+
+world_without_regions <- ne_countries(returnclass = "sf") %>%
+  filter(sovereignt != "Antarctica")
+
+# numberOfLevels should be less than half the number of colours in the
+# divergent palette used (usually 7)
+numberOfLevels <- 3
+
+regional_maps_l1 <- ms_simplify(
+  ne_states(gsub(" \\(.*\\)", "",
+    regional_countries_l1$origin,
+    perl = TRUE
+  ), returnclass = "sf") %>%
+    mutate(region_code = woe_id %% numberOfLevels),
+  keep = 0.04
+)
+
+regional_maps_l2 <- ms_simplify(
+  ne_states(gsub(" \\(.*\\)", "",
+    regional_countries_l2$origin,
+    perl = TRUE
+  ), returnclass = "sf") %>%
+    mutate(region_code = woe_id %% numberOfLevels + numberOfLevels + 1),
+  keep = 0.04
+)
+
+regional_maps <- bind_rows(regional_maps_l1, regional_maps_l2)
+
+# We keep 50% of the points of the country outlines because it's a
+# finer scale map
+# We add the US and the UK to the list because otherwise we don't
+# successfully include them.
+regional_outlines <- ms_lines(
+  ms_simplify(
+    ne_countries(
+      country = c(
+        gsub(" \\(.*\\)", "", regional_countries$origin, perl = TRUE),
+        "United States", "United Kingdom"
+      ),
+      returnclass = "sf"
+    ),
+    keep = 0.5
+  )
+)
+
+
+covid_map_3 <- ggplot() +
+  ggspatial::layer_spatial(data = world_without_regions, size = 0.01) +
+  ggspatial::layer_spatial(
+    data = regional_maps,
+    aes(fill = region_code), size = 0.02
+  ) +
+  ggspatial::layer_spatial(
+    data = regional_outlines,
+    aes(colour = 1), size = 0.1
+  ) +
+  coord_sf(crs = "ESRI:54016") +
+  scale_fill_fermenter(palette = "RdBu") +
+  theme_void() +
+  theme(legend.position = "none", axis.text.x = element_blank())
+
+print(covid_map_3)
+
 logo2 <- sticker(
   covid_map_2,
   package = "covidregionaldata",
@@ -113,3 +185,18 @@ logo3 <- sticker(
   u_size = 3.5,
   dpi = 1000
 )
+
+logo4 <- sticker(
+  covid_map_3,
+  package = "covidregionaldata",
+  p_size = 48, s_x = 1, s_y = 0.8, s_width = 1.7, s_height = 1.7,
+  p_y = 1.45,
+  p_color = "white",
+  p_family = "useme",
+  h_color = "#646770",
+  h_fill = "#24A7DF",
+  filename = "man/figures/logo5.png",
+  u_size = 3.5,
+  dpi = 1000
+)
+