Resumen

El objetivo de este notebook es representar oraciones mediante el modelo GloVe. Este modelo normalmente se utiliza para representar palabras con muy buenos resultados, en este caso se hace una ajuste de los vectores de cada palabra para lograr un vector de cada frase tratada.

Una vez establecido el modelo vectorial GloVe, se determina un modelo XGBTree para predecir la veracidad de desastres informados en varios textos.

Para ello se utilizan dos datasets, el primero es un dataset con mensajes informando desastres en twitter, con esta base de datos se implementa el XGBTree.

El segundo dataset es grande y se utiliza para generar el modelo GloVe, esto es para lograr generalizar mejor con GloVe.

GloVe (Global Vectors)

GloVe , que viene de Global Vectors, es un modelo para representar palabras distribuidas. El modelo es un algoritmo de aprendizaje no supervisado para obtener representaciones vectoriales de palabras. Esto se logra mapeando palabras en un espacio significativo donde la distancia entre palabras esta relacionada con la similitud semantica. El entrenamiento se realiza en estadisticas globales de co-ocurrencia palabra-palabra agregadas de un corpus, y las representaciones resultantes muestran interesantes subestructuras lineales del espacio vectorial de palabras (Wikipedia).

El algoritmo GloVe consta de los siguientes pasos:

1- Recopilacion de estadisticas de co-ocurrencia de palabras en una forma de matriz de co-ocurrencia \(X\). Cada elemento \(X_{ij}\) de dicha matriz representa la frecuencia con la que aparece la palabra \(i\) en el contexto de la palabra \(j\). Por lo general, se escanea el corpus de la siguiente manera: para cada termino se buscan terminos de contexto dentro de un area definida por un window-size antes del termino y un window.size despues del termino. Tambien se da menos peso a las palabras mas distantes, usualmente usando esta formula:

\[decay = \frac{1}{offset}\]

2- Definir restricciones suaves para cada par de palabras:

\[w_{i}^{T}w_j+b_i+b_j = log(X_{ij})\]

Donde:

  • \(w_i\): vector palabra principal.
  • \(w_j\): vector palabra contexto.
  • \(b_i\): sesgo palabra principal.
  • \(b_j\): sesgo palabra contexto.

3- Definir una funcion de costos:

\[J=\sum_{i=1}^{V}\sum_{j=1}^{V}f(X_{ij})(w_{i}^{T}w_j+b_i+b_j-logX_{ij})^2\]

Donde \(f\) es una funcion de ponderacion que ayuda a evitar el aprendizaje solo de pares de palabras extremadamente comunes. Los autores de GloVe eligen la siguiente funcion:

\[f(X_{ij})=\begin{cases} (\frac{X_{ij}}{x_{max}})^\alpha & \text{si X_{ij} > XMAX} \\1 & \text{en otro caso}\end{cases}\]

Para mayor informacion revisar “GloVe: Global Vectors for Word Representation”, “GloVe Word Embeddings”.

Exploracion Datasets.

Real or Not? NLP with Disaster Tweets.

Twitter es un importante canal de comunicacion en tiempos de emergencia. La ubicuidad de los telefonos inteligentes permite a las personas anunciar una emergencia que estan observando en tiempo real. Debido a esto, mas agencias estan interesadas en monitorear Twitter (es decir, organizaciones de ayuda ante desastres y agencias de noticias). Sin embargo, no siempre esta claro si las palabras de una persona realmente anuncian un desastre. Este dataset representa una muestra de mensajes de emergencia en Twitter identificando si los desastres informados son reales o no.

A continuacion se muestran las primeras 6 observaciones del dataset, que muestra que consta de 5 columnas:

  • id: un identificador unico para cada tweet.
  • keyword: una palabra clave en particular del tweet (puede estar en blanco).
  • location: la ubicacion desde la que se envio el tweet (puede estar en blanco).
  • text: el texto del tweet.
  • target: indica si un tweet trata sobre un desastre real (1) o no (0).
dataDisaster <- fread("train.csv")
htmlTable(dataDisaster %>% head(),
          caption = "Tabla 1. Muestra del dataset.",
          tfoot = "&dagger; primeras 6 observaciones",
          col.rgroup = c("none","#FC7C7C"),
          css.cell = "padding-left: .5em; padding-right: .2em;")
