Análisis de las intervenciones del presidente del Gobierno de España

import warnings
warnings.filterwarnings('ignore')

1 Introducción

Este trabajo se basa en un análisis de todas las intervenciones del presidente del Gobierno Español desde el inicio de la pandemia.

Previo a este análisis se ha realizado un web-scraping para obtener sus intervenciones.

Photo by Hello I'm Nik 🎞 on Unsplash

La web de la cual se ha obtenido dicha información ha sido:

https://www.lamoncloa.gob.es/presidente/intervenciones/Paginas/index.aspx

Now we will work with R

Dicho trabajo se ha realizado mediante lenguaje R y utilizando Jupyter como IDE.

%load_ext rpy2.ipython%%R
sessionInfo()
R version 4.0.2 (2020-06-22)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Ubuntu 20.04.1 LTS

Matrix products: default
BLAS/LAPACK: /home/oscar/anaconda3/lib/libmkl_rt.so

locale:
[1] LC_CTYPE=es_ES.UTF-8 LC_NUMERIC=C
[3] LC_TIME=es_ES.UTF-8 LC_COLLATE=es_ES.UTF-8
[5] LC_MONETARY=es_ES.UTF-8 LC_MESSAGES=es_ES.UTF-8
[7] LC_PAPER=es_ES.UTF-8 LC_NAME=C
[9] LC_ADDRESS=C LC_TELEPHONE=C
[11] LC_MEASUREMENT=es_ES.UTF-8 LC_IDENTIFICATION=C

attached base packages:
[1] tools stats graphics grDevices utils datasets methods
[8] base

loaded via a namespace (and not attached):
[1] compiler_4.0.2
'''%%R
# Librerías necesarias
paquetes = c("tidytext","tidyverse","caret", "tm", "dplyr","stringr",
"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)
}
})'''
'%%R\n# Librerías necesarias\npaquetes = c("tidytext","tidyverse","caret", "tm", "dplyr","stringr",\n "ggplot2", "tidyr","igraph","data.table",\n "pdftools", "wordcloud", "topicmodels", "ggraph","scales")\n# carga o instala en su caso\ncomprobacion.paquetes <- lapply(paquetes, FUN = function(x) {\n if (!require(x, character.only = TRUE)) {\n install.packages(x, dependencies = TRUE)\n library(x, character.only = TRUE)\n }\n})'%%R
# Importamos las librerias a utilizar

packages <- c('tidytext','tidyverse',"tm" ,'dplyr', 'caret',
'ggplot2','tidyr', 'igraph', 'wordcloud', 'topicmodels', 'ggraph', "scales"
,"SnowballC","syuzhet", "widyr","GGally",'lubridate','RColorBrewer', 'NLP', 'magrittr')
newpack = packages[!(packages %in% installed.packages()[,"Package"])]

if(length(newpack)) install.packages(newpack)
a=lapply(packages, library, character.only=TRUE)
R[write to console]: ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.0 ──

R[write to console]: ✔ ggplot2 3.3.2 ✔ purrr  0.3.4
✔ tibble  3.0.2 ✔ dplyr  1.0.0
✔ tidyr  1.1.0 ✔ stringr 1.4.0
✔ readr  1.3.1 ✔ forcats 0.5.0

R[write to console]: ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag() masks stats::lag()

R[write to console]: Loading required package: NLP

R[write to console]:
Attaching package: ‘NLP’


R[write to console]: The following object is masked from ‘package:ggplot2’:

annotate


R[write to console]: Loading required package: lattice

R[write to console]:
Attaching package: ‘caret’


R[write to console]: The following object is masked from ‘package:purrr’:

lift


R[write to console]:
Attaching package: ‘igraph’


R[write to console]: The following objects are masked from ‘package:dplyr’:

as_data_frame, groups, union


R[write to console]: The following objects are masked from ‘package:purrr’:

compose, simplify


R[write to console]: The following object is masked from ‘package:tidyr’:

crossing


R[write to console]: The following object is masked from ‘package:tibble’:

as_data_frame


R[write to console]: The following objects are masked from ‘package:stats’:

decompose, spectrum


R[write to console]: The following object is masked from ‘package:base’:

union


R[write to console]: Loading required package: RColorBrewer

R[write to console]:
Attaching package: ‘scales’


R[write to console]: The following object is masked from ‘package:purrr’:

discard


R[write to console]: The following object is masked from ‘package:readr’:

col_factor


R[write to console]:
Attaching package: ‘syuzhet’


R[write to console]: The following object is masked from ‘package:scales’:

rescale


R[write to console]: Registered S3 method overwritten by 'GGally':
method from
+.gg ggplot2

R[write to console]:
Attaching package: ‘lubridate’


R[write to console]: The following objects are masked from ‘package:igraph’:

%--%, union


R[write to console]: The following objects are masked from ‘package:base’:

date, intersect, setdiff, union


R[write to console]:
Attaching package: ‘magrittr’


R[write to console]: The following object is masked from ‘package:purrr’:

set_names


R[write to console]: The following object is masked from ‘package:tidyr’:

extract
%%R
# Multiple plot function
#
# ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects)
# - cols: Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#
multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
require(grid)

# Make a list from the ... arguments and plotlist
plots <- c(list(...), plotlist)

numPlots = length(plots)

# If layout is NULL, then use 'cols' to determine layout
if (is.null(layout)) {
# Make the panel
# ncol: Number of columns of plots
# nrow: Number of rows needed, calculated from # of cols
layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
ncol = cols, nrow = ceiling(numPlots/cols))
}

if (numPlots==1) {
print(plots[[1]])

} else {
# Set up the page
grid.newpage()
pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

# Make each plot, in the correct location
for (i in 1:numPlots) {
# Get the i,j matrix positions of the regions that contain this subplot
matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
layout.pos.col = matchidx$col))
}
}
}
%%R
data = read.table('data.csv', sep=',', header = TRUE)
%%R
library(lubridate)
data$date<- ymd(dmy(data[, 1]))
data = dplyr::arrange(data, date)
glimpse(data)
Rows: 33
Columns: 3
$ fecha <int> 180320, 210320, 220320, 250320, 280320, 180420, 220420, …
$ intervencion <chr> " PEDRO SÁNCHEZ.-Presidente del Gobierno Señora presiden…
$ date <date> 2020-03-18, 2020-03-21, 2020-03-22, 2020-03-25, 2020-03…
%%R
data <- data[with(data, order(data$date)), ] # Orden directo
%%R
#data$fecha = as.Date(as.character(data$fecha), "%Y%m%d")

#data$fecha <- as.character(data$fecha)
str(data)
summary(data)
'data.frame': 33 obs. of 3 variables:
$ fecha : int 180320 210320 220320 250320 280320 180420 220420 220420 250420 290420 ...
$ intervencion: chr " PEDRO SÁNCHEZ.-Presidente del Gobierno Señora presidenta, señoras y señores diputados, buenos días.Quiero empe"| __truncated__ " PEDRO SÁNCHEZ, presidente del Gobierno.Comparezco de nuevo para cumplir con mi deber de informar sobre la marc"| __truncated__ " PEDRO SÁNCHEZ, presidente del Gobierno.Buenas tardes:Cada día nos llegan a los responsables de todas las admin"| __truncated__ " Señora presidenta, señorías, buenas noches.Quiero que mis primeras palabras, igual que los primeros sentimient"| __truncated__ ...
$ date : Date, format: "2020-03-18" "2020-03-21" ...
fecha intervencion date
Min. :120820 Length:33 Min. :2020-03-18
1st Qu.:210520 Class :character 1st Qu.:2020-04-25
Median :240620 Mode :character Median :2020-06-20
Mean :238744 Mean :2020-06-06
3rd Qu.:270720 3rd Qu.:2020-06-30
Max. :310520 Max. :2020-08-25
# %%R
# head(data)
%%R
#limpio encodings
data$intervencion = str_replace_all(data$intervencion, "<U\\+F0A7>", " ")
data$intervencion = str_replace_all(data$intervencion, "<U\\+F0A0>", " ")

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

