TED Talks: AI and Topic Modelling

Continuing our series of analysis of text from recent TED Talks with the search keyword “AI”, today’s post uses the text data to perform some simple topic modelling in R.

Some relevant questions might be:

• Are there natural topics that exist in the data?
• Can we get an overview of the topic content without reading every transcript?
• Can we identify clusters of topic-related talks in the data set?

# Some packages

library(tidyverse)
library(data.table)
library(tidytext)
library(dendextend)
library(tm)
library(topicmodels)
library(ggrepel)
library(plotly)

# Some functions

mytheme<- theme_bw() +
          theme(strip.background = element_rect(fill="grey40"),
                strip.text= element_text(face= "bold", colour= "white"))

mytSNE<- function(thematrix){
  perplex<- round(sqrt(nrow(thematrix)))
  res<- Rtsne::Rtsne(thematrix, dims= 2, perplexity= perplex)
  resdf<- data.frame(x= res$Y[,1], y= res$Y[,2])
  resdf$x<- resdf$x + rnorm(nrow(resdf),0, 0.2)  # Add some noise 
  resdf$y<- resdf$y + rnorm(nrow(resdf),0, 0.2)
  return(resdf)
}

putZeros<- function(OB) {
  OB<- OB %>% mutate_at(vars(-group_cols()),~replace(.,is.na(.),0))
  return(OB)
}

# Load data from last time
df<- readRDS("TED_data.rds")
head(df,10)

Some text preprocessing…

Before undertaking any text modelling task, we must do some pre-processing. In this case, the term AI is used a lot in several variations. I want to recognise all of these and group them together under the term “subject_ai”. I will also remove stop words, and use word stemming/completion.

# Tokenization, pre-processing, stemming
sentObj<- unnest_sentences(df, sent, full_text)

# Look through the text for references to the term "AI"
ai_patt<- "^a\\.?i | a\\.?i | a\\.?i\\.| a\\.?i,"

# Label all these as "subject_ai"
sentObj$sent<- str_replace_all(sentObj$sent, ai_patt, " subject_ai ")

wordObj<-      sentObj %>% unnest_tokens(word, sent, drop= FALSE)

outwords<- c("yeah","no","black","ll","ve","ynh","don", "isn","won","didn","ca","em", "milo", "nb","ems","t","applause", "laughter")


wordObj<- wordObj %>% mutate(LEN= nchar(word)) %>% filter(LEN > 2) %>%
  filter(!word %in% stop_words$word) %>%
  filter(!word %in% outwords) %>%
  filter(!word %like% "\\d")

wordObj$stem<- stemDocument(wordObj$word)


# Some additional manual stemming
wordObj<- wordObj %>% mutate(stem= ifelse(word %like% "chinese|china","china",stem),
                             stem= ifelse(word %like% "deepfak", "deepfake", stem),
                             stem= ifelse(word %like% "superintel","superintelligent", stem),
                             stem= ifelse(word %like% "woman","women", stem),
                             stem= ifelse(word %like% "drug", "drug", stem),
                             stem= ifelse(word %like% "medicin", "medical", stem),
                             stem= ifelse(word %like% "percent", "percent", stem),
                             stem= ifelse(word %like% "a.i", "ai", stem),
                             stem= ifelse(word %like% "accid","accid", stem))

# make a stem completion dictionary 
t1<-  wordObj %>% ungroup() %>% count(word,stem)
t2<- t1 %>% ungroup() %>% arrange(stem, desc(n)) %>% group_by(stem) %>% mutate(Order= order(desc(n)))
t2<- t2 %>% filter(Order==1) %>% select(-c(Order,n)) %>% ungroup() %>% rename(complete= word)

# Apply stem completion
wordObj<- left_join(wordObj,t2)
wordObj$word<- wordObj$complete

Any non-useful words?

Before we proceed to topic modelling, we want to check if there are any words in our data set that are too ubiquitous to be useful for discerning topics. In this case there is only one word that seems to dominate our data, this is “information”.

# Identify any dominating words
t0<- wordObj %>% ungroup() %>% count(word, sort= TRUE) %>% 
                 slice(1:10) %>% print()

