Cachitos 2022. Tercera parte

estadística

polémica

2023

textmining

ocr

linux

cachitos

Author

José Luis Cañadas Reche

Published

January 4, 2023

Vamos ya con la última entrada del cachitos de este año. Las anteriores, las tenemos en esta y esta otra

El csv con el texto de los rótulos para 2022 lo tenemos en este enlace

Vamos al lío

Librerías


    suppressPackageStartupMessages({
        library(tidyverse) 
        library(tidytext)
        
        library(magick)
        library(RColorBrewer)
        library(wordcloud)
        library(topicmodels)
        
        }
    )

Lectura de datos, y vistazo datos

root_directory = "/media/hd1/canadasreche@gmail.com/public/proyecto_cachitos/"
anno <- "2022"

Leemos el csv. Uso DT y así podéis ver todos los datos o buscar cosas, por ejemplo emérito o Ayuso

subtitulos_proces <-  read_csv(str_glue("{root_directory}{anno}_txt_unido.csv"))

subtitulos_proces %>% 
  select(texto, n_fichero, n_caracteres) %>% 
  DT::datatable()

Pues nos valdría con esto para buscar términos polémicos.

Algo de minería de texto

Quitamos stopwords y tokenizamos de forma que tengamos cada palabra en una fila manteniendo de qué rótulo proviene


to_remove <- c(tm::stopwords("es"),
               "110", "4","1","2","7","10","0","ñ","of",
               "5","á","i","the","3", "n", "p",
               "ee","uu","mm","ema", "zz",
               "wr","wop","wy","x","xi","xl","xt",
               "xte","yí", "your")



subtitulos_proces_one_word <- subtitulos_proces %>% 
    unnest_tokens(input = texto,
                  output = word) %>% 
    filter(! word %in% to_remove) %>% 
    filter(nchar(word) > 1)

# Se nos quedan 3766 filas/palabras de los 488 rótulos
dim(subtitulos_proces_one_word)
#> [1] 3766    5

DT::datatable(subtitulos_proces_one_word)

Contar ocurrencias de cosas es lo más básico.


palabras_ordenadas_1 <- subtitulos_proces_one_word %>% 
    group_by(word) %>% 
    summarise(veces = n()) %>% 
    arrange(desc(veces))

palabras_ordenadas_1 %>% 
    slice(1:20) %>% 
    ggplot(aes(x = reorder(word, veces), y = veces)) +
    geom_col(show.legend = FALSE) +
    ylab("veces") +
    xlab("") +
    coord_flip() +
    theme_bw()

Y como el año pasado la palabra más común es “canción” . ¿Y si añadimos las 20 palabras como stopword, junto con algunas como [“tan”, “sólo”,“así”, “aquí”, “hoy”] . La tarea de añadir palabras como stopwords requiere trabajo, tampoco nos vamos a parar tanto.

(add_to_stop_words <- palabras_ordenadas_1 %>% 
    slice(1:25) %>% 
    pull(word) )
#>  [1] "canción"  "si"       "año"      "años"     "después"  "menos"   
#>  [7] "mismo"    "ahora"    "banda"    "grupo"    "versión"  "letra"   
#> [13] "ser"      "siempre"  "bien"     "cantante" "dos"      "momento" 
#> [19] "parece"   "sigue"    "tema"     "ver"      "aquí"     "así"     
#> [25] "casa"


to_remove <- unique(c(to_remove,
                      add_to_stop_words,
                      "tan", 
                      "sólo", 
                      "así",
                      "aquí", 
                      "hoy",
                      "va"))


subtitulos_proces_one_word <- subtitulos_proces %>% 
    unnest_tokens(input = texto,
                  output = word) %>% 
    filter(! word %in% to_remove) %>% 
    filter(nchar(word) > 1)


palabras_ordenadas_2 <- subtitulos_proces_one_word %>% 
    group_by(word) %>% 
    summarise(veces = n()) %>% 
    arrange(desc(veces))

palabras_ordenadas_2 %>% 
    slice(1:20) %>% 
    ggplot(aes(x = reorder(word, veces), y = veces)) +
    geom_col(show.legend = FALSE) +
    ylab("veces") +
    xlab("") +
    coord_flip() +
    theme_bw()

También podemos ver ahora una nube de palabras


pal <- brewer.pal(8,"Dark2")