%%R

data_token <- data %>%
tidytext::unnest_tokens(word, intervencion) %>%
mutate(orden_orig = seq_along(word))

head(data_token)
fecha date word orden_orig
1 180320 2020-03-18 pedro 1
2 180320 2020-03-18 sánchez 2
3 180320 2020-03-18 presidente 3
4 180320 2020-03-18 del 4
5 180320 2020-03-18 gobierno 5
6 180320 2020-03-18 señora 6
%%R
unique = (unique( data$fecha ))
list_unique = unlist(unique)
list_unique
[1] 180320 210320 220320 250320 280320 180420 220420 250420 290420 200520
[11] 210520 230520 270520 310520 200620 240620 250620 280620 300620 220720
[21] 230720 270720 290720 120820 200820 250820
%%R
d_t <- data_token %>%
group_by(fecha) %>%
summarise(n_words =n(), .groups = 'drop')
%%R
head(d_t)
# A tibble: 6 x 2
fecha n_words
<int> <int>
1 120820 2304
2 180320 10023
3 180420 10273
4 200520 9389
5 200620 7002
6 200820 10077
%%R
d_t$n_words < - as.numeric(d_t$n_words)

barplot(d_t$n_words, d_t$fecha, names.arg=c(list_unique),
horiz=TRUE, las=2, xlab='Numero de palabras',
ylab='fecha', , cex.names=0.8)
png

Veamos este despliegue al detalle de temas y medidas para tener una idea de la extensión de cada intervención.

%%R
replacePunctuation = function(x) { gsub("[[:punct:]]+", " ", x)}
replaceNumbers = function(x) { gsub("[[:digit:]]+", " ", x)}
%%R
data_token$word = data_token$word %>%
replacePunctuation() %>%
replaceNumbers() %>%
#bracketX() %>%
tolower () %>%
stripWhitespace()
%%R
# quitamos espacios en blanco, que ya no debería haber:
data_token$word <- gsub("\\s+","", data_token$word)
%%R
# eliminar stopwords
stop_words_sp = as.data.frame(stopwords("spanish"))
names(stop_words_sp) = "word"
data_token_cleared <- data_token %>% anti_join(stop_words_sp, by = "word")
%%R
# eliminar términos para nuestro contexto :
stop_especiales = c("gobierno","españa", "presidente", "va", "tan", "cada", "usted", "dicho",
"señorias", "puede", "pues", "primera", "primer", "contemple", "suficiente",
"manera","tipo","solo","parte", "resto", "sino", "correspondientes", "así",
"además","menos", "cs", "docs", "unas", "tal","dos","si","ustedes", "creo", "ser",
"señorias","van","vez","asi","dar","pedro","sanchez","GobiernoComparezco","Gobierno",
"gobiernocomparezco","sánchez","señorias", "señorías", "eh", "cuál", "sr", "de",
"señora","señor","presidenta","diputados","diputadas","buenos","buenas", "dije",
"señoras", "señores", "comienzo", "empezar", "comenzado", "debe", "podría")

stop_especiales = as.data.frame(stop_especiales, stringAsFactors = FALSE)
names(stop_especiales) = "word"
data_token_cleared = data_token_cleared %>% anti_join(stop_especiales, by = "word")
data_token_cleared = data_token_cleared %>% filter(word != "")
%%R
# tabla preparada
d_t_c_table <- data_token_cleared %>%
count(word, sort = TRUE)
head(d_t_c_table,30)
word n
1 país 426
2 lugar 337
3 alarma 328
4 pandemia 301
5 medidas 296
6 social 279
7 vamos 277
8 crisis 272
9 consecuencia 271
10 hacer 269
11 millones 269
12 ahora 267
13 todas 254
14 virus 245
15 conjunto 241
16 importante 237
17 países 233
18 europa 215
19 mismo 212
20 comunidades 209
21 semanas 205
22 salud 202
23 ejemplo 195
24 covid 194
25 respuesta 192
26 días 189
27 autónomas 187
28 económica 184
29 lógicamente 183
30 muchas 183
%%R
library(SnowballC) #-> wordStem aisla el lexema de cada palabra
palabras_unicas = data_token_cleared %>%
count(word, sort = TRUE)
%%R
zz = data_token_cleared %>%
group_by(word) %>%
mutate(word_stem = SnowballC::wordStem(word, language = "spanish")) %>%
left_join(palabras_unicas, by = "word")
%%R
# 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 , wt = n()) %>%
group_by(word_stem) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank ==1)
%%R
# finalmente, asigno a cada lexema la palabra de mi texto más frecuente :
data_token_cleared = data_token_cleared %>%
mutate(word_stem = SnowballC::wordStem(word, language = "spanish"))%>%
left_join(tops_lems, by = "word_stem")
head(data_token_cleared)
fecha date word.x orden_orig word_stem word.y n rank
1 180320 2020-03-18 díasquiero 13 diasquier díasquiero 2 1
2 180320 2020-03-18 congreso 22 congres congreso 65 1
3 180320 2020-03-18 transmitiendo 23 transmit transmitir 7 1
4 180320 2020-03-18 nombre 25 nombr nombre 14 1
5 180320 2020-03-18 toda 27 tod todas 254 1
6 180320 2020-03-18 sociedad 29 socied sociedad 128 1
%%R
data_token_cleared = data_token_cleared %>%
select(1:7) %>%
mutate(word = word.y) %>%
select(-word.y)
%%R
# y hacemos algunos a mano, debido a las declinaciones irregulares
sort(table(str_subset(data_token_cleared$word, "viru")),decreasing = TRUE)
virus coronavirus virusla
251 39 3
viruspero virusy coronavirusp
3 3 2
virusel viruspor viruspregunta
2 2 2
coronaviruscomo coronaviruspresidente coronavirussobre
1 1 1
coronavirustambién virusdifundir virusesta
1 1 1
virusfíjense virushoy virusp
1 1 1
viruspresidente viruspuedo virusrecuerdo
1 1 1
virussimplemente virussomos virustodos
1 1 1

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.

%%R
library(wordcloud)
data_token_cleared %>%
count(word, wt = n(), 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")))
png

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

%%R
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 = data_token_cleared %>%
count(fecha, word, wt = n())%>%
cast_dtm(word, fecha, 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)
png

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

%%R
# pantone de cada fecha
partidos_colores = c("red", "blue", "green", "brown", "white",
"lightgreen", "#83c2e3", "#ffe873","#f80000", "#d30de2",
"darkgreen", "yellow", "#0cf7d7","darkorange", "yellow",
"#d3a88a", "yellow", "orange","#a8c28a", "#f8c200",
"#d37b8a", "yellow", "#a8c2e3","#d3c28a", "#f8c200","#f5821c"
)

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

2.2 Confrontando discrusos

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

%%R
data_token_cleared$fecha <- factor(data_token_cleared$fecha, labels = c(list_unique))

data_token_cleared %>%
count(fecha, word, sort = TRUE, wt = n()) %>% # aqui con frecuencia sin ajustar peso
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=7) %>%
ungroup() %>%
mutate(word = reorder_within(word, n, fecha)) %>%
ggplot(aes(word, n, fill = fecha)) +
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=2.4, colour = "black",
fontface="bold") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = 5, scales = "free", labeller = labeller(list_unique)) +
coord_flip() +
scale_x_reordered() +
ggtitle("Palabras más empleadas en cada invervención del presidente")+
scale_fill_manual(values = partidos_colores)+
theme(axis.text.y = element_blank(),
axis.ticks = element_blank(),
plot.title=element_text(size=10, hjust=0.5, vjust = 1,
face="plain", colour="black"),
plot.margin = margin(1,1, 2, 1, "cm"),
legend.position="none")
png

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

