Análisis de texto sobre los Programas Electorales del 10N

1 Prefacio

1.1 Técnicas de PLN

El desarrollo de la analítica de datos ha ido pareja a grandes avances en las posibilidades de captación de información.

La mayor parte de la información no está en formato numérico, y menos en una manera estructurada.

La minería de texto junto con las técnicas de Procesamiento de Lenguaje Natural nos permiten abordar con un esfuerzo razonable análisis que antes resultaban titánicos en tiempo y dinero. Las palabras ya forman parte de nuestro ámbito de información para la gestión. Y no sólo las escritas, el reconocimiento de voz nos abre un mundo de posibilidades.

1.2 Casos de uso

El caso que mostraremos a continuación enlaza muy bien con nuestras sensibilidades, y es fácilmente interpretable por el conocimiento general de los temas tratados.

Pero es sólo un ejemplo de un amplio abanico de casos de uso para este tipo de técnicas.

Un uso muy habitual es la clasificación documental en las instituciones o empresas. ¿Cómo clasificar o etiquetar automáticamente nuevos documentos para facilitar su acceso a los usuarios?

También para el tratamiento de encuestas cualitativas, no sólo en investigación de mercados sino en cualquier encuesta lanzada a empleados de organizaciones, donde interesa especialmente analizar respuestas de tipo abierto sobre los temas de interés.

¿Y si queremos conocer la imagen que tienen los clientes o usuarios de nuestra empresa? Es muy factible monitorizar a través de redes sociales los comentarios y reviews y convertirlos en KPIs de reputación corporativa, o de aceptación de un producto, o incluso de comparación de nuestros productos con los de la competencia.

En fin, todo un mundo de utilidades por descubrir e incorporar a la gestión de decisiones basadas en datos.

1.3 Elecciones 10N - 2019

1.3.1 Las palabras importan

Dicen que vivimos en un mundo cada vez más líquido donde no importa lo que se dice mientras no quede retratado por hechos ciertos y demostrados.

Lamentablemente, la realidad parece confirmarlo. La palabra ha dejado de tener carácter contractual. Incumplir lo dicho ya no tiene coste.

Sin embargo, las palabras importan, tanto las que se dicen como las que no son dichas.

Los procesos electorales se han convertido en momentos dorados para el uso e interpretación de la investigación de mercados (electores) y el desarrollo de productos (promesas electorales).

Pero las palabras importan, porque nos mueven a la acción. Y nos hacen tomar decisiones. Que no se las lleve el viento.

1.3.2 Los objetivos

El objetivo de este estudio es extraer las claves de los diferentes programas electorales para confrontarlos a través de técnicas de PLN. Se han incluido únicamente los programas oficiales publicados de los partidos, de ámbito nacional, a los que el CIS estimó representación parlamentaria.

El estudio se realizará en lenguaje R, con las librerías habituales de PLN, además de paquetes personalizados.

# Librerías necesarias
paquetes = c("tidyverse","caret", "tm", "qdap", "dplyr","stringr",
             "tidytext", "ggplot2", "tidyr","igraph","data.table",
             "pdftools", "wordcloud", "topicmodels", "ggraph","scales")
# carga o instala en su caso
comprobacion.paquetes <- lapply(paquetes, FUN = function(x) {
  if (!require(x, character.only = TRUE)) {
    install.packages(x, dependencies = TRUE)
    library(x, character.only = TRUE)
  }
})

1.3.3 Obtención de información y preparación de tidy-frame

Los programas electorales fueron descargados de cada página web oficial, bien en formato pdf, bien en formato txt, y leídos desde R con funciones tipo pdftools.

Dado el razonable volumen de información es posible realizar algunos ajustes ad-hoc en cada programa para homogeneizar los documentos y facilitar su tratamiento. Después, y usando expresiones regulares, se identifican medidas electorales, temas de campaña (políticas), y se arreglan especificidades de diseño en cada programa (guiones de cambio de línea, etc).

Hay ciertas expresiones comunes equivalentes que hay que homogeneizar (CCAA - Comunidades Autónomas, FP - Formación Profesional).

También se descartan los textos introductorios en los programas, para centrar el análisis en la confrontación de las medidas.

Hay más acciones que realizar todavía en relación con calidad del dato, pero contamos ya con una tabla con características tidy que permite ser trabajada analíticamente.

tidy_10n = read.table("tidy_10n.csv", sep = ",", stringsAsFactors = FALSE, 
                             header = TRUE, row.names = NULL)
#limpio encodings
tidy_10n$text = str_replace_all(tidy_10n$text, "<U\\+F0A7>", "")
tidy_10n$text = str_replace_all(tidy_10n$text, "<U\\+F0A0>", "")

Desplegamos tokens = palabras, que será nuestra base principal de análisis. Generamos un index de control del orden original.

tidy_10n_token <- tidy_10n %>% unnest_tokens(word, text) %>% mutate(orden_orig = seq_along(word))

De esta manera, tenemos ya una visión cuantitativa de la extensión de los diferentes programas. Vemos cómo hay gran disparidad en el despliegue, lo que sin duda tiene impacto en el análisis cuando pretendamos sacar conclusiones del conjunto de programas. Lo abordaremos más tarde a través de una normalización.

label_graficos = c("Cs", "MasPais", "PP", "PSOE", "UPodemos", "VOX")

tidy_10n_token %>% group_by(doc_id) %>%
    summarise(n_words =n())  %>%
    ggplot(aes(doc_id, n_words)) +
    geom_col(fill = "#377EB8") +
    ggtitle("Número de palabras en el Programa publicado")+
    labs(y = NULL, x = NULL)+
    geom_text(aes(y = 300, size = 30, label = label_graficos,
              vjust = 0.2, hjust = 0),alpha = 0.8, color = "white")+
    coord_flip(clip = "off", expand = TRUE)+
    theme(axis.line=element_blank(),
          axis.text.y=element_blank(),
          axis.ticks=element_blank(),
          axis.title.x=element_blank(),
          plot.title=element_text(size=15, hjust=0.5, vjust = 1, face="bold", colour="#377EB8"),
          plot.margin = margin(2,2, 2, 2, "cm"),
          legend.position="none")

Veamos este despliegue al detalle de temas (políticas) y promesas electorales (medidas) para tener una idea de la extensión de cada programa.

(camp_temas = tidy_10n_token %>% count(doc_id,capitulo) %>% add_count(doc_id) %>% 
    group_by(doc_id) %>% summarise(capits = max(n)) )
(camp_medidas = tidy_10n_token %>% filter(medida >0) %>% count(doc_id,medida) %>% add_count(doc_id) %>% 
    group_by(doc_id) %>% summarise(medids = max(n)) )
(camp_palabras = tidy_10n_token %>% count(doc_id)  )

camp_temas %>% left_join(camp_medidas, by = "doc_id") %>%
    left_join(camp_palabras, by = "doc_id") %>% 
    transmute(programa = doc_id,
           politicas = capits,
           medidas = medids,
           total_palabras = n,
           palabras_x_medida = round(n/medids,0))

En cada tema - política- se proponen una serie de medidas - promesas electorales.

Las medidas están identificadas en función de la estructura visual de cada programa, pudiendo contener cada una a su vez bloques de medidas más concretas y detalladas.

Procedemos a la preparación y limpieza de la información para su posterior tratamiento.

Primero eliminamos cualquier elemento que no sea texto (puntuaciones, dígitos, etc.) y convertimos todo a minúscula. También eliminamos espacios innecesarios.

Por último, quitamos todas las palabras que no aportan significado al texto desde el punto de vista analítico (artículos, adverbios, etc.), así como palabras concretas que no aportan en este contexto en particular.

