Introducción:

En una notebook anterior recorrimos todo el proceso para obtener datos de +215k proyectos de kickstarter en Inglés corridos durante 2017 y con estado final de “successful o”failed“. Al final generamos un .csv que puede descargarse desde Google drive aquí o desde Kaggle aquí o a través de la API de Kaggle.

Esto porque no quiero repetir el proceso y porque espero pronto trabajar sobre el set de datos en un kernel de Kaggle, aprovechando que ahora disponen GPUs gratuitas, y en Google colab donde también disponen GPUs gratuitas. Todo ello en Python, hasta donde he leído por ahora (aunque es posible correr código de R en Python).

Importando datos:

Una vez descargados los datos a través de cualquiera de las opciones disponibles, procedemos a cargarlos:

library(readr)
library(dplyr)
df_text_eng <- read_csv("data/text_sets/df_text_eng.csv", 
                        col_types = cols(state = col_factor(levels = c("successful", "failed"))))[, 2:3]
glimpse(df_text_eng)
## Observations: 215,513
## Variables: 2
## $ blurb <chr> "Using their own character, users go on educational ques...
## $ state <fct> failed, successful, failed, failed, failed, failed, fail...

Preprocesamiento:

Ya tenemos un conjunto de 215513 textos, cada uno con su categoría, y los vamos a usar para entrenar un modelo con la interface de Keras para R Studio.

Vamos con el preprocesamiento para pasar de secuencias de palabras a secuencias de números, donde cada número representa una palabra, que es la manera en que el modelo puede ingerir los datos. Y también particionamos los datos, dejando unos para el entrenamiento y validación (80%), y otros para el posterior testeo del modelo ante datos totalmente nuevos para él (20%):

texts <- df_text_eng$blurb
texts <- iconv(texts, to = "UTF-8")
label <- df_text_eng$state
label <- ifelse(label == "successful", 1, 0)

inTrain <- sample(seq_along(texts), length(texts) * 0.8)

x_train <- texts[inTrain]
y_train <- label[inTrain]

x_test <- texts[-inTrain]
y_test <- label[-inTrain]

Tokenización:

Ya tenemos los sets de datos necesarios: de entrenamiento, de validación y de pruebas. Ahora tokenizamos (palabras a números), tomando solamente las 5000 palabras más frecuentes:

library(keras)

num_words <- 5000

tokenizer <- text_tokenizer(num_words = num_words) %>% 
    fit_text_tokenizer(x_train)

word_index <- tokenizer$word_index

# Ahora representamos las cadenas de textos como secuencias de tokens o palabras
train_sequences <- texts_to_sequences(tokenizer, x_train)
test_sequences <- texts_to_sequences(tokenizer, x_test)

Tenemos textos (pasados a números) de diferentes longitudes, pero debemos decidirnos por una longitud que es la que todos deben tener. Decidimos la longitud y truncamos los que sean más largos y hacemos padding (rellenamos) los que sean más cortos, de manera que todos queden de la misma longitud.

# Calculamos el maxlen, a través de los quartiles de la longitud de las secuencias
summary(lengths(train_sequences))
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00   14.00   18.00   17.38   21.00   35.00

Padding:

Tomaremos 25 como la longitud para todos los textos.

maxlen <- 25
# Padding a las secuencias
train_sequences <- pad_sequences(train_sequences, maxlen = maxlen)
test_sequences <- pad_sequences(test_sequences, maxlen = maxlen)

Entrenamiento del Modelo:

Y por fin podemos crear el modelo.

Después de probar varios modelos con redes neuronales recurrentes (RNN) desde convoluciones en 1D hasta LSTM con dropout recurrente y la combianción de ambas basándome en este post muy muy completo de machinelearningmastery, al final me decidí por el modelo que presento el cual, de acuerdo con el principio de parsimonia, es el más económico (en facilidad de entendimiento y exigencia de cómputo) para el mejor resultado.

Creamos el modelo y lo compilamos:

El modelo es un embedding con 32 dimensiones, un dropout para reducir el sobreajuste, un LSTM con dropout y dropout recurrente y activación relu, y finalmente una unidad con salida a sigmoide, dado que es un problema de clasificación binaria.

Para entrenarlo se usa el optimizador adam y como loss el binary cross entrophy dado que es un problema de clasificación binaria (1 o 0).

model <- keras_model_sequential() %>% 
    layer_embedding(input_dim = num_words, output_dim = 32, input_length = maxlen) %>% 
    layer_dropout(0.4) %>% 
    layer_lstm(50, dropout = 0.4, recurrent_dropout = 0.4, recurrent_activation = "relu") %>% 
    layer_dense(units = 1, activation = "sigmoid")

model %>% compile(
    optimizer = "adam",
    loss = "binary_crossentropy",
    metrics = c("acc")
)

Visualización del modelo:

Lo vemos antes de entrenarlo