Tabla 1. Muestra del dataset.
id keyword location text target
1 1 Our Deeds are the Reason of this #earthquake May ALLAH Forgive us all 1
2 4 Forest fire near La Ronge Sask. Canada 1
3 5 All residents asked to ‘shelter in place’ are being notified by officers. No other evacuation or shelter in place orders are expected 1
4 6 13,000 people receive #wildfires evacuation orders in California 1
5 7 Just got sent this photo from Ruby #Alaska as smoke from #wildfires pours into a school 1
6 8 #RockyFire Update => California Hwy. 20 closed in both directions due to Lake County fire - #CAfire #wildfires 1
† primeras 6 observaciones

De estas variables se utilizan solo text como caracteristica para predecir target. Se observa que el dataset tiene 7613 observaciones, donde 42.97% de las observaciones son desastres reales.

dataDisaster <- dataDisaster %>% select(text, target)
htmlTable(dataDisaster %>% summary(),
          caption = "Tabla 2. Distribucion de variables.",
          tfoot = "",
          col.rgroup = c("none","#FC7C7C"),
          css.cell = "padding-left: .5em; padding-right: .2em;")
Tabla 2. Distribucion de variables.
text target
Length:7613 Min. :0.0000
Class :character 1st Qu.:0.0000
Mode :character Median :0.0000
Mean :0.4297
3rd Qu.:1.0000
Max. :1.0000

HC Corpora.

El dataset HC Corpora esta conformado por doce corpus divididos en cuatro idiomas (ingles, ruso, finlandes y aleman). Cada idioma tiene textos de twitter, blogs y sitios de noticias (en este caso se utiliza el corpus en ingles).

news <- data.frame(text = readLines("en_US.news.txt", encoding = "UTF-8"),
                   stringsAsFactors = FALSE)
blogs <- data.frame(text = readLines("en_US.blogs.txt", encoding = "UTF-8"),
                    stringsAsFactors = FALSE)
twitter <- data.frame(text = readLines("en_US.twitter.txt", encoding = "UTF-8"),
                      stringsAsFactors = FALSE)

htmlTable(data.frame(obs = c(dim(blogs)[1], dim(news)[1], dim(twitter)[1]),
                     size = c(format(object.size(blogs), units = "Mb"),
                              format(object.size(news), units = "Mb"),
                              format(object.size(twitter), units = "Mb")),
                     row.names = c("blogs", "news", "twitter")),
          caption = "Tabla 3. Largo y peso de cada dataset.",
          col.rgroup = c("none","#FC7C7C"),
          css.cell = "padding-left: .5em; padding-right: .2em;")
Tabla 3. Largo y peso de cada dataset.
obs size
blogs 899288 255.4 Mb
news 77259 19.8 Mb
twitter 2360148 319 Mb 
htmlTable(data.frame(dataset = c("blogs", "news", "twitter"),
           text = c(blogs$text[1], news$text[1], twitter$text[1])
           ),
          caption = "Tabla 4. Largo y peso de cada dataset.",
          col.rgroup = c("none","#FC7C7C"),
          css.cell = "padding-left: .5em; padding-right: .2em;")
Tabla 4. Largo y peso de cada dataset.
dataset text
1 blogs In the years thereafter, most of the Oil fields and platforms were named after pagan “gods”.
2 news He wasn’t home alone, apparently.
3 twitter How are you? Btw thanks for the RT. You gonna be in DC anytime soon? Love to see you. Been way, way too long.

Se observa de la tabla 3 que el conjunto del dataset HC Corpora es bastante grande. La tabla 4 muestra una observacion de cada subgrupo del dataset.

Limpieza y tokenizacion.

Visto los datasets se procede a unirlos y limpiarlos, para ello consideraremos lo siguiente:

  • Limpiar direcciones web, eliminando los textos http, https, com, co y org.
  • Eliminar signos de puntuacion y numeros.
  • Eliminar saltos de linea y espacios finales.
  • Eliminar posibles emojis.
  • Eliminar Stopwords.
