Data Visualization Galleries

Comparision - With background

library(vroom)
# load titanic data
titanic <- vroom(here::here("data", "titanic3.csv"))
# Define a vector of colours... grey80 for background, and two different colours for male/female
density_colours <- c(
  "male" = "#0072B2",
  "female" = "#D55E00",
  "all passengers" = "grey80"
)

titanic %>%
  drop_na(sex, age) %>% # remove NAs for sex and age, and pass dataframe to ggplot
  
  # in the ggplot(), besides `x = age`, add `y = ..count..` to `aes()`
  ggplot(aes(x = age, y = ..count..)) + 
  
  
  # Add an additional `geom_density()` that will draw the background density, for all participants. 
  # This should come *before* the 'normal' `geom_density()` so that it draws the background.
  geom_density(
    
    # In the background geom_density(), set the `data` argument to be a function. This function 
    # takes a data frame and removes sex (select x, -sex) (on which sex we will facet on later).
    data = function(x) select(x, -sex),
    
    # Set both `colour` and `fill` equal to "all passengers", *not* `sex`.
    aes(fill = "all passengers", colour = "all passengers")
  ) +
  
  # now that we have the grey background, we can plot densities
  # coloured and facet_wrapped by sex
  geom_density(aes(fill = sex, colour = sex), alpha = 0.7, bw = 2) +
  
  # `facet_wrap()` to facet the plot by `sex`.
  # labeller() makes it easy to assign different labellers to different factors
  facet_wrap(~sex, labeller = labeller(sex = function(sex) paste(sex, "passengers"))) +
  
  
  # use the colours you defined for male, female, and all participants
  scale_colour_manual(
    values = density_colours,
    breaks = c("male", "female", "all passengers"),
    labels = c( "males", "females","all passengers"),
    name = NULL,
    guide = guide_legend(direction = "horizontal")
  )+
  scale_fill_manual(
    values = density_colours,
    breaks = c("male", "female", "all passengers"),
    labels = c( "males", "females","all passengers"),
    name = NULL,
    guide = guide_legend(direction = "horizontal")
  )+
  scale_x_continuous(name = "age (years)", limits = c(0, 75), expand = c(0, 0)) +
  scale_y_continuous(limits = c(0, 40), expand = c(0, 0), name = "scaled density") +
  coord_cartesian(clip = "off") +
  theme_minimal() +
  theme(legend.position = "bottom", 
        legend.justification = "center",
        text=element_text(size=12, family="Lato"),
        plot.title.position = "plot"
  ) +
  NULL

Comparision - with half box plot

library(tidyverse)
library(gapminder)
library(ggridges)
library(gghalves)
# use gghalves::geom_half_boxplot(), gghalves::geom_half_point()
ggplot(filter(gapminder2007, 
              continent != "Oceania"),
       aes(y = lifeExp,
           x = continent,
           colour = continent)) +
  geom_half_boxplot(side = "l") + # half boxplot to the left
  geom_half_point(side = "r")+    # points to the right
  theme_minimal()+
  guides(fill = FALSE, color = FALSE)+
  NULL

# Raincloud plots
ggplot(filter(gapminder2007, 
              continent != "Oceania"),
       aes(y = lifeExp,
           x = continent,
           colour = continent)) +
  geom_half_point(side = "l", size = 0.3) + 
  geom_half_boxplot(side = "l", width = 0.5, 
                    alpha = 0.3, nudge = 0.1) +
  geom_half_violin(aes(fill = continent), 
                   alpha = 0.8,
                   side = "r") +
  guides(fill = FALSE, color = FALSE) +
  coord_flip()+
  theme_minimal()+
  NULL

City miles vs Highway miles per gallon

library(tidyverse)
library(gapminder)
library(extrafont)
library(ggrepel)

set.seed(7)
# 20 random countries
some_countries <- gapminder$country %>% 
  levels() %>% 
  sample(20) 

