Introducción:

En una notebook anterior revisamos el proceso para obtener datos de +251k proyectos de kickstarter.

Ahora que los tenemos organizados, vamos a proceder con el análisis exploratorio, que es la forma de familiarizarnos con su contenido, variables y distribuciones, lo cual nos va a resultar útil cuando lleguemos al punto final: construir el modelo.

Importando datos y transformando:

Lo primero es importar los datos que ya hemos trabajado:

library(here)
library(dplyr)
df <- readRDS(here("/data/text_sets/df.rds"))
glimpse(df)
## Observations: 251,070
## Variables: 22
## $ periodo                <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...
## $ id                     <chr> "950629125", "703195101", "1894751075",...
## $ name                   <chr> "EduRoam: A MMORPG For Education", "Gas...
## $ blurb                  <chr> "Using their own character, users go on...
## $ goal                   <dbl> 200000, 350000, 5000, 100, 59000, 10000...
## $ pledged                <dbl> 25.00, 3649.00, 9716.51, 0.00, 145.00, ...
## $ state                  <chr> "failed", "canceled", "successful", "li...
## $ slug                   <chr> "eduroam-a-mmorpg-for-education", "gas-...
## $ country                <chr> "US", "US", "US", "IT", "US", "DE", "DK...
## $ currency               <chr> "USD", "USD", "USD", "EUR", "USD", "EUR...
## $ currency_symbol        <chr> "$", "$", "$", "€", "$", "€", "kr", "£"...
## $ currency_trailing_code <chr> "true", "true", "true", "false", "true"...
## $ deadline               <date> 2017-01-12, 2017-01-09, 2012-05-20, 20...
## $ state_changed_at       <date> 2017-01-12, 2016-11-18, 2012-05-20, 20...
## $ created_at             <date> 2016-12-09, 2016-09-20, 2012-04-17, 20...
## $ launched_at            <date> 2016-12-13, 2016-11-15, 2012-04-20, 20...
## $ staff_pick             <chr> "false", "false", "false", "false", "fa...
## $ backers_count          <int> 1, 7, 106, 0, 4, 4, 13, 0, 6, 28, 0, 6,...
## $ static_usd_rate        <dbl> 1.0000000, 1.0000000, 1.0000000, 1.0534...
## $ usd_pledged            <dbl> 25.000000, 3649.000000, 9716.510000, 0....
## $ location               <chr> "{\"country\":\"US\",\"urls\":{\"web\":...
## $ category               <chr> "{\"urls\":{\"web\":{\"discover\":\"htt...

Para entender un poco mejor las variables, pueden remitirse a esta página. Y lo primero que vamos a hacer es transformar el periodo en una fecha (en cierto momento previo pasamos de fecha a número y ahora debemos revertirlo con el fin de llevar a cabo el análisis exploratorio):

Periodo a fecha:

# No me gusta salirme del estilo dplyr, pero de esta manera es más eficiente
df$periodo <- as.Date(paste("01", as.character(df$periodo), "2017", sep = "-"), tz = "UTC", format = "%d-%m-%Y")
glimpse(df$periodo)
##  Date[1:251070], format: "2017-01-01" "2017-01-01" "2017-01-01" "2017-01-01" "2017-01-01" ...

Para ser un poco más claro con las fechas:

summary(df$periodo)
##         Min.      1st Qu.       Median         Mean      3rd Qu. 
## "2017-01-01" "2017-08-01" "2017-12-01" "2017-10-14" "2017-12-01" 
##         Max. 
## "2017-12-01"

goal a usd_goal:

La variable goal (cantidad de dinero que se aspira a captar) puede estar en diferentes monedas (USD, EUR, DKK, GBP, MXN, AUD, CAD, SEK, NZD, CHF, HKD, SGD, NOK, JPY), razón por la cual existe otra variable, que es “static_usd_rate”; al multiplicar el goal por esta taza, obtenemos el goal en dólares: una denominación común a todos los proyectos y al usd_pledged. Vamos a crear la variable usd_goal, que contiene el goal en dólares.

Esto se verifica si todos los proyectos con “currency” igual a “USD” tienen “static_usd_rate” igual a 1.00000000.

df_usd <- df[df$currency == "USD", ]
unique(df_usd$static_usd_rate) # valores únicos de "static_usd_rate" para proyectos en "USD"
## [1] 1
rm(df_usd)

Obtengamos entonces la nueva variable:

df$usd_goal <- df$static_usd_rate * df$goal

Explorando:

Verificación de los estados:

Respecto de la variable “state”, tenemos las siguientes posibilidades: failed, canceled, successful, live, suspended. Podemos verificar qué pasa cuando el “usd_pledged” es mayor o igual que el “usd_goal”: se logró recaudar la cantidad esperada o más:

pos <- df %>% filter(usd_pledged >= usd_goal) %>% select(id, state)
summary(as.factor(pos$state))
##   canceled     failed       live successful  suspended 
##        227          3       2589     109763        112

Esto indica que no todos los proyectos que alcanzan o superan el monto esperado son “live” o “successful”, sino que pueden ser “canceled”, “failed” o “suspended”. Habrá que ver las razones.

Mientras que los proyectos en los que el “usd_pledged” es mayor o igual que el “usd_goal”, el “state” es:

pos <- df %>% filter(usd_pledged < usd_goal) %>% select(id, state)
summary(as.factor(pos$state))
##   canceled     failed       live successful  suspended 
##      13609     109630      13757         71        806
rm(pos)

Y esto indica que hay proyectos que no alcanzan el monto propuesto y son exitosos (¿?). Podría tratarse de un error de los datos (hice el mismo ejercicio con pledged y goal -sin tomarlos convertidos a dólares- y el resultado es exactamente el mismo).

Debido a que estamos hablando de 3 y 71 casos respectivamente, podría considerarse eliminarlos o dejarlos, teniendo en cuenta que afectan poco dado que constituyen el 2.947385210^{-4} de la muestra. Pero debido a que no tengo elementos para saber si es un error de los datos o falta de conocimiento de mi parte, los voy a dejar.

Character a factor:

Hay variables que aparecen como caracter pero deben estar como factores. Excúsenme la falta de elegancia, pero “mutate_at”, “mutate” y “mutate_if” saturan la memoria y no me dejan avanzar.

df$state <- as.factor(df$state)
df$country <- as.factor(df$country)
df$currency <- as.factor(df$currency)
df$currency_symbol <- as.factor(df$currency_symbol)
df$currency_trailing_code <- as.factor(df$currency_trailing_code)
df$staff_pick <- as.factor(df$staff_pick)
glimpse(df)
## Observations: 251,070
## Variables: 23
## $ periodo                <date> 2017-01-01, 2017-01-01, 2017-01-01, 20...
## $ id                     <chr> "950629125", "703195101", "1894751075",...
## $ name                   <chr> "EduRoam: A MMORPG For Education", "Gas...
## $ blurb                  <chr> "Using their own character, users go on...
## $ goal                   <dbl> 200000, 350000, 5000, 100, 59000, 10000...
## $ pledged                <dbl> 25.00, 3649.00, 9716.51, 0.00, 145.00, ...
## $ state                  <fct> failed, canceled, successful, live, liv...
## $ slug                   <chr> "eduroam-a-mmorpg-for-education", "gas-...
## $ country                <fct> US, US, US, IT, US, DE, DK, GB, US, US,...
## $ currency               <fct> USD, USD, USD, EUR, USD, EUR, DKK, GBP,...
## $ currency_symbol        <fct> $, $, $, €, $, €, kr, £, $, $, $, $, €,...
## $ currency_trailing_code <fct> true, true, true, false, true, false, t...
## $ deadline               <date> 2017-01-12, 2017-01-09, 2012-05-20, 20...
## $ state_changed_at       <date> 2017-01-12, 2016-11-18, 2012-05-20, 20...
## $ created_at             <date> 2016-12-09, 2016-09-20, 2012-04-17, 20...
## $ launched_at            <date> 2016-12-13, 2016-11-15, 2012-04-20, 20...
## $ staff_pick             <fct> false, false, false, false, false, fals...
## $ backers_count          <int> 1, 7, 106, 0, 4, 4, 13, 0, 6, 28, 0, 6,...
## $ static_usd_rate        <dbl> 1.0000000, 1.0000000, 1.0000000, 1.0534...
## $ usd_pledged            <dbl> 25.000000, 3649.000000, 9716.510000, 0....
## $ location               <chr> "{\"country\":\"US\",\"urls\":{\"web\":...
## $ category               <chr> "{\"urls\":{\"web\":{\"discover\":\"htt...
## $ usd_goal               <dbl> 200000.0000, 350000.0000, 5000.0000, 10...

Proyectos por mes:

Teniendo en cuenta que de cada proyecto vamos a retener solamente el último periodo/mes en el que aparece, veamos cuántos proyectos hubo por mes:

library(ggplot2)
df %>% 
    group_by(periodo) %>% 
    summarise(cuenta = n()) %>% 
    ggplot(aes(periodo, cuenta, fill = cuenta)) + geom_bar(stat = "identity")

No sorprende, si recordamos que tomamos el periodo de enero de 2017 a diciembre de 2017, que para la mayoría de proyectos su último mes haya sido diciembre de 2017.

Es por eso que, todos los proyectos cuyo último periodo fue indefinido (los “live”) van a ser removidos.