subtitulos_proces_one_word %>% 
    group_by(word) %>% 
    count() %>% 
    with(wordcloud(word, n, random.order = FALSE, max.words = 80, colors=pal))

¿Polémicos?

Creamos lista de palabras polémicas (se aceptan otras, podéis poner en los comentarios)


palabras_polem <- c("abascal", "almeida", "ayuso", "belarra", "bloqueo",
                "borbon", "borras", "calvo", "celaa", "cgpj", "cis",
                "ciudada", "comunidad", "conde", "constitucional", "coron",
                "democr", "democracia", "derech", "díaz", "dioni",
                "errejon", "extremadura", "fach", "falcon", "feij",
                "gobierno", "guardia", "iglesias", "illa", "ivan",
                "izquier", "ley", "madrid","manipulador", "marlaska", 
                "marruecos","melilla", "militares", "minist", "monarca",
                "montero","negacion", "negacionismo", "olona", "oposición",
                "page", "pandem", "pp", "principe", "prisión", "psoe",
                "redondo", "republic", "rey", "rufian", "rufián", 
                "sabina", "sanchez", "sánchez", "sanz","tezanos", 
                "toled", "trans", "transición", "tren", "ultra",
                "vicepre", "vox", "yolanda", "zarzu", "zarzuela")

Y construimos una regex simple

(exp_regx <- paste0("^",paste(palabras_polem, collapse = "|^")))
#> [1] "^abascal|^almeida|^ayuso|^belarra|^bloqueo|^borbon|^borras|^calvo|^celaa|^cgpj|^cis|^ciudada|^comunidad|^conde|^constitucional|^coron|^democr|^democracia|^derech|^díaz|^dioni|^errejon|^extremadura|^fach|^falcon|^feij|^gobierno|^guardia|^iglesias|^illa|^ivan|^izquier|^ley|^madrid|^manipulador|^marlaska|^marruecos|^melilla|^militares|^minist|^monarca|^montero|^negacion|^negacionismo|^olona|^oposición|^page|^pandem|^pp|^principe|^prisión|^psoe|^redondo|^republic|^rey|^rufian|^rufián|^sabina|^sanchez|^sánchez|^sanz|^tezanos|^toled|^trans|^transición|^tren|^ultra|^vicepre|^vox|^yolanda|^zarzu|^zarzuela"

Y nos creamos una variable para identificar si es palabra polémica

subtitulos_proces_one_word <- subtitulos_proces_one_word %>% 
    mutate(polemica= str_detect(word, exp_regx))


subtitulos_polemicos <- subtitulos_proces_one_word %>% 
    filter(polemica) %>% 
    pull(n_fichero) %>% 
    unique()

subtitulos_polemicos
#>  [1] "00000018.jpg.subtitulo.tif.txt" "00000086.jpg.subtitulo.tif.txt"
#>  [3] "00000100.jpg.subtitulo.tif.txt" "00000113.jpg.subtitulo.tif.txt"
#>  [5] "00000127.jpg.subtitulo.tif.txt" "00000193.jpg.subtitulo.tif.txt"
#>  [7] "00000209.jpg.subtitulo.tif.txt" "00000225.jpg.subtitulo.tif.txt"
#>  [9] "00000242.jpg.subtitulo.tif.txt" "00000258.jpg.subtitulo.tif.txt"
#> [11] "00000289.jpg.subtitulo.tif.txt" "00000377.jpg.subtitulo.tif.txt"
#> [13] "00000475.jpg.subtitulo.tif.txt" "00000483.jpg.subtitulo.tif.txt"
#> [15] "00000522.jpg.subtitulo.tif.txt" "00000551.jpg.subtitulo.tif.txt"
#> [17] "00000563.jpg.subtitulo.tif.txt" "00000564.jpg.subtitulo.tif.txt"
#> [19] "00000566.jpg.subtitulo.tif.txt" "00000643.jpg.subtitulo.tif.txt"
#> [21] "00000706.jpg.subtitulo.tif.txt" "00000814.jpg.subtitulo.tif.txt"
#> [23] "00000846.jpg.subtitulo.tif.txt" "00000939.jpg.subtitulo.tif.txt"
#> [25] "00000945.jpg.subtitulo.tif.txt" "00000946.jpg.subtitulo.tif.txt"
#> [27] "00000997.jpg.subtitulo.tif.txt" "00001005.jpg.subtitulo.tif.txt"
#> [29] "00001006.jpg.subtitulo.tif.txt" "00001026.jpg.subtitulo.tif.txt"
#> [31] "00001030.jpg.subtitulo.tif.txt" "00001031.jpg.subtitulo.tif.txt"
#> [33] "00001061.jpg.subtitulo.tif.txt" "00001072.jpg.subtitulo.tif.txt"
#> [35] "00001112.jpg.subtitulo.tif.txt" "00001122.jpg.subtitulo.tif.txt"
#> [37] "00001132.jpg.subtitulo.tif.txt" "00001200.jpg.subtitulo.tif.txt"
#> [39] "00001231.jpg.subtitulo.tif.txt" "00001232.jpg.subtitulo.tif.txt"
#> [41] "00001276.jpg.subtitulo.tif.txt"