gapminder %>%
  filter(year == 2007) %>%
  mutate(
    label = ifelse(country  %in% some_countries, as.character(country), "")
  ) %>%
  ggplot(aes(log(gdpPercap), lifeExp)) +
    geom_point(
    size = 3,
    alpha = 0.8,
    shape = 21,
    colour = "white",
    fill = "#001e62"
  )+
  geom_text_repel(aes(label=label))+
  theme_minimal()+
  theme(panel.grid.minor = element_blank())+
  labs(
    title = "Gapminder 2007: Life expectancy vs GDP per capita",
    x = "log(GDP per capita)",
    y = "Life Expectancy"
  )

with Heatmap

# remotes::install_github("kjhealy/nycdogs")
library(nycdogs)
library(sf) # for geospatial visualisation

# load the data
data("nyc_license")
data("nyc_zips")

# what is the prevalent NYC breed ?
nyc_license %>% 
  count(breed_rc, sort=TRUE) 

## # A tibble: 301 × 2
##    breed_rc                     n
##    <chr>                    <int>
##  1 Unknown                  16797
##  2 Yorkshire Terrier         7786
##  3 Shih Tzu                  7154
##  4 Labrador (or Crossbreed)  6986
##  5 Pit Bull (or Mix)         6751
##  6 Chihuahua                 5785
##  7 Maltese                   4308
##  8 Pomeranian                2197
##  9 Beagle                    2111
## 10 Jack Russell Terrier      2041
## # … with 291 more rows

# what is the prevalent NYC dog name by animal gender? 
# Bella for girls, Max for boys!

nyc_license %>% 
  count(animal_name, animal_gender, sort=TRUE) 

## # A tibble: 19,294 × 3
##    animal_name       animal_gender     n
##    <chr>             <chr>         <int>
##  1 Unknown           M              1401
##  2 Bella             F              1365
##  3 Max               M              1272
##  4 Name Not Provided M              1111
##  5 Unknown           F              1093
##  6 Lola              F               875
##  7 Charlie           M               871
##  8 Rocky             M               869
##  9 Lucy              F               767
## 10 Buddy             M               743
## # … with 19,284 more rows

# Maps for two Breeds
top_breeds <- nyc_license %>%
  group_by(zip_code, breed_rc) %>%
  tally() %>%
  filter(n>10) %>% 
  mutate(freq = n / sum(n),
         pct = round(freq*100, 2)) %>%
  filter(breed_rc == "Yorkshire Terrier" |  breed_rc == "Labrador (or Crossbreed)") 

top_breeds_map <- left_join(nyc_zips, top_breeds) %>% 
  na.omit() 

top_breeds_map %>% ggplot(mapping = aes(fill = pct)) +
  geom_sf(color = "gray80", size = 0.1) +
  scale_fill_viridis_b(option = "A", direction= -1) +
  labs(fill = "Percent of Licensed Dogs") +
  facet_wrap(~breed_rc)+
  theme_void() + 
  guides(fill = guide_legend(title.position = "top", 
                             label.position = "bottom")) 

with Arrows

library(tidyverse)
library(sf)
library(rnaturalearth)
library(eurostat)
library(lubridate)
library(opencage)
library(hrbrthemes)
library(gridExtra)

# Air passenger transport between the main airports of the United Kingdom 
# and their main partner airports (routes data)
# https://ec.europa.eu/eurostat/web/products-datasets/-/avia_par_uk

flights_UK <- get_eurostat(id="avia_par_uk", 
                                select_time = "M") #get monthly data


# filter passengers only
flights <- flights_UK %>% 
  dplyr::filter(unit == "PAS") %>% 
  mutate(
    origin = str_sub(airp_pr, 1, 7),
    destination = str_sub(airp_pr, -7), 
    from = str_sub(origin, 4,7),
    to = str_sub(destination, 4,7),
    year = year(time),
    month_name = month(time, label = TRUE)
  ) 

flights %>% 
  filter(year>=2018) %>% 
  group_by(origin,year) %>% 
  summarise(totalpassengers = sum(values)) %>% 
  arrange(desc(totalpassengers))

