Trabajo Final de la materia “Machine learning con aplicaciones espaciales”

Este dataset se corresponde a precios de propiedades del estado de California.

Las variables del dataset son las siguientes:

  1. Valor medio de la vivienda: (Median house value) valor medio de la vivienda para los hogares dentro de un bloque (medido en dólares estadounidenses) [$]
  2. Ingresos medios: (Median Income) ingresos medios de los hogares dentro de una cuadra de casas (medidos en decenas de miles de dólares estadounidenses) [10k $]
  3. Edad promedio:(Median Age) Edad promedio de una casa dentro de una cuadra; un número menor es un edificio más nuevo [años]
  4. Total de habitaciones:(Total Rooms) número total de habitaciones dentro de un barrio
  5. Total de dormitorios: (Total Bedrooms)número total de dormitorios dentro de un barrio
  6. Población:(Population) Número total de personas que residen dentro de una cuadra.
  7. Hogares: (Households) número total de hogares, un grupo de personas que residen dentro de una unidad de hogar, para un barrio.
  8. Latitud:
  9. Longitud:
  10. Distancia a la costa: Distancia al punto de la costa más cercano [m]
  11. Distancia a Los Ángeles: Distancia al centro de Los Ángeles [m]
  12. Distancia a San Diego: Distancia al centro de San Diego [m]
  13. Distancia a San José: Distancia al centro de San José [m]
  14. Distancia a San Francisco: Distancia al centro de San Francisco [m]

Más información disponible en: https://www.kaggle.com/fedesoriano/california-housing-prices-data-extra-features

Planteo del problema:

Teniendo en cuenta todas las variables disponibles, estimar el Valor medio de la vivienda (Median House Value) mediante un modelo de machine learning.

Setting

Librerías a utilizar

Datos

EDA

Breve descripción del dataset y análisis descriptivo de aquellas variables consideradas de importancia para el caso de estudio.

options(scipen = 999)
skim(houses)
Data summary
Name houses
Number of rows 20640
Number of columns 14
_______________________
Column type frequency:
numeric 14
________________________
Group variables None

Variable type: numeric

skim_variable n_missing complete_rate mean sd p0 p25 p50 p75 p100 hist
Median_House_Value 0 1 206855.82 115395.62 14999.00 119600.00 179700.00 264725.00 500001.00 ▅▇▅▂▂
Median_Income 0 1 3.87 1.90 0.50 2.56 3.53 4.74 15.00 ▇▇▁▁▁
Median_Age 0 1 28.64 12.59 1.00 18.00 29.00 37.00 52.00 ▃▇▇▇▅
Tot_Rooms 0 1 2635.76 2181.62 2.00 1447.75 2127.00 3148.00 39320.00 ▇▁▁▁▁
Tot_Bedrooms 0 1 537.90 421.25 1.00 295.00 435.00 647.00 6445.00 ▇▁▁▁▁
Population 0 1 1425.48 1132.46 3.00 787.00 1166.00 1725.00 35682.00 ▇▁▁▁▁
Households 0 1 499.54 382.33 1.00 280.00 409.00 605.00 6082.00 ▇▁▁▁▁
Latitude 0 1 35.63 2.14 32.54 33.93 34.26 37.71 41.95 ▇▁▅▂▁
Longitude 0 1 -119.57 2.00 -124.35 -121.80 -118.49 -118.01 -114.31 ▂▆▃▇▁
Distance_to_coast 0 1 40509.26 49140.04 120.68 9079.76 20522.02 49830.41 333804.69 ▇▁▁▁▁
Distance_to_LA 0 1 269421.98 247732.45 420.59 32111.25 173667.46 527156.24 1018260.12 ▇▁▅▁▁
Distance_to_SanDiego 0 1 398164.93 289400.56 484.92 159426.39 214739.83 705795.40 1196919.27 ▇▁▃▃▁
Distance_to_SanJose 0 1 349187.55 217149.88 569.45 113119.93 459758.88 516946.49 836762.68 ▇▃▆▇▁
Distance_to_SanFrancisco 0 1 386688.42 250122.19 456.14 117395.48 526546.66 584552.01 903627.66 ▆▂▂▇▁

