library(tidyverse)
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──
## ✔ ggplot2 3.3.5     ✔ purrr   0.3.4
## ✔ tibble  3.1.6     ✔ dplyr   1.0.8
## ✔ tidyr   1.2.0     ✔ stringr 1.4.0
## ✔ readr   2.1.2     ✔ forcats 0.5.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
library(magrittr)
## 
## Attaching package: 'magrittr'
## The following object is masked from 'package:purrr':
## 
##     set_names
## The following object is masked from 'package:tidyr':
## 
##     extract
library(forcats)
library(knitr)
library(sf)
## Linking to GEOS 3.10.2, GDAL 3.4.2, PROJ 8.2.1; sf_use_s2() is TRUE
library(ggmap)
## Google's Terms of Service: https://cloud.google.com/maps-platform/terms/.
## Please cite ggmap if you use it! See citation("ggmap") for details.
## 
## Attaching package: 'ggmap'
## The following object is masked from 'package:magrittr':
## 
##     inset
library(ggthemes)
library(patchwork)
tweet_classifications <-
  readRDS("../storage/MMc_TwitterLeicester2018-2019_all-en_clr-emo-lemm-multi_no-spam_with-all-tweet-classif-v0-2-0.rds")

The re-classification of the sentiment values used below is based on the distributions illustrated in the MMc-compare-classifications-plots analysis document.

tweet_classifications <-
  tweet_classifications %>% 
  mutate(
    tweet_sentimentr_class = ordered(
      case_when(
        tweet_sentimentr_sentiment <= -0.1 ~ "Negative",
        tweet_sentimentr_sentiment >= 0.1 ~ "Positive",
        TRUE ~ "Neutral"
      ),
      levels = c("Negative", "Neutral", "Positive")
    ),
    tweet_flair_sentiment_class = ordered(
      case_when(
        tweet_flair_sentiment_confidence < 0.95 ~ "Neutral",
        tweet_flair_sentiment_value == "NEGATIVE" ~ "Negative",
        tweet_flair_sentiment_value == "POSITIVE" ~ "Positive"
      ),
      levels = c("Negative", "Neutral", "Positive")
    )
  )

tweet_classifications <-
  tweet_classifications %>% 
  left_join(
    tweet_classifications %>% 
      select(tweet_id_str, tweet_flair_e6c11m2_admiration:tweet_flair_e6c11m2_top_emotion) %>% 
      pivot_longer(
        cols = tweet_flair_e6c11m2_admiration:tweet_flair_e6c11m2_sadness,
        names_to = "emotion",
        values_to = "tweet_flair_e6c11m2_top_emotion_confidence"
      ) %>% 
      mutate(
        emotion = str_remove(emotion, "tweet_flair_e6c11m2_")
      ) %>% 
      filter(
        emotion == tweet_flair_e6c11m2_top_emotion
      ) %>%
      select(-emotion)
  ) %>% 
  relocate(
    tweet_flair_e6c11m2_top_emotion_confidence,
    .after = tweet_flair_e6c11m2_top_emotion
  ) %>% 
  left_join(
    tweet_classifications %>%
      select(tweet_id_str, tweet_flair_c6c12m1_commercial:tweet_flair_c6c12m1_top_context) %>%
      pivot_longer(
        cols = tweet_flair_c6c12m1_commercial:tweet_flair_c6c12m1_place_character,
        names_to = "context",
        values_to = "tweet_flair_c6c12m1_top_context_confidence"
      ) %>%
      mutate(
        context = str_remove(context, "tweet_flair_c6c12m1_")
      ) %>%
      filter(
        context == (tweet_flair_c6c12m1_top_context %>% 
          str_replace_all(" and ", "_") %>% 
          str_replace_all(", ", "_") %>% 
          str_replace_all(" ", "_"))
      ) %>%
      select(-context)
  ) %>%
  relocate(
    tweet_flair_c6c12m1_top_context_confidence,
    .after = tweet_flair_c6c12m1_top_context
  ) %>%
  mutate(
    tweet_flair_e6c11m2_top_emotion = if_else(
      tweet_flair_e6c11m2_top_emotion_confidence < 0.95,
      "uncertain", tweet_flair_e6c11m2_top_emotion
    ),
    tweet_flair_c6c12m1_top_context = if_else(
      tweet_flair_c6c12m1_top_context_confidence < 0.95,
      "uncertain", tweet_flair_c6c12m1_top_context
    )
  )
