Final project: Text analysis and topic modeling

Metrics: TF, IDF, TF-IDF

One of the first ideas that intuitively comes to mind when trying to identify the most frequently used words by outlet is to count the number of times each word appears in each news outlet. However, this method has significant shortcomings, two of which stand out: the length of documents varies, and the information about meaning does not grow proportionally to the number of occurrences of a word in a document. The result of the raw count is shown in the following graph.

medio_palabras<-corpus_tidy %>%
        group_by(outlet, word) %>%
        summarise(n = n()) %>%
        arrange(desc(n)) %>%
        ungroup()

medio_palabras %>%
        group_by(outlet) %>%
        slice_max(n, n = 10) %>%
        ungroup() %>%
        mutate(word = reorder_within(word, n, outlet)) %>%
        ggplot(aes(n, word, fill = outlet)) +
        geom_col(show.legend = FALSE) +
        facet_wrap(~outlet, ncol = 2, scales = "free") +
        scale_y_reordered()+
        labs(x = "n", y = NULL) +
        theme_minimal()+
        theme(text=element_text(size=16,family="mono",face = "bold"))

Given the limitations of the raw count, I now consider some alternative metrics.

The goal is to find a metric that balances two central dimensions of words: their importance (given by their frequency in a document) and their informativeness with respect to the content of that particular document (given by their presence in a few documents and not all documents in the corpus).

In this case, what I am trying to do is to identify the important and informative words in each news outlet. To achieve this, I introduce the following metrics into the analysis:

• The TF (Term frequency) reflects the importance. It measures the relative frequency of a word in a given document: the number of times the word appears in the document out of the total number of words in the document. In this sense, the TF overcomes one of the shortcomings of the raw count (documents of different sizes) by normalizing it in order to obtain comparable results.

• The IDF (Inverse document frequency) reflects the informativeness. It is calculated as the logarithm of the corpus size (the total number of documents) divided by the number of documents containing the word in question. This metric increases the weight of words that are not widely used (in the corpus) at the expense of commonly used words.

• The TF-IDF combines both metrics, balancing importance and informativeness. It is calculated by multiplying TF by IDF. This metric seeks to identify words that are important (common) and informative (not too common). In short, the TF-IDF metric allows to identify characteristic or distinctive words of a document within a collection of documents (the corpus).

All three metrics can be easily obtained using the bind_tfi_idf() function of tidytext.

library(forcats)

corpus_tf_idf <- medio_palabras %>%
  mutate(outlet=recode(outlet, "Clarin" = "Clarín", "Pagina 12" = "Página 12", "La Nacion" = "La Nación")) %>% 
  bind_tf_idf(word, outlet, n)

library(kableExtra)
kbltfidf1<-kable(head(corpus_tf_idf,20),caption="First 20 rows from table bind_tf_idf") %>%
  row_spec(0,bold=TRUE) %>% 
  kableExtra::kable_classic_2(full_width=TRUE) %>% 
  column_spec(1, bold = T)

kbltfidf1

Looking at the resulting table, one can see a number of words with a high TF and an IDF equal to zero. These are usually very common but not very informative words. If they had not been previously removed, this would be the case of stopwords.

The deficiencies of limiting the analysis of words to their relative frequency are clearly reflected in the following graph, with the 10 words with the highest TF for each news outlet. It is practically impossible to detect relevant differences between each news outlet, given that the words with the highest TF tend to be common and present in the different newspapers: “government” (gobierno), “country” (país), “Argentina”, “national” (nacional), “president” (presidente).

corpus_tf_idf %>%
  group_by(outlet) %>%
        slice_max(tf, n = 10) %>%
        ungroup() %>%
        mutate(word = reorder_within(word, tf, outlet)) %>%
        ggplot(aes(tf, word, fill = outlet)) +
        geom_col(show.legend = FALSE) +
        facet_wrap(~outlet, ncol = 2, scales = "free") +
        labs(x = "tf", y = NULL)+
        scale_y_reordered()+
        theme_minimal()+
        theme(text=element_text(size=16,family="mono",face = "bold"))