train <- rbind(news, blogs, twitter, dataDisaster$text) # hay alrededor de 3M de observaciones
rm(news, blogs, twitter, dataDisaster)
cleanText <- function(text, stopwords = TRUE, language = "english", remText = NULL){
      text = gsub("http "," ",text) # limpia paginas http
      text = gsub("https "," ",text) # limpia paginas https
      text = gsub("com "," ",text) # limpia direcciones
      text = gsub("co "," ",text) # limpia direcciones
      text = gsub("org "," ",text) # limpia direcciones
      text = gsub("[[:punct:]]"," ",text) # elimina puntuacion
      text = gsub("\\w*[0-9]+\\w*\\s*", " ",text) #elimina numeros
      text = stringr::str_replace_all(text, "\\p{quotation mark}", "") # elimina comillas
      text = gsub("\\n", " ",text) # elimina saltos de linea
      text = stringr::str_replace_all(text,"[\\s]+", " ")
      text = stringr::str_replace_all(text," $", "") # elimina espacios finales
      # elimina emojis
      text = gsub("<\\w+>","",iconv(text, from = "UTF-8", to = "latin1", sub = "byte"))
      text = gsub("<\\w+>","",iconv(text, from = "UTF-8", to = "latin1", sub = "byte"))
      text = gsub("-", "",text) # elimina giones
      text = tolower(text) # transforma a minuscula
      text = tm::removeWords(text, letters) # elimina letras sueltas
      text = stringr::str_replace_all(text," $", "") # elimina espacios finales
      if(stopwords){text = tm::removeWords(text, tm::stopwords(language))} # elimina stopwords 
      if(is.null(remText)){text = tm::removeWords(text, remText)} # elimina palabras especificas 
      text = tm::stripWhitespace(text) # quita espacios en blanco repetidos
      text = stringr::str_replace_all(text,"^ ", "") # elimina espacios iniciales
      text = tm::stemDocument(text) # Stem words
      return(text)
}
it_train = itoken(train$text, 
                  preprocessor = cleanText, 
                  tokenizer = word_tokenizer,
                  n_chunks = 5,
                  progressbar = TRUE)

vocab = create_vocabulary(it_train, ngram = c(1L, 1L))

Con lo anterior se genera un vocabulario con 391796 terminos, de los cuales a continuacion se presentan los 40 mas y menos frecuentes.


Palabras mas frecuentes
vocab_prune = vocab %>% 
      prune_vocabulary(term_count_min = 10, doc_count_min = 10) 

vocab[order(vocab$term_count, decreasing = TRUE),] %>% head(40) %>% 
      ggplot(aes(x=reorder(term, term_count), y=term_count)) +
      geom_bar(stat = "identity", fill="red", alpha = 0.7) +  coord_flip() +
      theme(legend.title=element_blank()) +
      xlab("Palabras") + ylab("Frecuencia") +
      labs(title = paste0("Palabras mas frecuentes (",dim(vocab)[1], " palabras)"))+
      theme_linedraw()

Palabras menos frecuentes
vocab[order(vocab$term_count, decreasing = TRUE),] %>% tail(40) %>% 
      ggplot(aes(x=reorder(term, term_count), y=term_count)) +
      geom_bar(stat = "identity", fill="red", alpha = 0.7) +  coord_flip() +
      theme(legend.title=element_blank()) +
      xlab("Palabras") + ylab("Frecuencia") +
      labs(title = paste0("Palabras menos frecuentes (",dim(vocab)[1], " palabras)"))+
      theme_linedraw()

Histograma
vocab %>% 
   ggplot(aes(x=term_count %>% log())) +
   geom_histogram(fill="red", bins = 100, alpha = 0.7) + 
   xlab("Log(term_count)") + ylab("Frecuencia") + 
   labs(title = paste0("Histograma de conteo de palabras"))+
   theme_linedraw()

Como se observa en el histograma, existen muchos terminos que aparecen solo una vez. Estos terminos no son utiles para el modelo y utilizan memoria, por lo que se eliminaran, como criterio se consideraron solo los terminos que aparezcan por lo menos 10 veces. Esto genera una reduccion significativa, quedando 50247 terminos en total.

Vectorizacion utilizando GloVe.

La idea central al aplicar GloVe al problema es vectorizar una oracion, dado que este modelo esta orientado a palabras se procedera a determinar los vectores de las palabras para luego realizar una combinacion de estos vectores y generar los vectores de las oraciones. Esto se fundamenta en la idea de que palabras relacionadas semanticamente tendran un vector similar, esto hace que al ser agregados al vector de la oracion se mantendra un resultado similar.

