Técnicas de Reducción de Dimensionalidad

1. ¿Por qué hacer análisis no supervisado?

Dentro de las técnicas de análisis supervisado de regresión y clasificación, usualmente tenemos acceso a un conjunto de variables \(X_1, X_2, ..., X_p\) medidas sobre \(n\) observaciones para predecir una variable de respuesta \(Y\). En el caso del análisis no supervisado, el objetivo es descubrir cosas interesantes acerca del conjunto de variables \(X_1, X_2, ..., X_p\) sobre las \(n\) observaciones medidas. Nótese que en este caso no tenemos una variable dependiente \(Y\) (Hastie et al., 2012).

Entonces, respecto al problema entre manos:

• ¿Existe una forma informativa de visualizar los datos?
• ¿Podemos descubrir subgrupos entre variables o entre observaciones?

La respuesta a ambas preguntas es sí. Podemos hacerlo a través de técnicas de reducción de dimensionalidad (a menudo llamadas técnicas de análisis de componentes principales) y de clustering.

En este primer cuaderno visitaremos las técnicas de reducción de dimensionalidad.

2. Reducción de dimensionalidad

Los métodos de reducción de dimensionalidad o análisis de componentes principales consisten en resumir y visualizar la información más importante contenida en un conjunto de datos a través de un número más pequeño de variables que expliquen de manera colectiva la mayor parte de la variabilidad de dicho conjunto.

Así también, este conjunto de técnicas puede ser útil en problemas de análisis supervisado para reducir el número de variables utilizadas, o también para imputar datos a través del descubrimiento de patrones existentes en los datos.

Existen entonces varias técnicas alrededor de esta temática, tanto si asumimos que existen patrones lineales como no lineales en los datos. A continuación se enumeran algunas de estas técnicas, clasificándolas acorde al tipo de datos con el que estemos trabajando y algunos de los paquetes existentes para su uso:

Tipo de variables	Técnicas recomendadas	Librerías
Numéricas	PCA (y sus variantes), t-SNE	base, FactoMineR, Rtsne
Categóricas	CA, MCA	FactoMineR, ade4, epMCA
Mixtas (numéricas y categóricas)	FAMD, MFA	FactoMineR

Dado los objetivos de este curso, en este cuaderno visitaremos las metodologías para variables mixtas FAMD y MFA, además de visitar, como un bono adicional, una variante de la metodología PCA, conocida como RPCA, la cual nos será útil para descubrir (y de ser necesario, alivianar) el ruido existente en un conjunto de datos.

3. Análisis Factorial de Datos Mixtos (FAMD)

3.1. Descripción de la técnica

El análisis factorial de datos mixtos (FAMD), desarrollado por (Pagès, 2004) es un método de componentes principales que tiene como objetivo analizar un conjunto de datos que contiene tanto información cuantitativa como cualitativa. Este análisis permite analizar la similaridad entre individuos, toando en cuenta un conjunto de variables mixto. Adicionalmente, nos permite explorar la asociación entre todas estas variables, tanto cuantitativas como cualitativas.

En esencia, el algoritmo FAMD puede ser visto como una combinación del PCA y el MCA. Es decir, utiliza PCA sobre las variables cuantitativas y MCA sobre las variables cualitativas. En el proceso, estas variables son normalizadas para balancear la influencia de cada conjunto de datos.

Formalmente, el criterio maximizado por la técnica para un factor \(s\) se puede escribir como:

\[ \lambda_s = \sum_{k \in K}r^2\left(z_s, \nu_k\right)+\sum_{q \in Q}\eta^2 \left( z_s, V_q \right) \]

Donde:

• \(K\) representa al conjunto de variables cuantitativas.

• \(Q\) representa al conjunto de variables cualitativas.

• \(r^2\) es el cuadrado del coeficiente de correlación entre \(\nu_k\) y el factor \(z_s\) de rango \(s\).

• \(\eta^2\) es el cuadrado de la razón de correlación entre \(V_q\) y el factor \(z_s\) de rango \(s\).

• \(\lambda_s\) es el valor propio de rango \(s\).