ggplot(t0, aes(x= n, y=fct_reorder(word, n), fill=n)) +
  geom_col() +
  theme_bw() + 
  theme(legend.position = "none") +
  labs(x= "Count", y="",title= "TED Talks: Most Frequently Occurring Words")

common_words<- "information"
# Construct a document-term matrix
dtm <- wordObj %>% 
  count(ID,word) %>% 
  filter(!word %in% common_words) %>%
  cast_dtm(document=ID, term=word, value=n)

freq_terms<- findFreqTerms(dtm,10)
mod_dtm<- dtm[, freq_terms]

glimpse(mod_dtm)

List of 6
 $ i       : int [1:18632] 1 9 13 16 19 21 32 37 46 48 ...
 $ j       : int [1:18632] 1 1 1 1 1 1 1 1 1 1 ...
 $ v       : num [1:18632] 2 1 1 2 1 1 1 4 1 1 ...
 $ nrow    : int 88
 $ ncol    : int 1180
 $ dimnames:List of 2
  ..$ Docs : chr [1:88] "1" "2" "3" "4" ...
  ..$ Terms: chr [1:1180] "accept" "act" "advanced" "agents" ...
 - attr(*, "class")= chr [1:2] "DocumentTermMatrix" "simple_triplet_matrix"
 - attr(*, "weighting")= chr [1:2] "term frequency" "tf"

Ordinary Clustering based on Document-Term-Matrix

Before we try anything fancy, we can try a clustering of talks based on the ordinary document-term matrix

dend<- dtm %>% dist() %>% hclust(method= "ward.D") %>%
       as.dendrogram() %>%
       set_labels(df$title) %>%
       color_branches(h= 145) %>%
       color_labels(h= 145) %>%
       set("labels_cex", 0.8)
  
par(mar= c(1,1,1,25))
plot(dend, horiz= TRUE, main= "TED Talks: Clustering based on DTM")

Based on clustering with the raw Document-Term Matrix we can see four clear clusters of talks. However, because there are so many different talks in each cluster, it is relatively difficult to distinguish a clear topic for each cluster.

Latent Dirichlet Allocation (LDA)

LDA is a topic modelling technique for finding groups of words that tend to occur together - hence a topic. It’s important to note that LDA doesn’t take the meaning of the words into account, simply their frequency of co-occurence. We don’t know in advance how many topics to specify in the LDA model, so I will try a range of topic counts from 10 to 30. Here we are seeking to maximise negative Log likelihood and minimise perplexity.

# ks<- seq(10,30,1)
# LL<- rep(NA,length(ks))
# pp<- rep(NA,length(ks))
# 
# 
# for (k in 1:length(ks)){
#   cat("\n",ks[k])
#   mod <- LDA(x=mod_dtm, k=ks[k], method= "Gibbs",
#              control=list(alpha=0.001, seed=10005))
#   LL[k]<- logLik(mod) # Retrieve log-likelihood
#   pp[k]<- perplexity(object=mod, newdata=mod_dtm) # Find perplexity
# 
# }

pdata<- data.frame(Topics= rep(ks,2), value= c(LL, pp), 
                   Metric= c(rep("Negative LogLik", length(ks)),
                             rep("Perplexity", length(ks))) )

ggplot(pdata, aes(x= Topics, y= value, color= Metric)) +
  geom_line(size=1.25) +
  geom_vline(xintercept = 19, size= 0.35, lty= "dashed") +
  facet_wrap(~Metric, scales= "free_y") +
  mytheme +
  labs(title= "LDA by Number of Topics")

Across the tested number of topics, the perplexity continues to decrease monotonically so this is not a helpful criterion. The maximum -LogLik across the testing range is 29 Topics. For our purposes that is rather a lot, so instead I have decided to take the first peak point at 19 Topics.

Implement a 19-topic solution

Now let’s run the LDA model again, specifying 19 topics. Then we will use the beta matrix from the solution to explore the top terms contributing to each topic.

mod <- topicmodels::LDA(x=mod_dtm, k=19, method= "Gibbs", 
                        control=list(alpha=0.001, seed=10005, burnin= 500, 
                                     thin= 100, iter= 4000))

