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
)
## 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"
# )
# )
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
}
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.