## Joining, by = c("tweet_id_str", "tweet_flair_e6c11m2_top_emotion")
## Joining, by = c("tweet_id_str", "tweet_flair_c6c12m1_top_context")
leic_hex <- sf::st_read("../data/Leicester_hexagons_width500m.geojson") %>%
  dplyr::rename(hex_id = id)
## Reading layer `Leicester_hexagons_width500m' from data source 
##   `/Users/sds27/repos/mapping-multiculture/data/Leicester_hexagons_width500m.geojson' 
##   using driver `GeoJSON'
## Simple feature collection with 1120 features and 5 fields
## Geometry type: POLYGON
## Dimension:     XY
## Bounding box:  xmin: 452524.1 ymin: 297691.1 xmax: 465773.7 ymax: 311763.6
## Projected CRS: OSGB36 / British National Grid
tweet_classifications_with_hex <-
  tweet_classifications %>%
  filter(!is.na(tweet_geo_long) & !is.na(tweet_geo_lat)) %>% 
  sf::st_as_sf(coords = c("tweet_geo_long", "tweet_geo_lat"), remove = FALSE, crs = 4326) %>%
  sf::st_transform(crs = 27700) %>%
  sf::st_join(
    leic_hex,
    sf::st_within
  )

Classification maps

Load basemaps

## GGmaps
leicester_ggmap <-
  ggmap(
    get_stamenmap(
      c(left = -1.225, bottom = 52.575, right = -1.03, top = 52.7),
      #c(left = -1.148097, bottom = 52.622853, right = -1.113855, top = 52.644261),
      #c(left = -1.192633, bottom = 52.578372, right = -1.039507, top = 52.683087),
      zoom = 14,
      maptype = "toner"
    )
  )
