HP OEM - Topic Model Comparison

Overview

Our implementation of latent Dirichlet allocation with Gibbs sampling is up and running on the HP Brandwatch query. There is more cleaning of the dataset, i.e. more stopwords to include, but this serves as POC.

Metaphor for LDA

Introduction to Latent Dirichlet Allocation (scroll down to ‘Layman’s Explanation’ section).

Overview of Brandwatch Query

Original Dataset:

• Size: >600MB
• Documents: >180,000

Since this is too large of a dataset, I only selected domains that appear more than 18 times in the query and took the top 10 most recent articles from each of the domains.

Subsetted Dataset:

• Size: >30MB
• Documents: >5,000

Comparison of Documents

library(tidytext)
library(tidyverse)
library(stringr)
library(readxl)
library(quanteda)
library(topicmodels)
library(ggplot2)
data("stop_words")
source("custom_functions.R")

load("output/hp_models.RData")

doc_tops_lda <- tidy(hp_lda, matrix = "gamma") %>%
    group_by(document) %>%
    top_n(1, gamma)
doc_tops_gibbs <- tidy(hp_gibbs, matrix = "gamma") %>%
    group_by(document) %>%
    top_n(1, gamma)
doc_tops <- bind_rows(list("LDA" = doc_tops_lda, "Gibbs" = doc_tops_gibbs), .id = "Model")

The problem we had using LDA before is that it lumped documents mostly into one topic. As you can see in the chart below, the topics are more distinct and separated when using Gibbs sampling. This makes intuitive sense to me given that we are essentially telling Brandwatch to look at one topic.

ggplot(doc_tops, aes(x=topic)) +
    #geom_histogram(bins=20) +
    geom_bar(aes(fill = topic)) +
    #scale_fill_discrete(palette = "Blues") +
    facet_grid(Model~.) +
    labs(title = "Distribution of Documents into Topics by Model",
         x = "Topic Number (1-20)",
         y = "Number of Documents")

Top Terms by Topic

Gibbs Model

Below is a chart of top topics. Right now the most “popular” topics are 3, 11, 12, 16, and 19. But looking at these topics tells me I have to adjust the stopwords list for the next iteration.

hp_topics_gibbs <- tidy(hp_gibbs, matrix = "beta")
hp_top_terms_gibbs <- hp_topics_gibbs %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)
hp_top_terms_gibbs %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() +
  labs(title = "Gibbs: Top 10 Terms for Each Topic",
       y = "term score (beta)" )

chart.name <- paste("Gibbs_","top-10-words_",topics,"-topics_",today,".png",sep = "")
ggsave(file.path("charts",chart.name), width = 14, height = 10)

LDA Model

Just for reference, here is are the top terms for each topic using basic LDA. Topic 13 is the winner here which overlaps a lot with Gibb’s Topic 3.

hp_topics_lda <- tidy(hp_lda, matrix = "beta")
hp_top_terms_lda <- hp_topics_lda %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)
hp_top_terms_lda %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() +
  labs(title = "LDA - Top 10 Terms for Each Topic",
       y = "term score (beta)" )

chart.name <- paste("LDA_","top-10-words_",topics,"-topics_",today,".png",sep = "")
ggsave(file.path("charts",chart.name), width = 14, height = 10)