Introducción

El objetivo de la clase de hoy es avanzar en el entrenamiento de un modelo de clasificación de texto. Para ello, vamos a utilizar un dataset de reseñas que hicieron diferentes usuarios luego de una experiencia de compras en Amazon.

Se trata de un conjunto de datos de revisiones de productos de Amazon para la clasificación de texto multilingüe. Contiene reseñas en inglés, japonés, alemán, francés, chino y español, recopiladas entre el 1 de noviembre de 2015 y el 1 de noviembre de 2019. Cada registro en el conjunto de datos contiene el texto de la revisión, el título de la revisión, la calificación por estrellas, un ID de revisor anonimizado, un ID de producto anonimizado y la categoría de producto de grano grueso (por ejemplo, ‘libros’, ‘electrodomésticos’, etc.). El corpus está equilibrado en estrellas, de modo que cada calificación por estrellas constituye el 20% de las revisiones en cada idioma.

Para cada idioma, hay 200,000 reseñas en los conjuntos de entrenamiento, desarrollo y prueba, respectivamente. El número máximo de revisiones por revisor es 20 y el número máximo de revisiones por producto es 20. Todas las revisiones se truncaron después de 2,000 caracteres, y todas las revisiones tienen al menos 20 caracteres de longitud.

Es importante tener en cuenta que el idioma de una revisión no necesariamente coincide con el idioma de su mercado (por ejemplo, las revisiones de amazon.de están principalmente escritas en alemán, pero también podrían estar escritas en inglés, etc.). Se aplicó un algoritmo de detección de idioma para determinar el idioma del texto de la revisión y eliminamos las revisiones que no estaban escritas en el idioma esperado.

De ese dataset original, vamos a trabajar con una muestra del 10%, es decir, de 20.000 reseñas y solamente nos vamos a quedar con los siguientes campos:

  • review_id: Un character que identifica la reseña
  • stars: Este campo fue trabajado, eliminando las reseñas de puntaje 3 (neutrales) y considerando las reseñas de 1 y 2 estrellas como “negativas” y las de 4 y 5 como “positivas”.
  • review_body: El texto de la reseña
  • product_category: Un character que representa la categoría del producto

Vamos, entonces, a entrenar un modelo de clasificación que es una variación de la regresión logística (y lineal) que se llama “regresión regularizada por LASSO”. Si bien no vamos a entrar en detalles solo diremos que Lla precisión predictiva de un modelo de regresión puede ser incrementada a través del encogimiento de los valores de los coeficientes o, incluso, haciéndolos cero.

Haciendo esto, se introduce algún sesgo pero se reduce la variancia de los valores pre-dichos y, por lo tanto, se incrementa la precisión predictiva total. En muchos casos, cuando existen muchos predictores puede ser necesario identificar un subconjunto más pequeño de estos predictores que muestren los efectos más grandes.Es por ello que resulta útil imponer restricciones en el proceso de estimación. A esta operación se la define como “regularización”.

Existen varios métodos de regularización de modelos lineales: non negative garrotte (Breiman,1995); ridge regression (Hoerl y Kennard, 1970). Este trabajo se centrará en el LASSO. Este método utiliza la norma l1 como medida de penalización para definir las restricciones al modelo lineal. LASSO busca minimizar la siguiente expresión:

\[\sum_{i=1}^{n} (Y_{i} - \beta_{0} - \sum_{j=1}^{p} \beta_{j})^2 + \lambda \sum_{j=1}^{p} |\beta_{j}| = RSS + \lambda \sum_{j=1}^{p} |\beta_{j}|\]