replacePunctuation = function(x) { gsub("[[:punct:]]+", " ", x)}
replaceNumbers = function(x) { gsub("[[:digit:]]+", " ", x)}

tidy_10n_token$word = tidy_10n_token$word %>%
  replacePunctuation() %>%
  replaceNumbers() %>%
  bracketX() %>%
  tolower () %>%
  stripWhitespace()

# quitamos espacios en blanco, que ya no debería haber:
tidy_10n_token$word <- gsub("\\s+","",tidy_10n_token$word)
# eliminar stopwords
stop_words_sp = as.data.frame(stopwords("spanish"))
names(stop_words_sp) = "word"
tidy_10n_token_cleared <- tidy_10n_token %>% anti_join(stop_words_sp, by = "word")

# eliminar términos para nuestro contexto :
stop_especiales = c("véase","apartado", "así", "todas", "toda", "ello", "cualquier", "quién",
                    "puedan", "asimismo", "ser", "través", "dicha", "contemple", "suficiente",
                    "manera","tipo","solo","parte", "resto", "sino", "correspondientes",
                    "además","menos", "cs", "docs", "unas", "tal")
stop_especiales = as.data.frame(stop_especiales, stringAsFactors = FALSE)
names(stop_especiales) = "word"
tidy_10n_token_cleared = tidy_10n_token_cleared %>% anti_join(stop_especiales, by = "word")

tidy_10n_token_cleared = tidy_10n_token_cleared %>% filter(word != "")

# tabla preparada  
tidy_10n_token_cleared %>% count(word, sort = TRUE)

Aunque no parecen existir actualmente diccionarios desarrollados en castellano para unificar palabras por lexemas y dotarlas de contenido posteriormente, es posible hacerlo manualmente. Esto permitirá evitar palabras diferentes únicamente por declinaciones, plurales , etc.

# library(SnowballC)  #-> wordStem aisla el lexema de cada palabra
palabras_unicas = tidy_10n_token_cleared %>% count(word, sort = TRUE)
zz = tidy_10n_token_cleared %>% group_by(word) %>% 
  mutate(word_stem = SnowballC::wordStem(word, language = "spanish")) %>%
  left_join(palabras_unicas, by = "word")
# identifico las equivalencias más frecuentes en mi texto entre palabras y lexemas : es mi diccionario de lexemas para este texto
tops_lems = zz %>% count(word_stem, word) %>% 
                    group_by(word_stem) %>% 
                    mutate(rank = rank(-n, ties.method= "random")) %>%
                    filter(rank ==1)
# finalmente, asigno a cada lexema la palabra de mi texto más frecuente :
tidy_10n_token_cleared = tidy_10n_token_cleared %>%
  mutate(word_stem = SnowballC::wordStem(word, language = "spanish"))%>%
  left_join(tops_lems, by = "word_stem")

tidy_10n_token_cleared = tidy_10n_token_cleared %>% select(1:4,6,8) %>%
  mutate(word = word.y) %>% select(-word.y)

# y hacemos algunos a mano, debido a las declinaciones irregulares
sort(table(str_subset(tidy_10n_token_cleared$word, "garantic")),decreasing = TRUE)

## garantice 
##        44

tidy_10n_token_cleared$word = gsub("garantic.+", "garantizar", tidy_10n_token_cleared$word)
sort(table(str_subset(tidy_10n_token_cleared$word, "acce")),decreasing = TRUE)

## 
##        acceso       acceder accesibilidad 
##           140            20            16

tidy_10n_token_cleared$word = gsub("acce.+", "acceso", tidy_10n_token_cleared$word)
sort(table(str_subset(tidy_10n_token_cleared$word, "lau")),decreasing = TRUE)

## launión 
##      44

tidy_10n_token_cleared$word = gsub("launión", "unión", tidy_10n_token_cleared$word)

# tabla obtenida 
tidy_10n_token_cleared %>% count(word, sort = TRUE)

Observamos la diferencia en el top palabras una vez unificados lexemas. “Público” es la palabra más utilizada al unirse “público”, “pública”, “públicos”, etc … También conseguimos reducir a la mitad el número de palabras en el análisis.

En el caso de “española”, recoge toda las palabras “español”, “española”, “españoles”, “españolas”, etc, y es su representante por ser la más utilizada de todas ellas en los textos

Por último, eliminamos también las palabras que sólo aparecen una vez entre todos los programas, para simplificar los listados. A la vez, normalizamos la frecuencias de palabras dentro de cada programa para eliminar el impacto de los programas más extensos versus los más concisos.

infrecuentes_eliminar = tidy_10n_token_cleared %>% count(doc_id, word) %>% filter(n<2)

tidy_10n_token_cleared = tidy_10n_token_cleared %>% 
  group_by(doc_id) %>% summarise(total_words = n()) %>%
  left_join(tidy_10n_token_cleared, by= "doc_id") %>%
  anti_join(infrecuentes_eliminar, by = c("doc_id", "word")) %>%
  mutate(peso = (1/total_words*10000))

tidy_10n_token_cleared = tidy_10n_token_cleared %>% select(-total_words) 

# tabla definitiva   
tidy_10n_token_cleared %>% count(word, wt = peso, sort = TRUE) %>% mutate(n= round(n,0))

Ya tenemos una tabla lista para el análisis.

2 Análisis exploratorio

2.1 Visión general

Lanzamos algunos gráficos generales para observar el texto : primero una nube de palabras con los términos más utilizados.

tidy_10n_token_cleared %>% 
  count(word, wt = peso, sort = TRUE) %>%
  with(wordcloud(word, n, max.words = 200, random.order=FALSE, random.color=FALSE, rot.per=.1,                  scale=c(6,.5), colors = c("grey80","darkgoldenrod1", "tomato")))

El paquete Wordcloud tiene funciones para generar nubes con los términos que son comunes a todos los programas

pal <- brewer.pal( 8, "Accent")
#use the darker colors
pal <- pal[-( 1: 5)]
#generate the commonality cloud : palabras comunes a todos los documentos
# selecciono 4 documentos
tidy_temp = tidy_10n_token_cleared %>% count(doc_id, word, wt = peso)%>%
  cast_dtm(word, doc_id, n) 
tidy_temp = as.matrix(tidy_temp)
commonality.cloud(tidy_temp, max.words = 200, comonality.measure=mean,  # por defecto min
                  random.order = FALSE, colors = pal)

y los términos que diferencian en mayor medida relativa cada programa de los demás.

# pantone de cada partido
partidos_colores = c("#ff8000", "darkgreen", "#3b83bd",
                     "#c81d11", "#572364", "#00bb2d")

comparison.cloud(tidy_temp, max.words = 200, rot.per=.0, title.size=2, scale=c(5,.5),
                 colors = partidos_colores, 
                 match.colors = TRUE, title.bg.colors=c("black"),
                 use.r.layout = TRUE)

2.2 Confrontando programas

Entremos un poco más al detalle de cada discurso, comparando el top palabras más utilizado en cada programa.

tidy_10n_token_cleared$doc_id <- factor(tidy_10n_token_cleared$doc_id, labels = label_graficos)