%%R
# reconstruimos la tabla con bigramas
untidy_all = data_token_cleared %>%
group_by(fecha) %>%
summarise(text=paste(word, collapse =" "), .groups = 'drop')

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, wt = n())
%%R
# y mostramos
JLM_bigrams %>%
count(fecha, bigram, sort = TRUE, wt = n()) %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=5) %>%
ungroup() %>%
mutate(bigram = reorder_within(bigram, n, fecha)) %>%
ggplot(aes(bigram, n, fill = fecha)) +
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=2.5, colour = "black",
fontface="bold") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = 5, 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")
png

Hay algunos resultados extraños debido a los lexemas (trabajo-trabajo viene de trabajadores y trabajadoras en el texto del discruso 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…

%%R
# para localizar palabras
bigrams_separated %>%
filter(word1 == "virus") %>%
count(word1, word2, sort = TRUE, wt = n())
# A tibble: 174 x 3
word1 word2 n
<chr> <chr> <int>
 1 virus desconocido 8
 2 virus covid 7
 3 virus dejar 5
 4 virus parece 5
 5 virus consecuencia 4
 6 virus desgraciadamente 4
 7 virus sigue 4
 8 virus unidad 4
 9 virus frente 3
10 virus hacer 3
# … with 164 more rows

…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 intervencións…

%%R
# y puedo ver al detalle asociaciones de una palabra en concreto
palabra_a_analizar = "europa" # en este caso el lexema con regexpr
set.seed(1234)
bigrams_separated %>% filter(grepl(palabra_a_analizar, word1)) %>%
group_by(fecha, word1, word2) %>%
summarise ( n = n(), .groups = 'drop') %>%
arrange(desc(n)) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=8) %>%
ungroup %>%
mutate(word2 = reorder_within(word2, n, fecha)) %>%
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=3, colour = "black",
fontface="bold") +
xlab(NULL) + ylab(NULL) +
facet_wrap(~fecha, ncol = 5, scales = "free") +
coord_flip() +
scale_x_reordered()+
ggtitle(paste ("Palabras más asociadas a \"", palabra_a_analizar,"..\" por fecha"))+
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")
png

“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.

%%R
options(repr.plot.width=15, repr.plot.height=8)
# 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(fecha, trigram, sort = TRUE) %>%
filter(!is.na(trigram))

(aa3 = JLM_trigrams %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=5) %>%
ungroup() %>%
mutate(trigram = reorder_within(trigram, n, fecha)) %>%
ggplot(aes(trigram, n, fill = fecha)) +
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=2.6, colour = "black",
fontface="plain") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = , scales = "free") +
coord_flip() +
scale_x_reordered()+
ggtitle("Most common trigrams - Data")+
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")
)
png
%%R
aa3 = JLM_trigrams %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=5) %>%
ungroup() %>%
mutate(trigram = reorder_within(trigram, n, fecha))

head(aa3)
# A tibble: 6 x 4
fecha trigram n rank
<fct> <fct> <int> <int>
1 250620 américa latina caribe___250620 14 1
2 120820 marco financiero plurianual___120820 13 1
3 250620 instituciones financieras internacional___250620 8 2
4 200520 marco financiero plurianual___200520 7 1
5 230520 graciaspresidente muchas gracias___230520 7 1
6 240620 hacia nueva normalidad___240620 7 1

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 intervención.

%%R
fechas_intervenciónes = unique(data_token_cleared$fecha)
fechas_intervenciónes
[1] 210320 220420 290420 200620 230720 220320 200520 240620 290720 250320
[11] 250420 230520 300620 250820 280320 310520 250620 270720 200820 210520
[21] 270520 220720 120820 180320 180420 280620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
%%R
plot_list = list()
plot_list
list()%%R
filter_n = c(4,5,3,4,5,4,4,5,3,4,5,4,3,4,5,4) # minimos frecuencias mostrar
%%R
head(JLM_bigrams)
# A tibble: 6 x 2
fecha bigram
<fct> <chr>
1 180320 díasbueno primero
2 180320 primero gracias
3 180320 gracias medios
4 180320 medios comunidades
5 180320 comunidades atender
6 180320 atender breve
%%R
library(igraph)
library(ggraph)
for(i in 1:length(fechas_intervenciónes)) {
print(fechas_intervenciónes[i])
bigrams_separated <- JLM_bigrams %>%
filter(fecha == fechas_intervenciónes[i])%>%
separate(bigram, c("word1", "word2"), sep = " ")

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

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 : ",fechas_intervenciónes[i], " (n>",filter_n[i], ")"))
)
plot_list[[i]] = bb99
}
[1] 210320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 290420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 230720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 240620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 290720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 230520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 300620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 280320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 310520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 270720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 210520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 270520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 120820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 180320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 180420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 280620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
%%R
library(grid)
p21= plot_list[[1]]
plot(p21)
png
%%R
p2= plot_list[[2]]
plot(p2)
#multiplot(p1,p2, cols = 2)
png
%%R
p3= plot_list[[3]]
p4= plot_list[[4]]
multiplot(p3,p4, cols = 2)
png
%%R
p3= plot_list[[5]]
p4= plot_list[[6]]
multiplot(p3,p4, cols = 2)
png
%%R
p3= plot_list[[7]]
p4= plot_list[[8]]
multiplot(p3,p4, cols = 2)
png
%%R
p3= plot_list[[9]]
p4= plot_list[[10]]
multiplot(p3,p4, cols = 2)
png
%%R
p3= plot_list[[15]]
p4= plot_list[[16]]
multiplot(p3,p4, cols = 2)
png
%%R
p3= plot_list[[13]]
p4= plot_list[[14]]
multiplot(p3,p4, cols = 2)
png

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 todas las intervenciónes, 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 (intervención) dentro de una colección de ellos (todas las intervenciónes). Es decir, penaliza la aparición en todas las intervenciónes 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 intervención comparado con el resto.

%%R
head(data_token_cleared)
fecha date word.x orden_orig word_stem n word
1 210320 2020-03-18 díasquiero 13 diasquier 2 díasquiero
2 210320 2020-03-18 congreso 22 congres 65 congreso
3 210320 2020-03-18 transmitiendo 23 transmit 7 transmitir
4 210320 2020-03-18 nombre 25 nombr 14 nombre
5 210320 2020-03-18 toda 27 tod 254 todas
6 210320 2020-03-18 sociedad 29 socied 128 sociedad
%%R
book_words_sp = data_token_cleared %>%
count(fecha, word, sort = TRUE, wt = n()) %>%
filter(n>50)