Se parte de la minimización de la RSS clásico de la regresión y se agrega una restricción: el segundo término \(\lambda \sum_{j=1}^{p} |\beta_{j}|\) se hace pequeño cuando los coeficientes son pequeños y, por lo tanto, tiene el efecto de reducir los coeficientes \(\beta\) estimados. \(\lambda\) constituye un parámetro de tunning y su función es controlar el impacto relativo de ambos términos. Cuando el coeficiente es igual a cero (\(\lambda=0\)), LASSO es equivalente a un modelo lineal estimado por MCO. Por el contrario, a medida que el parámetro se hace más grande (\(\lambda\)), el término de restricción lo hace en igual proporción y todos los coeficientes se reducen para po-der satisfacer dicha restricción. En el límite, cuando λ es lo suficientemente grande todos los coeficientes se hacen igual a cero y solamente queda como parámetro el intercepto (\(\beta_{0}\)), es decir, algo casi equivalente a predecir y solamente con la media de la distribución.

En nuestro caso, se trata de una regresión logística, pero cambia solamente la función de pérdida.

Vamos a analizar dos casos: uno, utilizando como features o predictores las variables generadas por una vectorización tipo TF-IDF. En el segundo caso, lo haremos con el uso de features derivadas de embeddings pre-entrenados.

LASSO con TF-IDF

Veamos primero un poco nuestro dataset:

library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.3     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.4.3     ✔ tibble    3.2.1
## ✔ lubridate 1.9.2     ✔ tidyr     1.3.0
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(tidytext)
library(tidymodels)
## ── Attaching packages ────────────────────────────────────── tidymodels 1.1.1 ──
## ✔ broom        1.0.5     ✔ rsample      1.2.0
## ✔ dials        1.2.0     ✔ tune         1.1.2
## ✔ infer        1.0.5     ✔ workflows    1.1.3
## ✔ modeldata    1.2.0     ✔ workflowsets 1.0.1
## ✔ parsnip      1.1.1     ✔ yardstick    1.2.0
## ✔ recipes      1.0.8     
## ── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ──
## ✖ scales::discard() masks purrr::discard()
## ✖ dplyr::filter()   masks stats::filter()
## ✖ recipes::fixed()  masks stringr::fixed()
## ✖ dplyr::lag()      masks stats::lag()
## ✖ yardstick::spec() masks readr::spec()
## ✖ recipes::step()   masks stats::step()
## • Use suppressPackageStartupMessages() to eliminate package startup messages
library(textrecipes)
library(textclean)
reviews <- read_csv('../data/amazon_reviews_train_sample.csv') %>%
        select(-product_category)
## Rows: 20000 Columns: 4
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): review_id, review_body, stars, product_category
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
reviews <- reviews %>%
        mutate(stars=as_factor(stars))

reviews %>%
        select(review_body, stars)
## # A tibble: 20,000 × 2
##    review_body                                                             stars
##    <chr>                                                                   <fct>
##  1 Lo recibí ayer. Viene el menú del teléfono en inglés, un gran problema… Nega…
##  2 Me gusta su modelo y la forma de carga , lo que no me gusta y me resul… Nega…
##  3 Hola, en un mes a dejado de funcionar, no se sincroniza con el tel. De… Nega…
##  4 Lo compré porque quería una radio para el baño y poder colocarla en la… Nega…
##  5 Ha llegado bastante sucio y con algunas muescas como hubiera sido usad… Nega…
##  6 La silla es perfecta en calidad precio, muy cómoda y bastante grande. … Nega…
##  7 Batería muy mala. He escrito al vendedor y no he recibido ninguna resp… Nega…
##  8 No se adhiere en los bordes dejando 1 mm despegado todo el perímetro d… Nega…
##  9 El caudal de agua mínimo en la descripción no es suficiente para ilumi… Nega…
## 10 No hace buen contacto. Hay que calzarlo para que funcione               Nega…
## # ℹ 19,990 more rows

Se observa que, entonces, el input que vamos a utilizar será el campo review_body y la variable dependiente stars.

Preprocesamiento TF-IDF

Vamos a aplicar un preprocesamiento simple:

reviews_idf <- reviews %>%
        mutate(review_body = str_replace_all(review_body, "'\\[.*?¿\\]\\%'", " ")) %>%
        mutate(review_body = str_replace_all(review_body, "[[:punct:]]", " ")) %>%
        mutate(review_body = tolower(review_body)) %>%
        mutate(review_body = str_replace_all(review_body, "[[:digit:]]+", "DIGITO")) %>%
        mutate(review_body = replace_non_ascii(review_body))

Luego, dividimos los datos en conjuntos de entrenamiento y prueba. Podemos utilizar la función initial_split() de rsample para crear esta división binaria de los datos. El argumento strata garantiza que la distribución del producto sea similar en el conjunto de entrenamiento y el conjunto de prueba. Dado que la división utiliza un muestreo aleatorio, establecemos una semilla para poder reproducir nuestros resultados.

## Split
set.seed(664)
reviews_split_idf <- initial_split(reviews_idf, strata = stars)

train_idf <- training(reviews_split_idf)
test_idf <- testing(reviews_split_idf)

A continuación, necesitamos preprocesar estos datos para prepararlos para el modelado; tenemos datos de texto y necesitamos construir características numéricas para el aprendizaje automático a partir de ese texto.

El paquete recipes, que forma parte de tidymodels, nos permite crear una especificación de los pasos de preprocesamiento que queremos realizar. Estas transformaciones se estiman (o “entrenan”) en el conjunto de entrenamiento para que puedan aplicarse de la misma manera en el conjunto de prueba o en nuevos datos durante la predicción, sin fuga de datos. Inicializamos nuestro conjunto de transformaciones de preprocesamiento con la función recipe(), utilizando una expresión de fórmula para especificar las variables, nuestra variable de resultado junto con nuestro predictor, junto con el conjunto de datos.

reviews_rec_idf <- recipe(stars ~ ., data = train_idf) %>% # definimos las variables y sus roles
        update_role("review_id", new_role = "ID") %>% # actualizamos el rol del ID
        step_tokenize(review_body) %>% #Tokenizamos
        step_tokenfilter(review_body, max_tokens=5000) %>% # filtramos los 5000 tokens más frecuentes
        step_tfidf(review_body)

Como puede verse, a partir del código anterior generamos la matriz TF-IDF en la que cada fila es un documento (una reseña) y cada columna, un token.

reviews_rec_idf %>% prep() %>% bake(train_idf[1:10,])
## # A tibble: 10 × 5,002
##    review_id  stars    tfidf_review_body_a tfidf_review_body_aa
##    <fct>      <fct>                  <dbl>                <dbl>
##  1 es_0631804 Negativa              0                         0
##  2 es_0837984 Negativa              0.0215                    0
##  3 es_0683391 Negativa              0.0885                    0
##  4 es_0712963 Negativa              0                         0
##  5 es_0222030 Negativa              0                         0
##  6 es_0944610 Negativa              0                         0
##  7 es_0513992 Negativa              0                         0
##  8 es_0327577 Negativa              0                         0
##  9 es_0348045 Negativa              0                         0
## 10 es_0171057 Negativa              0                         0
## # ℹ 4,998 more variables: tfidf_review_body_abajo <dbl>,
## #   tfidf_review_body_abierta <dbl>, tfidf_review_body_abiertas <dbl>,
## #   tfidf_review_body_abierto <dbl>, tfidf_review_body_abiertos <dbl>,
## #   tfidf_review_body_abollada <dbl>, tfidf_review_body_abra <dbl>,
## #   tfidf_review_body_abre <dbl>, tfidf_review_body_abren <dbl>,
## #   tfidf_review_body_abres <dbl>, tfidf_review_body_abri <dbl>,
## #   tfidf_review_body_abria <dbl>, tfidf_review_body_abridor <dbl>, …

Generando un esquema de validación cruzada

El parámetro penalty, es el equivlaente al \(lambda\), es decir, se usa para la regularización es un hiperparámetro del modelo. No podemos conocer su mejor valor durante el entrenamiento del modelo, pero podemos estimar el mejor valor entrenando muchos modelos en conjuntos de datos remuestreados y explorando qué tan bien funcionan todos estos modelos. Construyamos una nueva especificación de modelo para la sintonización del modelo.

