Homework 6: Word Relationships & Topic Models

Introduction

In this assignment you will apply the n-gram, word-correlation, and topic modeling skills to learn more about why students chose to enter the criminal justice major.

Note: While many of these steps could be done together into one code chunk, please keep your code for a particular step right under that step.

Setup

Load the tidyverse, tidytext, widyr, igraph, ggraph and topicmodels packages in this code chunk, along with your data.

library(tidyverse)
library(tidytext)
library(widyr)
library(igraph)
library(ggraph)
library(topicmodels)

cj_data <- read_csv("data/criminal_justice_short.csv")

A little bit of data preparation steps…

Remove the #| eval: false from the top of each provided code chunk in your template as you get to it.

cj_long <- cj_data |>
  # add a unique respondent ID to each row
  mutate(respondent_id = as.character(row_number())) |>
  # rename the questions to shorter variable names
  select(respondent_id, cj = why_cj, pols = why_pols_legal, para = why_paralegal_cert) |>
  # reshape so it's one row per response-question combination
  pivot_longer(cj:para, names_to = "program", values_to = "response", values_drop_na = TRUE)

1. Describe what each row is now.

Review the output below and describe in your own words what each row represents now. How many responses are there in total?

cj_long |>
  filter(respondent_id %in% c("11", "115", "126")) |>
  arrange(respondent_id) |>
  select(respondent_id, program, response)

Part A — Relationships between words

2. Bigrams

Let’s look at which pairs of words show up together.

  • tokenize response into bigrams. save as cj_bigrams
  • split each bigram into two words. Save as bigrams_separated
  • remove stop words from both positions. Save as bigrams_filtered
  • Count the pairs

In 2-3 sentences, describe the top 10 bigrams. Which seem meaningful for understanding students’ reasons, and which just reflect the wording of the survey question?

3. Assess impact of valence shifting.

Explore how much negation, or other valence shifting, is in these responses. Could it change how we interpret their sentiment? Here is a vector of potential valence shifters to consider.

shifters <- c("not", "no", "never", "don't", "didn't", "very", "really", "but", "however")

  1. Using the filter and count functions, count how often each word in shifters starts a bigram. How many responses have one or more of these shifters? What is this percent out of the total number of responses? Is this a large percent?

  2. Pick one of the shifter words other than “not”. Join the words that follow it (word2) to the AFINN lexicon and plot what it changes. Note: if an empty plot shows up, what does that tell you about the data? (my code is wrong is not what i’m looking for.))

  3. The word “not” is a common negator. Below I have pulled out and printed the first 5 responses that use this word. Based on your reading, how much negation of sentiments/emotions is happening?

cj_long %>%
  filter(str_detect(response, "not")) |>
  slice(c(1,2,3,5,6)) |>  pull(response) |>
  knitr::kable(row.names = FALSE)

4. Custom stop words and word correlations

  1. Create a custom stop-word list called custom_stop. You can reuse or adapt the list you made for Homework 3, and add any words you noticed in questions 2 and 3 that echo the survey wording or don’t tell us much. Then create the data frame cj_words by tokenizing response into single words and removing all stop words (orginal and custom).

  2. Fill in the blanks below to keep words in cj_words that appear at least 10 times, then calculate the pairwise correlations between words across people (respondent_id). Save the data frame as word_cors. Look at the top few rows of this data set using head() and comment on what you notice.

_______ <- _______ |>
  group_by(word) |>
  filter(n() >= 10) |>
  pairwise_cor(_______, _______, sort = TRUE)

5. Draw the word network

Turn word_cors into a network graph. Filter on correlation to hide the weakly correlated pairs. Choose a cutoff that leaves a graph you can read, and tell us what cutoff you used. Run set.seed(1234) before you draw it so the layout doesn’t change every time you render.

Part B — Topic Modeling

6. Build the document-term matrix

Finish the code below to count how often each word appears in each response, then cast the counts into a document-term matrix. How many documents are being analyzed, and what is the sparsity?

Code to combine respondent_id and program into one new column called unique_id is provided. For example “11_cj” is respondent 11’s response to why they chose the cj major, “. This allows for each response to have it’s own unique ID, which cast_dtm() needs.

(cj_dtm <- _______ |>
  unite(unique_id, respondent_id, program) |>
  count(_______, _______) |>
  cast_dtm(_______, _______, _______))

7. Fit and choose a topic model

  1. Fit LDA() at two different values of k, with the same seed = 8675309. For each model, tidy the \(\beta\) values, calculate the top terms per topic, and then plot the top 8 terms in each topic.

  2. Try to name the topics. Then choose which model you think makes more sense (e.g. choose which \(k\) to use). Save your chosen model as cj_lda.

cj_lda <- _______

8. Analyzing topic patterns

When we tidy a LDA object, it renames the unique identifier variable document. So let’s rename that back so it makes sense to us.

gamma.probs <- tidy(cj_lda, matrix = "gamma") |>
  rename(unique_id = document)
head(gamma.probs)
  1. Do student response align cleanly into a single topic? The code below filters gamma.probs to pull out a few students by their unique_id, then reshapes it to wide by topic to make it easier to read. Examine and interpret their topic probabilities. Remember what we’re analyzing. A response is a student’s reason for choosing that specific educational program. Write your answer in this context.
gamma.probs |>
  filter(str_starts(unique_id, "11_|12_|151_")) |>
  arrange(unique_id, topic) |>
  pivot_wider(names_from = topic, names_prefix = "Topic",
              values_from =  gamma)
  1. How do these topics differ across the three programs? Fill in the blank below to plot the topic each response most belongs to (its largest \(\gamma\)), by program. Since each program has a different number of responses, we need to compare proportions, not direct counts.
gamma.probs |>
  group_by(_______) |>
  slice_max(_______) |>
  ungroup() |>
  separate(unique_id, c("respondent_id", "program"), sep = "_") |>
  count(program, topic) |>
  group_by(program) |>
  mutate(prop = n / sum(n), topic = factor(topic)) |>
  ggplot(aes(x=_______, y=_______, fill = topic)) +
  geom_col() +
  facet_wrap(~ _______)

9. Reflection

Name one benefit of LDA over manual open coding.

Challenge question

Redraw your network from question 5 with the LDA topics drawn over it as shaded hulls. Each word is placed in the topic where it is most likely to appear (\(\beta\)). Fill in the same cutoff you used in question 5. This code uses the ggforce package, so you may need to install.packages("ggforce") first.

Keep changing the seed before graph to redraw the network map and hulls until you find something that looks reasonably good.

In 3-4 sentences: did the hulls tell you something you didn’t already know from the network alone, or lead you to notice or wonder about something new?

word_topic <- tidy(cj_lda, matrix = "beta") |>
  group_by(term) |>
  slice_max(beta, n = 1) |>
  ungroup() |>
  transmute(name = term, topic = factor(topic))

cors <- word_cors |>
  filter(correlation > ______)

g <- graph_from_data_frame(
  cors,
  vertices = filter(word_topic, name %in% c(cors$item1, cors$item2))
)

set.seed(123)
ggraph(g, layout = "fr") +
  ggforce::geom_mark_hull(aes(x, y, group = topic, fill = topic),
                          alpha = .2, concavity = 4, expand = unit(2, "mm")) +
  geom_edge_link(aes(edge_alpha = correlation), show.legend = FALSE) +
  geom_node_point() +
  geom_node_text(aes(label = name), repel = TRUE) +
  theme_void()