head(book_words_sp)
fecha word n
1 280620 autónomas 104
2 280620 comunidades 89
3 210520 formación 82
4 120820 europeo 78
5 210520 profesional 74
6 200520 europeo 73
%%R
label_graficos = unique(data_token_cleared$fecha)
%%R
set.seed(1234)
book_words_sp %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=10) %>%
ungroup() %>%
mutate(word = reorder_within(word, n, fecha)) %>%
ggplot(aes(word, n, fill = fecha)) +
geom_col(show.legend = FALSE) +
labs(x = NULL, y = NULL) +
coord_flip()+
scale_x_reordered() +
ggtitle("Palabras propias de cada Fecha (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=3, colour = "black",
fontface="bold") +
facet_wrap(~fecha, ncol = 5, 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=10, hjust=0.5, vjust = 1,
face="plain", colour="black"),
plot.margin = margin(1,1, 2, 1, "cm"),
legend.position="none")
png

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

%%R
head(data_token_cleared)
fecha date word.x orden_orig word_stem n word
1 210320 2020-03-18 díasquiero 13 diasquier 2 díasquiero
2 210320 2020-03-18 congreso 22 congres 65 congreso
3 210320 2020-03-18 transmitiendo 23 transmit 7 transmitir
4 210320 2020-03-18 nombre 25 nombr 14 nombre
5 210320 2020-03-18 toda 27 tod 254 todas
6 210320 2020-03-18 sociedad 29 socied 128 sociedad
%%R
untidy_all = data_token_cleared %>% group_by(fecha) %>%
summarise(word.x = first(word.x), text=paste(word, collapse =" "),.groups = 'drop')
JLM_bigrams <- untidy_all %>%
unnest_tokens(bigram, text, token = "ngrams", n = 2)
%%R
head(JLM_bigrams)
# A tibble: 6 x 3
fecha word.x bigram
<fct> <chr> <chr>
1 180320 díasbueno díasbueno primero
2 180320 díasbueno primero gracias
3 180320 díasbueno gracias medios
4 180320 díasbueno medios comunidades
5 180320 díasbueno comunidades atender
6 180320 díasbueno atender breve
%%R
bigrams_separated <- JLM_bigrams %>%
separate(bigram, c("word1", "word2"), sep = " ")
# new bigram counts:
bigram_counts <- bigrams_separated %>%
count(word1, word2, sort = TRUE)
%%R
bigram_tf_idf <- JLM_bigrams %>%
count(fecha, bigram) %>%
bind_tf_idf(bigram, fecha, n) %>%
arrange(desc(tf_idf)) %>% filter(n>1)

head(bigram_tf_idf)
# A tibble: 6 x 6
fecha bigram n tf idf tf_idf
<fct> <chr> <int> <dbl> <dbl> <dbl>
1 210520 formación profesional 63 0.0208 1.87 0.0390
2 250620 américa latina 16 0.00917 3.26 0.0299
3 250620 latina caribe 14 0.00802 3.26 0.0261
4 310520 sistema financiación 12 0.00601 2.56 0.0154
5 250620 financieras internacional 8 0.00458 3.26 0.0149
6 250620 instituciones financieras 8 0.00458 3.26 0.0149
%%R
bigram_tf_idf %>%
arrange(desc(tf_idf)) %>%
group_by(fecha) %>%
mutate(rank = rank(-tf_idf, ties.method= "random")) %>%
filter(rank <=10) %>%
ungroup() %>%
mutate(bigram = reorder_within(bigram, tf_idf, fecha)) %>%
ggplot(aes(bigram, tf_idf, fill = fecha)) +
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=2.5, colour = "gray50",
fontface="bold") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = 9, scales = "free") +
coord_flip() +
scale_x_reordered()+
ggtitle("Bigramas propios de cada intervención (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")
png
%%R
bigram_tf_idf %>%
arrange(desc(tf_idf)) %>%
group_by(fecha) %>%
mutate(rank = rank(-tf_idf, ties.method= "random")) %>%
filter(rank <=10) %>%
ungroup() %>%
mutate(bigram = reorder_within(bigram, tf_idf, fecha))

head(bigram_tf_idf)
# A tibble: 6 x 6
fecha bigram n tf idf tf_idf
<fct> <chr> <int> <dbl> <dbl> <dbl>
1 210520 formación profesional 63 0.0208 1.87 0.0390
2 250620 américa latina 16 0.00917 3.26 0.0299
3 250620 latina caribe 14 0.00802 3.26 0.0261
4 310520 sistema financiación 12 0.00601 2.56 0.0154
5 250620 financieras internacional 8 0.00458 3.26 0.0149
6 250620 instituciones financieras 8 0.00458 3.26 0.0149

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.

%%R
library(widyr)
word_cors <- data_token_cleared %>%
group_by(word) %>%
filter(n() >= 10) %>%
pairwise_cor(word, word.x, sort = TRUE)
%%R
head(word_cors,50)
# A tibble: 50 x 3
item1 item2 correlation
<chr> <chr> <dbl>
 1 coronavirus familiares -0.000170
 2 veces familiares -0.000170
 3 ir familiares -0.000170
 4 enfermedad familiares -0.000170
 5 covid familiares -0.000170
 6 planeta familiares -0.000170
 7 pilares familiares -0.000170
 8 incertidumbre familiares -0.000170
 9 nunca familiares -0.000170
10 libertad familiares -0.000170
# … with 40 more rows
%%R
# Filtrando de una manera sencilla podemos encontrar las palabras más correlacionadas con cualquiera que nos interese.

word_cors %>%
filter(item1 == "coronavirus")
# A tibble: 1,352 x 3
item1 item2 correlation
<chr> <chr> <dbl>
 1 coronavirus familiares -0.000170
 2 coronavirus veces -0.000170
 3 coronavirus ir -0.000170
 4 coronavirus enfermedad -0.000170
 5 coronavirus covid -0.000170
 6 coronavirus planeta -0.000170
 7 coronavirus pilares -0.000170
 8 coronavirus incertidumbre -0.000170
 9 coronavirus nunca -0.000170
10 coronavirus libertad -0.000170
# … with 1,342 more rows

O mostrarlas gráficamente.

%%R
word_cors %>%
filter(item1 %in% c("familiares", "enfermedad", "pilares",
"incertidumbre", "covid", "libertad")) %>%
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=3, 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")
Selecting by correlation
png

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.

%%R
head(data_token_cleared)
fecha date word.x orden_orig word_stem n word
1 210320 2020-03-18 díasquiero 13 diasquier 2 díasquiero
2 210320 2020-03-18 congreso 22 congres 65 congreso
3 210320 2020-03-18 transmitiendo 23 transmit 7 transmitir
4 210320 2020-03-18 nombre 25 nombr 14 nombre
5 210320 2020-03-18 toda 27 tod 254 todas
6 210320 2020-03-18 sociedad 29 socied 128 sociedad
%%R
fechas = unique(data_token_cleared$fecha)
plot_list = list()
min_corr = c(.30, .45, .30, .35, .50, .001)
%%R
head(fechas)
[1] 210320 220420 290420 200620 230720 220320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
%%R
word_cors <- data_token_cleared %>%
filter (fecha == fechas[i]) %>%
group_by(word) %>%
filter(n() >= 10) %>%
pairwise_cor(word, word.x, sort = TRUE)

head(word_cors)
# A tibble: 6 x 3
item1 item2 correlation
<chr> <chr> <dbl>
1 alarma gracias -0.00267
2 curva gracias -0.00267
3 covid gracias -0.00267
4 sanidad gracias -0.00267
5 hoy gracias -0.00267
6 vamos gracias -0.00267
%%R
for(i in 1:length(fechas)) {
print(fechas[i])
# we need to filter for at least relatively common words first
word_cors <- data_token_cleared %>%
filter (fecha == fechas[i]) %>%
group_by(word) %>%
filter(n() >= 10) %>%
pairwise_cor(word, word.x, 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 = n), show.legend = FALSE) +
geom_node_point(color = "gold", size = 5) +
geom_node_text(aes(label = fecha), repel = TRUE) +
theme_void()+
ggtitle(paste0("Correlaciones > ", min_corr[i], ": " , fechas[i]))
)
plot_list[[i]] = af1
}
[1] 210320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 290420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 230720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 240620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 290720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 230520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 300620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 280320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 310520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 250620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 270720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 200820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 210520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 270520
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 220720
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 120820
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 180320
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 180420
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820
[1] 280620
26 Levels: 180320 210320 220320 250320 280320 180420 220420 250420 ... 250820