¿Por qué maximizar el valor propio de cada uno de los factores (o nuevas dimensiones proyectadas? Pues porque estos son los que nos determinan la cantidad de varianza explicada por cada uno de dichos factores.

3.2. Ejercicio práctico

El objetivo de este caso práctico es descubrir patrones sobre la metadata de películas disponible en Kaggle.

Para aplicar la técnica de FAMD en R utilizaremos la librería FactoMineR, y para visualizar sus resultados utilizaremos la librería factoextra. Adicionalmente, urilizaremos las librerías tidyverse y tidymodels para la manipulación de datos, la creación de gráficos adicionales y el preprocesamiento necesario para el modelo (junto a la librería jsonlite dadas ciertas características de nuestros datos). Finalmente, nos serán las librerías visdat y naniar para el análisis descriptivo de los datos.

library(FactoMineR)
library(factoextra)
library(tidyverse)
library(tidymodels)
library(jsonlite)
library(visdat)
library(naniar)

Ahora, carguemos nuestro conjunto de datos descargado:

movies_metadata <- read_csv("datasets/movies_metadata.csv", show_col_types = F)
movies_metadata %>% glimpse()

## Rows: 45,466
## Columns: 24
## $ adult                 <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,~
## $ belongs_to_collection <chr> "{'id': 10194, 'name': 'Toy Story Collection', '~
## $ budget                <dbl> 30000000, 65000000, 0, 16000000, 0, 60000000, 58~
## $ genres                <chr> "[{'id': 16, 'name': 'Animation'}, {'id': 35, 'n~
## $ homepage              <chr> "http://toystory.disney.com/toy-story", NA, NA, ~
## $ id                    <dbl> 862, 8844, 15602, 31357, 11862, 949, 11860, 4532~
## $ imdb_id               <chr> "tt0114709", "tt0113497", "tt0113228", "tt011488~
## $ original_language     <chr> "en", "en", "en", "en", "en", "en", "en", "en", ~
## $ original_title        <chr> "Toy Story", "Jumanji", "Grumpier Old Men", "Wai~
## $ overview              <chr> "Led by Woody, Andy's toys live happily in his r~
## $ popularity            <dbl> 21.946943, 17.015539, 11.712900, 3.859495, 8.387~
## $ poster_path           <chr> "/rhIRbceoE9lR4veEXuwCC2wARtG.jpg", "/vzmL6fP7aP~
## $ production_companies  <chr> "[{'name': 'Pixar Animation Studios', 'id': 3}]"~
## $ production_countries  <chr> "[{'iso_3166_1': 'US', 'name': 'United States of~
## $ release_date          <date> 1995-10-30, 1995-12-15, 1995-12-22, 1995-12-22,~
## $ revenue               <dbl> 373554033, 262797249, 0, 81452156, 76578911, 187~
## $ runtime               <dbl> 81, 104, 101, 127, 106, 170, 127, 97, 106, 130, ~
## $ spoken_languages      <chr> "[{'iso_639_1': 'en', 'name': 'English'}]", "[{'~
## $ status                <chr> "Released", "Released", "Released", "Released", ~
## $ tagline               <chr> NA, "Roll the dice and unleash the excitement!",~
## $ title                 <chr> "Toy Story", "Jumanji", "Grumpier Old Men", "Wai~
## $ video                 <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,~
## $ vote_average          <dbl> 7.7, 6.9, 6.5, 6.1, 5.7, 7.7, 6.2, 5.4, 5.5, 6.6~
## $ vote_count            <dbl> 5415, 2413, 92, 34, 173, 1886, 141, 45, 174, 119~

Este dataset contiene 24 columnas y 45 mil observaciones. Démosle un vistazo a un par de ejemplos.

movies_metadata %>% 
  filter(title %>% 
           str_to_lower() %>% 
           str_detect("batman"))

## # A tibble: 39 x 24
##    adult belongs_to_colle~ budget genres homepage    id imdb_id original_langua~
##    <lgl> <chr>              <dbl> <chr>  <chr>    <dbl> <chr>   <chr>           
##  1 FALSE {'id': 120794, '~ 1   e8 [{'id~ <NA>       414 tt0112~ en              
##  2 FALSE {'id': 120794, '~ 3.5 e7 [{'id~ <NA>       268 tt0096~ en              
##  3 FALSE {'id': 120794, '~ 8   e7 [{'id~ <NA>       364 tt0103~ en              
##  4 FALSE {'id': 120794, '~ 1.25e8 [{'id~ <NA>       415 tt0118~ en              
##  5 FALSE {'id': 421904, '~ 6   e6 [{'id~ <NA>     14919 tt0106~ en              
##  6 FALSE <NA>              1.38e6 [{'id~ <NA>      2661 tt0060~ en              
##  7 FALSE {'id': 421904, '~ 0      [{'id~ <NA>     15805 tt0143~ en              
##  8 FALSE {'id': 404770, '~ 0      [{'id~ <NA>     17074 tt0169~ en              
##  9 FALSE {'id': 379475, '~ 0      [{'id~ <NA>     16234 tt0233~ en              
## 10 FALSE {'id': 263, 'nam~ 1.5 e8 [{'id~ http://~   272 tt0372~ en              
## # ... with 29 more rows, and 16 more variables: original_title <chr>,
## #   overview <chr>, popularity <dbl>, poster_path <chr>,
## #   production_companies <chr>, production_countries <chr>,
## #   release_date <date>, revenue <dbl>, runtime <dbl>, spoken_languages <chr>,
## #   status <chr>, tagline <chr>, title <chr>, video <lgl>, vote_average <dbl>,
## #   vote_count <dbl>

Podemos notar que la metadata de las películas es abundate. Utilizaremos como variables de análisis, las enlistadas a continuación (aunque el estudiante puede probar varias combinaciones):

• budget (presupuesto)

• genres (géneros a los que pertenece)

• original_language (lenguaje original)

• popularity (nivel de popularidad)

• production_companies (compañías productoras)

• production_countries (países productores)

• release_date (fecha de salida)

• revenue (ingresos_generados)

• runtime (tiempo de duración)

• votes_average (voto promedio)

• votes_count (número de votos)

Algunas de estas variables nos ayudarán a hacer algunos filtros preliminares:

• Lenguaje original: inglés.

• Número de votos: al menos 100 votos.

• Solo una fila por película (en casos muy raros, existen dos filas para una película).

movies_analysis <- movies_metadata %>% 
  filter(original_language=="en",
         vote_count >= 100) %>% 
  select(id, title, budget, genres, popularity,
         production_companies, production_countries,
         release_date, revenue, runtime, 
         vote_average, vote_count)
movies_analysis %>% 
  filter(title %>% 
           str_to_lower() %>% 
           str_detect("batman"))

## # A tibble: 22 x 12
##       id title   budget genres    popularity production_compa~ production_count~
##    <dbl> <chr>    <dbl> <chr>          <dbl> <chr>             <chr>            
##  1   414 Batma~  1   e8 [{'id': ~      13.3  [{'name': 'Warne~ [{'iso_3166_1': ~
##  2   268 Batman  3.5 e7 [{'id': ~      19.1  [{'name': 'PolyG~ [{'iso_3166_1': ~
##  3   364 Batma~  8   e7 [{'id': ~      15.0  [{'name': 'PolyG~ [{'iso_3166_1': ~
##  4   415 Batma~  1.25e8 [{'id': ~      17.0  [{'name': 'PolyG~ [{'iso_3166_1': ~
##  5 14919 Batma~  6   e6 [{'id': ~       7.29 [{'name': 'DC Co~ [{'iso_3166_1': ~
##  6  2661 Batman  1.38e6 [{'id': ~       8.99 [{'name': 'Twent~ [{'iso_3166_1': ~
##  7 16234 Batma~  0      [{'id': ~       7.87 [{'name': 'DC Co~ [{'iso_3166_1': ~
##  8   272 Batma~  1.5 e8 [{'id': ~      28.5  [{'name': 'DC Co~ [{'iso_3166_1': ~
##  9 13851 Batma~  3.5 e6 [{'id': ~      10.2  [{'name': 'DC Co~ [{'iso_3166_1': ~
## 10 40662 Batma~  0      [{'id': ~       7.04 [{'name': 'DC Co~ [{'iso_3166_1': ~
## # ... with 12 more rows, and 5 more variables: release_date <date>,
## #   revenue <dbl>, runtime <dbl>, vote_average <dbl>, vote_count <dbl>

Como se puede notar, existen dos variables leídas como código JSON, las separaremos en varias columnas (tomando solo la primera etiqueta para cada variable).

# Declaramos una función para leer el json y obtener la primera categoría
get_first_category <- function(json_string){
  tryCatch(json_string %>% 
    str_replace_all("\\'",'\\"') %>% 
    fromJSON() %>% 
    slice(1) %>% 
    pull(name),
    error = function(e){
      NA
    })
}
# Transformamos las variables con json
movies_analysis <- movies_analysis %>% 
  mutate(genres = map_chr(genres, get_first_category),
         production_companies = map_chr(production_companies, get_first_category),
         production_countries = map_chr(production_countries, get_first_category))
# Revisamos los datos
movies_analysis %>% 
  filter(title %>% 
           str_to_lower() %>% 
           str_detect("batman"))

## # A tibble: 22 x 12
##       id title      budget genres popularity production_compan~ production_coun~
##    <dbl> <chr>       <dbl> <chr>       <dbl> <chr>              <chr>           
##  1   414 Batman F~  1   e8 Action      13.3  Warner Bros.       United Kingdom  
##  2   268 Batman     3.5 e7 Fanta~      19.1  PolyGram Filmed E~ United Kingdom  
##  3   364 Batman R~  8   e7 Action      15.0  PolyGram Filmed E~ United Kingdom  
##  4   415 Batman &~  1.25e8 Action      17.0  PolyGram Filmed E~ United Kingdom  
##  5 14919 Batman: ~  6   e6 Action       7.29 DC Comics          United States o~
##  6  2661 Batman     1.38e6 Family       8.99 Twentieth Century~ United States o~
##  7 16234 Batman B~  0      Anima~       7.87 DC Comics          United States o~
##  8   272 Batman B~  1.5 e8 Action      28.5  DC Comics          United Kingdom  
##  9 13851 Batman: ~  3.5 e6 Anima~      10.2  DC Comics          United States o~
## 10 40662 Batman: ~  0      Action       7.04 DC Comics          United States o~
## # ... with 12 more rows, and 5 more variables: release_date <date>,
## #   revenue <dbl>, runtime <dbl>, vote_average <dbl>, vote_count <dbl>

Una vez que nuestras variables han sido transformadas a un formato adecuado, podemos realizar un análisis descriptivo (esencial en cualquier proyecto de ciencia de datos) antes de pasar a la aplicación de la técnica.

# Visualización de tipos de datos
vis_dat(movies_analysis)

Parece haber pocos datos perdidos. Confirmémoslo con otra gráfica.

# Visualización de perdidos
gg_miss_var(movies_analysis, show_pct = T)

## Warning: It is deprecated to specify `guide = FALSE` to remove a guide. Please
## use `guide = "none"` instead.

La variable con más datos perdidos es production_companies. Revisemos si existe algún patrón en repetidos. Si no existe, los eliminaremos.

gg_miss_upset(movies_analysis)

Al parecer no existe ningún patrón y podemos eliminarlos.

movies_analysis <- movies_analysis %>% 
  na.omit()
gg_miss_var(movies_analysis, show_pct = T)

## Warning: It is deprecated to specify `guide = FALSE` to remove a guide. Please
## use `guide = "none"` instead.

Finalmente, observemos la correlación entre las variables numéricas para darnos una idea de la posible existencia de patrones sobre los datos:

vis_cor(movies_analysis %>% select(where(is.numeric), -id))

Existe una correlación positiva entre los ingresos, el presupuesto y el número de votos. Luego, un poco más débil, entre la duración de la película, su presupuesto y su popularidad.

Para terminar este análisis descriptivo, visualicemos la frecuencia de nuestras variables categóricas.

# Declaramos un par de funciones útiles para ordenar nuestros gráficos
reorder_within <- tidytext::reorder_within
scale_x_reordered <- tidytext::scale_x_reordered
# Realizamos el gráfico (Top 10 por variable)
movies_analysis %>% 
  select(id, where(is.character)) %>% 
  pivot_longer(cols = -c(id, title), 
               names_to = "variable", values_to = "valor") %>% 
  group_by(variable, valor) %>% 
  summarise(n=n()) %>% 
  mutate(pct = n/sum(n)) %>% 
  ungroup() %>% 
  group_by(variable) %>% 
  slice_max(order_by = pct, n = 10, with_ties = F) %>% 
  ggplot(aes(reorder_within(valor, pct, variable), pct))+
  scale_x_reordered()+
  geom_col()+
  facet_wrap(vars(variable), scales = "free", ncol=1)+
  coord_flip()

## `summarise()` has grouped output by 'variable'. You can override using the `.groups` argument.

Un análisis similar, en una sola línea se puede realizar con la librería GGally (aunque algo lento).

movies_analysis %>%
  select(-id, -title, -production_countries, -production_companies) %>% 
  GGally::ggpairs(cardinality_threshold = 20)

## Registered S3 method overwritten by 'GGally':
##   method from   
##   +.gg   ggplot2

## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.

Ahora que conocemos mejor nuestros datos podemos pasar al FAMD.

Como primer paso, prepararemos nuestros datos; es decir, reagruparemos variables categóricas con demasiadas categorías, escalaremos las variables continuas, entre otras tareas.

preprocessing_rec <- movies_analysis %>% 
  mutate(age = (Sys.Date()-release_date)/365.25) %>% 
  select(-release_date) %>% 
  recipe() %>% 
  step_other(genres, production_companies, production_countries,
             threshold = 0.035, other = "Other") %>% 
  step_scale(all_numeric())
preprocessing_rec %>% summary()

## # A tibble: 12 x 4
##    variable             type    role  source  
##    <chr>                <chr>   <lgl> <chr>   
##  1 id                   numeric NA    original
##  2 title                nominal NA    original
##  3 budget               numeric NA    original
##  4 genres               nominal NA    original
##  5 popularity           numeric NA    original
##  6 production_companies nominal NA    original
##  7 production_countries nominal NA    original
##  8 revenue              numeric NA    original
##  9 runtime              numeric NA    original
## 10 vote_average         numeric NA    original
## 11 vote_count           numeric NA    original
## 12 age                  other   NA    original

prepared_data <- preprocessing_rec %>% 
  prep() %>% 
  juice()
prepared_data %>% 
  filter(title %>% 
           str_to_lower() %>% 
           str_detect("batman"))

## # A tibble: 22 x 12
##         id title    budget genres  popularity production_compa~ production_coun~
##      <dbl> <fct>     <dbl> <fct>        <dbl> <fct>             <fct>           
##  1 0.00395 Batman ~ 2.41   Action       0.982 Other             United Kingdom  
##  2 0.00256 Batman   0.845  Other        1.41  Other             United Kingdom  
##  3 0.00347 Batman ~ 1.93   Action       1.11  Other             United Kingdom  
##  4 0.00396 Batman ~ 3.02   Action       1.26  Other             United Kingdom  
##  5 0.142   Batman:~ 0.145  Action       0.538 Other             United States o~
##  6 0.0254  Batman   0.0333 Other        0.663 Twentieth Centur~ United States o~
##  7 0.155   Batman ~ 0      Animat~      0.581 Other             United States o~
##  8 0.00259 Batman ~ 3.62   Action       2.10  Other             United Kingdom  
##  9 0.132   Batman:~ 0.0845 Animat~      0.751 Other             United States o~
## 10 0.388   Batman:~ 0      Action       0.519 Other             United States o~
## # ... with 12 more rows, and 5 more variables: revenue <dbl>, runtime <dbl>,
## #   vote_average <dbl>, vote_count <dbl>, age <drtn>

Para comprobar los cambios que hicimos, observamos de nuevo la distribución de variables categóricas y la correlación de variables numéricas.

# Variables categóricas
prepared_data %>% 
  select(id, where(is.factor)) %>% 
  pivot_longer(cols = -c(id, title), 
               names_to = "variable", values_to = "valor") %>% 
  group_by(variable, valor) %>% 
  summarise(n=n()) %>% 
  mutate(pct = n/sum(n)) %>% 
  ungroup() %>% 
  group_by(variable) %>% 
  # slice_max(order_by = pct, n = 10, with_ties = F) %>% 
  ggplot(aes(reorder_within(valor, pct, variable), pct))+
  scale_x_reordered()+
  geom_col()+
  facet_wrap(vars(variable), scales = "free", ncol=1)+
  coord_flip()

## `summarise()` has grouped output by 'variable'. You can override using the `.groups` argument.

prepared_data %>% select(where(is.numeric), -id) %>% GGally::ggpairs()

Con la data preparada, podemos pasar a la estimación de nuestro modelo.

famd_pre_result <- prepared_data %>% 
  filter(production_countries=="United States of America",
         production_companies=="Universal Pictures") %>% 
  select(-title, -id, -production_companies, -production_countries) %>% 
  FAMD(ncp=5, graph = F)

Con nuestro modelo estimado, podemos observar la varianza explicada por cada componente.

fviz_screeplot(famd_pre_result)

Así como la contribución de cada variable.

fviz_contrib(famd_pre_result, choice = "var", axes = 1:5)

Y el llamado biplot.

fviz_famd_var(famd_pre_result)

fviz_famd_ind(famd_pre_result)

En el transcurso de la clase iremos mejorando la ejecución de esta técnica, acorde a la contribución de cada variable.

¿Has entendido todos los conceptos? No dudes en hacer preguntas. ¡Nos vemos en una próxima ocasión!