As mentioned, this problem can be avoided by using the TF-IDF metric, which balances importance and informativeness. When applied, these words quickly disappear from the ranking. The reason is simple: however high the TF value is, multiplying it by an IDF equal to zero will result in a TF_IDF equal to zero as well.

Final graph using TF-IDF

I now identify the words with the highest TF-IDF for each news outlet:

corpus_tf_idf %>%
  group_by(outlet) %>%
        slice_max(tf_idf, n = 15) %>%
        ungroup() %>%
        ggplot(aes(tf_idf, fct_reorder(word, tf_idf), fill = outlet)) +
        geom_col(show.legend = FALSE) +
        facet_wrap(~outlet, ncol = 2, scales = "free") +
        labs(x = "tf_idf", y = NULL)+
        theme_minimal()+
  theme(text=element_text(size=16,family="mono",face = "bold"))

For the final graph, I take some additional steps such as downloading the color palette I will use, and indicating certain criteria such as the size and font of the text, the size of the graph, etc.

In the case of Perfil and Minuto Uno, certain words head the list (three words in Perfil, and six in Minuto Uno), and many others compete for the next places, so I decided to cut the number of words that appear in those graphs in order to be able to read the labels clearly (with the argument with_ties = FALSE). It is important to note that applying this trimming without a particular criterion, it could also influence how enlightening the graphs themselves are.

corpus_tf_idf<-corpus_tf_idf %>% mutate(outlet=recode(outlet, "Clarin" = "Clarín", "Pagina 12" = "Página 12", "La Nacion" = "La Nación"))
library(tarantino)
p<-tarantino_palette('ReservoirDogs')

library(forcats)

