Actividad 4. Modelado de Tópicos
Javier Adolfo Carrillo Romero
2023-11-22
Universidad: ITESM
Carrera: Licenciatura en Gobierno y Transformación Pública (LTP)
Materia: Ciencia de Datos II
Profesor(es): René Rosado González, Yuritzi Paola Enríquez Caballero
Modelado de Tópicos
El objetivo de esta actividad es aplicar modelado de tópicos utilizando LDA y STM para identificar los temas preponderantes en los dos debates de las candidatas a la presidencia del Estado de México (2023-2029).
Limpieza de texto
En esta parte se cargan e instalan las bibliotecas necesarias para el análisis de texto y la manipulación de datos.
En esta parte, se realiza la limpieza y preparación de los datos del primer debate. Se leen las líneas del archivo de texto, se convierten en un tibble, se extraen nombres propios como doc_id, se eliminan filas vacías y se seleccionan los candidatos presidenciales.
Después se realiza una limpieza similar para el segundo debate, incluyendo la lectura de un archivo Excel y la selección de los candidatos presidenciales.
rm(list = ls()) # Clears variable environment
cat("\014") # Clears consolesetwd("/Users/javier94231/Desktop/Ciencia de Datos 2")
# Instalar - Cargar tidyverse
if(require(tidyverse) == FALSE){
install.packages('tidyverse')
library(tidyverse)
}else{
library(tidyverse)
}## Loading required package: tidyverse## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.4.2 ✔ tibble 3.2.1
## ✔ lubridate 1.9.2 ✔ tidyr 1.3.0
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors# Instalar - Cargar rvest
if(require(rvest) == FALSE){
install.packages('rvest')
library(rvest)
}else{
library(rvest)
} ## Loading required package: rvest
##
## Attaching package: 'rvest'
##
## The following object is masked from 'package:readr':
##
## guess_encoding# Instalar - Cargar tidytext
if(require(tidytext) == FALSE){
install.packages('tidytext')
library(tidytext)
}else{
library(tidytext)
} ## Loading required package: tidytextif(require(readxl) == FALSE){
install.packages('readxl')
library(readxl)
}else{
library(readxl)
}## Loading required package: readxl# Instalar - Cargar stringi
if(require(stringi) == FALSE){
install.packages('stringi')
library(stringi)
}else{
library(stringi)
} ## Loading required package: stringi# Instalar - Cargar stringi
if(require(tidyr) == FALSE){
install.packages('tidyr')
library(tidyr)
}else{
library(tidyr)
}
if(require(ggplot2) == FALSE){
install.packages('ggplot2')
library(ggplot2)
}else{
library(ggplot2)
}
if(require(dplyr) == FALSE){
install.packages('dplyr')
library(dplyr)
}else{
library(dplyr)
}
# Instalar - Cargar tm
if(require(tm) == FALSE){
install.packages('tm')
}## Loading required package: tm
## Loading required package: NLP
##
## Attaching package: 'NLP'
##
## The following object is masked from 'package:ggplot2':
##
## annotate##### Primer debate
pdebate <- read_lines("primer_debate_edomex.txt")
# Transforma el resultado en un tibble columna para poder manipularlo
pdebate = pdebate %>%
# Nombre la columna como texto
as_tibble_col(column_name = "text")
# Revisa como luce el tibble
head(pdebate)## # A tibble: 6 × 1
## text
## <chr>
## 1 "Ana Paula Ordorica: Qué tal Muy buenas noches Bienvenidos a este debate del …
## 2 ""
## 3 "Delfina Gómez: muy amable gracias buenas noches a todas a todos ustedes pues…
## 4 ""
## 5 "Ana Paula Ordorica: Muchísimas gracias candidata Delfina Gómez ahora el mens…
## 6 ""# Crea una columna llamada doc_id
pdebate = pdebate %>%
# Extrae el patrón del comienzo de oración seguido por uno o más nombres propios
mutate(doc_id = str_extract(text, "^[A-ZÁÉÍÓÚÑÜ]\\w+ [A-ZÁÉÍÓÚÑÜ][[A-ZÁÉÍÓÚÑÜ]\\w ]+[:,]"))
# Elimina las filas en las que la columna "texto" está vacía
pdebate <- pdebate %>%
filter(!is.na(text) & text != "")
# Llena los datos "NA" de la columna "doc_id" con "Alejandra del Moral"
pdebate <- pdebate %>%
mutate(doc_id = ifelse(is.na(doc_id), "Alejandra del Moral:", doc_id))
# Selecciona únicamente a los y la presidenciables
pcandidatas = pdebate %>%
# Filtra de manera tal que exluyas al y las presentadores
filter(!doc_id %in% c("Ana Paula Ordorica:"))
##### Segundo debate
sdebate <- read_excel("Segundo_debate_edomex.xlsx")
# Revisa como luce el tibble
head(sdebate)## # A tibble: 6 × 2
## interlocutores text
## <chr> <chr>
## 1 Gina Arely Valencia Alcántara muy buenas noches bienvenidas Bienvenidos a est…
## 2 Alejandra del Moral Muchas gracias Gina muy buenas noches Hoy tenem…
## 3 Gina Arely Valencia Alcántara gracias candidata comentar que el comité especi…
## 4 Alejandra del Moral Gracias Gina pues miren estoy consciente de que…
## 5 Gina Arely Valencia Alcántara Muchas gracias candidata Ahora toca el turno de…
## 6 Delfina Gómez Gracias efectivamente Seguridad y Justicia es u…# Transforma el resultado en un tibble columna para poder manipularlo
sdebate$doc_id <- sdebate$interlocutores
sdebate <- sdebate[, -which(names(sdebate) == "interlocutores")]
# Selecciona únicamente a los y la presidenciables
scandidatas = sdebate %>%
# Filtra de manera tal que exluyas al y las presentadores
filter(!doc_id %in% c("Gina Arely Valencia Alcántara"))
#### df con ambos debates
ambosd <- merge(pcandidatas, scandidatas, all=TRUE)
# Utilizando nuestro tibble
ambosd = ambosd %>%
# Homologa los nombres de las personas y organizaciones aludidas
mutate(
# Actualiza la columna doc_id eliminando ":"
doc_id = gsub(":", "", doc_id),
# Andrés_Manuel_López_Obrador
text = stri_replace_all_regex(text, "Delfina Gómez", "Delfina_Gómez"),
# José_Antonio_Meade_Kuribreña
text = stri_replace_all_regex(text, "Alejandra del Moral", "Alejandra_del_Moral")
)Bigramas
En esta sección, se crean bigramas y se filtran para excluir palabras vacías y patrones no deseados. También se crea un diccionario de monogramas a partir de los se usan para reemplazar los bigramas en el texto.
# Bigramas ----------------------------------------------------------------
palabras_vacias = c(stopwords::stopwords('es',source = 'stopwords-iso'),
"ser", "pues", "claro", "tres", "mira", "pueda", "puedan", "hacer",
"efectivamente", "mil", "tema", "quién", "entonces", "gracias", "cada",
"ello", "aquí", "siguiente", "después", "gina", "doce")
# Crear un diccionario para bigramas
bigramas = ambosd %>%
unnest_tokens(
input = text,
output = "bigrama",
token = "ngrams",
n = 2
) %>%
count(bigrama, sort = T) %>%
separate(bigrama, c('palabra_1', 'palabra_2'), sep = ' ') %>%
filter(
!palabra_1 %in% palabras_vacias,
!palabra_2 %in% palabras_vacias,
palabra_1 != palabra_2
) %>%
transmute(
bigrama = paste(palabra_1, palabra_2, sep = ' '),
monograma = paste(palabra_1, palabra_2, sep = '_'),
n = n
) %>%
filter(
n > 2,
!str_detect(bigrama, '\\d')
)
# Crear un diccionario de monogramas
monogramas = pull(bigramas, monograma)
names(monogramas) = pull(bigramas, bigrama)
# Remplazar bigramas
ambosd = ambosd %>%
mutate(text = str_remove_all(text, monogramas))Lematización
En esta parte, se realiza la lematización del texto.
# Lematización ------------------------------------------------------------
# Instalar - Cargar udpipe
if(require(udpipe) == FALSE){
install.packages('udpipe')
library(udpipe)
}else{
library(udpipe)
} ## Loading required package: udpipe# Construcción de lemas
lemmas = udpipe(
x = pull(ambosd, text),
object = 'spanish',
parallel.cores = 7
)Tokenización
Aquí se realiza la tokenización del texto lematizado, filtrando palabras según ciertos criterios (por ejemplo, longitud mínima, tipo de palabra) y calculando el peso de términos utilizando tf-idf. Finalmente se crea una matriz de documentos y términos a partir de los datos tokenizados.
# Tokenización ------------------------------------------------------------
ambosd_tokens = lemmas %>%
filter(
!upos %in% c('SCONJ','CCONJ','SYM','NUM','INTJ','VERB','X'),
!is.na(upos),
!lemma %in% palabras_vacias,
nchar(lemma) > 2,
!str_detect(lemma, '[:digit:]|[:punct:]')
) %>%
with_groups(
.groups = doc_id,
summarise,
text = str_c(token, collapse = ' ')
) %>%
unnest_tokens(
input = text,
output = palabra,
token = 'words'
) %>%
filter(
!palabra %in% palabras_vacias,
!str_detect(palabra, '[:digit:]|[:punct:]'),
nchar(palabra) > 2
) %>%
count(doc_id, palabra) %>%
bind_tf_idf(term = palabra, document = doc_id, n = n)
# Matriz de documentos y términos
ambosd_dtm = ambosd_tokens %>%
cast_dtm(
document = doc_id,
term = palabra,
value = n,
weighting = tm::weightTf
) Modelado de Tópicos LDA (Latent Dirichlet Allocation)
En esta sección, se realiza el modelado de tópicos utilizando el algoritmo Latent Dirichlet Allocation (LDA) con 5 tópicos. Al final se extrae la relación entre tópicos y documentos a través de la matriz gamma del modelo LDA.
###### Latent Dirichlet Allocation ----------------------------------------
if(require(topicmodels) == FALSE){
install.packages('topicmodels')
library(topicmodels)
}else{
library(topicmodels)
} ## Loading required package: topicmodelsmodelo_lda = LDA(
x = ambosd_dtm,
k = 5,
method = 'Gibbs',
control = list(seed = 123)
)
print(modelo_lda) ## A LDA_Gibbs topic model with 5 topics.# Relación Tópico - Documento
gamma_lda = tidy(modelo_lda, matrix = 'gamma')Visualizaciones del modelo LDA
A continuación se muestran los gráficos resultantes de este modelo de tópicos.
Gráfico gamma
Este gráfico muestra el cálculo de la probabilidad de los tópicos para cada intervención de las candidatas.
grafico_gamma = gamma_lda %>%
ggplot(
aes(
x = gamma,
y = reorder_within(document, topic, gamma)
)
) +
geom_col(fill = 'gray80') +
geom_text(
aes(label = document, x = 0.00001),
col = 'gray10', hjust = 'left'
) +
facet_wrap(~topic, scales = 'free_y', ncol = 5) +
scale_x_continuous(expand = c(0,0)) +
theme_bw(base_size = 8) +
theme(
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(family = 'Arial')
)
print(grafico_gamma)
Gráfico beta
En este gráfico se muestran las palabras preponderantes por cada uno de los tópicos.
########### Gráfico beta ---------------
# Relación Tópico - Palabra
beta_lda = tidy(modelo_lda, matrix = 'beta')
grafico_beta = beta_lda %>%
group_by(topic) %>%
top_n(beta, n = 15) %>%
ggplot(
aes(
x = beta,
y = reorder_within(term, beta, topic)
)
) +
geom_col(fill = 'gray80') +
geom_text(
aes(label = term, x = 0.00001),
col = 'gray10', hjust = 'left'
) +
facet_wrap(~topic, scales = 'free_y', ncol = 5) +
scale_x_continuous(expand = c(0,0)) +
theme_bw(base_size = 8) +
theme(
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(family = 'Arial')
)
print(grafico_beta)
Gráficos de gammas y betas
Combina los gráficos de grafico_beta y grafico_gamma para mostrarlos en un solo espacio.
if(require(patchwork) == FALSE){
install.packages('patchwork')
library(patchwork)
}else{
library(patchwork)
} ## Loading required package: patchworkgrafico_beta / grafico_gamma
Modelo Estructural de Tópicos (STM)
EL primer paso después de cargar las librerías es el preprocesamiento de datos, en la que se usa la función textProcessor para procesar los documentos, eliminando palabras vacías, convirtiendo a minúsculas, etc.Deespués se usa la función prepDocuments para preparar los documentos para el modelo estructural. Finalmente se construye el modelo estructural de tópicos usando la funcion stm.
Se seleccionaron 10 tópicos, pues son adecuados para comparar los temás que se trataron en el debate (hubo alrededor de 5 temas distintos abordados en cada debate).
# Modelo Estructural de Tópicos -------------------------------------------
# Install - stm
if(require(stm) == FALSE){
install.packages('stm')
library(stm)
}else{
library(stm)
} ## Loading required package: stm## stm v1.3.6.1 successfully loaded. See ?stm for help.
## Papers, resources, and other materials at structuraltopicmodel.comif(require(geometry) == FALSE){
install.packages('geometry')
library(geometry)
}else{
library(geometry)
} ## Loading required package: geometryif(require(rsvd) == FALSE){
install.packages('rsvd')
library(rsvd)
}else{
library(rsvd)
} ## Loading required package: rsvdif(require(Rtsne) == FALSE){
install.packages('Rtsne')
library(Rtsne)
}else{
library(Rtsne)
} ## Loading required package: Rtsne# Predatos de los datos
datos <- textProcessor(
documents = pull(ambosd, text),
metadata = ambosd,
language = "es",
stem = FALSE,
removepunctuation = FALSE,
lowercase = TRUE,
removestopwords = TRUE,
removenumbers = TRUE,
wordLengths = c(3, Inf),
customstopwords = palabras_vacias
)## Building corpus...
## Converting to Lower Case...
## Removing stopwords...
## Remove Custom Stopwords...
## Removing numbers...
## Creating Output...# Preparar documentos
outd <- prepDocuments(
documents = pluck(datos, 'documents'),
vocab = pluck(datos, 'vocab'),
meta = pluck(datos, 'meta'),
lower.thresh = nrow(ambosd) * 0.05,
upper.thresh = nrow(ambosd) * 0.95
)## Removing 1943 of 2334 terms (2349 of 4283 tokens) due to frequency
## Your corpus now has 40 documents, 391 terms and 1934 tokens.# Modelo estructural
modelo_stmd <- stm(
documents = pluck(outd, 'documents'),
vocab = pluck(outd, 'vocab'),
data = pluck(outd, 'meta'),
prevalence = ~ doc_id + text,
content = ~ doc_id,
K = 10,
max.em.its = 10000,
init.type = "Spectral",
seed = 123,
gamma.prior = 'L1'
)## Beginning Spectral Initialization
## Calculating the gram matrix...
## Finding anchor words...
## ..........
## Recovering initialization...
## ...
## Initialization complete.
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 1 (approx. per word bound = -5.206)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 2 (approx. per word bound = -5.115, relative change = 1.740e-02)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 3 (approx. per word bound = -5.072, relative change = 8.499e-03)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 4 (approx. per word bound = -5.041, relative change = 6.063e-03)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 5 (approx. per word bound = -5.031, relative change = 1.975e-03)
## Topic 1: universidades, investigación, desarrollo
## Topic 2: transparencia, papel, transparente, propuestas, público
## Topic 3: partido, mentiras, gente, género, único
## Topic 4: fuentes, río, lerma, cuidado, rehabilitar
## Topic 5: feminicidios, policías, ministerios_públicos, equipamiento, policía
## Topic 6: dinero, combate, transparencia, corrupción, públicos
## Topic 7: transporte, elección, partido, vive, ciudadanos
## Topic 8: maestros, estudiantes, educativa, docentes, fortaleceremos
## Topic 9: esperanza, histórica, junio, opciones, noches
## Topic 10: campo, turismo, nacional, empresas, mano
## Aspect 1: alejandra_del_moral:, delfina, gobernadora, salario, temas
## Aspect 2: delfina_gómez:, necesario, lamentablemente, amable, proceso
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 6 (approx. per word bound = -5.021, relative change = 2.038e-03)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 7 (approx. per word bound = -5.019, relative change = 4.318e-04)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 8 (approx. per word bound = -5.010, relative change = 1.789e-03)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Completing Iteration 9 (approx. per word bound = -4.999, relative change = 2.067e-03)
## ........................................
## Completed E-Step (0 seconds).
## ..................................................................................................................................
## Completed M-Step.
## Model ConvergedVisualizaciones del modelo STM
A continuación se muestran los gráficos resultantes de este modelo de tópicos.
Histograma de la relación tópico-documento.
# Histograma de relación tópico documento
plot(modelo_stmd, type = "hist", main = "Relación tópico-documento")
Términos más relevantes por tópico.
# Principales términos
plot(modelo_stmd, type = "labels", main = "Términos más relevantes",
topics = c(9, 10))
Gráficos de comparación de tópicos.
Aquí se comparan la relación que existen entre dos distintos tópicos y la preponderancia del tópico (en este caso, de dos tópicos) para ambas candidatas.
########### Graficas de comparación de tópicos ---------------
# Comparar 2 tópicos por candidata
plot(modelo_stmd, type = "perspectives", topics = c(1, 4))
# Comparar 2 tópicos por candidata
plot(modelo_stmd, type = "perspectives", topics = c(3, 5))
# Comparar tópicos por candidata
plot(modelo_stmd, type = "perspectives", topics = 2)
# Comparar tópicos por candidata
plot(modelo_stmd, type = "perspectives", topics = 9)
Puntos de correlación entre tópicos.
Muestra en dos dimensiones, la distancia que existe de un tópico a otro.
# Correlación del tópico
mod.out.corr <- topicCorr(model = modelo_stmd)
plot(mod.out.corr)
Probabilidad tópico-documento
Se muestra un correlograma que compara la relación de los 10 tópicos.
# Probabilidad tópico-documento
gammas <- tidy(modelo_stmd, matrix = 'gamma')
# Correlograma
if (!require(GGally)) {
install.packages('GGally')
}## Loading required package: GGally## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2########### Grafico de correlación entre tópicos ---------------
gammas %>%
spread(key = topic, value = gamma) %>%
select(-document) %>%
cor() %>%
GGally::ggcorr(label = TRUE, label_size = 1.5)
Gráfico ternario
Este gráfico muestra la distancia de correlación entre 3 tópicos. Como se puede ver, los tópicos 5 y 10 están más correlacionados que el tópico 2.
# Gráficos ternarios
if (!require(ggtern)) {
install.packages('ggtern')
library(ggtern)
}## Loading required package: ggtern## Registered S3 methods overwritten by 'ggtern':
## method from
## grid.draw.ggplot ggplot2
## plot.ggplot ggplot2
## print.ggplot ggplot2## --
## Remember to cite, run citation(package = 'ggtern') for further info.
## --##
## Attaching package: 'ggtern'## The following object is masked from 'package:NLP':
##
## annotate## The following objects are masked from 'package:ggplot2':
##
## aes, annotate, ggplot, ggplot_build, ggplot_gtable, ggplotGrob,
## ggsave, layer_data, theme_bw, theme_classic, theme_dark,
## theme_gray, theme_light, theme_linedraw, theme_minimal, theme_void########### Grafico ternario ---------------
gammas %>%
spread(key = topic, value = gamma, sep = '_') %>%
ggtern(aes(x = topic_2, y = topic_5, z = topic_10)) +
theme_showarrows() +
stat_density_tern(
aes(
fill = after_stat(level),
alpha = after_stat(level)
),
bdl = 0.1,
geom='polygon',
show.legend = FALSE
) +
geom_point(alpha = 0.5) +
labs(
x = 'Tópico 2',
y = 'Tópico 5',
z = 'Tópico 10',
title = 'Debate por la presidencia del Estado de México 2023-2029',
subtitle = 'Modelo de Tópicos Correlacionados'
)## Warning: Removed 23 rows containing non-finite values (`StatDensityTern()`).
Gráfico de dispersión
Este gráfico sirve para ver la dispersión de correlación entre dos tópicos.
# Visualizar correlación entre dos tópicos
gammas %>%
spread(key = topic, value = gamma, sep = '_') %>%
ggplot(aes(x = topic_1, y = topic_7)) +
geom_point() +
scale_y_continuous(
breaks = c(0.001, 0.01,0.1,0.5),
labels = scales::percent
) +
scale_x_continuous(
breaks = c(0.001, 0.01,0.1,0.5),
labels = scales::percent
) +
labs(
x = 'Tópico 1',
title = 'Correlación entre tópicos',
subtitle = 'Tópico 7'
) +
coord_trans(x="log2", y="log2") +
theme_bw() +
theme(
axis.title.y = element_blank()
)## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.