Se trata de un dataset con 20640 observaciones y 14 columnas, todos los valores son numéricos.

ggplot(data=houses, aes(x=Median_House_Value)) +
  geom_histogram(fill="steelblue", color="black", bins=40) +
  ggtitle("Histograma para la variable Median House Value")

La distribución de la variable target muestra un sesgo hacia la derecha que puede afectar la calidad de las predicciones del modelo.

Se utilizan bins de 10, 50 y 100 para explorar los valores de las casas superiores a $500000.

m5<-ggplot(data=houses, aes(x=Median_House_Value)) +
  geom_histogram(fill="steelblue", color="black", bins=5) +
  ggtitle("Hist 10")

m50<-ggplot(data=houses, aes(x=Median_House_Value)) +
  geom_histogram(fill="steelblue", color="black", bins=50) +
  ggtitle("Hist 50")

m100<-ggplot(data=houses, aes(x=Median_House_Value)) +
  geom_histogram(fill="steelblue", color="black", bins=100) +
  ggtitle("Hist 100")


m5+m50+m100

Los bins de 50 y 100 dan cuenta de los valores máximos en 500001.

Se filtran los valores máximos para saber cuantos son.

houses_b<-houses%>%
  filter(Median_House_Value>=500001)

Hay 965 casas con el mismo valor promedio, este hecho puede afectar las predicciones del modelo.

Seguidamente se visualiza en un gráfico de puntos la distribución de la distribucion de la variable objetivo según coordenadaas de latitud y longitud para saber si la lógica espacial aporta información extra.

d <-ggplot(houses, aes(Latitude, Longitude))+
  geom_point(aes(color = Median_House_Value))

p <- ggplot(houses_b, aes(Latitude, Longitude))+
  geom_point(aes(color = Median_House_Value))

p+d

Las propiedades con precios medios mas altos parecen agruparse a la izquierda del plano.

pal <- colorNumeric(
  palette = "RdYlGn",
  domain = houses$Median_House_Value)

houses%>%
  leaflet(options = leafletOptions(attributionControl=FALSE))%>%
  setView(lng =-119.417931, lat =36.778259, zoom = 6) %>%
  addProviderTiles(providers$CartoDB.Positron)%>%
  addCircleMarkers(
    lng =  ~ Longitude,
    lat =  ~ Latitude,
    radius = ~ Median_House_Value/100000,
    color =  ~ pal(Median_House_Value))%>%
  addLegend("bottomright", pal = pal, values = ~Median_House_Value,
    title = "Median_House_Value",
    labFormat = labelFormat(prefix = "$"),
    opacity = 1)

La localización de los puntos en el mapa da cuenta de una tendencia la cual indica que las casas de mayor precio se ubican en la costa. La proximidad al mar puede ser un indicador relacionado con el incremento del valor medio de las viviendas.

Con el objetivo de sistematizar las preguntas sobre posibles relaciones entre la variable objetivo y el resto de features se crea una matriz de correlaciones

houses.cor = cor(houses)

corrplot(houses.cor)

En base al corplot se seleccionan 3 variables que podrían ser de importancia Median_Income, Distance_to_coast, y Tot_Rooms para indagar en cómo afectan a la variable de estudio.

a<-ggplot(data = houses) + 
  geom_point(mapping = aes(y =Median_Income, x = Median_House_Value))


b<-ggplot(data = houses) + 
  geom_point(mapping = aes(y =Tot_Rooms, x = Median_House_Value))


c<-ggplot(data = houses) + 
  geom_point(mapping = aes(y =Distance_to_coast, x = Median_House_Value))

a+b+c