lasso_spec <- logistic_reg(
        penalty = tune(),
        mixture = 1) %>%
        set_mode("classification") %>%
        set_engine("glmnet")

Al finalizar el proceso de tuneo, vamos a poder seleccionar el mejor valor numérico para \(lambda\).

Luego, podemos crear una grilla para tunear los valores:

#grid_lasso <- tibble(penalty=seq(0,0.2, 0.01))
grid_lasso <- grid_regular(penalty(), levels = 30)
grid_lasso
## # A tibble: 30 × 1
##     penalty
##       <dbl>
##  1 1   e-10
##  2 2.21e-10
##  3 4.89e-10
##  4 1.08e- 9
##  5 2.40e- 9
##  6 5.30e- 9
##  7 1.17e- 8
##  8 2.59e- 8
##  9 5.74e- 8
## 10 1.27e- 7
## # ℹ 20 more rows

La función grid_regular() pertenece al paquete dials. Permite elegir valores para probar en un parámetro como la penalización de regularización; aquí, solicitamos 30 valores posibles diferentes.

Luego, seteemos un esquema de validación cruzada:

## Seteo de validación cruzada
set.seed(234)
idf_folds <- vfold_cv(train_idf, v = 5)

Entrenamiento

¡Ahora es el momento de sintonizar! Usemos tune_grid() para ajustar un modelo en cada uno de los valores para la penalización de regularización en nuestra cuadrícula regular.

En tidymodels, el paquete para el tuneo se llama tune. Tunear un modelo utiliza una sintaxis similar a la de un fiteo de un modelo a un conjunto de datos remuestreados con fines de evaluación (fit_resamples()), porque las dos tareas son muy similares. La diferencia es que, al tunear, cada modelo tiene parámetros diferentes y se busca encontrar el mejor.

Agregamos nuestra especificación de modelo tuneable (tune_lasso) a un workflow con la recipe de preprocesamiento que definimos antes, y luego lo fiteamos a cada parámetro posible en lambda_grid y en cada remuestreo en idf_folds con tune_grid().

wf_idf <- workflow() %>% 
        add_recipe(reviews_rec_idf) %>%
        add_model(lasso_spec)

tictoc::tic()
tune_lasso_idf <- tune_grid(
        wf_idf,
        idf_folds,
        grid = grid_lasso,
        control = control_resamples(save_pred = TRUE)
)
tictoc::toc()
## 658.572 sec elapsed

Ahora, en lugar de un conjunto de métricas, tenemos un conjunto de métricas para cada valor de la penalización de regularización.

Evaluación

Usemos la función collect_metrics(tune_lasso) para recopilar y examinar las métricas obtenidas durante el proceso de tuneo. Esto proporcionará información sobre el rendimiento del modelo para cada valor específico del parámetro de penalización de regularización. Esta recopilación de métricas es útil para comparar y seleccionar el mejor modelo en función de los resultados obtenidos en diferentes configuraciones de hiperparámetros.

collect_metrics(tune_lasso_idf)
## # A tibble: 60 × 7
##     penalty .metric  .estimator  mean     n std_err .config              
##       <dbl> <chr>    <chr>      <dbl> <int>   <dbl> <chr>                
##  1 1   e-10 accuracy binary     0.771     5 0.00135 Preprocessor1_Model01
##  2 1   e-10 roc_auc  binary     0.844     5 0.00188 Preprocessor1_Model01
##  3 2.21e-10 accuracy binary     0.771     5 0.00135 Preprocessor1_Model02
##  4 2.21e-10 roc_auc  binary     0.844     5 0.00188 Preprocessor1_Model02
##  5 4.89e-10 accuracy binary     0.771     5 0.00135 Preprocessor1_Model03
##  6 4.89e-10 roc_auc  binary     0.844     5 0.00188 Preprocessor1_Model03
##  7 1.08e- 9 accuracy binary     0.771     5 0.00135 Preprocessor1_Model04
##  8 1.08e- 9 roc_auc  binary     0.844     5 0.00188 Preprocessor1_Model04
##  9 2.40e- 9 accuracy binary     0.771     5 0.00135 Preprocessor1_Model05
## 10 2.40e- 9 roc_auc  binary     0.844     5 0.00188 Preprocessor1_Model05
## # ℹ 50 more rows

