Análisis de las intervenciones del presidente del Gobierno de España
45 min readSep 1, 2020
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.
La web de la cual se ha obtenido dicha información ha sido:
https://www.lamoncloa.gob.es/presidente/intervenciones/Paginas/index.aspxNow 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]: ── [1mAttaching packages[22m ─────────────────────────────────────── tidyverse 1.3.0 ──
R[write to console]: [32m✔[39m [34mggplot2[39m 3.3.2 [32m✔[39m [34mpurrr [39m 0.3.4
[32m✔[39m [34mtibble [39m 3.0.2 [32m✔[39m [34mdplyr [39m 1.0.0
[32m✔[39m [34mtidyr [39m 1.1.0 [32m✔[39m [34mstringr[39m 1.4.0
[32m✔[39m [34mreadr [39m 1.3.1 [32m✔[39m [34mforcats[39m 0.5.0
R[write to console]: ── [1mConflicts[22m ────────────────────────────────────────── tidyverse_conflicts() ──
[31m✖[39m [34mdplyr[39m::[32mfilter()[39m masks [34mstats[39m::filter()
[31m✖[39m [34mdplyr[39m::[32mlag()[39m masks [34mstats[39m::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 [3m[90m<int>[39m[23m 180320, 210320, 220320, 250320, 280320, 180420, 220420, …
$ intervencion [3m[90m<chr>[39m[23m " PEDRO SÁNCHEZ.-Presidente del Gobierno Señora presiden…
$ date [3m[90m<date>[39m[23m 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)[90m# A tibble: 6 x 2[39m
fecha n_words
[3m[90m<int>[39m[23m [3m[90m<int>[39m[23m
[90m1[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m304
[90m2[39m [4m1[24m[4m8[24m[4m0[24m320 [4m1[24m[4m0[24m023
[90m3[39m [4m1[24m[4m8[24m[4m0[24m420 [4m1[24m[4m0[24m273
[90m4[39m [4m2[24m[4m0[24m[4m0[24m520 [4m9[24m389
[90m5[39m [4m2[24m[4m0[24m[4m0[24m620 [4m7[24m002
[90m6[39m [4m2[24m[4m0[24m[4m0[24m820 [4m1[24m[4m0[24m077%%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)
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")))
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)
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)
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")
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")
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())[90m# A tibble: 174 x 3[39m
word1 word2 n
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<int>[39m[23m
[90m 1[39m virus desconocido 8
[90m 2[39m virus covid 7
[90m 3[39m virus dejar 5
[90m 4[39m virus parece 5
[90m 5[39m virus consecuencia 4
[90m 6[39m virus desgraciadamente 4
[90m 7[39m virus sigue 4
[90m 8[39m virus unidad 4
[90m 9[39m virus frente 3
[90m10[39m virus hacer 3
[90m# … with 164 more rows[39m
…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")
“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")
)
%%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)[90m# A tibble: 6 x 4[39m
fecha trigram n rank
[3m[90m<fct>[39m[23m [3m[90m<fct>[39m[23m [3m[90m<int>[39m[23m [3m[90m<int>[39m[23m
[90m1[39m 250620 américa latina caribe___250620 14 1
[90m2[39m 120820 marco financiero plurianual___120820 13 1
[90m3[39m 250620 instituciones financieras internacional___250620 8 2
[90m4[39m 200520 marco financiero plurianual___200520 7 1
[90m5[39m 230520 graciaspresidente muchas gracias___230520 7 1
[90m6[39m 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_listlist()%%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)[90m# A tibble: 6 x 2[39m
fecha bigram
[3m[90m<fct>[39m[23m [3m[90m<chr>[39m[23m
[90m1[39m 180320 díasbueno primero
[90m2[39m 180320 primero gracias
[90m3[39m 180320 gracias medios
[90m4[39m 180320 medios comunidades
[90m5[39m 180320 comunidades atender
[90m6[39m 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)
%%R
p2= plot_list[[2]]
plot(p2)
#multiplot(p1,p2, cols = 2)
%%R
p3= plot_list[[3]]
p4= plot_list[[4]]
multiplot(p3,p4, cols = 2)
%%R
p3= plot_list[[5]]
p4= plot_list[[6]]
multiplot(p3,p4, cols = 2)
%%R
p3= plot_list[[7]]
p4= plot_list[[8]]
multiplot(p3,p4, cols = 2)
%%R
p3= plot_list[[9]]
p4= plot_list[[10]]
multiplot(p3,p4, cols = 2)
%%R
p3= plot_list[[15]]
p4= plot_list[[16]]
multiplot(p3,p4, cols = 2)
%%R
p3= plot_list[[13]]
p4= plot_list[[14]]
multiplot(p3,p4, cols = 2)
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")
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)[90m# A tibble: 6 x 3[39m
fecha word.x bigram
[3m[90m<fct>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m
[90m1[39m 180320 díasbueno díasbueno primero
[90m2[39m 180320 díasbueno primero gracias
[90m3[39m 180320 díasbueno gracias medios
[90m4[39m 180320 díasbueno medios comunidades
[90m5[39m 180320 díasbueno comunidades atender
[90m6[39m 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)[90m# A tibble: 6 x 6[39m
fecha bigram n tf idf tf_idf
[3m[90m<fct>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<int>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m 210520 formación profesional 63 0.020[4m8[24m 1.87 0.039[4m0[24m
[90m2[39m 250620 américa latina 16 0.009[4m1[24m[4m7[24m 3.26 0.029[4m9[24m
[90m3[39m 250620 latina caribe 14 0.008[4m0[24m[4m2[24m 3.26 0.026[4m1[24m
[90m4[39m 310520 sistema financiación 12 0.006[4m0[24m[4m1[24m 2.56 0.015[4m4[24m
[90m5[39m 250620 financieras internacional 8 0.004[4m5[24m[4m8[24m 3.26 0.014[4m9[24m
[90m6[39m 250620 instituciones financieras 8 0.004[4m5[24m[4m8[24m 3.26 0.014[4m9[24m%%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")
%%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)[90m# A tibble: 6 x 6[39m
fecha bigram n tf idf tf_idf
[3m[90m<fct>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<int>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m 210520 formación profesional 63 0.020[4m8[24m 1.87 0.039[4m0[24m
[90m2[39m 250620 américa latina 16 0.009[4m1[24m[4m7[24m 3.26 0.029[4m9[24m
[90m3[39m 250620 latina caribe 14 0.008[4m0[24m[4m2[24m 3.26 0.026[4m1[24m
[90m4[39m 310520 sistema financiación 12 0.006[4m0[24m[4m1[24m 2.56 0.015[4m4[24m
[90m5[39m 250620 financieras internacional 8 0.004[4m5[24m[4m8[24m 3.26 0.014[4m9[24m
[90m6[39m 250620 instituciones financieras 8 0.004[4m5[24m[4m8[24m 3.26 0.014[4m9[24m
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)[90m# A tibble: 50 x 3[39m
item1 item2 correlation
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m coronavirus familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 2[39m veces familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 3[39m ir familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 4[39m enfermedad familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 5[39m covid familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 6[39m planeta familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 7[39m pilares familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 8[39m incertidumbre familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 9[39m nunca familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m10[39m libertad familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m# … with 40 more rows[39m%%R
# Filtrando de una manera sencilla podemos encontrar las palabras más correlacionadas con cualquiera que nos interese.
word_cors %>%
filter(item1 == "coronavirus")[90m# A tibble: 1,352 x 3[39m
item1 item2 correlation
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m coronavirus familiares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 2[39m coronavirus veces -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 3[39m coronavirus ir -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 4[39m coronavirus enfermedad -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 5[39m coronavirus covid -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 6[39m coronavirus planeta -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 7[39m coronavirus pilares -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 8[39m coronavirus incertidumbre -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m 9[39m coronavirus nunca -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m10[39m coronavirus libertad -[31m0[39m[31m.[39m[31m000[39m[31m[4m1[24m[4m7[24m[4m0[24m[39m
[90m# … with 1,342 more rows[39m
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
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)[90m# A tibble: 6 x 3[39m
item1 item2 correlation
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m alarma gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m
[90m2[39m curva gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m
[90m3[39m covid gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m
[90m4[39m sanidad gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m
[90m5[39m hoy gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m
[90m6[39m vamos gracias -[31m0[39m[31m.[39m[31m00[39m[31m2[4m6[24m[4m7[24m[39m%%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]:
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)[90m# A tibble: 6 x 27[39m
word `180320` `210320` `220320` `250320` `280320` `180420` `220420` `250420`
[3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m ª [31mNA[39m 2.13[90me[39m[31m-4[39m [31mNA[39m [90m [39m [31mNA[39m [31mNA[39m [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m
[90m2[39m ábal… [31mNA[39m 2.13[90me[39m[31m-4[39m [31mNA[39m [90m [39m [31mNA[39m [31mNA[39m [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m
[90m3[39m aban… [31mNA[39m 2.13[90me[39m[31m-4[39m 4.70[90me[39m[31m-4[39m [31mNA[39m 0.001[4m3[24m[4m3[24m [31mNA[39m 2.54[90me[39m[31m-4[39m [31mNA[39m
[90m4[39m abar… [31mNA[39m [31mNA[39m [90m [39m 2.35[90me[39m[31m-4[39m [31mNA[39m [31mNA[39m [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m
[90m5[39m abar… [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m [90m [39m [31mNA[39m [31mNA[39m [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m
[90m6[39m abas… [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m [90m [39m [31mNA[39m [31mNA[39m [31mNA[39m [31mNA[39m [90m [39m [31mNA[39m
[90m# … with 18 more variables: `290420` [3m[90m<dbl>[90m[23m, `200520` [3m[90m<dbl>[90m[23m, `210520` [3m[90m<dbl>[90m[23m,[39m
[90m# `230520` [3m[90m<dbl>[90m[23m, `270520` [3m[90m<dbl>[90m[23m, `310520` [3m[90m<dbl>[90m[23m, `200620` [3m[90m<dbl>[90m[23m,[39m
[90m# `240620` [3m[90m<dbl>[90m[23m, `250620` [3m[90m<dbl>[90m[23m, `280620` [3m[90m<dbl>[90m[23m, `300620` [3m[90m<dbl>[90m[23m,[39m
[90m# `220720` [3m[90m<dbl>[90m[23m, `230720` [3m[90m<dbl>[90m[23m, `270720` [3m[90m<dbl>[90m[23m, `290720` [3m[90m<dbl>[90m[23m,[39m
[90m# `120820` [3m[90m<dbl>[90m[23m, `200820` [3m[90m<dbl>[90m[23m, `250820` [3m[90m<dbl>[90m[23m[39m%%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
%%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
%%R
library(grid)
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.
%%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)[90m# A tibble: 6 x 2[39m
word lexicon
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m
[90m1[39m virus custom
[90m2[39m discapacidad custom
[90m3[39m dependencia custom
[90m4[39m inversión custom
[90m5[39m gobierno custom
[90m6[39m 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 ...
[90m# A tibble: 6 x 4[39m
lang word sentiment value
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m spanish abba positive 1
[90m2[39m spanish capacidad positive 1
[90m3[39m spanish citada positive 1
[90m4[39m spanish absoluto positive 1
[90m5[39m spanish absolución positive 1
[90m6[39m 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())
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)
%%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)
%%R
multiplot(b1,b2, cols = 2)
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")
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_ldaA 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)[90m# A tibble: 6,352 x 6[39m
term `1` `2` `3` `4` `5`
[3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m ª 6.45[90me[39m[31m- 5[39m 1.31[90me[39m[31m- 6[39m 4.57[90me[39m[31m- 5[39m 6.59[90me[39m[31m- 5[39m 4.63[90me[39m[31m- 13[39m
[90m 2[39m ábalos 2.34[90me[39m[31m-141[39m 1.12[90me[39m[31m- 17[39m 9.68[90me[39m[31m- 5[39m 6.59[90me[39m[31m- 5[39m 6.45[90me[39m[31m- 5[39m
[90m 3[39m abandonar 6.30[90me[39m[31m- 4[39m 3.21[90me[39m[31m- 8[39m 5.22[90me[39m[31m- 4[39m 1.97[90me[39m[31m- 4[39m 9.35[90me[39m[31m- 14[39m
[90m 4[39m abarca 1.59[90me[39m[31m-125[39m 9.62[90me[39m[31m- 8[39m 1.86[90me[39m[31m- 4[39m 7.52[90me[39m[31m-59[39m 3.44[90me[39m[31m- 41[39m
[90m 5[39m abarrotado 7.63[90me[39m[31m- 22[39m 5.23[90me[39m[31m- 50[39m 7.70[90me[39m[31m- 39[39m 6.59[90me[39m[31m- 5[39m 1.88[90me[39m[31m-177[39m
[90m 6[39m abascal 3.23[90me[39m[31m- 4[39m 8.24[90me[39m[31m- 35[39m 9.18[90me[39m[31m- 18[39m 5.06[90me[39m[31m-42[39m 5.90[90me[39m[31m-172[39m
[90m 7[39m abascalpor 6.45[90me[39m[31m- 5[39m 2.56[90me[39m[31m- 35[39m 7.40[90me[39m[31m- 18[39m 2.72[90me[39m[31m-43[39m 1.67[90me[39m[31m-172[39m
[90m 8[39m abastecimiento 7.92[90me[39m[31m- 8[39m 1.72[90me[39m[31m- 4[39m 1.95[90me[39m[31m- 10[39m 4.62[90me[39m[31m- 4[39m 8.46[90me[39m[31m-151[39m
[90m 9[39m abastecimientoy 3.47[90me[39m[31m-175[39m 7.20[90me[39m[31m-180[39m 1.15[90me[39m[31m-138[39m 6.59[90me[39m[31m- 5[39m 1.52[90me[39m[31m-178[39m
[90m10[39m abatir 2.02[90me[39m[31m-177[39m 1.10[90me[39m[31m-179[39m 2.76[90me[39m[31m-121[39m 6.59[90me[39m[31m- 5[39m 1.59[90me[39m[31m-182[39m
[90m# … with 6,342 more rows[39m
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")
¿ 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"))
}
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)
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)[90m# A tibble: 26 x 6[39m
document `1` `2` `3` `4` `5`
[3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m 120820 0.651 0.349 0.000[4m0[24m[4m0[24m[4m0[24m930 0.000[4m0[24m[4m0[24m[4m0[24m930 0.000[4m0[24m[4m0[24m[4m0[24m930
[90m 2[39m 180320 0.000[4m0[24m[4m0[24m[4m3[24m61 0.000[4m0[24m[4m0[24m[4m3[24m61 0.000[4m0[24m[4m0[24m[4m3[24m61 0.000[4m0[24m[4m0[24m[4m3[24m61 1.00
[90m 3[39m 180420 0.183 0.023[4m2[24m 0.000[4m0[24m[4m0[24m[4m0[24m784 0.012[4m2[24m 0.781
[90m 4[39m 200520 0.856 0.000[4m2[24m[4m1[24m[4m2[24m 0.141 0.003[4m0[24m[4m8[24m 0.000[4m0[24m[4m0[24m[4m0[24m736
[90m 5[39m 200620 0.000[4m0[24m[4m0[24m[4m2[24m02 0.000[4m0[24m[4m0[24m[4m2[24m02 0.000[4m0[24m[4m0[24m[4m2[24m02 1.00 0.000[4m0[24m[4m0[24m[4m2[24m02
[90m 6[39m 200820 1.00 0.000[4m0[24m[4m0[24m[4m3[24m50 0.000[4m0[24m[4m0[24m[4m3[24m50 0.000[4m0[24m[4m0[24m[4m3[24m50 0.000[4m0[24m[4m0[24m[4m3[24m50
[90m 7[39m 210320 0.000[4m0[24m[4m0[24m[4m0[24m740 0.000[4m0[24m[4m0[24m[4m0[24m740 0.000[4m0[24m[4m0[24m[4m0[24m740 1.00 0.000[4m0[24m[4m0[24m[4m0[24m740
[90m 8[39m 210520 0.833 0.000[4m0[24m[4m0[24m[4m1[24m15 0.000[4m0[24m[4m0[24m[4m1[24m15 0.000[4m0[24m[4m0[24m[4m1[24m15 0.167
[90m 9[39m 220320 0.000[4m0[24m[4m0[24m[4m0[24m817 0.409 0.591 0.000[4m1[24m[4m4[24m[4m7[24m 0.000[4m0[24m[4m0[24m[4m0[24m817
[90m10[39m 220420 0.000[4m0[24m[4m0[24m[4m0[24m881 0.000[4m0[24m[4m0[24m[4m0[24m881 0.000[4m0[24m[4m0[24m[4m0[24m881 1.00 0.000[4m0[24m[4m0[24m[4m0[24m881
[90m# … with 16 more rows[39m
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[90m# A tibble: 26 x 4[39m
title chapter topic gamma
[3m[90m<int>[39m[23m [3m[90m<lgl>[39m[23m [3m[90m<int>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m 1 0.651
[90m 2[39m [4m2[24m[4m0[24m[4m0[24m520 [31mNA[39m 1 0.856
[90m 3[39m [4m2[24m[4m0[24m[4m0[24m820 [31mNA[39m 1 1.00
[90m 4[39m [4m2[24m[4m1[24m[4m0[24m520 [31mNA[39m 1 0.833
[90m 5[39m [4m2[24m[4m3[24m[4m0[24m720 [31mNA[39m 1 0.619
[90m 6[39m [4m2[24m[4m5[24m[4m0[24m620 [31mNA[39m 1 1.00
[90m 7[39m [4m2[24m[4m2[24m[4m0[24m720 [31mNA[39m 2 1.00
[90m 8[39m [4m2[24m[4m8[24m[4m0[24m620 [31mNA[39m 2 1.00
[90m 9[39m [4m2[24m[4m2[24m[4m0[24m320 [31mNA[39m 3 0.591
[90m10[39m [4m2[24m[4m4[24m[4m0[24m620 [31mNA[39m 3 0.991
[90m# … with 16 more rows[39m
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")
%%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) )[90m# A tibble: 5 x 21[39m
topic `180320` `180420` `200520` `200620` `200820` `210320` `210520` `220420`
[3m[90m<int>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m 1 0 0 1 0 1 0 1 0
[90m2[39m 2 0 0 0 0 0 0 0 0
[90m3[39m 3 0 0 0 0 0 0 0 0
[90m4[39m 4 0 0 0 1 0 1 0 1
[90m5[39m 5 1 1 0 0 0 0 0 0
[90m# … with 12 more variables: `220720` [3m[90m<dbl>[90m[23m, `240620` [3m[90m<dbl>[90m[23m, `250320` [3m[90m<dbl>[90m[23m,[39m
[90m# `250420` [3m[90m<dbl>[90m[23m, `250620` [3m[90m<dbl>[90m[23m, `270520` [3m[90m<dbl>[90m[23m, `270720` [3m[90m<dbl>[90m[23m,[39m
[90m# `280320` [3m[90m<dbl>[90m[23m, `280620` [3m[90m<dbl>[90m[23m, `290420` [3m[90m<dbl>[90m[23m, `290720` [3m[90m<dbl>[90m[23m,[39m
[90m# `310520` [3m[90m<dbl>[90m[23m[39m
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")
)
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) )[90m# A tibble: 20 x 2[39m
consensus topic
[3m[90m<int>[39m[23m [3m[90m<int>[39m[23m
[90m 1[39m [4m1[24m[4m8[24m[4m0[24m320 5
[90m 2[39m [4m1[24m[4m8[24m[4m0[24m420 5
[90m 3[39m [4m2[24m[4m0[24m[4m0[24m520 1
[90m 4[39m [4m2[24m[4m0[24m[4m0[24m620 4
[90m 5[39m [4m2[24m[4m0[24m[4m0[24m820 1
[90m 6[39m [4m2[24m[4m1[24m[4m0[24m320 4
[90m 7[39m [4m2[24m[4m1[24m[4m0[24m520 1
[90m 8[39m [4m2[24m[4m2[24m[4m0[24m420 4
[90m 9[39m [4m2[24m[4m2[24m[4m0[24m720 2
[90m10[39m [4m2[24m[4m4[24m[4m0[24m620 3
[90m11[39m [4m2[24m[4m5[24m[4m0[24m320 3
[90m12[39m [4m2[24m[4m5[24m[4m0[24m420 3
[90m13[39m [4m2[24m[4m5[24m[4m0[24m620 1
[90m14[39m [4m2[24m[4m7[24m[4m0[24m520 5
[90m15[39m [4m2[24m[4m7[24m[4m0[24m720 5
[90m16[39m [4m2[24m[4m8[24m[4m0[24m320 3
[90m17[39m [4m2[24m[4m8[24m[4m0[24m620 2
[90m18[39m [4m2[24m[4m9[24m[4m0[24m420 4
[90m19[39m [4m2[24m[4m9[24m[4m0[24m720 3
[90m20[39m [4m3[24m[4m1[24m[4m0[24m520 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)[90m# A tibble: 20 x 4[39m
document term count .topic
[3m[90m<chr>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m 1[39m 120820 abandonar 0.2 1
[90m 2[39m 200520 abandonar 0.2 1
[90m 3[39m 210320 abandonar 0.1 4
[90m 4[39m 210520 abandonar 0.6 1
[90m 5[39m 220320 abandonar 0.2 3
[90m 6[39m 220420 abandonar 0.1 4
[90m 7[39m 250820 abandonar 0.1 3
[90m 8[39m 280320 abandonar 0.4 3
[90m 9[39m 290420 abandonar 0.1 4
[90m10[39m 290720 abandonar 0.4 3
[90m11[39m 120820 abastecimiento 0.1 2
[90m12[39m 200620 abastecimiento 0.3 4
[90m13[39m 210320 abastecimiento 0.4 4
[90m14[39m 220320 abastecimiento 0.1 2
[90m15[39m 120820 abierto 0.2 1
[90m16[39m 180420 abierto 0.3 5
[90m17[39m 200520 abierto 0.2 1
[90m18[39m 210520 abierto 0.2 1
[90m19[39m 220420 abierto 0.1 4
[90m20[39m 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))[90m# A tibble: 18,192 x 4[39m
title chapter term n
[3m[90m<int>[39m[23m [3m[90m<lgl>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<int>[39m[23m
[90m 1[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m abc 1
[90m 2[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m abismo 1
[90m 3[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m abordar 1
[90m 4[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m acordado 1
[90m 5[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m actitud 1
[90m 6[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m actividad 1
[90m 7[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m actuar 1
[90m 8[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m acuerdo 1
[90m 9[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m administraciones 1
[90m10[39m [4m1[24m[4m8[24m[4m0[24m320 [31mNA[39m administracióny 1
[90m# … with 18,182 more rows[39m%%R
#clasificación incorrecta (sin duplicados por topic4)
(fallos_1 = terms_total %>%
anti_join(aciertos_1, by = c("title", "chapter", "term")) )[90m# A tibble: 7,421 x 4[39m
title chapter term n
[3m[90m<int>[39m[23m [3m[90m<lgl>[39m[23m [3m[90m<chr>[39m[23m [3m[90m<int>[39m[23m
[90m 1[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abandonar 4
[90m 2[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abastecimiento 2
[90m 3[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abierto 4
[90m 4[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m aboga 4
[90m 5[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abordar 4
[90m 6[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abre 2
[90m 7[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abril 4
[90m 8[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abrió 2
[90m 9[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m abrir 4
[90m10[39m [4m1[24m[4m2[24m[4m0[24m820 [31mNA[39m absoluta 4
[90m# … with 7,411 more rows[39m
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)[90m# A tibble: 6 x 4[39m
title consensus n percent
[3m[90m<int>[39m[23m [3m[90m<int>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m0[24m[4m0[24m520 287. 0.217
[90m2[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m0[24m[4m0[24m820 287. 0.217
[90m3[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m1[24m[4m0[24m520 287. 0.217
[90m4[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m2[24m[4m0[24m720 86.4 0.065[4m4[24m
[90m5[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m5[24m[4m0[24m620 287. 0.217
[90m6[39m [4m1[24m[4m2[24m[4m0[24m820 [4m2[24m[4m8[24m[4m0[24m620 86.4 0.065[4m4[24m%%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)[90m# A tibble: 6 x 4[39m
title consensus n percent
[3m[90m<fct>[39m[23m [3m[90m<fct>[39m[23m [3m[90m<dbl>[39m[23m [3m[90m<dbl>[39m[23m
[90m1[39m 120820 200520 287. 0.217
[90m2[39m 120820 200820 287. 0.217
[90m3[39m 120820 [31mNA[39m 287. 0.217
[90m4[39m 120820 [31mNA[39m 86.4 0.065[4m4[24m
[90m5[39m 120820 [31mNA[39m 287. 0.217
[90m6[39m 120820 [31mNA[39m 86.4 0.065[4m4[24m%%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()
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"
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/