## 110 tiles needed, this may take a while (try a smaller zoom).
## Source : http://tile.stamen.com/toner/14/8136/5359.png
## Source : http://tile.stamen.com/toner/14/8137/5359.png
## Source : http://tile.stamen.com/toner/14/8138/5359.png
## Source : http://tile.stamen.com/toner/14/8139/5359.png
## Source : http://tile.stamen.com/toner/14/8140/5359.png
## Source : http://tile.stamen.com/toner/14/8141/5359.png
## Source : http://tile.stamen.com/toner/14/8142/5359.png
## Source : http://tile.stamen.com/toner/14/8143/5359.png
## Source : http://tile.stamen.com/toner/14/8144/5359.png
## Source : http://tile.stamen.com/toner/14/8145/5359.png
## Source : http://tile.stamen.com/toner/14/8136/5360.png
## Source : http://tile.stamen.com/toner/14/8137/5360.png
## Source : http://tile.stamen.com/toner/14/8138/5360.png
## Source : http://tile.stamen.com/toner/14/8139/5360.png
## Source : http://tile.stamen.com/toner/14/8140/5360.png
## Source : http://tile.stamen.com/toner/14/8141/5360.png
## Source : http://tile.stamen.com/toner/14/8142/5360.png
## Source : http://tile.stamen.com/toner/14/8143/5360.png
## Source : http://tile.stamen.com/toner/14/8144/5360.png
## Source : http://tile.stamen.com/toner/14/8145/5360.png
## Source : http://tile.stamen.com/toner/14/8136/5361.png
## Source : http://tile.stamen.com/toner/14/8137/5361.png
## Source : http://tile.stamen.com/toner/14/8138/5361.png
## Source : http://tile.stamen.com/toner/14/8139/5361.png
## Source : http://tile.stamen.com/toner/14/8140/5361.png
## Source : http://tile.stamen.com/toner/14/8141/5361.png
## Source : http://tile.stamen.com/toner/14/8142/5361.png
## Source : http://tile.stamen.com/toner/14/8143/5361.png
## Source : http://tile.stamen.com/toner/14/8144/5361.png
## Source : http://tile.stamen.com/toner/14/8145/5361.png
## Source : http://tile.stamen.com/toner/14/8136/5362.png
## Source : http://tile.stamen.com/toner/14/8137/5362.png
## Source : http://tile.stamen.com/toner/14/8138/5362.png
## Source : http://tile.stamen.com/toner/14/8139/5362.png
## Source : http://tile.stamen.com/toner/14/8140/5362.png
## Source : http://tile.stamen.com/toner/14/8141/5362.png
## Source : http://tile.stamen.com/toner/14/8142/5362.png
## Source : http://tile.stamen.com/toner/14/8143/5362.png
## Source : http://tile.stamen.com/toner/14/8144/5362.png
## Source : http://tile.stamen.com/toner/14/8145/5362.png
## Source : http://tile.stamen.com/toner/14/8136/5363.png
## Source : http://tile.stamen.com/toner/14/8137/5363.png
## Source : http://tile.stamen.com/toner/14/8138/5363.png
## Source : http://tile.stamen.com/toner/14/8139/5363.png
## Source : http://tile.stamen.com/toner/14/8140/5363.png
## Source : http://tile.stamen.com/toner/14/8141/5363.png
## Source : http://tile.stamen.com/toner/14/8142/5363.png
## Source : http://tile.stamen.com/toner/14/8143/5363.png
## Source : http://tile.stamen.com/toner/14/8144/5363.png
## Source : http://tile.stamen.com/toner/14/8145/5363.png
## Source : http://tile.stamen.com/toner/14/8136/5364.png
## Source : http://tile.stamen.com/toner/14/8137/5364.png
## Source : http://tile.stamen.com/toner/14/8138/5364.png
## Source : http://tile.stamen.com/toner/14/8139/5364.png
## Source : http://tile.stamen.com/toner/14/8140/5364.png
## Source : http://tile.stamen.com/toner/14/8141/5364.png
## Source : http://tile.stamen.com/toner/14/8142/5364.png
## Source : http://tile.stamen.com/toner/14/8143/5364.png
## Source : http://tile.stamen.com/toner/14/8144/5364.png
## Source : http://tile.stamen.com/toner/14/8145/5364.png
## Source : http://tile.stamen.com/toner/14/8136/5365.png
## Source : http://tile.stamen.com/toner/14/8137/5365.png
## Source : http://tile.stamen.com/toner/14/8138/5365.png
## Source : http://tile.stamen.com/toner/14/8139/5365.png
## Source : http://tile.stamen.com/toner/14/8140/5365.png
## Source : http://tile.stamen.com/toner/14/8141/5365.png
## Source : http://tile.stamen.com/toner/14/8142/5365.png
## Source : http://tile.stamen.com/toner/14/8143/5365.png
## Source : http://tile.stamen.com/toner/14/8144/5365.png
## Source : http://tile.stamen.com/toner/14/8145/5365.png
## Source : http://tile.stamen.com/toner/14/8136/5366.png
## Source : http://tile.stamen.com/toner/14/8137/5366.png
## Source : http://tile.stamen.com/toner/14/8138/5366.png
## Source : http://tile.stamen.com/toner/14/8139/5366.png
## Source : http://tile.stamen.com/toner/14/8140/5366.png
## Source : http://tile.stamen.com/toner/14/8141/5366.png
## Source : http://tile.stamen.com/toner/14/8142/5366.png
## Source : http://tile.stamen.com/toner/14/8143/5366.png
## Source : http://tile.stamen.com/toner/14/8144/5366.png
## Source : http://tile.stamen.com/toner/14/8145/5366.png
## Source : http://tile.stamen.com/toner/14/8136/5367.png
## Source : http://tile.stamen.com/toner/14/8137/5367.png
## Source : http://tile.stamen.com/toner/14/8138/5367.png
## Source : http://tile.stamen.com/toner/14/8139/5367.png
## Source : http://tile.stamen.com/toner/14/8140/5367.png
## Source : http://tile.stamen.com/toner/14/8141/5367.png
## Source : http://tile.stamen.com/toner/14/8142/5367.png
## Source : http://tile.stamen.com/toner/14/8143/5367.png
## Source : http://tile.stamen.com/toner/14/8144/5367.png
## Source : http://tile.stamen.com/toner/14/8145/5367.png
## Source : http://tile.stamen.com/toner/14/8136/5368.png
## Source : http://tile.stamen.com/toner/14/8137/5368.png
## Source : http://tile.stamen.com/toner/14/8138/5368.png
## Source : http://tile.stamen.com/toner/14/8139/5368.png
## Source : http://tile.stamen.com/toner/14/8140/5368.png
## Source : http://tile.stamen.com/toner/14/8141/5368.png
## Source : http://tile.stamen.com/toner/14/8142/5368.png
## Source : http://tile.stamen.com/toner/14/8143/5368.png
## Source : http://tile.stamen.com/toner/14/8144/5368.png
## Source : http://tile.stamen.com/toner/14/8145/5368.png
## Source : http://tile.stamen.com/toner/14/8136/5369.png
## Source : http://tile.stamen.com/toner/14/8137/5369.png
## Source : http://tile.stamen.com/toner/14/8138/5369.png
## Source : http://tile.stamen.com/toner/14/8139/5369.png
## Source : http://tile.stamen.com/toner/14/8140/5369.png
## Source : http://tile.stamen.com/toner/14/8141/5369.png
## Source : http://tile.stamen.com/toner/14/8142/5369.png
## Source : http://tile.stamen.com/toner/14/8143/5369.png
## Source : http://tile.stamen.com/toner/14/8144/5369.png
## Source : http://tile.stamen.com/toner/14/8145/5369.png
# citycentre_ggmap <- 
#   ggmap(
#     get_stamenmap(
#       #c(left = -1.225, bottom = 52.575, right = -1.0, top = 52.7),
#       c(left = -1.148097, bottom = 52.622853, right = -1.113855, top = 52.644261),
#       zoom = 15,
#       maptype = "toner"
#     )
#   )