## # A tibble: 95 × 3
## # Groups:   origin [34]
##    origin   year totalpassengers
##    <chr>   <dbl>           <dbl>
##  1 UK_EGLL  2019       315616656
##  2 UK_EGLL  2018       314171004
##  3 UK_EGKK  2019       174720542
##  4 UK_EGKK  2018       173091550
##  5 UK_EGCC  2019       102403412
##  6 UK_EGSS  2019       101440212
##  7 UK_EGSS  2018       100518160
##  8 UK_EGCC  2018        98376330
##  9 UK_EGLL  2020        64403150
## 10 UK_EGGW  2019        62841150
## # … with 85 more rows

london_airports <- c("UK_EGLL","UK_EGKK","UK_EGSS","UK_EGGW")

london_flights <- flights %>% 
  dplyr::filter(origin %in% london_airports) %>% 
  distinct()

# count number of flights from origins to destinations
origins <- london_flights %>% 
  count(from, sort=TRUE) %>% 
  mutate(prop = n/sum(n))

destinations <- london_flights %>% 
  count(to, sort=TRUE)  %>% 
  mutate(prop = n/sum(n))

# geocode origin/destination airports
origins <- origins %>% 
  mutate(
    origin_geo = purrr::map(from, opencage_forward, limit=1)
  ) %>% 
  unnest_wider(origin_geo) %>% 
  unnest(results) %>% 
  rename(from_y = geometry.lat,
         from_x = geometry.lng)

destinations <- destinations %>% 
  mutate(
    destination_geo = purrr::map(to, opencage_forward, limit=1)
  ) %>% 
  unnest_wider(destination_geo) %>% 
  unnest(results) %>% 
  rename(to_y = geometry.lat,
         to_x = geometry.lng)


#geocode airports

londonflights2018 <- london_flights %>% 
  filter(year==2018) %>% 
  group_by(year, destination, origin, from, to) %>% 
  summarise(totalpassengers = sum(values)) %>% 
  arrange(desc(totalpassengers)) %>% 

  #geocode origin (from_x, from_y)
  mutate(
    origin_geo = purrr::map(from, opencage_forward, limit=1)
  ) %>% 
  unnest_wider(origin_geo) %>% 
  unnest(results) %>% 
  rename(from_y = geometry.lat,
         from_x = geometry.lng) %>% 
  select(destination, from, to, totalpassengers, from_x, from_y) %>% 
  
  #geocode destination (to_x, to_y)
  mutate(
    destination_geo = purrr::map(to, opencage_forward, limit=1)
  ) %>% 
  unnest_wider(destination_geo) %>% 
  unnest(results) %>% 
  rename(to_y = geometry.lat,
         to_x = geometry.lng) %>% 
  select(destination, from, to, totalpassengers, from_x, from_y, to_x, to_y)


# for displaying a data table as annotation next to the map
table <- as_tibble(londonflights2018 %>% group_by(destination) %>%  head(20)) %>%
  select(Origin = origin, Destination = destination, Passengers = totalpassengers) %>%
  mutate(Passengers = glue::glue("{scales::comma(Passengers)}")) %>%
  tableGrob(
    rows = NULL,
    theme = ttheme_default(
      core = list(
        fg_params = list(
          fontfamily = "Lato",
          hjust = c(rep(0, 20), rep(1, 20)),
          x = c(rep(0.1, 20), rep(0.9, 20))
        )
      )
    )
  )


ggplot() +
  geom_sf(data = world, size = 0.125) +
  geom_curve(
    data = londonflights2018 %>% head(20), 
    aes(x = from_x, y = from_y, xend = to_x, yend = to_y, 
        size= totalpassengers, colour = totalpassengers),
    curvature = 0.2, arrow = arrow(length = unit(3, "pt"), type = "closed"),
  )+
  theme_void()+
  
  annotation_custom(table, xmin=-165, xmax=-160, ymin=-120, ymax=90) + 
  labs(
    x = NULL, y = NULL,
    title = "Top 20 destinations for London flights in 2018",
    subtitle = "Data source: Eurostat , id=avia_par_uk"
  ) +
  
  theme(
    text=element_text(size=16, family="Lato"),
    plot.title = element_text(),
    plot.title.position = "plot",
    axis.text.x = element_blank(),
    axis.title.y = element_blank(),
    legend.position = "none"
  ) +
  NULL

London Wards Map