plotpalabras<-corpus_tf_idf %>%
  group_by(outlet) %>%
        slice_max(tf_idf, n = 10,with_ties = FALSE) %>%
        ungroup() %>%
        ggplot(aes(tf_idf, fct_reorder(word, tf_idf), fill = outlet)) +
        geom_col(show.legend = FALSE) +
        facet_wrap(~outlet, ncol = 2, scales = "free") +
        labs(title="Most important and informative words from each news outlet
(highest TF_IDF)",x = "tf-idf", y = NULL) +
        theme_minimal()+
  scale_fill_manual(values = p)+
  theme(plot.title = element_text(family="mono",face = "bold",size = 18,hjust = 0.5),text=element_text(size=15,  family="mono",face = "bold"),strip.text = element_text(size=17,face = "bold",family="mono"))

png("plotpalabras.png",
    units="in", width=10, height=8,res=300)
print(plotpalabras)

plotpalabras

Topic modeling

The next step is to identify the main topics present in the corpus.

The Latent Dirichlet Allocation (LDA) method ⁴ is an algorithm for topic modeling. It presents two central assumptions:

1. Each document is a mixture of topics (i.e., it may contain words from various topics in different proportions).

2. Each topic is a mixture of words (and these may be part of different topics).

Using the LDA method, I will identify the combination of words within each topic and the combination of topics that make up each document.

I load the package that I will use for these next steps.

library(topicmodels)

To perform topic modeling, I create a document term matrix: a matrix where rows correspond to documents; columns, to words; and values, to word counts.

To get to this matrix, I first generate the table with the counts.

word_counts <- corpus_tidy %>%
        group_by(id, word) %>%
        summarise(n=n()) %>%
        ungroup()

I then transform it into a document term matrix (needed by the topicmodels package, which will perform the topic estimation).

disc_dtm <- word_counts %>%
                cast_dtm(id, word, n)

disc_dtm

## <<DocumentTermMatrix (documents: 7000, terms: 96678)>>
## Non-/sparse entries: 1146136/675599864
## Sparsity           : 100%
## Maximal term length: 38
## Weighting          : term frequency (tf)

The resulting matrix has 675,599,864 entries and only 1,146,136 entries are non-zero, so the matrix is almost 100% sparse (basically, the matrix is full of zeros).

This document-term matrix will be the input to the topicmodels package, which will estimate an LDA model. In this case, I instruct it to identify 14 topics.

lda_14 <- LDA(disc_dtm, k=14, control = list(seed = 1234))

I now explore the first 20 terms of each topic.

terms(lda_14,20)

##       Topic 1      Topic 2      Topic 3        Topic 4         Topic 5    
##  [1,] "papa"       "ciudad"     "cristina"     "juez"          "musica"   
##  [2,] "francisco"  "san"        "gobierno"     "causa"         "disco"    
##  [3,] "minutos"    "aires"      "pais"         "kirchner"      "teatro"   
##  [4,] "carrera"    "agua"       "sociales"     "federal"       "banda"    
##  [5,] "final"      "zona"       "clase"        "dinero"        "canciones"
##  [6,] "vaticano"   "metros"     "modelo"       "baez"          "argentina"
##  [7,] "equipo"     "rio"        "politico"     "empresa"       "arte"     
##  [8,] "san"        "nacional"   "presidenta"   "millones"      "mundo"    
##  [9,] "argentina"  "centro"     "justicia"     "cristina"      "publico"  
## [10,] "iglesia"    "manana"     "mundo"        "fiscal"        "cantante" 
## [11,] "partido"    "personas"   "meses"        "justicia"      "cancion"  
## [12,] "manana"     "dias"       "militante"    "denuncia"      "rock"     
## [13,] "mundo"      "vecinos"    "kirchnerismo" "investigacion" "festival" 
## [14,] "argentino"  "semana"     "uber"         "nacional"      "grupo"    
## [15,] "copa"       "arte"       "deberian"     "informacion"   "aires"    
## [16,] "boca"       "provincia"  "relato"       "empresas"      "of"       
## [17,] "viernes"    "obras"      "argentina"    "caso"          "vida"     
## [18,] "encuentro"  "villa"      "opositores"   "pesos"         "apple"    
## [19,] "lunes"      "barrio"     "izquierda"    "gobierno"      "artista"  
## [20,] "comentario" "kilometros" "problemas"    "lopez"         "musical"  
##       Topic 6       Topic 7      Topic 8       Topic 9        Topic 10       
##  [1,] "macri"       "gobierno"   "mundo"       "salud"        "policia"      
##  [2,] "gobierno"    "justicia"   "argentina"   "personas"     "fiscal"       
##  [3,] "presidente"  "presidente" "sistema"     "casos"        "seguridad"    
##  [4,] "frente"      "corte"      "politica"    "hospital"     "mujer"        
##  [5,] "scioli"      "pais"       "vida"        "argentina"    "casa"         
##  [6,] "nacional"    "ley"        "forma"       "ciento"       "victima"      
##  [7,] "provincia"   "derechos"   "sociedad"    "enfermedad"   "hombre"       
##  [8,] "candidato"   "camara"     "social"      "pais"         "causa"        
##  [9,] "mauricio"    "brasil"     "pais"        "riesgo"       "manana"       
## [10,] "elecciones"  "judicial"   "educacion"   "nacional"     "joven"        
## [11,] "jefe"        "caso"       "personas"    "pacientes"    "justicia"     
## [12,] "cristina"    "juicio"     "universidad" "desarrollo"   "federal"      
## [13,] "politica"    "argentina"  "informacion" "ministerio"   "investigacion"
## [14,] "gobernador"  "tribunal"   "sociales"    "enfermedades" "crimen"       
## [15,] "ministro"    "nacional"   "tecnologia"  "vida"         "caso"         
## [16,] "kirchner"    "politico"   "desarrollo"  "estudio"      "detenido"     
## [17,] "pro"         "juez"       "internet"    "caso"         "ciudad"       
## [18,] "pais"        "fiscal"     "paises"      "medico"       "tarde"        
## [19,] "electoral"   "jueces"     "gente"       "tratamiento"  "muerte"       
## [20,] "oficialismo" "proceso"    "cambio"      "cancer"       "zona"         
##       Topic 11     Topic 12      Topic 13   Topic 14       
##  [1,] "millones"   "trump"       "vida"     "pais"         
##  [2,] "argentina"  "mujeres"     "historia" "presidente"   
##  [3,] "gobierno"   "unidos"      "libro"    "gobierno"     
##  [4,] "ciento"     "clinton"     "mundo"    "unidos"       
##  [5,] "economia"   "violencia"   "casa"     "paises"       
##  [6,] "dolares"    "campana"     "mujer"    "personas"     
##  [7,] "pais"       "personas"    "hombre"   "acuerdo"      
##  [8,] "mercado"    "mujer"       "gente"    "seguridad"    
##  [9,] "precios"    "donald"      "amor"     "guerra"       
## [10,] "pesos"      "mundo"       "familia"  "siria"        
## [11,] "inflacion"  "genero"      "pelicula" "refugiados"   
## [12,] "sector"     "hillary"     "obra"     "paz"          
## [13,] "banco"      "sexual"      "libros"   "fuerzas"      
## [14,] "empresas"   "pais"        "cine"     "obama"        
## [15,] "aumento"    "hombres"     "paso"     "mundo"        
## [16,] "central"    "presidente"  "novela"   "cuba"         
## [17,] "meses"      "republicano" "madre"    "ministro"     
## [18,] "deuda"      "york"        "hijos"    "grupo"        
## [19,] "acuerdo"    "democrata"   "hijo"     "internacional"
## [20,] "produccion" "partido"     "mujeres"  "europa"

To analyze the distribution of words for each topic, I apply the tidy() function, which generates a one-topic-word-per-row format: for each possible combination, it estimates the probability of that word being generated from that topic (probability called “beta”).

ap_topics <- tidy(lda_14, matrix = "beta")
ap_topics<-ap_topics %>%
  mutate(beta = round(beta, 5))
ap_topics

## # A tibble: 1,353,492 × 3
##    topic term       beta
##    <int> <chr>     <dbl>
##  1     1 acelero 0.00002
##  2     2 acelero 0      
##  3     3 acelero 0      
##  4     4 acelero 0.00002
##  5     5 acelero 0      
##  6     6 acelero 0.00001
##  7     7 acelero 0      
##  8     8 acelero 0.00003
##  9     9 acelero 0.00002
## 10    10 acelero 0.00006
## # ℹ 1,353,482 more rows

From this process, I identify the 15 most common words within each topic.

ap_top_terms <- ap_topics %>%
  group_by(topic) %>%
  slice_max(beta, n = 15) %>% 
  ungroup() %>%
  arrange(topic, -beta)

plottopicos<-ap_top_terms %>%
  mutate(term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(beta, term, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales='free') +
  scale_y_reordered() +
        labs(title="Topics identified with LDA",y = "term") +
        theme_minimal()+
  scale_fill_manual(values = c(p,"#245C59","#707B5D","#696E68","#D7DA4C","#015c89","#B6523B","#8A7A23"))+
  theme(plot.title = element_text(family="mono",face = "bold",size = 18,hjust = 0.5),text=element_text(size=15,  family="mono",face = "bold"),strip.text = element_text(size=17,face = "bold",family="mono"))


plottopicos

png("plottopicos.png",
    units="in", width=10, height=10,res=300)
print(plottopicos)

I proceed to label -to the extent possible- each topic:

• 1. Football/sports
• 2. Services and public spaces/urbanism
• 3. National politics
• 4. Legal cases/corruption
• 5. Culture: focus on music and theater, shows, etc.
• 6. Elections
• 7. Politics of Latin American countries
• 8. Development/education/technology
• 9. Health
• 10. Insecurity
• 11. Economy
• 12. International news
• 13. Culture: focus on cinema and literature (+ broad topics such as love, life, family)
• 14. International politics with a focus on conflicts/war/terrorism

I want to confirm if the difference I drew between topic 12 and 14 is correct. For this, I identify and visualize the words that have the largest difference in beta between the two topics. To narrow it down to meaningful words, I filter out words with a beta of 2/1000 in at least one topic (i.e., that their usage is relatively common).

beta_wide <- ap_topics %>%
  mutate(topic = paste0("topic", topic)) %>%
  pivot_wider(names_from = topic, values_from = beta) %>% 
  filter(topic12 > .002 | topic14 > .002) %>%
  mutate(log_ratio12_14 = log2(topic12 / topic14))

plotdif<-beta_wide %>%
  mutate(pos = log_ratio12_14 >= 0) %>% 
  ggplot(aes(x=reorder(term,log_ratio12_14) , y=log_ratio12_14, fill=pos)) +
    geom_col(show.legend = FALSE) +
    coord_flip() +
    labs(x='term',
         y='Log2 ratio topic14/topic12') +
        theme_minimal()+
  scale_fill_manual(values = c("#245C59","#B6523B"))+
  theme(plot.title = element_text(family="mono",face = "bold",size = 18,hjust = 0.5),text=element_text(size=15,  family="mono",face = "bold"))

png("plotdif.png",
    units="in", width=10, height=5,res=300)
print(plotdif)

plotdif

In topic 14, words related to international conflicts stand out, such as “Syria”, “France” -remember the attacks in France during this period-, “refugees”, “forces”, “security”, “war” and “peace”. In topic 12, this is the case for terms linked to US domestic politics (“hillary”, “trump”, “clinton”, “republican” -remember Trump’s victory in 2016-), to the church (“vatican”, “pope”, “church”, “francisco”) and to gender issues (“gender”, “women” and -possibly- “sexual”? ⁵).

Topic composition by news outlet

In the previous section, the analysis was guided by the first premise of LDA: each topic is a mixture of words. This section focuses on the second: each document is a mixture of topics.

I seek to identify the topic composition of each news outlet.

I calculate the probabilities per document per topic (denoted “gamma”) with the following code. These values reflect the estimated proportion of the words in a certain document that are generated from a certain topic.

doc_2_topics1 <- tidy(lda_14, matrix = "gamma")
doc_2_topics1<-doc_2_topics1 %>%
  mutate(gamma = round(gamma, 5))
doc_2_topics1

## # A tibble: 98,000 × 3
##    document topic   gamma
##    <chr>    <int>   <dbl>
##  1 92           1 0.00019
##  2 132          1 0.00009
##  3 250          1 0.00003
##  4 346          1 0.00008
##  5 455          1 0.00029
##  6 465          1 0.00012
##  7 489          1 0.00005
##  8 502          1 0.00008
##  9 508          1 0.00009
## 10 534          1 0.00023
## # ℹ 97,990 more rows

I examine the composition of topics of each news outlet from the generated gamma matrix.

Then I apply a left_join with the corpus ⁶.

I calculate the average gamma for each topic for each outlet.

doc_2_topics<-doc_2_topics1 %>%
  rename(id = document) %>%
  mutate(id = as.integer(id)) %>%
  left_join(corpus %>% select(id, outlet) %>% unique()) %>%
  group_by(outlet, topic) %>%
  summarise(mean = mean(gamma)*100)

doc_2_topics<-doc_2_topics %>% mutate(outlet=recode(outlet, "Clarin" = "Clarín", "Pagina 12" = "Página 12", "La Nacion" = "La Nación"))

etiq<-c("Football/sports", "Services and public spaces/urbanism","National politics","Legal cases/corruption","Culture: focus on music and theater","Elections","Politics of Latin American countries","Development/education/technology","Health","Insecurity","Economy","International news","Culture: focus on cinema and literature", "International conflicts")

plottop<-doc_2_topics %>%
  ggplot(aes(factor(topic), mean,fill=factor(topic)))+  
  geom_col() +
  facet_wrap(~ outlet,ncol = 4) +
  labs(y = "mean")+
        labs(title="Topics composition by news outlet") +
        theme_minimal()+
  scale_fill_manual(values = c(p,"#245C59","#707B5D","#696E68","#D7DA4C","#015c89","#B6523B","#8A7A23"),name = "Topic", labels=etiq)+
  theme(plot.title = element_text(family="mono",face = "bold",size = 24,hjust = 0.5),text=element_text(size=13,  family="mono",face = "bold"),strip.text = element_text(size=13,face = "bold",family="mono"),panel.spacing = unit(2, "lines"),legend.text = element_text(size=13),legend.title = element_text(size=13))

plottop

png("plottop.png",
    units="in", width=18, height=11,res=300)
print(plottop)

An alternative way to visualize the topics composition by news outlet is the following:

plottop2<-doc_2_topics %>%
  ggplot(aes(factor(outlet), mean,fill=factor(topic),label=round(mean)))+  
  geom_bar(position="stack", stat="identity") +
  geom_text(size = 5,color="white",face="bold", position = position_stack(vjust = 0.5)) +
  labs(x = "outlet", y = "mean")+
        labs(title="Topics composition by news outlet") +
        theme_minimal()+
  scale_fill_manual(values = c(p,"#245C59","#707B5D","#696E68","#D7DA4C","#015c89","#B6523B","#8A7A23"),name = "Topic", labels=etiq)+
  theme(plot.title = element_text(family="mono",face = "bold",size = 24,hjust = 0.5),text=element_text(size=12,  family="mono",face = "bold"),axis.text.x = element_text(angle = 30, size=13,  family="mono",face = "bold",color="black"),strip.text = element_text(size=13,face = "bold",family="mono"),panel.spacing = unit(2, "lines"),legend.text = element_text(size=13),legend.title = element_text(size=13))


plottop2

png("plottop2.png",
    units="in", width=18, height=11,res=300)
print(plottop2)

Trends over time

Finally, I am interested in analyzing the evolution of topics over time.

I apply a left_join with the corpus, where the variable date appears.

doc_2_topicstemp<-doc_2_topics1 %>%
  rename(id = document) %>%
  mutate(id = as.integer(id)) %>%
  left_join(corpus %>% select(id, fecha) %>% unique()) %>%
  group_by(fecha, topic) %>%
  summarise(mean = mean(gamma)*100)

I explore and visualize the evolution of the average gamma for each topic for each date, applying geom_smooth() to discard noise and reveal the trend.

plottemp<-ggplot(doc_2_topicstemp, aes(x = fecha, y = mean, color=factor(topic))) + 
  geom_smooth(size=2)+
  scale_color_manual(values = c(p,"#245C59","#707B5D","#696E68","#D7DA4C","#015c89","#B6523B","#8A7A23"),name = "Topic", labels=etiq) +
  facet_wrap(~topic, ncol = 3, scales = "free_y")+
  labs(x = "date", y = "mean")+
  labs(title="Trends over time") + 
  scale_x_date(date_labels = "%b-%y",date_breaks  ="3 month")+
  theme_minimal()+
  theme(plot.title = element_text(family="mono",face = "bold",size = 25,hjust = 0.5),text=element_text(size=17,  family="mono",face = "bold"),strip.text = element_text(size=19,face = "bold",family="mono"),panel.spacing = unit(2, "lines"),legend.text = element_text(size=14),legend.title = element_text(size=15),axis.text.x = element_text(angle = 45, hjust = 1.1,size=10,family="mono",face = "bold",color="black"))

plottemp

d=data.frame(date=as.Date(c("2015-08-09", "2015-10-25", "2015-11-22")), evento=c("Primary elections", "Presidential elections", "Ballotage"))

plottempelecc<-ggplot(data=filter(doc_2_topicstemp,topic==6), aes(x = fecha, y = mean)) + 
  geom_smooth(size=2,color="#245C59")+
  labs(x = "date", y = "mean")+
  labs(title="Evolution of the topic 'elections' over time",legend=FALSE) + 
  scale_x_date(date_labels = "%b-%y",date_breaks  ="3 month")+
  theme_minimal()+
  theme(plot.title = element_text(family="mono",face = "bold",size = 25,hjust = 0.5),text=element_text(size=17,  family="mono",face = "bold"),strip.text = element_text(size=19,face = "bold",family="mono"),panel.spacing = unit(2, "lines"),axis.text.x = element_text(angle = 45, hjust = 1.1,size=10,family="mono",face = "bold",color="black"))+
  geom_vline(data=d,mapping=aes(xintercept=date), linetype=2, colour='black')+
geom_text(data=d, mapping=aes(x=date, y=12, label=evento), size=6, color="black", angle=90, vjust=-0.4, hjust=0)

plottempelecc