Y podemos ver en el texto original antes de tokenizar qué rótulos hemos considerado polémicos y qué texto

subtitulos_proces %>% 
    filter(n_fichero %in% subtitulos_polemicos) %>% 
    arrange(n_fichero) %>% 
    pull(texto) %>% 
    unique()
#>  [1] "bienvenidos si estáis todos es porque habéis recordado que tras los cuartos van tu banco hacienda y el rey emérito"   
#>  [2] "la orquesta gente joven fue posponiendo el cambio de nombre como el psoe con la ley trans"                            
#>  [3] "hace chacachá entonces podemos llamarlo y q tren de altas prestaciones de extremadura"                                
#>  [4] "debieron traducir la letra con el google translate de la época el collins no phil sino el diccionario"                
#>  [5] "de imagen y de mensaje iban sobrados pp como samantha hudson pero con musicón"                                        
#>  [6] "rocío ya cumplía la ley de transparencia 23 años antes de su aproba"                                                  
#>  [7] "en 2022 cayeron los muros de metacrilato ya sólo llevamos mascarilla en transporte orgías y atracos"                  
#>  [8] "si tuviera sólo una pizca más de clase habría que aplicarle la ley celaá"                                             
#>  [9] "es muy raro ver actuar con tanta coordinación a quienes están a la izquierda"                                         
#> [10] "como feos de pleno derecho por eso somos guionistas vamos a ofendernos un poco y ahora seguimos"                      
#> [11] "oes del silencio roe de leyenda"                                                                                      
#> [12] "la primera comunión 7 de macarena olona rena olona"                                                                   
#> [13] "pa así eran las fiestas de nochevieja a antes de la ley antitabaco"                                                   
#> [14] "midge fue líder de ultravox y como veis domina el arte o del falsete el santiago abascal escocés"                     
#> [15] "niños no os preocupéis que en cuanto terminen la actuación los reyes magos se ponen con lo de los regalos"            
#> [16] "su hombre blandengue ha servido para una campaña del ministerio de igualdad a ver cuándo le toca a la mandanga"       
#> [17] "mn poner resistiré y salir al balcón a aplaudir a los militares"                                                      
#> [18] "recuperar el lema de la transición a follar que el mundo se va a acabar"                                              
#> [19] "82 negarlo todo y seguir viviendo no como el resto de borregos que creen a los medios manipuladores"                  
#> [20] "esta leyenda de la música italiana cultivó con éxito el look llevo 15 días durmiendo en un ford fiesta"               
#> [21] "necesitaron una pandemia mundial para dar el pelotazo a almeida le bastó con un saque de honor"                       
#> [22] "desde la atrevida ignorancia de algún panfleto le definieron como transformista supremacista asturiano"               
#> [23] "me tienes aquí colgado es originalmente de las supremes hoy se canta en los centros médicos de la comunidad de madrid"
#> [24] "y se entiende perfectamente los disfraces de ardilla pp lo que más"                                                   
#> [25] "nos ha pedido pedro sánchez que os digamos que esta subida también es culpa de la guerra en ucrania"                  
#> [26] "izquierda derecha como veis tienen la postura tan sólidamente definida como el gobierno respecto al sahara"           
#> [27] "la relación entre rufián y borrás tiene menos roces"                                                                  
#> [28] "no dirás que no es doble negacionismo"                                                                                
#> [29] "venga que esta nos la sabemos todos de mario conde al dioni"                                                          
#> [30] "sin documentos es mejor no quedarse q entreespaña y marruecos"                                                        
#> [31] "quín sabina to entre caballeros"                                                                                      
#> [32] "sabina pactó con unos ladrones hacerles esta copla y cumplió como lo del cgpj pero con gente responsable"             
#> [33] "es incomprensible que los negacionistas no usaran este tema para protestar por las mascarillas"                       
#> [34] "y ahora que hemos localizado a la prima de mari carmen del hermano de ayuso sabéis algo"                              
#> [35] "en su último disco se han disfrazado de star wars ángeles de leia y dioni de maestro jedi"                            
#> [36] "transitando la fina línea que separa a danny zuko att del protagonista de una peli de eloy de la iglesia"             
#> [37] "desde 2013 tina es ciudadana suiza allí disfruta de sus paisajes alpinos y un poco también de su régimen fiscal"      
#> [38] "esas hombreras nos habrían venido muy bien para mantener la distancia social durante la pandemia"                     
#> [39] "catar no es una democracia sino una monarquía absoluta sin respeto por los derechos humanos dos"                      
#> [40] "el esfuerzo del coreógrafo es inútil la única forma de bailar esto es haciendo el trenecito"                          
#> [41] "g 1 cachitos es como el roscón de reyes a a siempre suele llevar abba dentro"