Vectores de palabras.

Con el vocabulario reducido se genera un modelo GloVe considerando 200 variables y 50 iteraciones. Con esto se reduce la dimensionalidad de manera significativa. A continuacion se observa la evolucion de la perdida durante el entrenamiento.

vectorizer = vocab_vectorizer(vocab_prune)
tfidf = TfIdf$new()
dtm = create_dtm(it_train, vectorizer)
dtm_tfidf = fit_transform(dtm, tfidf)
tcm <- create_tcm(it_train, vectorizer)

glove = GlobalVectors$new(rank = 200, x_max = 10, shuffle = TRUE)
word_vectors = glove$fit_transform(tcm, n_iter = 50)
INFO  [23:36:54.689] epoch 1, loss 0.2012 
INFO  [23:37:45.595] epoch 2, loss 0.1161 
INFO  [23:38:35.033] epoch 3, loss 0.1015 
INFO  [23:39:22.986] epoch 4, loss 0.0916 
INFO  [23:40:12.777] epoch 5, loss 0.0867 
INFO  [23:41:07.390] epoch 6, loss 0.0832 
INFO  [23:41:58.991] epoch 7, loss 0.0805 
INFO  [23:42:51.779] epoch 8, loss 0.0784 
INFO  [23:43:54.591] epoch 9, loss 0.0766 
INFO  [23:44:51.357] epoch 10, loss 0.0751 
INFO  [23:45:40.118] epoch 11, loss 0.0738 
INFO  [23:46:40.222] epoch 12, loss 0.0728 
INFO  [23:47:41.497] epoch 13, loss 0.0718 
INFO  [23:48:33.750] epoch 14, loss 0.0710 
INFO  [23:49:21.883] epoch 15, loss 0.0702 
INFO  [23:50:09.643] epoch 16, loss 0.0695 
INFO  [23:50:53.735] epoch 17, loss 0.0689 
INFO  [23:51:36.832] epoch 18, loss 0.0684 
INFO  [23:52:26.522] epoch 19, loss 0.0679 
INFO  [23:53:12.389] epoch 20, loss 0.0674 
INFO  [23:53:57.198] epoch 21, loss 0.0670 
INFO  [23:54:39.526] epoch 22, loss 0.0666 
INFO  [23:55:21.479] epoch 23, loss 0.0662 
INFO  [23:56:03.953] epoch 24, loss 0.0659 
INFO  [23:56:46.284] epoch 25, loss 0.0656 
INFO  [23:57:28.937] epoch 26, loss 0.0653 
INFO  [23:58:11.395] epoch 27, loss 0.0650 
INFO  [23:58:53.856] epoch 28, loss 0.0647 
INFO  [23:59:36.026] epoch 29, loss 0.0645 
INFO  [00:00:18.166] epoch 30, loss 0.0643 
INFO  [00:01:00.573] epoch 31, loss 0.0640 
INFO  [00:01:42.703] epoch 32, loss 0.0638 
INFO  [00:02:24.921] epoch 33, loss 0.0636 
INFO  [00:03:07.048] epoch 34, loss 0.0635 
INFO  [00:03:49.157] epoch 35, loss 0.0633 
INFO  [00:04:32.686] epoch 36, loss 0.0631 
INFO  [00:05:12.066] epoch 37, loss 0.0630 
INFO  [00:05:51.384] epoch 38, loss 0.0628 
INFO  [00:06:31.125] epoch 39, loss 0.0627 
INFO  [00:07:10.923] epoch 40, loss 0.0625 
INFO  [00:07:50.425] epoch 41, loss 0.0624 
INFO  [00:08:29.887] epoch 42, loss 0.0623 
INFO  [00:09:09.878] epoch 43, loss 0.0621 
INFO  [00:09:49.398] epoch 44, loss 0.0620 
INFO  [00:10:28.747] epoch 45, loss 0.0619 
INFO  [00:11:08.035] epoch 46, loss 0.0618 
INFO  [00:11:56.487] epoch 47, loss 0.0617 
INFO  [00:12:45.166] epoch 48, loss 0.0616 
INFO  [00:13:35.361] epoch 49, loss 0.0615 
INFO  [00:14:31.884] epoch 50, loss 0.0614 
data.frame(loss = glove$get_history()[[1]], epoch = c(1:length(glove$get_history()[[1]]))) %>% 
   ggplot(aes(y = loss, x = epoch)) + 
   ggtitle("Entrenamiento modelo GloVe")+
   geom_line(colour = "red", size = 1) + 
   geom_point(colour = "red", size = 3) + 
   theme_linedraw()