top_terms <- tidy(mod, matrix = "beta") %>%
              group_by(topic) %>%
              arrange(topic, desc(beta)) %>%
              slice(seq_len(6)) %>%
              arrange(topic, beta) %>%
              mutate(row = row_number()) %>%
              ungroup() %>%
              mutate(topic = paste("Topic", str_pad(topic,width= 2, pad="0"), sep = " "))

# Plot the topics

top_terms %>%
  mutate(topic = factor(topic),
         term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(term, beta, fill = log(beta))) +
  geom_bar(stat = "identity", show.legend = FALSE, color= "grey20", size= 0.2) +
  scale_x_reordered() +
  facet_wrap(~ topic, scales = "free", ncol = 3) +
  coord_flip() +
  theme_minimal() +
  scale_fill_distiller(palette = "RdYlBu") +
  theme(legend.position = 'none',
        panel.grid = element_blank(),
        axis.text.y = element_text(size= 10),
        axis.text.x = element_blank(),
        plot.margin = margin(0.5, 1, 0.5, 0.5, "cm")) +
  labs(title= "TED Talks: Strongest Words by Topic", y= NULL, x= NULL)

Assign Topic Labels

We can assign the top four terms in each topic to form a topic label. This helps us know key words are influential within each topic.

topicLabels<- top_terms %>% ungroup() %>% arrange(topic, desc(beta)) %>% group_by(topic) %>%
                            mutate(Order= order(desc(beta))) %>% filter(Order < 5) %>%
                            summarise(Label= str_c(term, collapse=" ")) %>%
                            mutate(topic= str_sub(topic, 7),
                                   Label= paste0(topic,": ",str_to_sentence(Label)), 
                                   topic= as.numeric(topic)) %>% print()

Topics in Space

Although we have set the alpha on the LDA model very small, our topics will still be correlated. I found it helpful to look at how the topics group together, and how they could be laid out in two-dimensional space.

bt<-      mod %>% tidy(matrix= "beta") %>% spread(term, beta) 
hc<-      bt %>% dist() %>% hclust(method= "ward.D")
plot(hc); rect.hclust(hc, h =0.12, border = "blue")

tsne<-    mytSNE(bt) %>% mutate(text= str_wrap(topicLabels$Label,15), color= cutree(hc, h=0.12))


ggplot(tsne, aes(x= x, y=y, color= factor(color))) +
  geom_text_repel(aes(label= text), segment.alpha= 0, fontface= "bold")  +
  theme_bw() +
  theme(legend.position = "none",
        panel.grid = element_blank()
        ) +
  scale_color_manual(values= brewer.pal(8,"Set2")) +
  labs(title= "Topics in 2-Dimensional Space (tSNE)")

We can see from this that topic 4 is quite a distinct entity, while there are two groups of topics (turquoise and pink) that have empirical commonalities. The dendrogram tells us that toopic 17 actually joins on the periphery of the pink group of topics, while Topics 10 and 7 loosely relate to Topics 5 and 13. In this way we could see the domain of talks breaking down into:

• Broad ideas about AI and what is possible (Topics 5, 7, 9, and 13)
• The intersection of human life and AI (Turquoise topics)
• Interesting applications of AI (Most pink topics 6, 10, 12, 14, 15, 17, 18, 19)
• Applications of Robots (Topic 4)

Clustering Talks based on LDA gamma matrix

One big advantage of the LDA model is that it has two very handy matrices as outputs. The beta matrix we have already used above to relate terms to topics. The gamma matrix relates documents to topics, and so can be used as input to document clustering.

par(mar= c(1,1,1,1)) 
dt<-    mod %>% tidy(matrix = "gamma")  %>% 
               spread(topic,gamma) %>% putZeros() %>%
               select(-document)
hc<-    dt %>% dist() %>% hclust(method= "ward.D") 
plot(hc); rect.hclust(hc, k = 17, border = "blue")

par(mar= c(1,1,1,25))

dend<- hc %>% as.dendrogram() %>%
       set_labels(df$title) %>%
       color_branches(k= 18) %>%
       color_labels(k= 18) %>%
       set("labels_cex", 0.7) %>% plot(horiz= TRUE)