Podemos ver los mejores resultados utilizando show_best() y seleccionando una métrica, como el área bajo la curva ROC (ROC AUC).

Por ejemplo, puedes utilizar la siguiente sintaxis para ver los mejores resultados en términos de ROC AUC:

show_best(tune_lasso_idf, "roc_auc", n=2)
## # A tibble: 2 × 7
##   penalty .metric .estimator  mean     n std_err .config              
##     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1 0.00386 roc_auc binary     0.928     5 0.00295 Preprocessor1_Model23
## 2 0.00174 roc_auc binary     0.922     5 0.00188 Preprocessor1_Model22

El mejor valor para el área bajo la curva ROC (ROC AUC) de esta ejecución de tuneo es 0.922. Podemos extraer el mejor parámetro de regularización para este valor de ROC AUC de nuestros resultados de sintonización con select_best(), o podemos elegir un modelo más simple con una regularización más alta utilizando select_by_pct_loss() o select_by_one_std_err().

Vamos a elegir el modelo con el mejor ROC AUC dentro de un error estándar del mejor modelo numéricamente.

chosen_auc_idf <- tune_lasso_idf %>%
  select_by_one_std_err(metric = "roc_auc", -penalty)

chosen_auc_idf
## # A tibble: 1 × 9
##   penalty .metric .estimator  mean     n std_err .config            .best .bound
##     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>              <dbl>  <dbl>
## 1 0.00386 roc_auc binary     0.928     5 0.00295 Preprocessor1_Mod… 0.928  0.925

Estimación final

A continuación, finalicemos nuestro flujo de trabajo sintonizable con este penalizador de regularización en particular. Este es el término de penalización de regularización que nuestros resultados de sintonización indican que nos proporciona el mejor modelo.

final_params_lasso_idf <- finalize_workflow(wf_idf, chosen_auc_idf)

final_params_lasso_idf
## ══ Workflow ════════════════════════════════════════════════════════════════════
## Preprocessor: Recipe
## Model: logistic_reg()
## 
## ── Preprocessor ────────────────────────────────────────────────────────────────
## 3 Recipe Steps
## 
## • step_tokenize()
## • step_tokenfilter()
## • step_tfidf()
## 
## ── Model ───────────────────────────────────────────────────────────────────────
## Logistic Regression Model Specification (classification)
## 
## Main Arguments:
##   penalty = 0.00385662042116347
##   mixture = 1
## 
## Computational engine: glmnet

En lugar de penalty = tune() como antes, ahora nuestro worflow tiene valores finales para todos los argumentos. La receta de preprocesamiento ha sido evaluada en los datos de entrenamiento, y sintonizamos la penalización de regularización para que tengamos un valor de penalización de 0.00385662042116347. ¡Este flujo de trabajo está listo para funcionar! Ahora puede ajustarse a nuestros datos de entrenamiento.