En una primera vista existiría cierta asociación positiva en entre la variable objetivo con la media de ingresos y con el total de habitaciones, la relación es inversa con la distancia a la costa (las casas mas cercanas a la costa tienen a presentar precios medios mas elevados).

Modelado: Random Forest

División de datos

Armado de grupos de datos para train y testing con el criterio 75/25.

set.seed(1234)

p_split <- houses %>%
    initial_split(prop = 0.75)

p_train <- training(p_split)

p_test <- testing(p_split)

glimpse(p_train)
## Rows: 15,480
## Columns: 14
## $ Median_House_Value       <dbl> 165500, 225200, 125500, 206900, 114600, 17500~
## $ Median_Income            <dbl> 4.6389, 4.0603, 2.4167, 3.4808, 3.0924, 2.562~
## $ Median_Age               <dbl> 17, 37, 31, 45, 14, 52, 16, 15, 23, 43, 36, 3~
## $ Tot_Rooms                <dbl> 1145, 2059, 1014, 944, 2391, 1114, 2512, 539,~
## $ Tot_Bedrooms             <dbl> 209, 349, 252, 178, 451, 206, 356, 71, 835, 2~
## $ Population               <dbl> 499, 825, 1064, 533, 798, 425, 795, 287, 2357~
## $ Households               <dbl> 202, 334, 247, 193, 308, 207, 353, 66, 823, 1~
## $ Latitude                 <dbl> 33.94, 33.83, 34.03, 33.81, 37.29, 37.73, 33.~
## $ Longitude                <dbl> -118.17, -118.10, -118.17, -118.20, -119.56, ~
## $ Distance_to_coast        <dbl> 21064.3345, 10513.2231, 28063.1951, 7476.0654~
## $ Distance_to_LA           <dbl> 14208.836, 28041.689, 7225.341, 27235.138, 37~
## $ Distance_to_SanDiego     <dbl> 165280.04, 151557.98, 173589.00, 155354.70, 5~
## $ Distance_to_SanJose      <dbl> 505621.00, 519121.29, 498068.93, 514914.25, 2~
## $ Distance_to_SanFrancisco <dbl> 573641.78, 587133.23, 566101.74, 582890.50, 2~

Los datos de train se dividen en 3-folds para hacer validación cruzada (v-folds=3)

p_folds <- vfold_cv(p_train, v=3, repeats = 5)

Preprocesamiento de los datos

recipe_rf <- p_train %>%
  recipe(Median_House_Value~.) %>%
  step_corr(all_predictors()) %>% #elimino las correlaciones
  step_center(all_predictors(), -all_outcomes()) %>% #centrado
  step_scale(all_predictors(), -all_outcomes()) %>% #escalado
  prep()

Especificación del modelo

Se define el moderlo a implementar: Random Forest Baseline.

rf_spec <- rand_forest() %>% 
  set_engine("ranger") %>% 
  set_mode("regression")

Workflow

Creación del workflow

rf_wf <- workflow() %>%
    add_recipe(recipe_rf) %>%
    add_model(rf_spec)

Entrenamiento del Modelo

set.seed(123)

rf_res <- rf_wf %>%
    fit_resamples(
        p_folds,
        control = control_resamples(save_pred = TRUE)
    )
## Warning: package 'ranger' was built under R version 4.1.3
glimpse(rf_res)
## Rows: 15
## Columns: 6
## $ splits       <list> [<vfold_split[10320 x 5160 x 15480 x 14]>], [<vfold_spli~
## $ id           <chr> "Repeat1", "Repeat1", "Repeat1", "Repeat2", "Repeat2", "R~
## $ id2          <chr> "Fold1", "Fold2", "Fold3", "Fold1", "Fold2", "Fold3", "Fo~
## $ .metrics     <list> [<tbl_df[2 x 4]>], [<tbl_df[2 x 4]>], [<tbl_df[2 x 4]>],~
## $ .notes       <list> [<tbl_df[0 x 3]>], [<tbl_df[0 x 3]>], [<tbl_df[0 x 3]>],~
## $ .predictions <list> [<tbl_df[5160 x 4]>], [<tbl_df[5160 x 4]>], [<tbl_df[516~