Functions

draw_leicester_map_many <- function(data, column, title, palette){

  column_levels <-
    data %>% 
    st_drop_geometry() %>% 
    filter(.data[[column]] != "Other") %>% 
    count(.data[[column]], sort = TRUE) %>% 
    pull(.data[[column]]) %>% 
    c("Other")
  
  leicester_map <-
    leicester_ggmap + 
    geom_sf(
      data = data %>% st_transform(crs = 4326),
      aes(fill = ordered(.data[[column]], levels = column_levels)),
      colour = NA,
      alpha = 0.7,
      size = 0.5, 
      inherit.aes = FALSE,
      na.rm = TRUE
    ) +
    coord_sf(crs = st_crs(4326)) +
    scale_fill_tableau(palette = palette) +
    guides(fill = guide_legend(title)) +
    xlab("") + ylab("") +
    theme(
      legend.position = "bottom",
      axis.text.x = element_blank(),
      axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      #legend.position = "none",
      panel.border = element_rect(colour = "black", fill=NA, size=1)
    )

  leicester_map
}

draw_leicester_map_few <- function(data, column, title, palette){

  leicester_map <-
    leicester_ggmap + 
    geom_sf(
      data = data %>% st_transform(crs = 4326),
      aes(fill = .data[[column]]),
      colour = NA,
      alpha = 0.7,
      size = 0.5, 
      inherit.aes = FALSE,
      na.rm = TRUE
    ) +
    coord_sf(crs = st_crs(4326)) +
    scale_fill_brewer(palette = palette) +
    guides(fill = guide_legend(title)) +
    xlab("") + ylab("") +
    theme(
      legend.position = "bottom",
      axis.text.x = element_blank(),
      axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      #legend.position = "none",
      panel.border = element_rect(colour = "black", fill=NA, size=1)
    )

  leicester_map
}

Maps