Y podemos ver los fotogramas.

# identificamos nombre del archivo jpg con los rótulos polémicos
polemica_1_fotogramas <- unique(substr(subtitulos_polemicos, 1,12))

head(polemica_1_fotogramas)
#> [1] "00000018.jpg" "00000086.jpg" "00000100.jpg" "00000113.jpg" "00000127.jpg"
#> [6] "00000193.jpg"

# creamos la ruta completa donde están
polemica_1_fotogramas_full <- paste0(str_glue("{root_directory}video/{anno}_jpg/"), polemica_1_fotogramas)


# añadimos sufijo subtitulo.tif para tenr localizado la imagen que tiene solo los rótulos
subtitulos_polemicos_1_full <- paste0(polemica_1_fotogramas_full,".subtitulo.tif")

Con la función image_read del paquete magick leemos las imágenes polémicas y los rótulos

fotogramas_polemicos_img <- map(polemica_1_fotogramas_full, image_read)
subtitulos_polemicos_img <- map(subtitulos_polemicos_1_full, image_read)


subtitulos_polemicos_img[[25]]

fotogramas_polemicos_img[[25]]

Podemos ver una muestra de algunos de ellos.

No es perfecto ( al meter ley o tren como palabras polémticas) pero bueno, nos vale.

set.seed(2023)
indices <- sort(sample(1:length(fotogramas_polemicos_img), 9))

lista_fotogram_polemicos <- lapply(fotogramas_polemicos_img[indices], grid::rasterGrob)
gridExtra::grid.arrange(grobs=lista_fotogram_polemicos )

Y el recorte de los subtítulos que hicimos enla primera entrega.

lista_subtitulos <-  lapply(subtitulos_polemicos_img[indices], grid::rasterGrob)
gridExtra::grid.arrange(grobs=lista_subtitulos)

Tópicos

Aquí no me refiero a los tópicos de este país nuestro, sino a identificar si hay temas comunes a varios documentos.

Ya aviso que con tan pocos “documentos”, unos 488 y siendo tan cortos cada rótulo, es muy probable que no salga mucho..

Tópicos usando conteo de palabras.

Contamos palabras con 3 caracteres o más.

Guardamos la variable name que nos indica en qué rótulo ha aparecido


word_counts <- subtitulos_proces_one_word %>% 
    group_by(name, word) %>% 
    count(sort=TRUE) %>% 
    mutate(ncharacters = nchar(word)) %>% 
    filter(
        ncharacters >= 3) %>% 
    select(-ncharacters) %>% 
    ungroup()


length(unique(word_counts$name))
#> [1] 488

head(word_counts, 15)
#> # A tibble: 15 × 3
#>     name word         n
#>    <dbl> <chr>    <int>
#>  1   433 duran        3
#>  2   924 boom         3
#>  3    51 palabra      2
#>  4   181 voz          2
#>  5   269 enemigos     2
#>  6   269 john         2
#>  7   269 wayne        2
#>  8   355 plano        2
#>  9   377 olona        2
#> 10   396 iba          2
#> 11   455 montar       2
#> 12   492 gusta        2
#> 13   558 ropa         2
#> 14   598 calderón     2
#> 15   598 carlos       2

Ahora convertimos este data.frame a un DocumentTermMatrix

# usamos como peso la TermFrequency de la palabra
rotulos_dtm <- word_counts %>%
    cast_dtm(name, word, n, weighting = tm::weightTf)