3 Comparando intervenciones

La frecuencia de uso de las palabras puede ser comparada entre los distintas intervencióness, de una manera global, para detectar similitudes o diferencias en el uso del léxico entre intervenciónes.

%%R
library(GGally)
frequency_relatos <- data_token_cleared %>%
count(fecha, word, wt = n()) %>%
group_by(fecha) %>%
mutate(proportion = n / sum(n)) %>%
select(-n) %>%
spread(fecha, proportion)
# correlaciones entre intervencións :

ggpairs(frequency_relatos[2:7],title = "Correlaciones entre fechas")
R[write to console]:
R[write to console]: plot: [1,1] [>-------------------------------------------------] 3% est: 0s
R[write to console]:
R[write to console]: plot: [1,2] [==>-----------------------------------------------] 6% est: 1s
R[write to console]:
R[write to console]: plot: [1,3] [===>----------------------------------------------] 8% est: 1s
R[write to console]:
R[write to console]: plot: [1,4] [=====>--------------------------------------------] 11% est: 2s
R[write to console]:
R[write to console]: plot: [1,5] [======>-------------------------------------------] 14% est: 2s
R[write to console]:
R[write to console]: plot: [1,6] [=======>------------------------------------------] 17% est: 2s
R[write to console]:
R[write to console]: plot: [2,1] [=========>----------------------------------------] 19% est: 2s
R[write to console]:
R[write to console]: plot: [2,2] [==========>---------------------------------------] 22% est: 2s
R[write to console]:
R[write to console]: plot: [2,3] [===========>--------------------------------------] 25% est: 2s
R[write to console]:
R[write to console]: plot: [2,4] [=============>------------------------------------] 28% est: 2s
R[write to console]:
R[write to console]: plot: [2,5] [==============>-----------------------------------] 31% est: 2s
R[write to console]:
R[write to console]: plot: [2,6] [================>---------------------------------] 33% est: 2s
R[write to console]:
R[write to console]: plot: [3,1] [=================>--------------------------------] 36% est: 1s
R[write to console]:
R[write to console]: plot: [3,2] [==================>-------------------------------] 39% est: 1s
R[write to console]:
R[write to console]: plot: [3,3] [====================>-----------------------------] 42% est: 1s
R[write to console]:
R[write to console]: plot: [3,4] [=====================>----------------------------] 44% est: 1s
R[write to console]:
R[write to console]: plot: [3,5] [=======================>--------------------------] 47% est: 1s
R[write to console]:
R[write to console]: plot: [3,6] [========================>-------------------------] 50% est: 1s
R[write to console]:
R[write to console]: plot: [4,1] [=========================>------------------------] 53% est: 1s
R[write to console]:
R[write to console]: plot: [4,2] [===========================>----------------------] 56% est: 1s
R[write to console]:
R[write to console]: plot: [4,3] [============================>---------------------] 58% est: 1s
R[write to console]:
R[write to console]: plot: [4,4] [==============================>-------------------] 61% est: 1s
R[write to console]:
R[write to console]: plot: [4,5] [===============================>------------------] 64% est: 1s
R[write to console]:
R[write to console]: plot: [4,6] [================================>-----------------] 67% est: 1s
R[write to console]:
R[write to console]: plot: [5,1] [==================================>---------------] 69% est: 1s
R[write to console]:
R[write to console]: plot: [5,2] [===================================>--------------] 72% est: 1s
R[write to console]:
R[write to console]: plot: [5,3] [=====================================>------------] 75% est: 1s
R[write to console]:
R[write to console]: plot: [5,4] [======================================>-----------] 78% est: 0s
R[write to console]:
R[write to console]: plot: [5,5] [=======================================>----------] 81% est: 0s
R[write to console]:
R[write to console]: plot: [5,6] [=========================================>--------] 83% est: 0s
R[write to console]:
R[write to console]: plot: [6,1] [==========================================>-------] 86% est: 0s
R[write to console]:
R[write to console]: plot: [6,2] [===========================================>------] 89% est: 0s
R[write to console]:
R[write to console]: plot: [6,3] [=============================================>----] 92% est: 0s
R[write to console]:
R[write to console]: plot: [6,4] [==============================================>---] 94% est: 0s
R[write to console]:
R[write to console]: plot: [6,5] [================================================>-] 97% est: 0s
R[write to console]:
R[write to console]: plot: [6,6] [==================================================]100% est: 0s

R[write to console]:
png

La función ggpairs nos muestra las correlaciones cruzadas entre todas las fechas, 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 las fecha en cuanto a la frecuencia de uso de palabras. A mayor dispersión de puntos, menor similitud entre fechas (menos correlación).