fitted_lasso_idf <- fit(final_params_lasso_idf, train_idf)
fitted_lasso_idf
## ══ Workflow [trained] ══════════════════════════════════════════════════════════
## Preprocessor: Recipe
## Model: logistic_reg()
## 
## ── Preprocessor ────────────────────────────────────────────────────────────────
## 3 Recipe Steps
## 
## • step_tokenize()
## • step_tokenfilter()
## • step_tfidf()
## 
## ── Model ───────────────────────────────────────────────────────────────────────
## 
## Call:  glmnet::glmnet(x = maybe_matrix(x), y = y, family = "binomial",      alpha = ~1) 
## 
##       Df  %Dev   Lambda
## 1      0  0.00 0.200400
## 2      1  1.97 0.182600
## 3      1  3.65 0.166400
## 4      1  5.08 0.151600
## 5      1  6.32 0.138200
## 6      1  7.40 0.125900
## 7      1  8.34 0.114700
## 8      1  9.17 0.104500
## 9      1  9.89 0.095230
## 10     1 10.52 0.086770
## 11     2 11.10 0.079060
## 12     3 11.98 0.072040
## 13     4 12.80 0.065640
## 14     6 13.68 0.059810
## 15     8 14.81 0.054490
## 16     9 15.91 0.049650
## 17    12 17.10 0.045240
## 18    14 18.39 0.041220
## 19    17 19.70 0.037560
## 20    22 21.11 0.034220
## 21    27 22.59 0.031180
## 22    34 24.03 0.028410
## 23    39 25.56 0.025890
## 24    51 27.14 0.023590
## 25    63 28.76 0.021490
## 26    71 30.38 0.019580
## 27    84 31.96 0.017840
## 28    95 33.48 0.016260
## 29   112 35.02 0.014810
## 30   134 36.52 0.013500
## 31   160 38.05 0.012300
## 32   187 39.56 0.011210
## 33   220 41.06 0.010210
## 34   271 42.57 0.009304
## 35   338 44.13 0.008477
## 36   403 45.76 0.007724
## 37   467 47.39 0.007038
## 38   554 49.01 0.006413
## 39   664 50.65 0.005843
## 40   779 52.29 0.005324
## 41   898 53.92 0.004851
## 42  1014 55.52 0.004420
## 43  1163 57.13 0.004027
## 44  1314 58.71 0.003670
## 45  1441 60.28 0.003344
## 46  1571 61.80 0.003047
## 
## ...
## and 54 more lines.

Evaluación sobre test-set

Podemos utilizar la función last_fit() para ajustar nuestro modelo una última vez en nuestros datos de entrenamiento y evaluarlo en nuestros datos de prueba. Solo necesitamos pasarle esta función nuestro modelo/flujo de trabajo finalizado y nuestra división de datos.

final_fitted <- last_fit(final_params_lasso_idf, reviews_split_idf)

collect_metrics(final_fitted)
## # A tibble: 2 × 4
##   .metric  .estimator .estimate .config             
##   <chr>    <chr>          <dbl> <chr>               
## 1 accuracy binary         0.863 Preprocessor1_Model1
## 2 roc_auc  binary         0.931 Preprocessor1_Model1

O de forma equivalente:

preds_idf <- test_idf %>%
        select(stars) %>%
        bind_cols(predict(fitted_lasso_idf, test_idf, type="prob")) %>%
        bind_cols(predict(fitted_lasso_idf, test_idf, type="class"))

roc_auc(preds_idf, stars, .pred_Negativa) %>%
bind_rows(accuracy(preds_idf, stars, .pred_class)) %>%
bind_rows(precision(preds_idf, stars, .pred_class)) %>%
bind_rows(recall(preds_idf, stars, .pred_class)) %>%
bind_rows(f_meas(preds_idf, stars, .pred_class))
## # A tibble: 5 × 3
##   .metric   .estimator .estimate
##   <chr>     <chr>          <dbl>
## 1 roc_auc   binary         0.931
## 2 accuracy  binary         0.863
## 3 precision binary         0.859
## 4 recall    binary         0.868
## 5 f_meas    binary         0.864

Word embeddings como features

Vimos que el uso del modelo BoW y su ponderación mediante TF-IDF tenían un rendimiento razonable al momento de hacer predicciones. Veamos cómo hacerlo.

Vamos a tener que trabajar de forma diferente algunas etapas. En primer lugar, el preprocesamiento. No vamos a pasar a minúscula nada y atmpoco vamos a eliminar caracteres no ascii.