rotulos_dtm
#> <<DocumentTermMatrix (documents: 488, terms: 2478)>>
#> Non-/sparse entries: 3257/1206007
#> Sparsity           : 100%
#> Maximal term length: 24
#> Weighting          : term frequency (tf)

Podríamos haberlo visto en forma de filas = palabras y columnas = rótulo

word_counts  %>%
    cast_dfm(word, name, n)
#> Document-feature matrix of: 2,478 documents, 488 features (99.73% sparse) and 0 docvars.
#>           features
#> docs       433 924 51 181 269 355 377 396 455 492
#>   duran      3   0  0   0   0   0   0   0   0   0
#>   boom       0   3  0   0   0   0   0   0   0   0
#>   palabra    0   0  2   0   0   0   0   0   0   0
#>   voz        0   0  0   2   0   0   0   0   0   0
#>   enemigos   0   0  0   0   2   0   0   0   0   0
#>   john       0   0  0   0   2   0   0   0   0   0
#> [ reached max_ndoc ... 2,472 more documents, reached max_nfeat ... 478 more features ]

Vamos a ver si sale algo haciendo un LDA (Latent Dirichlet Allocation)

Considero 7 tópicos porque me gusta el número 7. El que quiera elegir con algo más de criterio que se mire esto


# Cons

rotulos_lda <- LDA(rotulos_dtm, k = 7, control = list(seed = 1234))
rotulos_lda
#> A LDA_VEM topic model with 7 topics.

rotulos_lda_td <- tidy(rotulos_lda)
rotulos_lda_td
#> # A tibble: 17,346 × 3
#>    topic term      beta
#>    <int> <chr>    <dbl>
#>  1     1 duran 3.39e-75
#>  2     2 duran 3.55e-75
#>  3     3 duran 6.13e- 3
#>  4     4 duran 3.56e-75
#>  5     5 duran 3.18e-75
#>  6     6 duran 3.75e-75
#>  7     7 duran 3.63e-75
#>  8     1 boom  6.21e- 3
#>  9     2 boom  4.49e-75
#> 10     3 boom  4.23e-75
#> # … with 17,336 more rows

# se suele ordenar por beta que ahora mismo no recuerdo que era, 

top_terms <- rotulos_lda_td %>%
    group_by(topic) %>%
    top_n(3, beta) %>%
    ungroup() %>%
    arrange(topic, -beta)

top_terms
#> # A tibble: 34 × 3
#>    topic term     beta
#>    <int> <chr>   <dbl>
#>  1     1 disco 0.0124 
#>  2     1 juan  0.0104 
#>  3     1 hacer 0.00878
#>  4     2 mundo 0.0130 
#>  5     2 gusta 0.00651
#>  6     2 bueno 0.00651
#>  7     2 salir 0.00651
#>  8     2 peret 0.00651
#>  9     3 fama  0.0123 
#> 10     3 voz   0.00817
#> # … with 24 more rows


top_terms %>%
    mutate(term = reorder_within(term, beta, topic)) %>%
    ggplot(aes(term, beta)) +
    geom_bar(stat = "identity") +
    scale_x_reordered() +
    facet_wrap(~ topic, scales = "free_x") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))

Pues la verdad es que yo no veo nada interesante

Tópicos usando tfidf como peso

Vamos a probar usando tfidf

Como la función LDA no permite usar un DocumentTermMatrix que se haya construido con cast_dtm y usando como parámetro de weighting el peso tm::weightTfIdf nos construimos los datos de otra forma.


tf_idf_data <- subtitulos_proces_one_word %>% 
    filter(nchar(word)>2) %>% 
    group_by(name,word) %>% 
    summarise(veces_palabra = n()) %>% 
    bind_tf_idf(word, name, veces_palabra) %>% 
    ungroup()

tf_idf_data %>% 
    arrange(desc(veces_palabra)) %>%
    head()
#> # A tibble: 6 × 6
#>    name word     veces_palabra    tf   idf tf_idf
#>   <dbl> <chr>            <int> <dbl> <dbl>  <dbl>
#> 1   433 duran                3 0.6    6.19   3.71
#> 2   924 boom                 3 0.75   6.19   4.64
#> 3    51 palabra              2 0.286  5.50   1.57
#> 4   181 voz                  2 0.5    4.24   2.12
#> 5   269 enemigos             2 0.25   5.50   1.37
#> 6   269 john                 2 0.25   4.80   1.20