%%R
head(frequency_relatos)
# A tibble: 6 x 27
word `180320` `210320` `220320` `250320` `280320` `180420` `220420` `250420`
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ª NA 2.13e-4 NA   NA NA NA NA   NA
2 ábal… NA 2.13e-4 NA   NA NA NA NA   NA
3 aban… NA 2.13e-4 4.70e-4 NA 0.00133 NA 2.54e-4 NA
4 abar… NA NA   2.35e-4 NA NA NA NA   NA
5 abar… NA NA   NA   NA NA NA NA   NA
6 abas… NA NA   NA   NA NA NA NA   NA
# … with 18 more variables: `290420` <dbl>, `200520` <dbl>, `210520` <dbl>,
# `230520` <dbl>, `270520` <dbl>, `310520` <dbl>, `200620` <dbl>,
# `240620` <dbl>, `250620` <dbl>, `280620` <dbl>, `300620` <dbl>,
# `220720` <dbl>, `230720` <dbl>, `270720` <dbl>, `290720` <dbl>,
# `120820` <dbl>, `200820` <dbl>, `250820` <dbl>
%%R
# un ejemplo
a1 = ggplot(frequency_relatos,
aes(x = 180320, y = 210320,
color = abs(180320 - 210320))) +
geom_abline(color = "gray40", lty = 2) +
geom_jitter(alpha = 0.1, size = 2, 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 180320 - 210320")
a1
png
%%R
# los extremos se tocan ?
a2 = ggplot(frequency_relatos, aes(x = 180320,
y = 200620,
color = abs(180320 - 200620))) +
geom_abline(color = "gray40", lty = 2) +
geom_jitter(alpha = 0.1, size = 2, 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 180320 - 200620")
a2
png
%%R
library(grid)
multiplot(a1, a2, cols = 2)
png

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.

%%R

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("virus", "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","señor","señora","señoría"),
lexicon = c("custom"))
%%R
head(sentiment_stop_words)
# A tibble: 6 x 2
word lexicon
<chr> <chr>
1 virus custom
2 discapacidad custom
3 dependencia custom
4 inversión custom
5 gobierno custom
6 necesario custom
%%R
dim(nrc)
str(nrc)
head(nrc)
tibble [13,901 × 4] (S3: tbl_df/tbl/data.frame)
$ lang : chr [1:13901] "spanish" "spanish" "spanish" "spanish" ...
$ word : chr [1:13901] "abba" "capacidad" "citada" "absoluto" ...
$ sentiment: chr [1:13901] "positive" "positive" "positive" "positive" ...
$ value : num [1:13901] 1 1 1 1 1 1 1 1 1 1 ...
# A tibble: 6 x 4
lang word sentiment value
<chr> <chr> <chr> <dbl>
1 spanish abba positive 1
2 spanish capacidad positive 1
3 spanish citada positive 1
4 spanish absoluto positive 1
5 spanish absolución positive 1
6 spanish absorbido positive 1
%%R
head(data_token_cleared)
fecha date word.x orden_orig word_stem n word
1 210320 2020-03-18 díasquiero 13 diasquier 2 díasquiero
2 210320 2020-03-18 congreso 22 congres 65 congreso
3 210320 2020-03-18 transmitiendo 23 transmit 7 transmitir
4 210320 2020-03-18 nombre 25 nombr 14 nombre
5 210320 2020-03-18 toda 27 tod 254 todas
6 210320 2020-03-18 sociedad 29 socied 128 sociedad
%%R

sentiment_data <- data_token_cleared %>%
anti_join(sentiment_stop_words, by = "word") %>%
inner_join(nrc, by = "word") %>%
filter(sentiment %in% c("positive", "negative"))%>%
count(fecha, word.x , sentiment, wt = n()) %>%
spread(sentiment, n, fill = 0) %>%
mutate(sentiment = positive /(positive + negative))

str(sentiment_data)
head(sentiment_data)
'data.frame': 6393 obs. of 5 variables:
$ fecha : Factor w/ 26 levels "180320","210320",..: 1 1 1 1 1 1 1 1 1 1 ...
$ word.x : chr "abismo" "acuerdo" "acuerdos" "adversa" ...
$ negative : num 2 0 0 1 4 0 0 0 0 0 ...
$ positive : num 0 21 3 0 0 1 1 3 12 6 ...
$ sentiment: num 0 1 1 0 0 1 1 1 1 1 ...
fecha word.x negative positive sentiment
1 180320 abismo 2 0 0
2 180320 acuerdo 0 21 1
3 180320 acuerdos 0 3 1
4 180320 adversa 1 0 0
5 180320 angustias 4 0 0
6 180320 aspecto 0 1 1
%%R
a_sentiment_data <- sentiment_data%>%
filter(positive > 2 & negative > 2)
%%R
ggplot(a_sentiment_data, aes(fecha, sentiment, fill = fecha)) +
geom_col(show.legend = FALSE) +
#geom_smooth(show.legend = FALSE) +
facet_wrap(~word.x, ncol = 5, 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 = 3),
axis.ticks = element_blank(),
axis.text.y = element_blank())
png

Observamos, para cada tema, el nivel de sentimiento positivo a través de las palabras empleadas en cada intervención. Es fácil ver ciertos temas que implican lenguajes menos “positivos”, y intervencións menos “ positivos” ante un mismo tema.

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

%%R
# Most common positive and negative words
bing_word_counts_neg <- data_token_cleared %>%
anti_join(sentiment_stop_words, by = "word") %>%
inner_join(nrc, by = "word") %>%
filter(sentiment == "negative") %>%
count(word, fecha, sort = TRUE,wt = n) %>%
ungroup()
bing_word_counts_pos <- data_token_cleared %>%
anti_join(sentiment_stop_words, by = "word") %>%
inner_join(nrc, by = "word") %>%
filter(sentiment == "positive") %>%
count(word, fecha, sort = TRUE,wt = n) %>%
ungroup()
%%R
head(bing_word_counts_neg)
word fecha n
1 alarma 280620 18696
2 crisis 250320 15232
3 crisis 210320 13600
4 crisis 200520 13600
5 alarma 230520 13120
6 crisis 250620 13056
%%R
head(bing_word_counts_pos)
word fecha n
1 acuerdo 120820 18696
2 hacer 280620 16678
3 consejo 120820 16200
4 hacer 220320 15871
5 hacer 230720 15602
6 acuerdo 180420 15252
%%R
# POR INTERVENCIÓN
####################################################
# Negative
b1 = bing_word_counts_neg %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=5) %>%
ungroup() %>%
mutate(word = reorder_within(word, n, fecha)) %>%
ggplot(aes(word, n, fill = fecha)) +
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=2.5, colour = "black",
fontface="bold") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = 5, 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")