rm(tcm, glove, train)

Para visualizar las relaciones generadas por el modelo se muestra a continuacion una representacion utilizando t-SNE en (3D). Para complementar la visualizacion se colorean las palabras en base a su sentimiento en negro para neutro, azul para positivo y rojo para negativo.

# selecciona vocabulario mas frecuente
wvOrder <- vocab[order(vocab$term_count, decreasing = TRUE),][c(1:500),]
# calcula sentimientos
sentCalc <- function(name, row.names = TRUE){
      text <- name %>% t() %>% apply(1,function(x) get_sentiment(char_v = x, method = "syuzhet"))
      if(row.names){text <- text %>% as.data.frame(row.names = name)}
      if(!row.names){text <- text %>% as.data.frame(row.names = c(1:length(name)))}
      return(text)
}
em <- wvOrder$term %>% sentCalc()
em <- ifelse(em==0,'#000000',ifelse(em>0,'#0000FF','#FF0000'))
#
tsne <- Rtsne(word_vectors[wvOrder$term, ], 
              perplexity = 100, pca = FALSE, dims = 3,
              max_iter = 3000, verbose = FALSE)
tsne_plot <- tsne$Y %>% 
      as.data.frame() %>% 
      mutate(word = wvOrder$term)
p <- plot_ly(tsne_plot, x = ~V1, y = ~V2, z = ~V3, 
             mode = 'text', 
             type = 'scatter3d',
             text = ~word, textposition = 'middle right',
             textfont = list(color = em[,1], size = 12),
             width = 1000*0.75, height = 700*0.75) %>%
      layout(title = "Representacion de palabras con GloVe", 
             scene = list(xaxis = list(title = 'x'),
                          yaxis = list(title = 'y'),
                          zaxis = list(title = 'z')
                          ))
p

La representacion selecciona las 500 palabras mas comunes. Se observan varias relaciones de palabras con un contexto similar, como por ejemplo:

  • day, yesterday, today, month, week, weekend, tomorrow, season, year, saturday, sunday.
  • tweet, twitter, facebook.
  • write, read, book.
  • women, woman, man, men.
  • girl, boy, baby.
  • kid, children, child, mom, mother, family, parent.
  • happy, birthday, celebr.
  • white, black.
  • red, green.
  • etc.

Estas relaciones semanticas son utiles para poder codificar oraciones completas. Ademas, se tiene que las palabras negativas y positivas no son cercanas, a excepcion de algunos casos aislados como white/black y money/pay.

Vectores ponderados de oraciones.

Para intentar representar oraciones que incluyan relaciones semanticas se considera la suma ponderada utilizando los vectores del modelo GloVe generados en el punto anterior. Esto se lleva a cabo de la siguiente manera:

\[V_s=\frac{\sum_{i=1}^{n}{\overline{dtm_i}V_{w_i}}}{n}\]

Donde:

  • \(V_s\): Vector ponderado de la oracion.
  • \(V_{w_i}\): Vector de cada palabra \(w_i\).
  • \(\overline{dtm_i}\): Factor de ponderacion de cada \(w_i\). Este se determina a partir de la \(dtm\) normalizada mediante Tf-Idf.
  • \(n\): Numero de palabras en la oracion.

Se utiliza la normalizacion Tf-Idf para que las palabras mas comunes sean menos representativas y no influyan de sobremanera en el promedio.

Aplicando nuevamente t-SNE(2D) al dtm (Document-term matrix), dtm tfidf (Document-term matrix normalizado Tf-Idf) y al modelo GloVe se observa que en ningun caso hay una clara relacion entre el target (desastre/no desastre) y los datos. Por otro, lado tambien se observa que ambos dtm presentan algunos patrones, que en el caso de Glove se tienden a perder.


Vectorizacion con GloVe
trainSample <- fread("train.csv") %>% select(text, target)