reviews_embed <- reviews %>%
        mutate(review_body = str_replace_all(review_body, "'\\[.*?¿\\]\\%'", " ")) %>%
        mutate(review_body = str_replace_all(review_body, "[[:digit:]]+", "DIGITO"))

Carga del embedding

Vamos a usar un embedding entrenado mediante el algoritmo wor2vec por C. Cardelino. Está entrenado sobre un corpus grande en español. Pueden encontrar los detalles aquí.

Escribamos una función que cargue el embedding y ejecutémosla:

load_embeddings <- function(path=NULL, type=c("w2v", "ft")){
        if (type=="w2v"){
                embedding <- word2vec::read.wordvectors(path, 
                                                        type = "bin", 
                                                        normalize = TRUE) %>%
                        as_tibble(rownames="word")
        }
        else if (type=="ft"){
                model <- fastTextR::ft_load(path)
                words <- fastTextR::ft_words(model)
                embedding <- fastTextR::ft_word_vectors(model,
                                                        words) %>%
                        as_tibble(rownames="word")
        }
        
        return(embedding)
}


embedding <- load_embeddings(path = "../../../../WordEmbeddings/Word2Vec/sbw_vectors.bin",
                             type = "w2v")
## Warning: The `x` argument of `as_tibble.matrix()` must have unique column names if
## `.name_repair` is omitted as of tibble 2.0.0.
## ℹ Using compatibility `.name_repair`.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Como puede verse, es necesario previamente descargar el archivo .bin (con la información en formato binario) del embedding para poder cargarlo . La función también permite cargar (si quisieran hacerlo) un .bin entrenado mediante FastText.

Tokenización y construcción de features mediante el embedding

Si bien existe un método step_word_embeddings() análogo al step_tfidf() que realizaría la vectorización, vamos a hacer “a mano” para tratar de entender qué pasa (y porque además, el método tiene algunos comportamientos raros).

La secuencia de operaciones que vamos a realizar es la siguiente:

  1. Tokenización pero sin pasar todo a minúscula y sin eliminar la puntuación.
reviews_tidy <- reviews_embed %>%
                unnest_tokens(word, review_body, 
                              to_lower=TRUE,
                              strip_punct=TRUE)
  1. Left-join de la tabla tokenizada de cada review con el embedding. De esta forma, cada palabra va a estar representada por un vector de 300 dimensiones, que se corresponde con un vector del embedding pre-entrenado.
reviews_tidy <- reviews_tidy %>%
        left_join(embedding) %>%
        drop_na()
## Joining with `by = join_by(word)`
  1. Por último, agrupamos por cada review y calculamos el promedio para cada dimensión de cada palabra que forma parte de una review.
tictoc::tic()
reviews_embed <- reviews_tidy %>%
        group_by(review_id, stars) %>%
        summarise(across(V1:V300, ~mean(.x, na.rm=TRUE))) %>%
        ungroup()
## `summarise()` has grouped output by 'review_id'. You can override using the
## `.groups` argument.
tictoc::toc()
## 71.764 sec elapsed

De esta forma, reemplazamos cada palabra de una review por sus coordenadas en el embedding. Luego, calculamos algo así como el centroide, es decir, la coordenada promedio. Así, una reseña que era una lista de palabras ahora es lista de coordenadas en 300 dimensiones.

Fuente: El Gato y la Caja

Ahora tenemos todo listo para repetir el flujo anterior.

## Split
set.seed(664)
reviews_split <- initial_split(reviews_embed, strata = stars)

train_embed <- training(reviews_split)
test_embed <- testing(reviews_split)

## especifico el modelo
lasso_spec <- logistic_reg(
        penalty = tune(),
        mixture = 1) %>%
        set_mode("classification") %>%
        set_engine("glmnet")

# especifico la receta
reviews_rec_embed <-
        recipe(stars ~ ., data = train_embed) %>%
        update_role("review_id", new_role = "ID")

# especifico el flujo
wf_embed <- workflow() %>% 
        add_recipe(reviews_rec_embed) %>%
        add_model(lasso_spec)