plot(b1)
png
%%R
# Positive
b2 = bing_word_counts_pos %>%
group_by(fecha) %>%
mutate(rank = rank(-n, ties.method= "random")) %>%
filter(rank <=5) %>%
ungroup() %>%
mutate(word = reorder_within(word, n, fecha)) %>%
ggplot(aes(word, n, fill = fecha)) +
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=2.5, colour = "black",
fontface="bold") +
labs(x = NULL, y = NULL) +
facet_wrap(~fecha, ncol = 5, 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")

plot(b2)
png
%%R

multiplot(b1,b2, cols = 2)
png

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.

%%R
#download.file("https://raw.githubusercontent.com/jboscomendoza/rpubs/master/sentimientos_afinn/lexico_afinn.en.es.csv",
# "lexico_afinn.en.es.csv")
afinn <- read.csv("https://raw.githubusercontent.com/jboscomendoza/rpubs/master/sentimientos_afinn/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),.groups = 'drop') %>%
filter(word != "") %>%
distinct()

book_kernel <- data_token_cleared %>%
inner_join(afinn, by = c("word")) %>%
filter(fecha %in% c("180320","280620"))

ggplot(book_kernel, aes(value, fill = fecha)) +
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")
png

Vemos así la comparación entre 2 intervencións 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, intervenciónes , 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 intervenciónes, para identificar las grandes cuestiones relevantes que reflejan los intervencións durante este periodo.

5.1 Buscando los temas (topics)

%%R
head(data_token_cleared)
fecha date word.x orden_orig word_stem n word
1 210320 2020-03-18 díasquiero 13 diasquier 2 díasquiero
2 210320 2020-03-18 congreso 22 congres 65 congreso
3 210320 2020-03-18 transmitiendo 23 transmit 7 transmitir
4 210320 2020-03-18 nombre 25 nombr 14 nombre
5 210320 2020-03-18 toda 27 tod 254 todas
6 210320 2020-03-18 sociedad 29 socied 128 sociedad
%%R
# Preparo la tabla para pasarla por LDA
chapters_dtm = data_token_cleared %>%
unite(word.x, fecha, sep = "-") %>%
count(word.x, word, wt = n()) %>%
mutate(n = round(n*10,0)) %>%
cast_dtm(word.x, word, n)

head(chapters_dtm)
<<DocumentTermMatrix (documents: 6, terms: 6352)>>
Non-/sparse entries: 5874/32238
Sparsity : 85%
Maximal term length: 28
Weighting : term frequency (tf)

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

'''%%R

max_list_i = length(table(data_token_cleared$word.x))
k = 2:max_list_i
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 = 2, seed = 12345, thin =1))
mod_log_lik[i] = logLik(mod)
mod_perplexity[i] = perplexity(mod, chapters_dtm)
}
y = mod_perplexity[2:max_list_i]
plot(k, y, type = "o")'''
'%%R\n\nmax_list_i = length(table(data_token_cleared$word.x))\nk = 2:max_list_i\nlist_i = c(2:max_list_i)\n\n\nmod_log_lik = numeric(length(list_i))\nmod_perplexity = numeric(length(list_i))\n\nfor (i in 2:max_list_i) {\n mod= LDA(chapters_dtm, k = i, method= "Gibbs", \n control = list(alpha=1/k, iter = 2, seed = 12345, thin =1))\n mod_log_lik[i] = logLik(mod)\n mod_perplexity[i] = perplexity(mod, chapters_dtm)\n}\ny = mod_perplexity[2:max_list_i]\nplot(k, y, type = "o")'

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

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

%%R
library(topicmodels)
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.%%R
perplexity(chapters_lda, chapters_dtm)
[1] 1147,902

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

%%R
topicTerm <- t(posterior(chapters_lda)$terms)
head(topicTerm,20)
1 2 3 4
abandonar 6,303369e-04 3,214010e-08 5,221842e-04 1,968501e-04
abastecimiento 7,919926e-08 1,716138e-04 1,954390e-10 4,616346e-04
abierto 3,747523e-04 4,004799e-04 6,421192e-06 6,650349e-05
aboga 1,934368e-04 3,023033e-09 1,082031e-24 2,851888e-37
abordar 1,212316e-03 1,180646e-03 9,315302e-06 6,947829e-05
abre 6,872394e-12 3,323442e-04 1,933207e-04 4,340333e-102
abril 1,452800e-03 1,163653e-03 3,769799e-04 3,143751e-04
abrió 3,667513e-05 1,236171e-04 1,142010e-17 3,412808e-131
abrir 2,123627e-04 2,646245e-07 3,590239e-04 1,636582e-14
absoluta 4,243223e-04 6,351086e-04 7,535220e-04 1,201699e-03
absorber 2,734693e-06 1,681596e-04 3,093808e-184 7,323421e-175
absorción 1,909658e-06 8,335785e-05 1,793308e-185 2,008594e-175
abstractas 1,935732e-04 2,085179e-10 1,164568e-175 1,324132e-176
acaba 1,012065e-03 4,922845e-04 7,509891e-04 5,513437e-04
acceso 2,939728e-04 7,963754e-08 1,827992e-04 2,717835e-04
acción 8,368385e-04 2,932648e-04 3,453599e-04 1,187903e-03
acelerar 8,692348e-04 6,808369e-04 3,490630e-06 2,772260e-04
acentuaba 7,497247e-07 8,490205e-05 5,192422e-185 3,591838e-176
acerca 2,393828e-04 3,106231e-04 3,842188e-06 2,975873e-04
acicate 3,740558e-11 1,718002e-04 3,323277e-171 1,423078e-126
5
abandonar 9,354656e-14
abastecimiento 8,457243e-151
abierto 3,091502e-04
aboga 1,467180e-07
abordar 6,498050e-04
abre 1,387971e-04
abril 3,662802e-06
abrió 2,110706e-04
abrir 2,803019e-04
absoluta 1,169333e-03
absorber 1,581115e-152
absorción 4,388221e-153
abstractas 8,189971e-140
acaba 4,972556e-04
acceso 9,766813e-05
acción 1,140093e-03
acelerar 5,870582e-04
acentuaba 3,094243e-153
acerca 5,510980e-06
acicate 5,408001e-156
%%R
docTopic <- posterior(chapters_lda)$topics
head(docTopic,20)
1 2 3 4 5
120820 6,511880e-01 3,488092e-01 9,304382e-07 9,304382e-07 9,304382e-07
180320 3,614234e-06 3,614234e-06 3,614234e-06 3,614234e-06 9,999855e-01
180420 1,831914e-01 2,323076e-02 7,844012e-07 1,223417e-02 7,813429e-01
200520 8,560119e-01 2,121885e-04 1,406998e-01 3,075366e-03 7,363429e-07
200620 2,020539e-06 2,020539e-06 2,020539e-06 9,999919e-01 2,020539e-06
200820 9,999860e-01 3,501292e-06 3,501292e-06 3,501292e-06 3,501292e-06
210320 7,401085e-07 7,401085e-07 7,401085e-07 9,999970e-01 7,401085e-07
210520 8,326410e-01 1,147447e-06 1,147447e-06 1,147447e-06 1,673556e-01
220320 8,168692e-07 4,092554e-01 5,905961e-01 1,468794e-04 8,168692e-07
220420 8,813313e-07 8,813313e-07 8,813313e-07 9,999965e-01 8,813313e-07
220720 1,729737e-06 9,999931e-01 1,729737e-06 1,729737e-06 1,729737e-06
230520 6,785173e-07 8,089043e-04 4,536673e-01 6,785173e-07 5,455225e-01
230720 6,185612e-01 9,600125e-07 1,828817e-02 3,631487e-01 9,600125e-07
240620 8,004905e-07 9,108765e-03 9,908888e-01 8,004905e-07 8,004905e-07
250320 8,672789e-02 8,244310e-07 8,242104e-01 8,848623e-02 5,746847e-04
250420 4,919627e-06 4,919627e-06 9,224099e-01 4,919627e-06 7,757532e-02
250620 9,999920e-01 1,989294e-06 1,989294e-06 1,989294e-06 1,989294e-06
250820 7,647135e-07 2,657160e-01 7,237183e-01 7,647135e-07 1,056424e-02
270520 1,748568e-01 2,063759e-06 2,063759e-06 2,063759e-06 8,251370e-01
270720 1,428625e-02 1,357826e-06 1,357826e-06 1,357826e-06 9,857097e-01

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.

%%R
chapter_topics <- tidy(chapters_lda, matrix = "beta")
chapter_topics %>% spread(topic,beta)
# A tibble: 6,352 x 6
term `1` `2` `3` `4` `5`
<chr> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 ª 6.45e- 5 1.31e- 6 4.57e- 5 6.59e- 5 4.63e- 13
 2 ábalos 2.34e-141 1.12e- 17 9.68e- 5 6.59e- 5 6.45e- 5
 3 abandonar 6.30e- 4 3.21e- 8 5.22e- 4 1.97e- 4 9.35e- 14
 4 abarca 1.59e-125 9.62e- 8 1.86e- 4 7.52e-59 3.44e- 41
 5 abarrotado 7.63e- 22 5.23e- 50 7.70e- 39 6.59e- 5 1.88e-177
 6 abascal 3.23e- 4 8.24e- 35 9.18e- 18 5.06e-42 5.90e-172
 7 abascalpor 6.45e- 5 2.56e- 35 7.40e- 18 2.72e-43 1.67e-172
 8 abastecimiento 7.92e- 8 1.72e- 4 1.95e- 10 4.62e- 4 8.46e-151
 9 abastecimientoy 3.47e-175 7.20e-180 1.15e-138 6.59e- 5 1.52e-178
10 abatir 2.02e-177 1.10e-179 2.76e-121 6.59e- 5 1.59e-182
# … with 6,342 more rows

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.

%%R
top_terms <- chapter_topics %>%
mutate(topic = paste0("topic", topic)) %>%
group_by(topic) %>%
top_n(15, beta) %>%
ungroup() %>%
arrange(topic, -beta)
%%R
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)") +
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")
png

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

%%R
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"))
}
png

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.

%%R
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(10, 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
}
[1] 2
[1] 3
[1] 4
[1] 5
[1] 3
[1] 4
[1] 5
[1] 4
[1] 5
[1] 5
%%R
multiplot(plot_list[[1]],
plot_list[[2]],
plot_list[[3]],
plot_list[[4]], cols = 1)
png

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”).