Resultados de TRAIN

Se imprimen las métricas obtenidas.

rf_res %>%
    collect_metrics()
## # A tibble: 2 x 6
##   .metric .estimator      mean     n   std_err .config             
##   <chr>   <chr>          <dbl> <int>     <dbl> <chr>               
## 1 rmse    standard   50442.       15 174.      Preprocessor1_Model1
## 2 rsq     standard       0.810    15   0.00131 Preprocessor1_Model1

El RMSE es de 50442. en etapa de entrenamiento.

Finaliza el workflow

final_model <- finalize_model(rf_spec, select_best(rf_res, "rmse"))

final_model
## Random Forest Model Specification (regression)
## 
## Computational engine: ranger

Predicción en TEST set

final_rs <- last_fit(final_model, Median_House_Value ~ ., p_split)
final_rs
## # Resampling results
## # Manual resampling 
## # A tibble: 1 x 6
##   splits               id               .metrics .notes   .predicti~1 .workflow 
##   <list>               <chr>            <list>   <list>   <list>      <list>    
## 1 <split [15480/5160]> train/test split <tibble> <tibble> <tibble>    <workflow>
## # ... with abbreviated variable name 1: .predictions
final_rs %>%
  collect_metrics()
## # A tibble: 2 x 4
##   .metric .estimator .estimate .config             
##   <chr>   <chr>          <dbl> <chr>               
## 1 rmse    standard   45460.    Preprocessor1_Model1
## 2 rsq     standard       0.848 Preprocessor1_Model1

El RMSE es de 45460, en test mejora los datos de entramiento (50442).

final_rs %>% 
    collect_predictions()
## # A tibble: 5,160 x 5
##    id                 .pred  .row Median_House_Value .config             
##    <chr>              <dbl> <int>              <dbl> <chr>               
##  1 train/test split 417173.     2             358500 Preprocessor1_Model1
##  2 train/test split 406694.     3             352100 Preprocessor1_Model1
##  3 train/test split 342056.     4             341300 Preprocessor1_Model1
##  4 train/test split 268262.     5             342200 Preprocessor1_Model1
##  5 train/test split 244060.     8             241400 Preprocessor1_Model1
##  6 train/test split 271396.    10             261100 Preprocessor1_Model1
##  7 train/test split 225722.    11             281500 Preprocessor1_Model1
##  8 train/test split 267100.    12             241800 Preprocessor1_Model1
##  9 train/test split 151927.    19             158700 Preprocessor1_Model1
## 10 train/test split 138314.    20             162900 Preprocessor1_Model1
## # ... with 5,150 more rows

Se comparan las predicciones con los valores reales:

collect_predictions(final_rs) %>%
  ggplot(aes(Median_House_Value, .pred)) +
  geom_abline(lty = 2, color = "gray50") +
  geom_point(alpha = 0.5, color = "midnightblue") +
  coord_fixed()

Importancia de las variables

Gráfico de importancia de las variables

library(vip)
final_model %>%
  set_engine("ranger", importance = "permutation") %>%
  fit(Median_House_Value ~ .,
      data = juice(recipe_rf)) %>%
  vip(geom = "point")

El gráfico de importancia de las variables ratificó parte de las especulaciones planteadas en el EDA acerca de las variables que podrían influir en el precio medio de las viviendas, Sobre todo en el caso del ingreso medio de los residentes y la distancia a la costa.

Caso distinto fue el de la cantidad de cuartos, que dadas las referencias del gráfico de correlaciones podía ser significativa , pero según los datos del modelo de random forest y el plot de importancia hay variables más influyentes como las distancias a Los Ángeles o San Jose.