cleanText <- function(text, stopwords = TRUE, language = "english", remText = NULL){
      text = gsub("http "," ",text) # limpia paginas http
      text = gsub("https "," ",text) # limpia paginas https
      text = gsub("com "," ",text) # limpia direcciones
      text = gsub("co "," ",text) # limpia direcciones
      text = gsub("org "," ",text) # limpia direcciones
      text = gsub("[[:punct:]]"," ",text) # elimina puntuacion
      text = gsub("\\w*[0-9]+\\w*\\s*", " ",text) #elimina numeros
      text = stringr::str_replace_all(text, "\\p{quotation mark}", "") # elimina comillas
      text = gsub("\\n", " ",text) # elimina saltos de linea
      text = stringr::str_replace_all(text,"[\\s]+", " ")
      text = stringr::str_replace_all(text," $", "") # elimina espacios finales
      # elimina emojis
      text = gsub("<\\w+>","",iconv(text, from = "UTF-8", to = "latin1", sub = "byte"))
      text = gsub("<\\w+>","",iconv(text, from = "UTF-8", to = "latin1", sub = "byte"))
      text = gsub("-", "",text) # elimina giones
      text = tolower(text) # transforma a minuscula
      text = tm::removeWords(text, letters) # elimina letras sueltas
      text = stringr::str_replace_all(text," $", "") # elimina espacios finales
      if(stopwords){text = tm::removeWords(text, tm::stopwords(language))} # elimina stopwords
      if(is.null(remText)){text = tm::removeWords(text, remText)} # elimina palabras especificas
      text = tm::stripWhitespace(text) # quita espacios en blanco repetidos
      text = stringr::str_replace_all(text,"^ ", "") # elimina espacios iniciales
      text = tm::stemDocument(text) # Stem words
      return(text)
}

vocab_prune = vocab %>% prune_vocabulary(term_count_min = 10, doc_count_min = 10)
# limpiar y crear dtm con el nuevo texto
it_train = itoken(trainSample$text,
                  preprocessor = cleanText,
                  tokenizer = word_tokenizer,
                  n_chunks = 5,
                  progressbar = FALSE)

vectorizer = vocab_vectorizer(vocab_prune)
dtm = create_dtm(it_train, vectorizer)
# ajustar dtm con tfidf calculado anteriormente
dtm_tfidf = transform(dtm, tfidf)
# Codificar en base a Glove calculdo anteriormente (normalizado)
nword <- slam::row_sums(dtm, na.rm = T)
nword[nword==0] <- 1


docCod <- slam::matprod_simple_triplet_matrix(
   slam::as.simple_triplet_matrix(dtm_tfidf),
   slam::as.simple_triplet_matrix(word_vectors)
   )/nword

docCod <- list(docCod = docCod, nword = nword)

docCodS <- docCod$docCod

set.seed(1)
samp <- sample.int(dim(trainSample)[1], 500, replace = F)

# t-SNE GloVe
tsne2 <- Rtsne(docCodS[samp,], 
               perplexity = 0.3*length(samp), pca = TRUE, dims = 2,
               check_duplicates = F, max_iter = 1000, theta = 0.1, eta = 500,
               verbose = F, exaggeration_factor = 30)

tsne_plot2 <- tsne2$Y %>%
   as.data.frame() %>%
   mutate(Sentence = ifelse(trainSample$target[samp]==0,'no disaster','disaster') %>% as.factor())

tsne_plot2 %>% 
   GGally::ggpairs(columns = c(1,2), 
                   aes(colour=Sentence),
                   upper = list(continuous = GGally::wrap("cor", alpha = 1, size = 8)),
                   lower = list(continuous = GGally::wrap("points", alpha = 0.5, size = 6)),
                   diag = list(continuous = GGally::wrap("densityDiag", alpha = 0.7)),
                   title = "Representacion t-SNE de vectorización GloVe"
                   )+
   scale_fill_manual(values = c("#FF0000", "#000000"))+
   scale_color_manual(values = c("#FF0000", "#000000"))+
   theme_linedraw()