%%R
chapters_gamma <- tidy(chapters_lda, matrix = "gamma")
chapters_gamma %>% spread(topic, gamma)
# A tibble: 26 x 6
document `1` `2` `3` `4` `5`
<chr> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 120820 0.651 0.349 0.000000930 0.000000930 0.000000930
 2 180320 0.00000361 0.00000361 0.00000361 0.00000361 1.00
 3 180420 0.183 0.0232 0.000000784 0.0122 0.781
 4 200520 0.856 0.000212 0.141 0.00308 0.000000736
 5 200620 0.00000202 0.00000202 0.00000202 1.00 0.00000202
 6 200820 1.00 0.00000350 0.00000350 0.00000350 0.00000350
 7 210320 0.000000740 0.000000740 0.000000740 1.00 0.000000740
 8 210520 0.833 0.00000115 0.00000115 0.00000115 0.167
 9 220320 0.000000817 0.409 0.591 0.000147 0.000000817
10 220420 0.000000881 0.000000881 0.000000881 1.00 0.000000881
# … with 16 more rows

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.

%%R
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

%%R
chapter_classifications <- chapters_gamma %>%
group_by(title, chapter) %>%
top_n(1, gamma) %>%
ungroup()
chapter_classifications
# A tibble: 26 x 4
title chapter topic gamma
<int> <lgl> <int> <dbl>
 1 120820 NA 1 0.651
 2 200520 NA 1 0.856
 3 200820 NA 1 1.00
 4 210520 NA 1 0.833
 5 230720 NA 1 0.619
 6 250620 NA 1 1.00
 7 220720 NA 2 1.00
 8 280620 NA 2 1.00
 9 220320 NA 3 0.591
10 240620 NA 3 0.991
# … with 16 more rows

Graficamente

%%R
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 intervención segun gamma")
png
%%R
# 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) )
# A tibble: 5 x 21
topic `180320` `180420` `200520` `200620` `200820` `210320` `210520` `220420`
<int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 1 0 0 1 0 1 0 1 0
2 2 0 0 0 0 0 0 0 0
3 3 0 0 0 0 0 0 0 0
4 4 0 0 0 1 0 1 0 1
5 5 1 1 0 0 0 0 0 0
# … with 12 more variables: `220720` <dbl>, `240620` <dbl>, `250320` <dbl>,
# `250420` <dbl>, `250620` <dbl>, `270520` <dbl>, `270720` <dbl>,
# `280320` <dbl>, `280620` <dbl>, `290420` <dbl>, `290720` <dbl>,
# `310520` <dbl>

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.

%%R
# 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)
%%R
(p_1 = top_policy %>%
mutate(policy = paste(title)) %>%
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)") +
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")
)
png

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. 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.

%%R
# 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) )
# A tibble: 20 x 2
consensus topic
<int> <int>
 1 180320 5
 2 180420 5
 3 200520 1
 4 200620 4
 5 200820 1
 6 210320 4
 7 210520 1
 8 220420 4
 9 220720 2
10 240620 3
11 250320 3
12 250420 3
13 250620 1
14 270520 5
15 270720 5
16 280320 3
17 280620 2
18 290420 4
19 290720 3
20 310520 5

Ciertos temas (1,2,4) están muy relacionados con ciertas intervenciones.

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.

%%R
assignments <- augment(chapters_lda, data = chapters_dtm)
# ajuste del uso de pesos original
assignments$count = assignments$count / 100
head(assignments,20)
# A tibble: 20 x 4
document term count .topic
<chr> <chr> <dbl> <dbl>
 1 120820 abandonar 0.2 1
 2 200520 abandonar 0.2 1
 3 210320 abandonar 0.1 4
 4 210520 abandonar 0.6 1
 5 220320 abandonar 0.2 3
 6 220420 abandonar 0.1 4
 7 250820 abandonar 0.1 3
 8 280320 abandonar 0.4 3
 9 290420 abandonar 0.1 4
10 290720 abandonar 0.4 3
11 120820 abastecimiento 0.1 2
12 200620 abastecimiento 0.3 4
13 210320 abastecimiento 0.4 4
14 220320 abastecimiento 0.1 2
15 120820 abierto 0.2 1
16 180420 abierto 0.3 5
17 200520 abierto 0.2 1
18 210520 abierto 0.2 1
19 220420 abierto 0.1 4
20 230520 abierto 0.1 5
%%R
table(assignments$.topic)
1 2 3 4 5
5260 3240 7153 5192 4768

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.

%%R 
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))
# A tibble: 18,192 x 4
title chapter term n
<int> <lgl> <chr> <int>
 1 180320 NA abc 1
 2 180320 NA abismo 1
 3 180320 NA abordar 1
 4 180320 NA acordado 1
 5 180320 NA actitud 1
 6 180320 NA actividad 1
 7 180320 NA actuar 1
 8 180320 NA acuerdo 1
 9 180320 NA administraciones 1
10 180320 NA administracióny 1
# … with 18,182 more rows
%%R
#clasificación incorrecta (sin duplicados por topic4)
(fallos_1 = terms_total %>%
anti_join(aciertos_1, by = c("title", "chapter", "term")) )
# A tibble: 7,421 x 4
title chapter term n
<int> <lgl> <chr> <int>
 1 120820 NA abandonar 4
 2 120820 NA abastecimiento 2
 3 120820 NA abierto 4
 4 120820 NA aboga 4
 5 120820 NA abordar 4
 6 120820 NA abre 2
 7 120820 NA abril 4
 8 120820 NA abrió 2
 9 120820 NA abrir 4
10 120820 NA absoluta 4
# … with 7,411 more rows

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.

%%R
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()

head(assign_2)
# A tibble: 6 x 4
title consensus n percent
<int> <int> <dbl> <dbl>
1 120820 200520 287. 0.217
2 120820 200820 287. 0.217
3 120820 210520 287. 0.217
4 120820 220720 86.4 0.0654
5 120820 250620 287. 0.217
6 120820 280620 86.4 0.0654
%%R
# 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)])

head(assign_2)
# A tibble: 6 x 4
title consensus n percent
<fct> <fct> <dbl> <dbl>
1 120820 200520 287. 0.217
2 120820 200820 287. 0.217
3 120820 NA 287. 0.217
4 120820 NA 86.4 0.0654
5 120820 NA 287. 0.217
6 120820 NA 86.4 0.0654
%%R
library(scales)
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()
png

6 Confrontando intervencións

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

'''%%R
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 = n()) %>%
spread(title, n, fill = 0) %>%
data.frame(row.names = "term")

comparison.cloud(topic_1, max.words = 300, 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"
png
png
png
png
png

Conclusión:

Ese proyecto define la evolución del Presidente del Gobierno a lo largo del periodo que abarca desde el inicio del confinamiento hasta agosto

. Espero que os guste.

No importa de qué libros o blogs o cursos o videos uno aprende, cuando se trata de la implementación todo puede parecer como “Fuera del programa de estudios”

¡La mejor manera de aprender es haciendo! ¡La mejor manera de aprender es enseñando lo que has aprendido!

¡Nunca te rindas!

¡Nos vemos en Linkedin!

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 Alexander Seoane en https://alexanderseoane.com/Final_10N.html y 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/

--

--

Master in Data Science. Passionate about learning new skills. Former branch risk analyst. https://www.linkedin.com/in/oscar-rojo-martin/. www.oscarrojo.es

Love podcasts or audiobooks? Learn on the go with our new app.

Get the Medium app

A button that says 'Download on the App Store', and if clicked it will lead you to the iOS App store
A button that says 'Get it on, Google Play', and if clicked it will lead you to the Google Play store
Oscar Rojo

Oscar Rojo

Master in Data Science. Passionate about learning new skills. Former branch risk analyst. https://www.linkedin.com/in/oscar-rojo-martin/. www.oscarrojo.es