Para cada palabra tenemos su tf_idf dentro de cada rótulo en el que aparece

tf_idf_data %>% 
    filter(word== "izquierda")
#> # A tibble: 2 × 6
#>    name word      veces_palabra    tf   idf tf_idf
#>   <dbl> <chr>             <int> <dbl> <dbl>  <dbl>
#> 1   242 izquierda             1 0.2    5.50  1.10 
#> 2   946 izquierda             1 0.111  5.50  0.611

Como de nuevo LDA solo acepta peso con valores enteros, pues simplemente multiplicamos por 100 el tf_idf y redondeamos

dtm_long <- tf_idf_data %>% 
    mutate(tf_idf_integer = round(100*tf_idf)) %>% 
    cast_dfm(name, word, tf_idf_integer)

lda_model_long_1 <- LDA(dtm_long, k = 7, control = list(seed = 1234))

result <- tidy(lda_model_long_1, 'beta')

result %>%
    group_by(topic) %>%
    top_n(5, beta) %>%
    ungroup() %>%
    arrange(topic, -beta) %>% 
    mutate(term = reorder(term, beta)) %>%
    ggplot(aes(term, beta, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ topic, scales = "free", ncol = 4) +
    coord_flip()

Y claramente , yo sigo sin ver nada claro. Aunque me daría pistas para añadir más palabras a las stopwords y para aceptar que para el tamaño de los documentos (unas pocas palabras por rótulo), quizá no valga el LDA.

Esta es la vida del analista de datos, prueba y error y sólo de vez en cuándo algún éxito.

Sólo con los rótulos polémicos

Asumiendo que parece que no tiene sentido hacer topicmodelling sobre estos datos, me picó la curiosidad de ver qué pasaba si sólo usaba los rótulos polémicos.


tf_idf_data_polem <- subtitulos_proces_one_word %>% 
    filter(nchar(word)>2, polemica == TRUE) %>% 
    group_by(name,word) %>% 
    summarise(veces_palabra = n()) %>% 
    bind_tf_idf(word, name, veces_palabra) %>% 
    ungroup() 


tf_idf_data_polem %>% 
    arrange(desc(veces_palabra)) %>%
    head()
#> # A tibble: 6 × 6
#>    name word        veces_palabra    tf   idf tf_idf
#>   <dbl> <chr>               <int> <dbl> <dbl>  <dbl>
#> 1   377 olona                   2 1      3.66  3.66 
#> 2    18 rey                     1 1      3.66  3.66 
#> 3    86 ley                     1 0.333  2.28  0.759
#> 4    86 psoe                    1 0.333  3.66  1.22 
#> 5    86 trans                   1 0.333  3.66  1.22 
#> 6   100 extremadura             1 0.5    3.66  1.83

Topic modelling usando conteo de palabras

dtm_long_polem <- tf_idf_data_polem %>% 
    # filter(tf_idf > 0.00006) %>% 
    # filter(veces_palabra>1) %>%
    cast_dtm(name, word, veces_palabra)

lda_model_long_polem <- LDA(dtm_long_polem, k = 7, control = list(seed = 1234))

result_polem <- tidy(lda_model_long_polem, 'beta')

result_polem %>%
    group_by(topic) %>%
    top_n(5, beta) %>%
    ungroup() %>%
    arrange(topic, -beta) %>% 
    mutate(term = reorder(term, beta)) %>%
    ggplot(aes(term, beta, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ topic, scales = "free", ncol = 4) +
    coord_flip()

Y bueno parece que en el tópico 3 se meten juntos rótulos que hablan de pandemia y de negacionistas, ha podido ser casalidad, quién sabe.

Si vemos en qué tópico cae cada documento.

result_documento_polem <-  tidy(lda_model_long_polem, 'gamma')


result_documento_polem %>%
    group_by(topic) %>%
    top_n(5, gamma) %>%
    ungroup() %>%
    arrange(topic, -gamma) %>% 
    mutate(document = reorder(document, gamma)) %>%
    ggplot(aes(document, gamma, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ topic, scales = "free", ncol = 4) +
    coord_flip()

Veamos algunos subtítulos del tópico 3

subtitulos_proces %>% 
    filter(name %in% c(100, 706, 1061, 563)) %>% 
    pull(texto)
#> [1] "hace chacachá entonces podemos llamarlo y q tren de altas prestaciones de extremadura"         
#> [2] "mn poner resistiré y salir al balcón a aplaudir a los militares"                               
#> [3] "necesitaron una pandemia mundial para dar el pelotazo a almeida le bastó con un saque de honor"
#> [4] "es incomprensible que los negacionistas no usaran este tema para protestar por las mascarillas"

top_10_topic3 <-  result_documento_polem %>%
    group_by(topic) %>% 
    top_n(10, gamma) %>% 
    filter(topic==3) %>% 
    pull(document)

subtitulos_proces %>% 
    filter(name %in% top_10_topic3) %>% 
    pull(texto)
#>  [1] "hace chacachá entonces podemos llamarlo y q tren de altas prestaciones de extremadura"                          
#>  [2] "es muy raro ver actuar con tanta coordinación a quienes están a la izquierda"                                   
#>  [3] "mn poner resistiré y salir al balcón a aplaudir a los militares"                                                
#>  [4] "necesitaron una pandemia mundial para dar el pelotazo a almeida le bastó con un saque de honor"                 
#>  [5] "nos ha pedido pedro sánchez que os digamos que esta subida también es culpa de la guerra en ucrania"            
#>  [6] "no dirás que no es doble negacionismo"                                                                          
#>  [7] "quín sabina to entre caballeros"                                                                                
#>  [8] "es incomprensible que los negacionistas no usaran este tema para protestar por las mascarillas"                 
#>  [9] "desde 2013 tina es ciudadana suiza allí disfruta de sus paisajes alpinos y un poco también de su régimen fiscal"
#> [10] "esas hombreras nos habrían venido muy bien para mantener la distancia social durante la pandemia"

Y bueno si que parece que ha agrupado algunos rótulos relacionados con la pandemia

Topic modelling usando tf_idf

dtm_long_polem_tf_idf <- tf_idf_data_polem %>%
    mutate(tf_idf_integer = round(100 * tf_idf)) %>%
    cast_dfm(name, word, tf_idf_integer)

lda_model_long_polem_tf_idf <- LDA(dtm_long_polem_tf_idf, k = 7, control = list(seed = 1234))

result_polem_tf_idf <- tidy(lda_model_long_polem_tf_idf, 'beta')

result_polem_tf_idf %>%
    group_by(topic) %>%
    top_n(5, beta) %>%
    ungroup() %>%
    arrange(topic, -beta) %>% 
    mutate(term = reorder(term, beta)) %>%
    ggplot(aes(term, beta, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ topic, scales = "free", ncol = 4) +
    coord_flip()

Y no parece tan diferente. Veamos el tópico 4

result_documento_polem_tf_idf <-  tidy(lda_model_long_polem_tf_idf, 'gamma')


result_documento_polem_tf_idf %>%
    group_by(topic) %>%
    top_n(5, gamma) %>%
    ungroup() %>%
    arrange(topic, -gamma) %>% 
    mutate(document = reorder(document, gamma)) %>%
    ggplot(aes(document, gamma, fill = factor(topic))) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ topic, scales = "free", ncol = 4) +
    coord_flip()

Veamos algunos subtítulos del tópico 4

top_5_topic4 <-  result_documento_polem_tf_idf %>%
    group_by(topic) %>% 
    top_n(5, gamma) %>% 
    filter(topic==4) %>% 
    pull(document)

subtitulos_proces %>% 
    filter(name %in% top_5_topic4) %>% 
    pull(texto)
#> [1] "la orquesta gente joven fue posponiendo el cambio de nombre como el psoe con la ley trans"                 
#> [2] "como feos de pleno derecho por eso somos guionistas vamos a ofendernos un poco y ahora seguimos"           
#> [3] "izquierda derecha como veis tienen la postura tan sólidamente definida como el gobierno respecto al sahara"
#> [4] "es incomprensible que los negacionistas no usaran este tema para protestar por las mascarillas"            
#> [5] "el esfuerzo del coreógrafo es inútil la única forma de bailar esto es haciendo el trenecito"

Y bueno no lo veo tan poco muy claro.

Otras pruebas realizadas

En vez de considerar que cada rótulo es un documento, consideré los rótulos correspondientes a la primera parte del programa, a la segunda, y así hasta 10. pero no se obtuvo nada consistente

Y bueno aquí acaba el análisis del cachitos de este año, salvo que alguien tenga interés en que haga alguna prueba o mejore algo.

Feliz 2023 a todos