# espefico la grilla
grid_lasso <- grid_regular(penalty(), levels = 30)

## Seteo de validación cruzada
set.seed(234)
embed_folds <- vfold_cv(train_embed, v = 5)

Entrenamiento

# Entreno el modelo
tictoc::tic()
tune_lasso_embed <- tune_grid(
        wf_embed,
        embed_folds,
        grid = grid_lasso,
        control = control_resamples(save_pred = TRUE)
)
tictoc::toc()
## 16.913 sec elapsed

Evaluación

Veamos los dos mejores modelos en términos de ROC:

show_best(tune_lasso_embed, "roc_auc", n=2)
## # A tibble: 2 × 7
##    penalty .metric .estimator  mean     n std_err .config              
##      <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1 0.000788 roc_auc binary     0.914     5 0.00190 Preprocessor1_Model21
## 2 0.000356 roc_auc binary     0.913     5 0.00195 Preprocessor1_Model20

Veamos el mejor modelo dentro de 1 error estándar:

chosen_auc_embed <- tune_lasso_embed %>%
  select_by_one_std_err(metric = "roc_auc", -penalty)

chosen_auc_embed
## # A tibble: 1 × 9
##   penalty .metric .estimator  mean     n std_err .config            .best .bound
##     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>              <dbl>  <dbl>
## 1 0.00174 roc_auc binary     0.913     5 0.00186 Preprocessor1_Mod… 0.914  0.912

Entrenamiento final

Elegimos el mejor modelo…

final_params_lasso_embed <- finalize_workflow(wf_embed, chosen_auc_embed)
final_params_lasso_embed
## ══ Workflow ════════════════════════════════════════════════════════════════════
## Preprocessor: Recipe
## Model: logistic_reg()
## 
## ── Preprocessor ────────────────────────────────────────────────────────────────
## 0 Recipe Steps
## 
## ── Model ───────────────────────────────────────────────────────────────────────
## Logistic Regression Model Specification (classification)
## 
## Main Arguments:
##   penalty = 0.00174332882219999
##   mixture = 1
## 
## Computational engine: glmnet

Fiteemos el mejor modelo sobre el total del traning set:

fitted_lasso_embed <- fit(final_params_lasso_embed, train_embed)

Hagamos su evaluación sobre el test-set

preds_embed <- test_embed %>%
        select(stars) %>%
        bind_cols(predict(fitted_lasso_embed, test_embed, type="prob")) %>%
        bind_cols(predict(fitted_lasso_embed, test_embed, type="class"))

Comparemos ahora ambos modelos… ¿qué pueden decir al respecto?

Embeddings

roc_auc(preds_embed, stars, .pred_Negativa) %>%
bind_rows(accuracy(preds_embed, stars, .pred_class)) %>%
bind_rows(precision(preds_embed, stars, .pred_class)) %>%
bind_rows(recall(preds_embed, stars, .pred_class)) %>%
bind_rows(f_meas(preds_embed, stars, .pred_class))
## # A tibble: 5 × 3
##   .metric   .estimator .estimate
##   <chr>     <chr>          <dbl>
## 1 roc_auc   binary         0.917
## 2 accuracy  binary         0.839
## 3 precision binary         0.826
## 4 recall    binary         0.86 
## 5 f_meas    binary         0.842

TF-IDF

roc_auc(preds_idf, stars, .pred_Negativa) %>%
bind_rows(accuracy(preds_idf, stars, .pred_class)) %>%
bind_rows(precision(preds_idf, stars, .pred_class)) %>%
bind_rows(recall(preds_idf, stars, .pred_class)) %>%
bind_rows(f_meas(preds_idf, stars, .pred_class))
## # A tibble: 5 × 3
##   .metric   .estimator .estimate
##   <chr>     <chr>          <dbl>
## 1 roc_auc   binary         0.931
## 2 accuracy  binary         0.863
## 3 precision binary         0.859
## 4 recall    binary         0.868
## 5 f_meas    binary         0.864