df2 <- df %>% 
    filter(!state == "live")

Ahora tenemos 234692, el 0.9347672 del original.

library(ggplot2)
df2 %>% 
    group_by(periodo) %>% 
    summarise(cuenta = n()) %>% 
    ggplot(aes(periodo, cuenta, fill = cuenta)) + geom_bar(stat = "identity")

Restructurando los factores:

Tenemos una serie de posibles “states” para cada proyecto: failed, canceled, successful, suspended. Voy a asumir que hay dos tipos de proyectos: “failed” o “successful”. Bajo “failed” voy a meter “failed”, “canceled” y “suspended”; y bajo “successful” sólo “successful”.

Además, para el caso, voy a conservar solamente el “blurb” (pequeña descripción o propaganda) y el “bin_state” o estado binario, que es la variable que vamos a recategorizar:

df_text <- df2[, c("blurb", "state")]
df_text$bin_state <- ifelse(df_text$state == "successful", "successful", "failed")
glimpse(df_text)
## Observations: 234,692
## Variables: 3
## $ blurb     <chr> "Using their own character, users go on educational ...
## $ state     <fct> failed, canceled, successful, failed, failed, failed...
## $ bin_state <chr> "failed", "failed", "successful", "failed", "failed"...
df_text <- df_text[, c(1, 3)]
df_text$bin_state <- as.factor(df_text$bin_state)
df_text %>% 
    group_by(bin_state) %>% 
    summarise(cuenta = n())

Hay otras líneas que se podrían explorar, y que voy a retomar en otra notebook, tales como el comportamiento de los montos por país, la relación entre los montos a recaudar (goal) y la probabilidad de éxito del proyecto, el tiempo que se toman los proyectos en salir al aire y la probabilidad de éxito y otros datos interesantes que también permiten construir modelos que logran predecir el éxito o fracaso del proyecto con una precisión decente (sobre el 65% de acierto con modelos bastante básicos). Pero ahora mi propósito es construir un primer modelo que a partir del texto prediga si el proyecto va a ser exitoso o no.

Procesamiento de lenguaje natural (NLP):

Hemos visto que las clases no están desbalanceadas (failed: 0.531454 y successful: 0.468546). Pero nos queda un asunto: los blurb no están todos en inglés. Vamos a conservar solamente los que están en inglés, y para ellos vamos a detectarlos con la librería “cldr”, siguiendo la sugerencia de aykutfirat en esta entrada de stackoverflow, donde además dan los pasos para la instalación del paquete.

library(cldr)
lang <- detectLanguage(df_text$blurb)
df_text_eng <- df_text[lang$detectedLanguageCode == 0, ]

Preprocesamiento:

Ya tenemos un conjunto de 229827 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:

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

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

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:

library(keras)

num_words <- 20000

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 blurbs/textos de diferentes longitudes, pero debemos decidirnos por una longitud que es la que todos los textos deben tener. Decidimos la longitud y truncamos los que sean más largos y hacemos padding (rellenamos) los que sean más cortos.

# 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   16.00   20.00   18.95   22.00   36.00

Padding:

Tomaremos 22 como la longitud para todos los textos. Y en consecuencia hacemos padding:

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

Modelo:

Y por fin podemos crear el modelo

model <- keras_model_sequential() %>% # iniciamos el modelo secuancial
    layer_embedding(input_dim = num_words, output_dim = 15, # imput_dim es el número de palabras del vocabulario del tokenizador o # max_features
                    input_length = maxlen) %>%  #input_length es la longitud después del padding
    layer_flatten() %>% # y output_dim es la longitud de los vectores de los embeddings
    layer_dropout(rate = 0.4) %>%
    layer_dense(units = 1, activation = "sigmoid") # por último insertamos una unidad con activación sigmoide

Lo compilamos

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

Lo vemos antes de entrenarlo

summary(model)
## ___________________________________________________________________________
## Layer (type)                     Output Shape                  Param #     
## ===========================================================================
## embedding_1 (Embedding)          (None, 22, 12)                240000      
## ___________________________________________________________________________
## flatten_1 (Flatten)              (None, 264)                   0           
## ___________________________________________________________________________
## dropout_1 (Dropout)              (None, 264)                   0           
## ___________________________________________________________________________
## dense_1 (Dense)                  (None, 1)                     265         
## ===========================================================================
## Total params: 240,265
## Trainable params: 240,265
## Non-trainable params: 0
## ___________________________________________________________________________

Lo entrenamos

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

Resultados:

plot(history)

Es apenas 16% mejor que lanzar una moneda. Pero no está mal para ser un modelo simple. Lo que sigue es mejorar el modelo y visualizar los embeddings.

Gracias por seguirme hasta aquí.