tidy_10n_token_cleared %>%
  count(doc_id, word, sort = TRUE) %>%   # aqui con frecuencia sin ajustar peso
  group_by(doc_id) %>%
    mutate(rank = rank(-n, ties.method= "random")) %>%
    filter(rank <=25) %>%
  ungroup() %>%
  mutate(word = reorder_within(word, n, doc_id)) %>%
  ggplot(aes(word, n, fill = doc_id)) +
  geom_col(show.legend = FALSE) +
  geom_text(aes(x = word, y = 0.5, label = str_replace(word, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "white",
              fontface="bold") + 
  labs(x = NULL, y = NULL) +
  facet_wrap(~doc_id, ncol = 9, scales = "free", labeller = labeller(label_graficos)) +
  coord_flip() +
  scale_x_reordered() +
  ggtitle("Palabras más  empleadas en cada Programa-10N")+
  scale_fill_manual(values = partidos_colores)+
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

Si utilizamos los bigramas, es decir, las parejas de palabras que aparecen juntas con mayor frecuencia, observamos ideas más concretas

# reconstruimos la tabla con bigramas
untidy_all = tidy_10n_token_cleared %>% group_by(doc_id) %>%
  summarise(capitulo = first(capitulo), text=paste(word, collapse =" "))
JLM_bigrams <- untidy_all %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2)

bigrams_separated <- JLM_bigrams %>% separate(bigram, c("word1", "word2"), sep = " ")
bigram_counts = bigrams_separated %>% count(word1, word2, sort = TRUE)

# y mostramos
JLM_bigrams %>%
  count(doc_id, bigram, sort = TRUE)  %>%
  group_by(doc_id) %>%
  mutate(rank = rank(-n, ties.method= "random")) %>%
  filter(rank <=20) %>%
  ungroup() %>%
  mutate(bigram = reorder_within(bigram, n, doc_id)) %>%
  ggplot(aes(bigram, n, fill = doc_id)) +
  geom_col(show.legend = FALSE, alpha = 0.5) +
  geom_text(aes(x = bigram, y = 0.2, label = str_replace(bigram, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "black",
              fontface="bold") + 
  labs(x = NULL, y = NULL) +
  facet_wrap(~doc_id, ncol = 9, scales = "free") +
  coord_flip() +
  scale_x_reordered()+
  ggtitle("Most common bigrams - 10N")+
  scale_fill_manual(values = partidos_colores)+
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

Hay algunos resultados extraños debido a los lexemas (trabajo-trabajo viene de trabajadores y trabajadoras en el texto del programa correspondiente, al igual que niños-niños desde niños-niñas). Por otro lado, las parejas i-d y d-i provienen de I+D+I (políticas sobre investigación + desarrollo + innovación), quizá debiéramos unirlos y tratarlo como una palabra única.

En todo caso, es posible ver al detalle cómo aparecen a la vez en los documentos ciertas palabras en concreto, para resolver este tipo de situaciones…

# para localizar palabras
bigrams_separated %>%
  filter(word1 == "cataluña") %>%
  count(word1, word2, sort = TRUE)

…o indagar cómo y en qué medida aparecen ciertos términos.

También podemos analizar cómo aparece relacionado cierto término en cada uno de los programas…

# y puedo ver al detalle asociaciones de una palabra en concreto
palabra_a_analizar = "familia"  # en este caso el lexema con regexpr
bigrams_separated %>% filter(grepl(palabra_a_analizar, word1)) %>%
  group_by(doc_id, word1, word2) %>%
  summarise ( n = n()) %>%  arrange(desc(n)) %>% 
  mutate(rank = rank(-n, ties.method= "random")) %>%
  filter(rank <=10) %>%
  ungroup %>%
  mutate(word2 = reorder_within(word2, n, doc_id)) %>%
  ggplot(aes(word2, n)) +
  geom_col(fill = "darkred", alpha = 0.4) +
  geom_text(aes(x = word2, y = 0.1, label = str_replace(word2, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "black",
              fontface="bold") + 
  xlab(NULL) + ylab(NULL) +
  facet_wrap(~doc_id, ncol = 7, scales = "free") +
  coord_flip() +
  scale_x_reordered()+
  ggtitle(paste ("Palabras más asociadas a  \"", palabra_a_analizar,"..\"  por Programa"))+
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

“número” funciona como palabra principal del lexema “numer”, con lo que aquí se refiere sin duda a familia numerosa.

Por último, el uso de trigramas, aunque implica una frecuencia mucho menor de posibilidad de aparición, sin embargo nos transmite casi frases completas.

# la frecuencia de trigramas a lo largo de toda la colección
JLM_trigrams <- untidy_all %>%
  unnest_tokens(trigram, text, token = "ngrams", n = 3) %>%
  count(doc_id, trigram, sort = TRUE) %>%
  filter(!is.na(trigram))
(aa3 = JLM_trigrams %>%
  group_by(doc_id) %>%
  mutate(rank = rank(-n, ties.method= "random")) %>%
  filter(rank <=10) %>%
  ungroup() %>%
  mutate(trigram = reorder_within(trigram, n, doc_id)) %>%
  ggplot(aes(trigram, n, fill = doc_id)) +
  geom_col(show.legend = FALSE, alpha = 0.3) +
  geom_text(aes(x = trigram, y = 0.1, label = str_replace(trigram, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "black",
              fontface="plain") + 
  labs(x = NULL, y = NULL) +
  facet_wrap(~doc_id, ncol = 9, scales = "free") +
  coord_flip() +
  scale_x_reordered()+
  ggtitle("Most common trigrams - 10N")+
  scale_fill_manual(values = partidos_colores)+
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")
)

2.3 Una visión general con Grafos

Los grafos son una herramienta muy útil cuando existe mucha cantidad de información de relaciones entre elementos. En nuestro caso, los bigramas son relaciones entre 2 palabras, medidas además por la frecuencia de ocurrencia.

Con el paquete “igraph” podemos ver de manera ágil las co-ocurrencias por programa electoral.

partys = unique(tidy_10n_token_cleared$doc_id)
plot_list = list()
filter_n = c(4,7,3,4,7,2) # minimos frecuencias mostrar

for(i in 1:length(partys)) {
print(partys[i])
bigrams_separated <- JLM_bigrams %>% filter(doc_id == partys[i])%>%
  separate(bigram, c("word1", "word2"), sep = " ")

bigram_counts = bigrams_separated %>% count(word1, word2, sort = TRUE)

bigram_graph <- bigram_counts %>%
  filter(n > filter_n[i] & !is.na(word1)) %>%
  graph_from_data_frame()

set.seed(2016)
a <- grid::arrow(type = "closed", length = unit(.15, "inches"))
(bb99 = ggraph(bigram_graph, layout = "fr") +
    geom_edge_link(aes(edge_alpha = n, edge_width = n), 
                   edge_colour = "cyan4", show.legend = TRUE,
                   arrow = a, end_cap = circle(.07, 'inches')) +
    geom_node_point(color = "lightblue", size = 5) +
    geom_node_text(aes(label = name), repel = TRUE,
                   point.padding = unit(0.2, "lines"),
                   vjust = 1, hjust = 1) +
    theme_void()+
    theme(legend.position = c(0.9, 0.1))+
    ggtitle(paste0("Co-ocurrencias : ",partys[i], "  (n>",filter_n[i], ")"))
)
plot_list[[i]] = bb99
} 

El grosor de los enlaces muestran los diferentes niveles de co-ocurrencia entre palabras.

2.4 TfIdf en lugar de Frecuencias

Lo cierto es que normalmente hay palabras que aparecen mucho en todos los programas, como “público”, “nacional”, etc y que son las que copan el top palabras. Son como árboles que no nos dejan ver el bosque de las palabras propias y no tan compartidas de los documentos analizados.

El estadístico tf-idf (Term Frequency and Inverse Document Frequency) busca medir la importancia de una palabra para un documento (programa electoral) dentro de una colección de ellos (todos los programas). Es decir, penaliza la aparición en todos los programas electorales y premia la exclusividad respecto al resto.

Si en lugar de frecuencias de aparición utilizamos ésta conversión a TfidF, estaremos observando de alguna manera las palabras que son más “propias” de cada programa comparado con el resto.

book_words_sp = tidy_10n_token_cleared %>% 
  count(doc_id, word, sort = TRUE) %>%  filter(n>4) %>%
  bind_tf_idf(word, doc_id, n)

book_words_sp %>%
  group_by(doc_id) %>% 
    mutate(rank = rank(-tf_idf, ties.method= "random")) %>%
    filter(rank <=10) %>%
  ungroup() %>%
  mutate(word = reorder_within(word, tf_idf, doc_id)) %>%
  ggplot(aes(word, tf_idf, fill = doc_id)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = NULL) +
  coord_flip()+
  scale_x_reordered() +
  ggtitle("Palabras propias de cada Programa (TfIdf)")+
  scale_fill_manual(values = partidos_colores)+
  geom_text(aes(x = word, y = 0.000015, label = str_replace(word, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "white",
              fontface="bold") + 
  facet_wrap(~doc_id, ncol = 9, scales = "free", labeller = labeller(label_graficos)) +
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.text.x = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

Igualmente con los bigramas, utilizando la conversión a Tf-Idf, podemos ver ideas más diferenciales de cada programa electoral.

untidy_all = tidy_10n_token_cleared %>% group_by(doc_id) %>%
  summarise(capitulo = first(capitulo), text=paste(word, collapse =" "))
JLM_bigrams <- untidy_all %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2)

bigrams_separated <- JLM_bigrams %>%
  separate(bigram, c("word1", "word2"), sep = " ")
# new bigram counts:
bigram_counts <- bigrams_separated %>% 
  count(word1, word2, sort = TRUE)

bigram_tf_idf <- JLM_bigrams %>%
  count(doc_id, bigram) %>%
  bind_tf_idf(bigram, doc_id, n) %>%
  arrange(desc(tf_idf)) %>% filter(n>1)

bigram_tf_idf %>%
  arrange(desc(tf_idf)) %>%
  group_by(doc_id) %>% 
    mutate(rank = rank(-tf_idf, ties.method= "random")) %>%
    filter(rank <=10) %>% 
  ungroup() %>%
  mutate(bigram = reorder_within(bigram, tf_idf, doc_id)) %>% 
  ggplot(aes(bigram, tf_idf, fill = doc_id)) +
  geom_col(show.legend = FALSE, alpha = 0.4) +
  geom_text(aes(x = bigram, y = 0.000015, label = str_replace(bigram, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "gray50",
              fontface="bold") +
  labs(x = NULL, y = NULL) +
  facet_wrap(~doc_id, ncol = 9, scales = "free") +
  coord_flip() +
  scale_x_reordered()+
  ggtitle("Bigramas propios de cada Programa (TfIdf)")+
  scale_fill_manual(values = partidos_colores)+
  theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.text.x = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

2.5 Correlación entre palabras

Por último, y al igual que hemos visto con el estadístico Tf-Idf, los grafos de correlación entre palabras nos muestran especificidades. En este caso, las palabras que aparecen juntas en mayor medida de que lo hacen junto a otras.

library(widyr)
word_cors <- tidy_10n_token_cleared %>% group_by(word) %>% filter(n() >= 10) %>%
  pairwise_cor(word, lineatexto, sort = TRUE)
head(word_cors,50)

# Filtrando de una manera sencilla podemos encontrar las palabras más correlacionadas con cualquiera que nos interese.
word_cors %>% filter(item1 == "policía")

O mostrarlas gráficamente.

word_cors %>%
  filter(item1 %in% c("corrupción", "empleo", "seguridad", 
                      "derechos", "bienestar", "igualdad")) %>%
  group_by(item1) %>%
  top_n(10) %>%
  ungroup() %>%
  mutate(item2 = reorder_within(item2, correlation, item1)) %>%
  ggplot(aes(item2, correlation, fill = item1)) +
  geom_bar(stat = "identity", show.legend = FALSE, alpha = 0.9) +
  geom_text(aes(x = item2, y = 0.000015, label = str_replace(item2, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
            hjust = 0, vjust = 0.3, size=4, colour = "white",
            fontface="bold") + 
  ylab(NULL) +
  facet_wrap(~ item1, scales = "free") +
  scale_x_reordered() +
  coord_flip()+
  ggtitle("Palabras de mayor correlación con cada caso")+
  theme(axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    axis.text.x = element_blank(),
    plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                            face="plain", colour="black"),
    plot.margin = margin(1,1, 2, 1, "cm"),
    legend.position="none")

Y podemos igualmente crear un grafo de correlaciones para detectar las palabras que aparecen juntas en los documentos en mucha mayor medida a la que aparecen con otras palabras diferentes.

partys = unique(tidy_10n_token_cleared$doc_id)
plot_list = list()
min_corr = c(.30, .45, .30, .35, .50, .001)

for(i in 1:length(partys)) {
  print(partys[i])
  # we need to filter for at least relatively common words first
  word_cors <- tidy_10n_token_cleared %>%
    filter (doc_id == partys[i]) %>%
    group_by(word) %>%
    filter(n() >= 10) %>%
    pairwise_cor(word, lineatexto, sort = TRUE)
  set.seed(2016)
  (af1 = word_cors %>%
    filter(correlation > min_corr[i]) %>%
    graph_from_data_frame() %>%
    ggraph(layout = "fr") +
    geom_edge_link(aes(edge_alpha = correlation), show.legend = FALSE) +
    geom_node_point(color = "gold", size = 5) +
    geom_node_text(aes(label = name), repel = TRUE) +
    theme_void()+
    ggtitle(paste0("Correlaciones > ", min_corr[i], ": " , partys[i]))
  )
  plot_list[[i]] = af1
}

3 Comparando programas

La frecuencia de uso de las palabras puede ser comparada entre los distintos programas, de una manera global, para detectar similitudes o diferencias en el uso del léxico entre programas.

frequency_relatos <- tidy_10n_token_cleared %>% 
  count(doc_id, word) %>%
  group_by(doc_id) %>%
  mutate(proportion = n / sum(n)) %>% 
  select(-n) %>% 
  spread(doc_id, proportion)
# correlaciones entre programas :
library(GGally)
ggpairs(frequency_relatos[2:7],title = "Correlaciones entre programas")

La función ggpairs nos muestra las correlaciones cruzadas entre todos los programas, en función de las frecuencias de uso de palabras. ¿Sorprende algún resultado?

Podemos verlo comparando 2 a 2 algunos casos. Los ejes reflejan la proporción de uso de las palabras en cada documento. La línea diagonal nos muestra el eje de similitud entre los programas en cuanto a la frecuencia de uso de palabras. A mayor dispersión de puntos, menor similitud entre programas (menos correlación).

# un ejemplo
a1 = ggplot(frequency_relatos, aes(x = Cs, 
                              y = PP, 
                              color = abs(Cs - PP))) +
  geom_abline(color = "gray40", lty = 2) +
  geom_jitter(alpha = 0.1, size = 2.5, width = 0.3, height = 0.3) +
  geom_text(aes(label = word), check_overlap = TRUE, vjust = 1.5) +
  scale_x_log10(labels = NULL) + #percent_format()) +
  scale_y_log10(labels = NULL) + #percent_format()) +
  scale_color_gradient(#limits = c(0, 0.001),
    low = "lightblue",
    high = "darkblue", name="Contraste") +
  theme(legend.position=c(0.9, 0.2))+
  ggtitle("Comparando uso de palabras Cs - PP")

# los extremos se tocan ?
a2 = ggplot(frequency_relatos, aes(x = VOX, 
                              y = UPodemos, 
                              color = abs(VOX - UPodemos))) +
  geom_abline(color = "gray40", lty = 2) +
  geom_jitter(alpha = 0.1, size = 2.5, width = 0.3, height = 0.3) +
  geom_text(aes(label = word), check_overlap = TRUE, vjust = 1.5) +
  scale_x_log10(labels = NULL) + #percent_format()) +
  scale_y_log10(labels = NULL) + #percent_format()) +
  scale_color_gradient(#limits = c(0, 0.001),
    low = "lightblue",
    high = "darkblue", name="Contraste") +
  theme(legend.position=c(0.9, 0.2))+
  ggtitle("Comparando uso de palabras VOX - Podemos")

multiplot(a1, a2, cols = 2)

4 Análisis de sentimiento

Las técnicas de análisis de sentimiento buscan extraer información subjetiva de los documentos. Hasy diferentes métodos que utilizan Procesamiento de Lenguaje Natural. En nuestro caso utilizamos diccinarios predeterminados de sentimientos para valorar conceptos en base a puntuaciones asignadas a las palabras.

Existen diferentes diccionarios, creados para contextos concretos, por lo que conviene revisar al detalle los resultados para ajustar valoraciones de ciertas palabras según cada contexto que estemos tratando.

Utilizamos aquí el diccionario NRC, que contempla hasta 8 sentimientos diferentes, basados en la rueda de Plutchik, Plutchik’s Wheel of Emotions.

En nuestro caso nos ceñimos a la simplificación a 2 sentimientos : positivo / negativo.

library(syuzhet)
nrc= get_sentiment_dictionary(dictionary = "nrc", language = "spanish")
# palabras de contexto diferente a eliminar del análisis de sentimiento
sentiment_stop_words <- tibble(word = c("impuesto", "discapacidad","dependencia",
                                        "inversión","gobierno","necesario", "aumentar",
                                        "demanda", "vivienda", "jubilación",
                                        "infantil", "suelo", "tribunal",
                                        "situación", "caso", "ingresos", "forma", "laboral",
                                        "modelo", "especial", "carrera", "extranjero",
                                        "administración", "aplicación"), 
                               lexicon = c("custom"))
sentiment_10N <- tidy_10n_token_cleared %>% anti_join(sentiment_stop_words, by = "word") %>%
  inner_join(nrc, by = "word") %>%
  filter(sentiment %in% c("positive", "negative")) %>%
  count(doc_id, capitulo , sentiment, wt = peso) %>%
  spread(sentiment, n, fill = 0) %>%
  mutate(sentiment = positive /(positive + negative))

ggplot(sentiment_10N, aes(doc_id, sentiment, fill = doc_id)) +
    geom_col(show.legend = FALSE) +
    #geom_smooth(show.legend = FALSE) +
    facet_wrap(~capitulo, ncol = 8, scales = "free_x") +
    #geom_hline(yintercept = 0, color = "red") +
    ggtitle ("Análisis de sentimiento - %positivo por política")+
    scale_fill_manual(values = partidos_colores)+
    xlab(NULL) + ylab(NULL) +
    theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust = 0.5, size = 4),
          axis.ticks = element_blank(),
          axis.text.y = element_blank())

Observamos, para cada tema o política, el nivel de sentimiento positivo a través de las palabras empleadas en cada programa. Es fácil ver ciertos temas que implican lenguajes menos “positivos”, y programas menos " positivos" ante un mismo tema.

Interesa también cuáles son las palabras que definen el sentimiento en cada programa.

# 2.4 Most common positive and negative words
bing_word_counts_neg <- tidy_10n_token_cleared %>% anti_join(sentiment_stop_words, by = "word") %>%
  inner_join(nrc, by = "word") %>%
  filter(sentiment == "negative") %>%
  count(word, doc_id, sort = TRUE) %>%
  ungroup()
bing_word_counts_pos <- tidy_10n_token_cleared %>% anti_join(sentiment_stop_words, by = "word") %>%
  inner_join(nrc, by = "word") %>%
  filter(sentiment == "positive") %>%
  count(word, doc_id, sort = TRUE) %>%
  ungroup()

# POR PARTIDO
####################################################
# Negative
b1 = bing_word_counts_neg %>%
    group_by(doc_id) %>%
    mutate(rank = rank(-n, ties.method= "random")) %>%
    filter(rank <=10) %>% 
    ungroup() %>%
    mutate(word = reorder_within(word, n, doc_id)) %>%
    ggplot(aes(word, n, fill = doc_id)) +
    geom_col(show.legend = FALSE) +
    geom_text(aes(x = word, y = 0.000015, label = str_replace(word, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "white",
              fontface="bold") + 
    labs(x = NULL, y = NULL) +
    facet_wrap(~doc_id, ncol = 9, scales = "free") +
    coord_flip() +
    scale_x_reordered() +
    ggtitle("Negative- sentiment words")+
    scale_fill_manual(values = partidos_colores)+
    theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.text.x = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")


# Positive
b2 = bing_word_counts_pos %>%
    group_by(doc_id) %>%
    mutate(rank = rank(-n, ties.method= "random")) %>%
    filter(rank <=10) %>% 
    ungroup() %>%
    mutate(word = reorder_within(word, n, doc_id)) %>%
    ggplot(aes(word, n, fill = doc_id)) +
    geom_col(show.legend = FALSE) +
    geom_text(aes(x = word, y = 0.000015, label = str_replace(word, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "white",
              fontface="bold") + 
    labs(x = NULL, y = NULL) +
    facet_wrap(~doc_id, ncol = 9, scales = "free") +
    coord_flip() +
    scale_x_reordered() +
    ggtitle("Positive- sentiment words")+
    scale_fill_manual(values = partidos_colores)+
    theme(axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.text.x = element_blank(),
      plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                              face="plain", colour="black"),
      plot.margin = margin(1,1, 2, 1, "cm"),
      legend.position="none")

multiplot(b1,b2, cols = 1)

Hay otras técnicas interesantes para comparar sentimientos. En este caso utilizando el diccionario BING, que puntúa cada palabra en una escala entre -5 y +5 en función de su nivel negativo-positivo.

download.file("https://raw.githubusercontent.com/jboscomendoza/rpubs/master/sentimientos_afinn/lexico_afinn.en.es.csv",
              "lexico_afinn.en.es.csv")
afinn <- read.csv("lexico_afinn.en.es.csv", 
          stringsAsFactors = F, fileEncoding = "latin1") %>% 
          tbl_df()
names(afinn)[1] = "word"
# Elimino duplicados provenientes de la traducción del inglés
afinn = afinn %>% group_by(word) %>% summarise(value = mean(Puntuacion)) %>% 
  filter(word != "") %>% distinct()

book_kernel <- tidy_10n_token_cleared %>% inner_join(afinn, by = c("word")) %>%
  filter(doc_id %in% c("UPodemos","VOX"))

ggplot(book_kernel, aes(value, fill = doc_id)) + 
  geom_density(alpha = 0.2) + 
  ggtitle("AFINN Score Densities")+
  geom_vline(xintercept = 0, color ="red")+
  theme(legend.position = c(0.87, 0.92))+
  labs(x = "Values scoring AFINN")

Vemos así la comparación entre 2 programas y sus valoraciones en el rango -5 a +5 en cuanto a frecuencia (densidad) de palabras en cada puntuación.

5 Topic Modeling

Es habitual en minería de textos tratar con colecciones de documentos, como en este caso, programas electorales, que nos gustaría dividir en grupos naturales para que puedan ser entendidos por separado.

Topic Modeling es un método para la clasificación no supervisada de dichos documentos, similar a la clusterización de datos numéricos, que intentar encontrar grupos naturales de elementos incluso cuando no estamos seguros de lo que estamos buscando.

El modelo LDA “Latent Dirichlet allocation” es muy habitual para realizar topic modeling. Trata cada documento como una mezcla de temas y cada tema como una mezcla de palabras. Esto permite que los documentos se “superpongan” entre sí en cuanto a contenido, en lugar de separarse estrictamente como haría una clusterización, de manera que refleje el uso típico del lenguaje natural.

Aplicado a nuestro caso, buscamos extraer las palabras que definen temas implícitos entre los diferentes programas electorales, para identificar las grandes cuestiones relevantes que reflejan los programas para esta Campaña electoral.

5.1 Buscando los temas (topics)

# Preparo la tabla para pasarla por LDA
chapters_dtm = tidy_10n_token_cleared %>% select(-lineatexto) %>%
  unite(document, doc_id, capitulo, sep = "-") %>%
  count(document, word, wt = peso) %>%  mutate(n = round(n*100,0)) %>%
  cast_dtm(document, word, n)

El número “k” de topics óptimo puede ser precalculado.

(max_list_i = length(table(tidy_10n_token_cleared$capitulo)))
(list_i = c(2:max_list_i))
mod_log_lik = numeric(length(list_i))
mod_perplexity = numeric(length(list_i))

for (i in 2:max_list_i) {
  mod= LDA(chapters_dtm, k = i, method= "Gibbs", 
           control = list(alpha=1/k, iter = 200, seed = 12345, thin =1))
  mod_log_lik[i] = logLik(mod)
  mod_perplexity[i] = perplexity(mod, chapters_dtm)
}
y = mod_perplexity[2:max_list_i]
k = 2:max_list_i
plot(k, y, type = "o")

Cálculo optimal K a través de nivel perplexity

Creamos el modelo LDA a través de su algoritmo:

k_decision = 5
chapters_lda <- LDA(chapters_dtm, k = k_decision, 
                    control = list(seed = 12345, alpha= 1/k_decision ))
chapters_lda            

## A LDA_VEM topic model with 5 topics.

perplexity(chapters_lda, chapters_dtm)

## [1] 616.7346

El modelo nos devuelve la asignación probable de palabras a cada tema (topic) y la identificación de cada documento a cada tema.

topicTerm <- t(posterior(chapters_lda)$terms)
head(topicTerm,20)

##                           1            2            3            4
## administración 3.487751e-03 1.013826e-03 4.605487e-03 6.799355e-03
## apostaremos    6.460447e-04 3.255470e-04 1.908327e-04 5.309733e-06
## aprobaremos    1.122189e-03 2.326024e-03 5.192209e-03 4.968594e-03
## armonizaremos  8.797177e-13 3.284815e-04 2.524718e-04 1.928968e-07
## auditoría      5.562913e-05 9.426100e-05 5.270177e-04 1.692115e-15
## autónomas      2.185598e-03 7.036817e-03 2.399156e-03 7.983130e-03
## barrera        4.863110e-15 1.797744e-18 1.207258e-04 1.951993e-04
## beneficios     1.235479e-03 2.324222e-03 2.388625e-03 1.038455e-03
## burocracia     7.743593e-09 6.192929e-26 3.372896e-04 2.846641e-04
## cero           3.784791e-04 1.355959e-03 3.209352e-04 4.633261e-04
## ciudadanía     2.458017e-03 1.220302e-03 2.889593e-03 2.436214e-03
## código         1.738051e-04 3.146891e-05 6.500706e-04 2.760355e-03
## competencias   6.053810e-04 5.835354e-04 1.319609e-03 2.104282e-03
## consumo        4.300325e-03 2.849153e-04 9.791017e-05 1.963656e-11
## crearemos      1.525704e-03 2.531843e-03 3.145185e-03 6.567726e-04
## crecimiento    6.271141e-04 1.336971e-07 4.933287e-04 3.621026e-31
## digital        8.388823e-05 2.273376e-04 3.252993e-04 6.053647e-08
## distintas      4.069826e-07 7.252551e-04 2.623387e-04 3.537919e-04
## economía       8.302852e-03 1.673251e-03 1.187387e-03 3.575171e-03
## elevaremos     5.196621e-04 4.331336e-04 1.517061e-03 6.837033e-04
##                           5
## administración 5.701285e-03
## apostaremos    5.514373e-04
## aprobaremos    6.513628e-03
## armonizaremos  9.748435e-04
## auditoría      6.984962e-06
## autónomas      1.068343e-02
## barrera        3.404384e-04
## beneficios     1.329845e-06
## burocracia     1.170395e-04
## cero           2.861856e-18
## ciudadanía     4.430834e-03
## código         2.275926e-04
## competencias   1.991501e-03
## consumo        9.047415e-04
## crearemos      3.800727e-03
## crecimiento    7.789464e-10
## digital        5.878544e-03
## distintas      9.841425e-04
## economía       4.119616e-03
## elevaremos     2.086719e-04

docTopic <- posterior(chapters_lda)$topics
head(docTopic,20)

##                           1            2            3            4
## Cs-AAPP        5.992483e-02 6.481888e-06 8.220061e-01 6.481887e-06
## Cs-AGRICULTURA 6.491765e-01 8.213136e-02 2.686879e-01 2.100543e-06
## Cs-AGUA        6.804286e-01 4.343219e-06 4.343220e-06 3.357457e-02
## Cs-CLIMA       7.336785e-01 1.556313e-02 1.505284e-01 2.778131e-06
## Cs-CONSUMO     4.587384e-01 9.072430e-02 4.504902e-01 2.353748e-05
## Cs-CULTURA     1.506456e-06 1.506456e-06 4.480737e-01 1.506457e-06
## Cs-DEMOGRAFIA  1.931936e-01 3.196332e-01 1.639878e-01 3.218539e-06
## Cs-DEPENDENCIA 2.647314e-06 5.776464e-02 2.647314e-06 1.554073e-01
## Cs-DEPORTE     3.218195e-06 5.014041e-01 3.218194e-06 4.119227e-01
## Cs-ECONOMIA    1.895827e-06 1.895826e-06 4.537335e-01 1.895826e-06
## Cs-EDUCACION   1.033416e-06 1.033416e-06 7.344208e-03 1.033416e-06
## Cs-EMPLEO      1.193029e-06 8.502409e-01 1.193029e-06 1.193036e-06
## Cs-ENERGIA     2.612350e-01 5.590653e-06 5.842156e-01 1.545382e-01
## Cs-EUROPA      2.711389e-06 2.711389e-06 9.075107e-01 9.248120e-02
## Cs-EXTERIOR    2.727680e-06 2.442003e-01 6.996931e-01 5.610119e-02
## Cs-FAMILIA     1.368176e-06 9.030895e-01 2.044129e-04 1.368176e-06
## Cs-FISCAL      1.270925e-06 1.856165e-01 7.161296e-01 9.825141e-02
## Cs-IGUALDAD    1.242701e-06 4.793388e-01 3.301443e-02 4.259544e-01
## Cs-INMIGRACION 4.466095e-02 5.140843e-06 9.786461e-02 6.392603e-01
## Cs-JUSTICIA    3.441223e-06 3.441224e-06 4.652624e-02 8.663905e-01
##                           5
## Cs-AAPP        1.180562e-01
## Cs-AGRICULTURA 2.100543e-06
## Cs-AGUA        2.859881e-01
## Cs-CLIMA       1.002272e-01
## Cs-CONSUMO     2.353748e-05
## Cs-CULTURA     5.519218e-01
## Cs-DEMOGRAFIA  3.231822e-01
## Cs-DEPENDENCIA 7.868228e-01
## Cs-DEPORTE     8.666674e-02
## Cs-ECONOMIA    5.462608e-01
## Cs-EDUCACION   9.926527e-01
## Cs-EMPLEO      1.497555e-01
## Cs-ENERGIA     5.590654e-06
## Cs-EUROPA      2.711389e-06
## Cs-EXTERIOR    2.727681e-06
## Cs-FAMILIA     9.670333e-02
## Cs-FISCAL      1.270925e-06
## Cs-IGUALDAD    6.169109e-02
## Cs-INMIGRACION 2.182090e-01
## Cs-JUSTICIA    8.707637e-02

5.2 Perfilando los temas de campaña:

5.2.1 Probabilidad palabra - topic

La librería tiditext aporta un método para extraer del modelo las probabilidades de cada palabra en cada topic, llamada β (“beta”). El análisis de este estadístico nos permitirá encontrar las palabras que definen en mayor medida cada tema de campaña.

chapter_topics <- tidy(chapters_lda, matrix = "beta")
chapter_topics %>% spread(topic,beta)

Para cada combinación de palabra-tema, el modelo estima la probabilidad de que esa palabra pertenezca a ese tema. La clasificación en todo caso no es cerrada, por lo que tenemos probabilidades más o menos altas de cada palabra en cada tema distinto.

Para perfilar cada tema, mostramos las palabras con mayor probabilidad de pertenecer a cada tema. Empezamos a ver así esos grandes temas identificados.

top_terms <- chapter_topics %>% mutate(topic = paste0("topic", topic)) %>%
  group_by(topic) %>% top_n(15, beta) %>% ungroup() %>%
  arrange(topic, -beta)

top_terms %>% 
    mutate(term = reorder_within(term, beta, topic)) %>%
    ggplot(aes(term, beta, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    geom_text(aes(x = term, y = 0.000015, label = str_replace(term, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=4, colour = "white",
              fontface="bold") + 
    labs(x = NULL, y = NULL) +
    facet_wrap(~ topic, ncol = 3, scales = "free") +
    coord_flip() +
    scale_x_reordered()+
    ggtitle("Palabras +asociadas a topics (temas campaña)") +
    theme(axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    axis.text.x = element_blank(),
    plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                            face="plain", colour="black"),
    plot.margin = margin(0.5,0.5,0.5,0.5, "cm"),
    legend.position="none")

¿ Y si lo vemos a través de nubes de palabras?

max_topics = max(chapter_topics$topic)
par(mfrow=c(3,2))
for(i in 1:max_topics) {
  ao1_t = chapter_topics %>% spread(topic,beta) %>%
            select(word = term, n = i+1)
  xxx= wordcloud(ao1_t$word, ao1_t$n, max.words = 50, random.order=FALSE,
            random.color=FALSE, rot.per=.1, 
            scale=c(3,.5), 
            colors = c("grey80","darkgoldenrod1", "tomato"))
}

Podríamos aproximar que el topic 1 hace referencia a todo lo relacionado con las políticas medioambientales y la denominada transición ecológica. El topic 2 pudiera tratar sobre derechos laborales, empleo, protección, igualdad. El topic 3 parece referirse a cuestiones de fiscalidad y políticas de vivienda. Por último, el topic 4 presenta términos más relacionados la seguridad, soberanía, apareciendo también la inmigración. Y el topic 5 incluye términos en relación con la educación, innovación, etc.

Para confirmar el perfilado de los topics o temas conviene profundizar con otras aproximaciones. Por ejemplo, analizando las diferencias entre topics.

Para ello , una alternativa es confrontar las palabras con mayor diferencia en probabilidad β. Esto nos permite reforzar el perfilado de cada tema vía contraste entre ellos. Para asegurar que tomamos las palabras relevantes en cada caso, filtramos aquellos β mayores de 1/1000 en cualquier tema.

num_topics = max(chapter_topics$topic)
plot_list = list()

for(i in 1:(num_topics-1)) {  
beta_matrix <- chapter_topics %>% filter(beta > 0.001) %>%
  mutate(topic = paste0("topic", topic)) %>% spread(topic, beta, fill = 0.001)

    g_1 = i+1
    n1= names(beta_matrix)[g_1]
    
    for(j in (i+1):num_topics){
        print(j)
        g_2 = j+1 
        n2= names(beta_matrix)[g_2]
        column = as.data.frame(log2(beta_matrix[,g_1]/beta_matrix[,g_2]))
        names(column) = paste0("log_",n1,"/",n2)
        beta_matrix= cbind(beta_matrix, column)
    } 
    bm1 = beta_matrix %>% 
        gather(combination, log_ratio , -c(1:(k_decision+1))) %>%
        select(combination, term, log_ratio) %>%
        arrange(-abs(log_ratio))  %>%
        group_by(combination) %>%
        top_n(15, wt = abs(log_ratio)) %>%
        ungroup()%>%
        mutate(term = reorder_within(term, log_ratio, combination)) %>%
        ggplot(aes(term, log_ratio, fill = log_ratio >0)) +
        geom_col(show.legend = FALSE) +
        facet_wrap(~combination, ncol = 5, scales = "free") +
        ylab(NULL) + xlab(NULL)+
        coord_flip()+
        scale_x_reordered()+
        ggtitle(paste("Contraste entre topic",n1,"y resto"))
   
    plot_list[[i]] = bm1
} 

multiplot(plot_list[[1]],
          plot_list[[2]],
          plot_list[[3]],
          plot_list[[4]], cols = 2)

5.2.2 Probabilidad documento - topic

Además, la técnica LDA también modela cada programa electoral como una mezcla de temas, y lo vemos a través de la probabilidad “documento-topic” γ (“gamma”).

chapters_gamma <- tidy(chapters_lda, matrix = "gamma")
chapters_gamma %>% spread(topic, gamma)

Cada uno de estos valores gamma representa la proporción estimada de palabras de ese documento que son generadas desde ese topic. Lo asimilaríamos a la identificación de cada documento con cada topic.

chapters_gamma <- chapters_gamma %>%
  separate(document, c("title", "chapter"), sep = "-", convert = TRUE)

Y los mayores gammas nos señalan los paralelismos entre documentos y temas-topics

chapter_classifications <- chapters_gamma %>% group_by(title, chapter) %>%
  top_n(1, gamma) %>% ungroup()
chapter_classifications

Gráficamente,

chapter_classifications %>%
    mutate(title = reorder(title, gamma * topic)) %>%
    ggplot(aes(factor(topic), gamma, fill = topic)) +
    geom_jitter(position=position_jitter(0.2)) +
    geom_boxplot(show.legend = FALSE) +
    facet_wrap(~ title)+
    ggtitle("Topics preponderantes por partido segun gamma")

# para ver exactamente los documentos que tiene cada programa por topic, filtrando para asegurar que son los más relevantes
(num_topics = chapter_classifications %>% filter(gamma > 0.75) %>% 
    count(title,topic) %>% spread(title,n, fill = 0) )

Por ejemplo, Más País está relacionado de una manera muy relevante en la mayoría de sus políticas con el Topic 1, que habíamos visto que respondía a cuestiones medioambientales. De esta manera, es posible identificar la cercanía de cada programa a cada topic-tema de campaña.

# y al detalle de política:
top_policy <- chapter_classifications %>% filter(gamma > 0.75) %>% 
  mutate(topic = paste0("topic", topic)) %>%
  group_by(topic) %>%
  top_n(15, gamma) %>%
  ungroup() %>%
  arrange(topic, -gamma)

(p_1 = top_policy %>% 
    mutate(policy = paste(title,chapter)) %>%
    mutate(policy = reorder_within(policy, gamma, topic)) %>%
    ggplot(aes(policy, gamma, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    geom_text(aes(x = policy, y = 0.000015, label = str_replace(policy, "(.+)___.+", replacement = str_c(" ", "\\1"))), 
              hjust = 0, vjust = 0.3, size=3, colour = "white",
              fontface="bold") + 
    labs(x = NULL, y = NULL) +
    facet_wrap(~ topic, ncol = 3, scales = "free") +
    coord_flip() +
    scale_x_reordered()+
    ggtitle("Políticas +asociadas a topics (temas campaña)") +
    theme(axis.text.y = element_blank(),
          axis.ticks = element_blank(),
          axis.text.x = element_blank(),
          plot.title=element_text(size=15, hjust=0.5, vjust = 1, 
                                  face="plain", colour="black"),
          plot.margin = margin(0.5,0.5,0.5,0.5, "cm"),
          legend.position="none")
)

5.3 Identificación de los programas con los grandes temas de campaña

Hemos visto cómo hay ciertos programas que aparecen más frecuentemente identificados con ciertos temas de campaña. Si asignamos el programa más frecuente en un tema como representante principal de dicho tema, podemos llegar a construir un modelo de paralelismos entre programas.

Imaginemos que mezclamos todos los programas anonimizados y vamos extrayendo medidas al azar. ¿Seríamos capaces de reconocer el partido que está proponiendo esa medida simplemente a través de su lectura?

Las probabilidades del modelo LDA nos permiten crear una matriz de confusión donde mostramos el nivel de acierto en el reconocimiento de medidas entre partidos, comparando la pertenencia de cada medida con el “consenso” que ha alcanzado LDA en la asignación de esa medida a un programa concreto.

# establecemos el consenso en función del número de políticas relevantes en cada topic
(book_topics <- chapter_classifications %>% filter(gamma > 0.75) %>%
    count(title, topic) %>%
    group_by(title) %>%
    top_n(1, n) %>%
    ungroup() %>%
    transmute(consensus = title, topic) ) 

Ciertos temas de campaña (1,2,4) están muy relacionados con ciertos programas (Más País, Podemos, Vox). El tema 3 se relaciona con Ciudadanos, de una manera menos notoria, y el tema 5 está repartido entre PP y PSOE principalmente.

Recordemos que LDA permite clasificar, pero de una manera no estricta como en las técnicas de clusterización habituales. Las agrupaciones son de naturaleza probabilística.

5.4 Contraste de los programas a nivel palabra

Como vimos, una de las fases del modelo LDA es asignar cada palabra de cada documento a un topic concreto. De manera general, cuantas más palabras en un documento son asignadas a un topic, mayor peso (gamma) tendrá esa relación topic-documento.

De manera que podemos contemplar el paralelismo entre programas desde la visión de las palabras en cada documento. La función “augment” nos permitirá calcularlo, ya que añade la información del topic probable para cada palabra, dentro de cada documento.

assignments <- augment(chapters_lda, data = chapters_dtm)
# ajuste del uso de pesos original
assignments$count = assignments$count / 100
head(assignments,20)

table(assignments$.topic)

## 
##    1    2    3    4    5 
## 8471 4070 3380 3251 4543

Observamos cuantas palabras han sido asignadas por cada tema.

Y, si combinamos esta tabla con el consenso de programa para cada tema de campaña que construimos en el punto anterior, obtendremos las palabras clasificadas tanto correcta como incorrectamente.

assignments <- assignments %>%
  separate(document, c("title", "chapter"), sep = "-", convert = TRUE)
#clasificación correcta
assign_1 = assignments %>% inner_join(book_topics, by = c(".topic" = "topic"))
terms_total = assign_1 %>% count(title,chapter,term)
(aciertos_1 = assign_1 %>% filter(title == consensus) %>% count(title,chapter,term))

#clasificación incorrecta (sin duplicados por topic4)
(fallos_1 = terms_total %>% anti_join(aciertos_1, by = c("title", "chapter", "term")) )

Mostrando, finalmente, una matriz de confusión, que representa tanto el nivel de “especificidad” del programa en la diagonal principal, como el nivel de “parecido” entre los diferentes programas, desde el punto de vista del léxico.

assign_2 = assignments %>% inner_join(book_topics, by = c(".topic" = "topic")) %>%
  count(title, consensus, wt = count) %>%
  group_by(title) %>% mutate(percent = n / sum(n)) %>% ungroup()

# convierto en factores para reordenar en el gráfico
assign_2$title = factor(assign_2$title,
                        levels(factor(assign_2$title))[c(2,5,4,3,1,6)])
assign_2$consensus = factor(assign_2$consensus,
                        levels(factor(assign_2$consensus))[c(2,5,4,3,1,6)])
assign_2 %>%
  ggplot(aes(consensus, title, fill = percent)) +
    geom_tile() +
    scale_fill_gradient2(high = muted("red"), label = percent_format()) +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          panel.grid = element_blank()) +
    labs(x = "Las medidas fueron asignadas a ...",
         y = "Las medidas realmente pertenecen a ...",
         fill = "% de asignación")+
    ggtitle("Matriz de confusión")+
    scale_x_discrete()

Matriz de confusión que muestra dónde el modelo LDA asignó las palabras de cada documento. Cada fila de representa el verdadero programa del que proviene cada palabra, y cada columna representa a qué programa se le asignó.

Vemos cómo casi todas las palabras de MásPaís se asignaron correctamente a su programa, aún habiendo algunas confusiones con Podemos o PSOE. También VOX tuvo un nivel superior al resto en asignaciones correctas.

Es lógico encontrar errores de asignación entre programas debido a la propia naturaleza del método, que no genera grupos cerrados. En todo caso podemos observar que gran parte de las “confusiones” en los programas se encuentran en las zonas ideológicas o de carácter institucional más cercanas.

Podemos verlo numéricamente ( datos en % )

assign_2 %>% mutate(percent = round(percent*100,0)) %>%
  select(-n) %>% spread(consensus, percent, fill =0)

6 Confrontando programas

Para terminar, una vez definidos los grandes temas, es posible visualizar las palabras más propias o específicas de cada programa electoral para cada tema de campaña, a través de comparison cloud.

number_topics = max(assignments$.topic)
for(i in 1:number_topics) {
print(paste("Topic",i))
  topic_1 = assignments %>% filter(count >0.01) %>% filter(.topic == i) %>% 
  count(title, term, wt = count) %>%
  spread(title, n, fill = 0) %>%
  data.frame(row.names = "term")
comparison.cloud(topic_1, max.words = 200, rot.per=.0, title.size=2, scale=c(3,1),
                 colors = partidos_colores, 
                 match.colors = TRUE, title.bg.colors=c("black"))
}

## [1] "Topic 1"

## [1] "Topic 2"

## [1] "Topic 3"

## [1] "Topic 4"

## [1] "Topic 5"

Noviembre 2019

6.0.1 Créditos

Hay abundante y muy buena documentación sobre minería de texto en redes, con diferentes casos de uso.

Para este caso resultó de muchísima utilidad el trabajo de Julia Silge y David Robinson disponible en https://www.tidytextmining.com/tidytext.html

Charles Bordet dispone de un preciso tutorial para la descarga de documentos en formato pdf : https://www.charlesbordet.com

Y éste es un buen ejemplo de clasificación de documentos supervisada sobre la biblioteca del Congreso de EE.UU. https://cfss.uchicago.edu/notes/supervised-text-classification/