summary(model)
## ___________________________________________________________________________
## Layer (type)                     Output Shape                  Param #     
## ===========================================================================
## embedding_1 (Embedding)          (None, 25, 32)                160000      
## ___________________________________________________________________________
## dropout_1 (Dropout)              (None, 25, 32)                0           
## ___________________________________________________________________________
## lstm_1 (LSTM)                    (None, 50)                    16600       
## ___________________________________________________________________________
## dense_1 (Dense)                  (None, 1)                     51          
## ===========================================================================
## Total params: 176,651
## Trainable params: 176,651
## Non-trainable params: 0
## ___________________________________________________________________________

Entrenamiento:

Lo entrenamos

early_stopping <- callback_early_stopping(monitor = 'val_loss', patience = 1)
history <- model %>% fit(
    train_sequences, y_train,
    epochs = 10,
    batch_size = 64,
    validation_split = 0.3,
    callbacks = c(early_stopping)
)

Resultados:

Veamos que precisión alcanza el modelo sobre datos totalmente nuevos; nunca antes vistos para el modelo.

model %>% 
    evaluate(test_sequences, y_test, batch_size = 32)
## $loss
## [1] 0.6040276
## 
## $acc
## [1] 0.6679349

Es apenas 16.79% mejor que lanzar una moneda (a veces 18%, como máximo).

Embeddings:

Lo que sigue es visualizar los embeddings. Los cuales se entrenaron sobre la tarea de clasificación y en esa medida nos va a dar información sobre las relaciones de las palabras en el contexto de lo que va a ser exitoso y lo que no:

Extrayendo los embeddings:

library(dplyr)

embedding_matrix <- get_weights(model)[[1]]

words <- data.frame(
    word = names(tokenizer$word_index), 
    id = as.integer(unlist(tokenizer$word_index))
)

words <- words %>% 
    filter(id <= tokenizer$num_words) %>% 
    arrange(id)

#embedding_matrix <- rbind(embedding_matrix, rep(0, 100))
#row.names(embedding_matrix) <- c("UNK", words$word)

row.names(embedding_matrix) <- words$word

Función similitud:

Ahora que extrajimos los embeddings podemos ver qué palabras son similares en este contexto. Veamos las palabras similares a “man”, “case”, “computer”, “money” y “cat”.

library(text2vec)
## 
## Attaching package: 'text2vec'
## The following objects are masked from 'package:keras':
## 
##     fit, normalize
find_similar_words <- function(word, embedding_matrix, n = 5) {
    similarities <- embedding_matrix[word, , drop = FALSE] %>% 
        sim2(embedding_matrix, y = ., method = "cosine")
    
    similarities[, 1] %>% sort(decreasing = TRUE) %>% head(n)
}

find_similar_words("man", embedding_matrix)
##       man      take      stop    potter         o 
## 1.0000000 0.6649775 0.6177274 0.6108578 0.6096026
find_similar_words("case", embedding_matrix)
##      case       ads     blood      five  terrible 
## 1.0000000 0.7562312 0.7518229 0.7501483 0.7492881
find_similar_words("computer", embedding_matrix)
##    computer cooperative    frontier        jeff    intended 
##   1.0000000   0.7859127   0.7717577   0.7711036   0.7652816
find_similar_words("money", embedding_matrix)
##      money         it       race innovative      smash 
##  1.0000000  0.6580707  0.6227086  0.5709993  0.5704644
find_similar_words("cats", embedding_matrix)
##         cats successfully  installment       stress         with 
##    1.0000000    0.5643760    0.5589821    0.5481237    0.5122096

Graficando embeddings:

Los embeddings pueden ser reducidos de sus dimensiones originales (32 en este caso) a 2 o 3, con el fin de graficarlos. Para ello vamos a apoyarnos en t-SNE. Y para evitar que el gráfico se congestione y sature, vamos a tomar sólo los primeros 200 embeddings:

library(Rtsne)
library(ggplot2)
library(plotly)

tsne <- Rtsne(embedding_matrix[1:200, ], perplexity = 50, pca = FALSE)

tsne_plot <- tsne$Y %>% 
    as.data.frame() %>% 
    mutate(word = row.names(embedding_matrix)[1:200]) %>% 
    ggplot(aes(x= V1, y = V2, label = word)) + 
    geom_text(size = 3)
tsne_plot

Además, con la ayuda de plotly podemos visualizarlos en 3D, lo cual produce una presentación muy atractiva

library(Rtsne)
library(ggplot2)
library(plotly)

tsne <- Rtsne(embedding_matrix[1:200, ], perplexity = 50, pca = FALSE, dims = 3)

tsne_plot <- tsne$Y %>% 
    as.data.frame() %>% 
    mutate(word = row.names(embedding_matrix)[1:200])
p <- plot_ly(tsne_plot, x = ~V1, y = ~V2, z = ~V3, 
             mode = 'text', 
             type = 'scatter3d',
             text = ~word, textposition = 'middle right',
             textfont = list(color = '#000000', size = 16)) %>%
    layout(scene = list(xaxis = list(title = 'x'),
                        yaxis = list(title = 'y'),
                        zaxis = list(title = 'z')))
p

Lo atractivo de este tipo de gráfico es que se puede rotar, acercar y alejar de manera interactiva.

Espero que lo disfruten y que se animen a escribirme si encuentran un modelo que logre una mayor precisión.