Vectorizacion con DTM
# t-SNE dtm
tsne2 <- Rtsne(dtm[samp,] %>% as.matrix(), 
               perplexity = 0.3*length(samp), pca = TRUE, dims = 2,
               check_duplicates = F, max_iter = 1000, theta = 0.1, eta = 500,
               verbose = F, exaggeration_factor = 30)

tsne_plot2 <- tsne2$Y %>%
   as.data.frame() %>%
   mutate(Sentence = ifelse(trainSample$target[samp]==0,'no disaster','disaster') %>% as.factor())

tsne_plot2 %>% 
   GGally::ggpairs(columns = c(1,2), 
                   aes(colour=Sentence),
                   upper = list(continuous = GGally::wrap("cor", alpha = 1, size = 8)),
                   lower = list(continuous = GGally::wrap("points", alpha = 0.5, size = 6)),
                   diag = list(continuous = GGally::wrap("densityDiag", alpha = 0.7)),
                   title = "Representacion t-SNE de Document-term matrix"
                   )+
   scale_fill_manual(values = c("#FF0000", "#000000"))+
   scale_color_manual(values = c("#FF0000", "#000000"))+
   theme_linedraw()

Vectorizacion con DTM normalizado Tf-Idf
# t-SNE dtm_tfidf
tsne2 <- Rtsne(dtm_tfidf[samp,] %>% as.matrix(), 
               perplexity = 0.3*length(samp), pca = TRUE, dims = 2,
               check_duplicates = F, max_iter = 1000, theta = 0.1, eta = 500,
               verbose = F, exaggeration_factor = 30)

tsne_plot2 <- tsne2$Y %>%
   as.data.frame() %>%
   mutate(Sentence = ifelse(trainSample$target[samp]==0,'no disaster','disaster') %>% as.factor())

tsne_plot2 %>% 
   GGally::ggpairs(columns = c(1,2), 
                   aes(colour=Sentence),
                   upper = list(continuous = GGally::wrap("cor", alpha = 1, size = 8)),
                   lower = list(continuous = GGally::wrap("points", alpha = 0.5, size = 6)),
                   diag = list(continuous = GGally::wrap("densityDiag", alpha = 0.7)),
                   title = "Representacion t-SNE de Document-term matrix normalizado Tf-Idf"
                   )+
   scale_fill_manual(values = c("#FF0000", "#000000"))+
   scale_color_manual(values = c("#FF0000", "#000000"))+
   theme_linedraw()

Modelo XGBTree

Para predecir consideraremos un modelo XGB Tree y los siguientes parametros:

  • Validacion cruzada con 10 folds.
  • Busqueda de hiperparametros aleatoria, con 50 busquedas.
  • Muestreo up, esto debido a que esta levemente desbalanceada el target.
  • Se centraran y escalaran las variables predictoras.
  • Metrica ROC.
fitControl <- trainControl(method = "cv",
                           number = 10,
                           search = "random",
                           summaryFunction = twoClassSummary,
                           classProbs = TRUE,
                           sampling = "up",
                           verboseIter = FALSE
                           )

dataGloVe <- data.frame(target = factor(trainSample$target, labels = c("X0", "X1")), docCod$docCod)

set.seed(1)
xgbTreeGloVe <- caret::train(target ~.,
                             data = dataGloVe,
                             preProcess = c("center", "scale"),
                             method = "xgbTree",
                             trControl = fitControl,
                             metric = "ROC",
                             tuneLength = 50,
                             verbose = FALSE
                             )
ggplot(xgbTreeGloVe) + ggtitle("Resultado del Modelo XGBTree con GloVe")+
   geom_point(colour = "red", size = 3) + 
   theme_linedraw()

Este modelo entrega buenos resultados, con un ROC mayor a 0.86. Si lo comparamos con un modelo anterior que como maximo llego a 0.83 es una buena mejora.

Es necesario considerar que este modelo se desarrollo con una vectorizacion GloVe de 200 variables en oposicion al modelo con el que se compara que utiliza 1122 variables.

Observaciones

Es posible generar una vectorizacion a partir de GloVe para oraciones, aunque es necesario considerar una base de datos los suficientemente grande para la vectorizacion de palabras y que el modelo sea representativo y se puedan generalizar las relaciones entre palabras. De lo anterior y como este modelo fue desarrollado en un computador personal, es perfectamente mejorable el modelo de vectorizacion de palabras.