small_classifications <- c("tweet_sentimentr_class", "tweet_flair_sentiment_class")
small_classification_titles <- c("Sentimentr", "Flair sentiment")
small_classification_palettes <- c("RdYlBu", "RdYlBu")

for (i in 1:2) {
  map_few <-
    leic_hex %>% 
    left_join(
      tweet_classifications_with_hex %>% 
        st_drop_geometry() %>% 
        count(hex_id, .data[[small_classifications[i]]]) %>% 
        group_by(hex_id) %>% 
        slice_max(order_by = n, n = 1) %>% 
        left_join(
          tweet_classifications %>% 
            count(.data[[small_classifications[i]]]) %>% 
            rename(overall_n = n)
        ) %>% 
        slice_min(order_by = overall_n, n = 1, with_ties = FALSE) %>% 
        ungroup()
    ) %>% 
    draw_leicester_map_few(small_classifications[i], small_classification_titles[i], small_classification_palettes[i])
  
  print(map_few)
}
## Joining, by = "tweet_sentimentr_class"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.
## Joining, by = "tweet_flair_sentiment_class"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.

large_classifications <- c("btm200bg_topic_sum_b", "trans_umap_hdbscan")
large_classification_titles <- c("BTM (top 20 by size)", "Transformer (top 20 by size)")
large_classification_palettes <- c("Tableau 20", "Tableau 20")
large_classification_maps <- c()

for (i in 1:2) {
  map_many <-
    leic_hex %>% 
    left_join(
      tweet_classifications_with_hex %>% 
        st_drop_geometry() %>% 
        count(hex_id, .data[[large_classifications[i]]]) %>% 
        group_by(hex_id) %>% 
        slice_max(order_by = n, n = 1) %>% 
        ungroup() %>% 
        left_join(
          tweet_classifications_with_hex %>% 
            st_drop_geometry() %>% 
            count(hex_id, .data[[large_classifications[i]]]) %>% 
            group_by(hex_id) %>% 
            slice_max(order_by = n, n = 1) %>% 
            ungroup() %>% 
            count(.data[[large_classifications[i]]]) %>% 
            slice_max(order_by = n, n = 19, with_ties = FALSE) %>% 
            select(.data[[large_classifications[i]]]) %>% 
            mutate(to_plot = .data[[large_classifications[i]]])
        )
    ) %>% 
    mutate(to_plot = if_else(
      is.na(.data[[large_classifications[i]]]), NA_character_,
      if_else(is.na(to_plot), "Other", to_plot)
    )) %>% 
    draw_leicester_map_many("to_plot", large_classification_titles[i], large_classification_palettes[i])
  
  print(map_many)
}
## Joining, by = "btm200bg_topic_sum_b"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.
## Joining, by = "trans_umap_hdbscan"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.

small_classifications <- c("tweet_flair_e6c11m2_top_emotion", "tweet_flair_c6c12m1_top_context")
small_classification_titles <- c("Emotion", "Context")
small_classification_palettes <- c("Set3", "Set1")

for (i in 1:2) {
  map_few <-
    leic_hex %>% 
    left_join(
      tweet_classifications_with_hex %>% 
        st_drop_geometry() %>% 
        mutate(tweet_flair_c6c12m1_top_context = str_trunc(tweet_flair_c6c12m1_top_context, 10)) %>% 
        count(hex_id, .data[[small_classifications[i]]]) %>% 
        group_by(hex_id) %>% 
        slice_max(order_by = n, n = 1) %>% 
        left_join(
          tweet_classifications %>% 
            count(.data[[small_classifications[i]]]) %>% 
            rename(overall_n = n)
        ) %>% 
        slice_min(order_by = overall_n, n = 1, with_ties = FALSE) %>% 
        ungroup()
    ) %>% 
    draw_leicester_map_few(small_classifications[i], small_classification_titles[i], small_classification_palettes[i])
  
  print(map_few)
}
## Joining, by = "tweet_flair_e6c11m2_top_emotion"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.
## Joining, by = "tweet_flair_c6c12m1_top_context"
## Joining, by = "hex_id"
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.