Spatial Representation by Gamma Score

resdf<- mytSNE(dt) %>% mutate(cluster= cutree(hc, k=18), text= str_wrap(df$title, 25))

plot_ly(resdf, x= ~x, y=~y, color= ~factor(cluster),
        hoverinfo = "text",
        text = ~text) %>%
  add_markers(size= 6) %>%
  layout(showlegend= FALSE, 
         title= "TED Talks: Talks tSNE by Gamma Score",
         xaxis = list(title = 'Dimension 1', color= "grey"),
         yaxis = list(title = 'Dimension 2', color= "grey"))

Grouping Talks by Highest Topic Gamma

An alternative method for grouping talks together would be to assign each talk to the topic with which they had the highest gamma score. This means some overlapping information is lost, but helps us sort the talks into categories.

titleRef<- df %>% select(document= ID, title, Year) %>% mutate(document= as.character(document))

dt0<- mod %>% tidy("gamma")
dt2<- dt0 %>% arrange(document, desc(gamma)) %>% group_by(document) %>% slice(1)
dt2<- dt2 %>% left_join(titleRef) %>% left_join(topicLabels)

dt2<- dt2 %>% ungroup() %>% group_by(topic) %>% mutate(Order= order(gamma))

ggplot(dt2, aes(x= gamma, y= factor(Order), group= Label, fill= Label)) +
  geom_col(width=1) +
  geom_text(aes(x= 0.01, y= Order, label= title), hjust= 0, size= 3, fontface= "bold", color= "white") +
  scale_x_continuous(limits = c(0, 1), expand = c(0, 0)) +
  facet_wrap(~Label, scales= "free_y", ncol= 3) +
  theme(legend.position= "none",
        panel.background = element_rect(fill= "grey30"),
        panel.grid = element_blank(),
        strip.background = element_rect(fill= "black"),
        strip.text = element_text(face= "bold", color= "white", size= 10),
        axis.text.y =  element_blank(),
        axis.ticks.y = element_blank()) +
  labs(title= "TED Talks by Topic Cluster", x= "Gamma", y=NULL)

How have talk topics evolved over time?

The analysis below shows how we can gather the gamma scores across the years to show which topics are more prominent, and how this has varied from year to year.

byYear<- dt0 %>% left_join(titleRef) %>% left_join(topicLabels) %>%
  filter(Year!= 2020) %>% group_by(Year,topic, Label) %>% summarise(Sum_gamma= sum(gamma))
yearTotals<- byYear %>% group_by(Year) %>% summarise(total_gamma= sum(Sum_gamma))

trendRef<- data.frame(
  stringsAsFactors = FALSE,
                        topic = c(4L,5L,
                                  2L,6L,8L,9L,11L,12L,7L,10L,13L,14L,1L,
                                  15L,16L,19L,3L,17L,18L),
                        trend = c("Decreasing","Decreasing","Increasing Worm",
                                  "Increasing Worm","Increasing Worm",
                                  "Increasing Worm","Increasing Worm","Lump","Lump","Lump",
                                  "Lump","Lump","Rocky","Rocky","Rocky",
                                  "Rocky","Worm","Worm","Worm"))

byYear<- left_join(byYear, yearTotals) %>% mutate(pc= Sum_gamma/total_gamma) %>% left_join(trendRef)
thetrends<- names(table(trendRef$trend))
for (k in 1:length(thetrends)) {
  sett<- byYear %>% filter(trend==thetrends[k])
g<- ggplot(sett, aes(x= Year, y=pc, fill= Label)) +
  geom_area(aes(group= Label), position= "stack", color= "grey20", size= 0.3, show.legend = TRUE, alpha= 0.7) +
  labs(title= paste("Trend over time:",thetrends[k]), fill= "Topic", y= "Percent of Gamma by Year") +
  theme_bw() +
  ylim(0, 0.7) +
  scale_x_continuous(breaks= unique(byYear$Year)) +
  theme(axis.text.x = element_text(angle= 90))
print(g)  
}

… … …

…