La ponderacion utilizando Tf-Idf resulto ser una buena opcion. Es posible mejorar estos pesos utilizando otro modelo que determine pesos optimos para cada problema, pero como primer paso es una buena opcion.

Sesion Info

sessionInfo()
R version 3.6.2 (2019-12-12)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 18363)

Matrix products: default

locale:
[1] LC_COLLATE=Spanish_Chile.1252  LC_CTYPE=Spanish_Chile.1252   
[3] LC_MONETARY=Spanish_Chile.1252 LC_NUMERIC=C                  
[5] LC_TIME=Spanish_Chile.1252    

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

other attached packages:
 [1] Rtsne_0.15         glmnet_4.0-2       Matrix_1.2-18      slam_0.1-47       
 [5] text2vec_0.6       plotly_4.9.2.1     RColorBrewer_1.1-2 ggcorrplot_0.1.3  
 [9] tidytext_0.2.5     syuzhet_1.0.4      tm_0.7-7           NLP_0.2-0         
[13] lubridate_1.7.9    Metrics_0.1.4      ranger_0.12.1      caret_6.0-86      
[17] lattice_0.20-41    ggpubr_0.4.0       data.table_1.13.0  htmlTable_2.0.1   
[21] forcats_0.5.0      stringr_1.4.0      dplyr_1.0.2        purrr_0.3.4       
[25] readr_1.3.1        tidyr_1.1.2        tibble_3.0.3       ggplot2_3.3.2     
[29] tidyverse_1.3.0   

loaded via a namespace (and not attached):
 [1] colorspace_1.4-1     ggsignif_0.6.0       ellipsis_0.3.1      
 [4] class_7.3-17         rio_0.5.16           fs_1.5.0            
 [7] rstudioapi_0.11      SnowballC_0.7.0      prodlim_2019.11.13  
[10] fansi_0.4.1          xml2_1.3.2           codetools_0.2-16    
[13] splines_3.6.2        rsparse_0.4.0        knitr_1.29          
[16] mlapi_0.1.0          jsonlite_1.7.1       pROC_1.16.2         
[19] RhpcBLASctl_0.20-137 broom_0.7.0          dbplyr_1.4.4        
[22] compiler_3.6.2       httr_1.4.2           backports_1.1.9     
[25] lazyeval_0.2.2       assertthat_0.2.1     cli_2.0.2           
[28] htmltools_0.5.0      tools_3.6.2          gtable_0.3.0        
[31] glue_1.4.2           reshape2_1.4.4       float_0.2-4         
[34] Rcpp_1.0.5           carData_3.0-4        cellranger_1.1.0    
[37] vctrs_0.3.4          nlme_3.1-149         iterators_1.0.12    
[40] timeDate_3043.102    gower_0.2.2          xfun_0.16           
[43] openxlsx_4.1.5       rvest_0.3.6          lifecycle_0.2.0     
[46] rstatix_0.6.0        MASS_7.3-52          scales_1.1.1        
[49] ipred_0.9-9          lgr_0.3.4            hms_0.5.3           
[52] parallel_3.6.2       yaml_2.2.1           curl_4.3            
[55] rpart_4.1-15         stringi_1.4.6        tokenizers_0.2.1    
[58] foreach_1.5.0        checkmate_2.0.0      zip_2.1.1           
[61] shape_1.4.4          lava_1.6.7           rlang_0.4.7         
[64] pkgconfig_2.0.3      evaluate_0.14        recipes_0.1.13      
[67] htmlwidgets_1.5.1    tidyselect_1.1.0     plyr_1.8.6          
[70] magrittr_1.5         R6_2.4.1             generics_0.0.2      
[73] DBI_1.1.0            pillar_1.4.6         haven_2.3.1         
[76] foreign_0.8-76       withr_2.2.0          survival_3.2-3      
[79] abind_1.4-5          nnet_7.3-14          janeaustenr_0.1.5   
[82] modelr_0.1.8         crayon_1.3.4         car_3.0-9           
[85] rmarkdown_2.3        grid_3.6.2           readxl_1.3.1        
[88] blob_1.2.1           ModelMetrics_1.2.2.2 reprex_0.3.0        
[91] digest_0.6.25        stats4_3.6.2         munsell_0.5.0       
[94] viridisLite_0.3.0