Proyecto final DS4B

Big Data Analytics aplicado al negocio: Análisis preliminar de los datos de Renfe

Contexto

En la comunidad en línea de Kaggle, como plataforma para el aprendizaje de Machine Learning, está publicado un dataset de la compañia pública Renfe S.A, para el estudio en profundidad de sus datos. Este dataset está siendo examinado por numerosas personas en todo el mundo, intentando en su mayoría, encontrar un modelo predictivo eficaz, sobre el precio de los billetes.
En su inmensa mayoría, los participantes utilizan como herramienta de desarrollo Python, por tanto es interesante mostrar otro enfoque y análisis haciendo uso de Rstudio.

Metodología aplicada

En el programa de DS4B se aplica una metodología híbrida entre las dos más habituales CRISP-DM y SEMMA, extrayendo los puntos mas relevantes y el proceso a seguir es el siguiente:

Importación y muestreo -> Calidad de datos -> Transformación -> Modelización -> Evaluación -> Implantación

Conclusiones tras el análisis:

Podemos observar que el archivo contiene: 7.671.354 registros y 9 variables, dentro de las cuales destacan estaciones de origen y destino, horarios, clase de tren y precio, esta última considerada target y sobre la cual desarrollamos el modelo predictivo.
El período observado transcurre desde:

11 abril 2019, fecha de primera compra de billetes.
12 abril 2019, fecha de primera circulación.
21 octubre 2019, fecha de última ciruclación.

El tren con mayores circulaciones y tráfico de viajeros es el AVE con: 5.240.331 circulaciones. La tarifa más elegida en la compra del billete es Promo con: 5.322.563 billetes comprados y la clase más elegida en la compra del billete es Turista con: 5.818.271 usuarios.
El grupo de ciudades inlcuidas en el dataset son 5, BARCELONA, SEVILLA, VALENCIA, PONFERRADA y MADRID esta última como eje principal de las circulaciones.
Un billete cuesta de media: 61.40 € y el billete más caro ha sido de: 342.8 €.
El modelo ML aplicado en el análisis es el de Regresión Lineal Múltiple, tiene un R2 alta (0.8448), lo que indica que es capaz de explicar el 84,48% de la variabilidad observada en el precio. El p-value es inferior a 0,05, lo que me asegura que confirma que el modelo es bueno.
La métrica para evaluar el rendimiento del modelo ML es la de RMSE. El valor obtenido es: 10.12592, lo que me indica que la predicción de precios varía en 10€ aproximadamente, esto significa que el modelo reduce en 2,5 veces la variabilidad del error promedio al calcular el precio.

Detalle del trabajo realizado

Importación: Cargamos los datos Usamos fread de data.table para una lectura mucho mas rapida

renfe <- fread('renfe.csv')

Muestreo: Analisis exploratorio

glimpse(renfe)

## Rows: 7,671,354
## Columns: 9
## $ insert_date <chr> "2019-04-11 21:49:46", "2019-04-11 21:49:46", "2019-04-...
## $ origin      <chr> "MADRID", "MADRID", "MADRID", "MADRID", "MADRID", "MADR...
## $ destination <chr> "BARCELONA", "BARCELONA", "BARCELONA", "BARCELONA", "BA...
## $ start_date  <chr> "2019-04-18 05:50:00", "2019-04-18 06:30:00", "2019-04-...
## $ end_date    <chr> "2019-04-18 08:55:00", "2019-04-18 09:20:00", "2019-04-...
## $ train_type  <chr> "AVE", "AVE", "AVE", "AVE", "AVE", "AVE", "AVE", "AVE",...
## $ price       <dbl> 68.95, 75.40, 106.75, 90.50, 88.95, 107.70, 107.70, 102...
## $ train_class <chr> "Preferente", "Turista", "Turista Plus", "Turista Plus"...
## $ fare        <chr> "Promo", "Promo", "Promo", "Promo", "Promo", "Flexible"...

2.1. Calidad de datos: Estadísticos básicos Hacemos un summary, con lapply que sale en formato de lista y se lee mejor

lapply(renfe,summary)

## $insert_date
##    Length     Class      Mode 
##   7671354 character character 
## 
## $origin
##    Length     Class      Mode 
##   7671354 character character 
## 
## $destination
##    Length     Class      Mode 
##   7671354 character character 
## 
## $start_date
##    Length     Class      Mode 
##   7671354 character character 
## 
## $end_date
##    Length     Class      Mode 
##   7671354 character character 
## 
## $train_type
##    Length     Class      Mode 
##   7671354 character character 
## 
## $price
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##     0.0    41.2    58.1    61.4    76.3   342.8  573121 
## 
## $train_class
##    Length     Class      Mode 
##   7671354 character character 
## 
## $fare
##    Length     Class      Mode 
##   7671354 character character

Primeras observaciones:

*Todos los datos son de tipo caracter, excepto el precio.

*La variable fecha debe ser transformada para poder trabajarla mejor.

*En la variable precio, encontramos un número muy alto de datos no encontrados.

2.2. Calidad de datos: Análisis de nulos

data.frame(colSums(is.na(renfe)))

##             colSums.is.na.renfe..
## insert_date                     0
## origin                          0
## destination                     0
## start_date                      0
## end_date                        0
## train_type                      0
## price                      573121
## train_class                     0
## fare                            0

Podemos observar que contiene demasiados datos nulos. Puede ser debido a un cambio de tren, adelantando el billete a coste cero o anulación del mismo.

Una opción que podría ser interesante es la de sustutuír los nulos por los precios de media, pero segmentando la media de cada una de las tarifas (Promo, turista, turista plus, preferente…) Pero esto cargaría cierto grado de error tratándose de la variable a predecir, por lo tanto:

Eliminamos registros nulos

colSums(is.na(renfe))

## insert_date      origin destination  start_date    end_date  train_type 
##           0           0           0           0           0           0 
##       price train_class        fare 
##      573121           0           0

renfe <- na.omit(renfe)

Investigaremos cada variable un poco más:

2.2.1. Vamos a conocer las diferentes tarifas existentes:

renfe %>%                       
  group_by(fare) %>%      
  tally()

## # A tibble: 10 x 2
##    fare                          n
##    <chr>                     <int>
##  1 4x100                         1
##  2 Adulto ida               459234
##  3 COD.PROMOCIONAL            3268
##  4 Doble Familiar-Flexible      18
##  5 Flexible                1445738
##  6 Grupos Ida                   21
##  7 Individual-Flexible         177
##  8 Mesa                        138
##  9 Promo                   5015639
## 10 Promo +                  173999

Las más significativa es la tarifa promo con mas de 5 millones de registros de los 7 que tiene el dataframe, seguida de flexible y adulto ida

2.2.2. Vamos a conocer las diferentes clases de tren :

 renfe %>%                       
  group_by(train_class) %>%      
  tally()

## # A tibble: 9 x 2
##   train_class                     n
##   <chr>                       <int>
## 1 Cama G. Clase                 195
## 2 Cama Turista                 5309
## 3 Preferente                 676316
## 4 PreferenteSÃ³lo plaza H      5632
## 5 Turista                   5417159
## 6 Turista con enlace         433222
## 7 Turista Plus               517765
## 8 Turista PlusSÃ³lo plaza H      21
## 9 TuristaSÃ³lo plaza H        42614

La clase mas usada para viajar es turista con 5,4 millones de registros, seguida de preferente y turista plus

2.2.3. Conoceremos ahora los tipos de tren que hay en circulación:

 renfe %>%                       
  group_by(train_type) %>%      
  tally()

## # A tibble: 15 x 2
##    train_type       n
##    <chr>        <int>
##  1 ALVIA       420706
##  2 AV City     204552
##  3 AVE        5027467
##  4 AVE-LD       62781
##  5 AVE-MD       53220
##  6 AVE-TGV     100578
##  7 INTERCITY   369604
##  8 LD           82958
##  9 LD-MD        53303
## 10 MD           10933
## 11 MD-AVE       16957
## 12 MD-LD       153070
## 13 R. EXPRES    92932
## 14 REGIONAL    366302
## 15 TRENHOTEL    82870

En este caso los trenes que tiene mayor número de circulaciones son los AVE coincidiendo con más de 5 millones de registros, seguido del Alvia e Intercity

2.3.4. Ahora vamos a conocer los principales orígenes y destinos

renfe %>%                       
  group_by(origin, destination) %>%      
  tally()

## # A tibble: 8 x 3
## # Groups:   origin [5]
##   origin     destination       n
##   <chr>      <chr>         <int>
## 1 BARCELONA  MADRID      1195817
## 2 MADRID     BARCELONA   1211906
## 3 MADRID     PONFERRADA   169259
## 4 MADRID     SEVILLA     1066122
## 5 MADRID     VALENCIA    1091056
## 6 PONFERRADA MADRID       256651
## 7 SEVILLA    MADRID      1073318
## 8 VALENCIA   MADRID      1034104

Los resultados muestran que sólo tenemos 5 orígenes y destinos en el dataset, combinaciones de trenes que van y vienen hacia Madrid, ciudad eje de toda la curulación.

Tras estos primeros análisis, se puede observar también con facilidad, que el grueso de los datos están obtenidos por trenes AVE, en sus 3 principales clases Preferente, Turista Plus y Turista clases que además algunas coindiden en los trenes Alvia e Intercity

A continuación veremos algunos gráficos:

Uso de Ggplot

Gráfico 1:

ggplot(data = renfe, aes(x = train_type, fill = as.factor(train_class))) + geom_bar() + 
  xlab("Tipo de Tren") + 
  ylab("Número de viajeros") + 
  ggtitle("Gráfico Viajeros por tipo de tren y clase ") +
  labs(fill = "Clases") + 
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

Gráfico 2:

ggplot(data = renfe, aes(x = origin, fill = as.factor(train_type))) + 
  geom_bar() + 
  xlab("Origen") + 
  ylab("Número de viajeros") + 
  ggtitle("Gráfico Viajeros por origen y destino en función del tren ") +
  labs(fill = "Tipos de tren") + 
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

Uso de PLotly

Gráfico 1. Mapa con Leaflet:

dest_df <- data.frame (
  lat = c(41.38879, 39.46975, 37.38283, 42.5466400),
  lon = c(2.15899, -0.37739, -5.97317, -6.5961900))

orig_df <- data.frame (lat = c(rep.int(40.4165, nrow(dest_df))),
                   long = c(rep.int(-3.70256,nrow(dest_df)))
                  )


orig_df$sequence <- c(sequence = seq(1, length.out = nrow(orig_df), by=2))
dest_df$sequence <- c(sequence = seq(2, length.out = nrow(orig_df), by=2))

library("sqldf")

## Loading required package: gsubfn

## Loading required package: proto

## Loading required package: RSQLite

q <- "
SELECT * FROM orig_df
UNION ALL
SELECT * FROM dest_df
ORDER BY sequence
"
poly_df <- sqldf(q)


m <- leaflet() %>% 
    setView(lat  = 40.416775, lng = -3.703790, zoom = 5)%>%
    addTiles() %>%  
    addPolylines(data = poly_df, lng = ~long, lat = ~lat, weight = 2,
    opacity = 3 ) %>%
    addMarkers(lat=40.4165, lng=-3.70256, popup="Madrid")%>%
    addMarkers(lat=41.38879, lng=2.15899, popup="Barcelona")%>%
    addMarkers(lat=39.46975, lng=-0.37739, popup="Valencia")%>%
    addMarkers(lat=37.38283, lng=-5.97317, popup="Sevilla")%>%
    addMarkers(lat=42.5466400, lng=-6.5961900, popup="Ponferrada")
    
m %>% addProviderTiles(providers$CartoDB.Positron)

Gráfico 2. Donut chart con GGplot2 y Plotly:

df <- renfe
df <- df %>% group_by(train_type)
df <- df %>% summarize(count = n())

fig <- df %>% plot_ly(labels = ~train_type, values = ~count,
        textposition = 'inside',
        textinfo = 'label+percent')

fig <- fig %>% add_pie(hole = 0.5)
fig <- fig %>% layout( showlegend = F,
                      xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
                      yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))


fig

2.3. Calidad de datos: Análisis de atípicos

Analizamos las que son de tipo numerico: Precio

out <- function(variable){
  t(t(head(sort(variable,decreasing = F),60))) #la doble traspuesta es un truco para que se visualice la salida, si no lo que crearia es una coleccion de dataframes que no se ven bien
}
lapply(renfe,function(x){
  if(is.double(x)) out(x)
})

## $insert_date
## NULL
## 
## $origin
## NULL
## 
## $destination
## NULL
## 
## $start_date
## NULL
## 
## $end_date
## NULL
## 
## $train_type
## NULL
## 
## $price
##        [,1]
##  [1,]  0.00
##  [2,]  0.00
##  [3,]  0.00
##  [4,]  0.00
##  [5,]  0.00
##  [6,]  0.00
##  [7,]  0.00
##  [8,]  0.00
##  [9,]  0.00
## [10,]  0.00
## [11,]  0.00
## [12,]  0.00
## [13,]  0.00
## [14,]  0.00
## [15,]  0.00
## [16,]  0.00
## [17,]  0.00
## [18,]  0.00
## [19,]  0.00
## [20,]  0.00
## [21,]  0.00
## [22,]  0.00
## [23,]  0.00
## [24,]  0.00
## [25,]  0.00
## [26,]  0.00
## [27,]  0.00
## [28,]  0.00
## [29,]  0.00
## [30,]  0.00
## [31,]  0.00
## [32,]  0.00
## [33,]  0.00
## [34,]  0.00
## [35,]  0.00
## [36,]  0.00
## [37,]  0.00
## [38,]  0.00
## [39,]  0.00
## [40,]  0.00
## [41,]  0.00
## [42,]  0.00
## [43,]  0.00
## [44,]  0.00
## [45,]  0.00
## [46,]  0.00
## [47,]  0.00
## [48,]  0.00
## [49,]  0.00
## [50,]  0.00
## [51,]  0.00
## [52,] 12.85
## [53,] 12.85
## [54,] 12.85
## [55,] 12.85
## [56,] 12.85
## [57,] 12.85
## [58,] 12.85
## [59,] 12.85
## [60,] 12.85
## 
## $train_class
## NULL
## 
## $fare
## NULL

Previamente había observado en los estadísticos básicos de la función Lapply que el precio máximo es de 342,80€, cantidad razonable. Pero tenía dudas sobre cuántos billetes a precio “cero” se podían encontrar. Para ello hago uso de esta fórmula y tan solo encuentro 51 registros. cantidad asumible. Si cambio el decreassing a True me da la tarifa máxima y coincide.

También investigo la desviación típica del precio, que me proporciona la varición del conjunto de datos:

sd(renfe$price)

## [1] 25.68568

2.4. Acciones resultado del analisis de calidad de datos y exploratorio

Tras los principales análisis y comprobar la calidad de los datos, podemos definir el trabajo a seguir: Nos centraremos en tres tipos de trenes: AVE, ALVIA e INTERCITY, en las principales clases: PREFERENTE; TURISTA PLUS Y TURISTA y las tarifas más demandadas: PROMO, FLEXIBLE y ADULTO IDA. No eliminaremos ninguna categoría hasta saber la relación que puedan tener unas con otras.

Trasformación de datos

3.1. Cambio de formato en las fechas, están en formato caracter y podemos trabajarlas en el formato que viene de origen:

renfe$insert_date <- as_datetime(renfe$insert_date)
renfe$start_date <- as_datetime(renfe$start_date)
renfe$end_date <- as_datetime(renfe$end_date)

Una vez transformado el formato, podemos volver a hacer un lapply para conocer los períodos de compra y viaje entre los que se encuentra el dataframe.

lapply(renfe,summary)

## $insert_date
##                  Min.               1st Qu.                Median 
## "2019-04-11 21:49:46" "2019-04-30 07:29:27" "2019-05-25 07:07:54" 
##                  Mean               3rd Qu.                  Max. 
## "2019-05-30 07:58:30" "2019-06-14 19:30:38" "2019-08-22 19:06:26" 
## 
## $origin
##    Length     Class      Mode 
##   7098233 character character 
## 
## $destination
##    Length     Class      Mode 
##   7098233 character character 
## 
## $start_date
##                  Min.               1st Qu.                Median 
## "2019-04-12 05:50:00" "2019-05-24 12:30:00" "2019-06-21 06:38:00" 
##                  Mean               3rd Qu.                  Max. 
## "2019-06-25 14:27:57" "2019-07-17 19:19:00" "2019-10-20 22:14:00" 
## 
## $end_date
##                  Min.               1st Qu.                Median 
## "2019-04-12 08:38:00" "2019-05-24 15:45:00" "2019-06-21 09:31:00" 
##                  Mean               3rd Qu.                  Max. 
## "2019-06-25 17:33:43" "2019-07-17 22:17:00" "2019-10-21 04:31:00" 
## 
## $train_type
##    Length     Class      Mode 
##   7098233 character character 
## 
## $price
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00   41.20   58.15   61.40   76.30  342.80 
## 
## $train_class
##    Length     Class      Mode 
##   7098233 character character 
## 
## $fare
##    Length     Class      Mode 
##   7098233 character character

Todo transcurre en un período de 7 meses, de Abril a Octubre de 2019.

*Fechas de compra: del 11 de abril al 22 de agosto.

*Fechas de inicio de viaje: del 12 de abril al 20 de octubre.

*Última llegada: 21 de octubre.

Creación de variables

3.2. Crearemos una lista con todos los festivos del año examinado y posteriormente compararemos si en el df conicide con la fecha de salida, almacenando su resultado en la nueva variable “festivo”

fiestas <- (c("2019-01-01", "2019-04-19","2019-05-19","2019-08-15","2019-10-12","2019-11-01","2019-12-06","2019-12-25","2019-01-07","2019-02-28","2019-04-18","2019-12-09","2019-04-22","2019-12-26","2019-05-24","2019-09-11","2019-03-19","2019-04-22","2019-08-09","2019-05-17","2019-07-25"))

renfe <- renfe %>%
  mutate(fecha = as.character(date(start_date)),
         festivo = ifelse(fecha %in% fiestas, 1, 0))

3.3. Dia de la semana de compra y de salida:

renfe <- renfe %>%
  mutate(
   dia_compra = (wday(insert_date, label = TRUE, abbr = FALSE,week_start = getOption("lubridate.week.start", 1))),
   dia_salida = (wday(start_date, label = TRUE, abbr = FALSE,week_start = getOption("lubridate.week.start", 1))))

Hacemos una breve comprobación para saber los días de mayor afluencia de viajeros:

renfe %>%
  group_by(dia_salida)%>%
  tally()

## # A tibble: 7 x 2
##   dia_salida       n
##   <ord>        <int>
## 1 lunes      1062248
## 2 martes     1075006
## 3 miércoles  1070492
## 4 jueves     1116022
## 5 viernes    1066604
## 6 sábado      756139
## 7 domingo     951722

Podemos observar que entre semana hay un número muy similar de viajeros, despuntando, por poco, los Martes y Jueves. El sábado es el día de menor tráfico de viajeros.

Para comprobar si la fecha de salida y llegada son las mismas, creo la variable “mismo_dia” que me dara un valor logico:

renfe <- renfe %>%
  mutate (mismo_dia = as.numeric(as.character((ifelse 
                        (end_date == start_date, '1','0')))))

renfe <- renfe %>%
  mutate(
    fecha1 = as.character(date(end_date)),
    fecha2 = as.character(date(start_date)),
    mismo_dia = ifelse(fecha2 == fecha1, 1, 0))

3.4. Semana del año de compra y de salida:

renfe <- renfe %>%
  mutate(
    semana_ano_compra = week(insert_date),
    semana_ano_salida = week(start_date))

3.5. Mes del año de compra y de salida:

renfe <- renfe %>%
  mutate(
    mes_ano_compra = month(insert_date, label = F ),
    mes_ano_salida = month(start_date, label = F ))

3.6. Creamos otra variable que nos determine la duración del viaje. Restando end_date y start_date.

renfe <- renfe %>%
  mutate(duracion = round(difftime(end_date,start_date,units="hours"),2))

3.7. Creamos la variable “antelacion” que nos puede ayudar más adelante a saber si existe una relación estrecha entre la fecha de compra y el precio. Para ello restaremos start_date e insert_date.

antelacion <- round(difftime(renfe$start_date,renfe$insert_date,units="days"),0)

3.8. Discretización de la variable “antelación” Usando los estadísticos básicos he obtenido lo siguiente: Media: 26 días, Mediana: 25 días, Moda: 22 días, Max.: 60 días. Aún así quiero establecer períodos semnales para discretizar la variable.

Discretizamos manualmente

renfe <- renfe %>%
  mutate(antelacion_DISC = as.factor(case_when(
      antelacion >= 49 ~ 'Dos_meses',
      antelacion < 49 & antelacion >= 42 ~ 'Mes_y_medio',
      antelacion < 42 & antelacion >= 35 ~ '5_semanas',
      antelacion < 35 & antelacion >= 28 ~ '4_semanas',
      antelacion < 28 & antelacion >= 21 ~ '3_semanas',
      antelacion < 21 & antelacion >= 14 ~ '2_semanas',
      antelacion < 14 & antelacion >= 7 ~ '1_semana',
      TRUE ~ 'Poca_antelacion')))

3.9. Eliminamos variables no predictoras del dataset, todas son relacionadas con las fechas, las cuales han sido transformadas para obtener más información.

renfe <- select(renfe, -insert_date,-end_date,-start_date,-fecha,-fecha1,-fecha2)

Hacemos una visión general de como queda el dataset

head(renfe)

##   origin destination train_type  price  train_class     fare festivo dia_compra
## 1 MADRID   BARCELONA        AVE  68.95   Preferente    Promo       1     jueves
## 2 MADRID   BARCELONA        AVE  75.40      Turista    Promo       1     jueves
## 3 MADRID   BARCELONA        AVE 106.75 Turista Plus    Promo       1     jueves
## 4 MADRID   BARCELONA        AVE  90.50 Turista Plus    Promo       1     jueves
## 5 MADRID   BARCELONA        AVE  88.95      Turista    Promo       1     jueves
## 6 MADRID   BARCELONA        AVE 107.70      Turista Flexible       1     jueves
##   dia_salida mismo_dia semana_ano_compra semana_ano_salida mes_ano_compra
## 1     jueves         1                15                16              4
## 2     jueves         1                15                16              4
## 3     jueves         1                15                16              4
## 4     jueves         1                15                16              4
## 5     jueves         1                15                16              4
## 6     jueves         1                15                16              4
##   mes_ano_salida   duracion antelacion_DISC
## 1              4 3.08 hours Poca_antelacion
## 2              4 2.83 hours Poca_antelacion
## 3              4 2.50 hours Poca_antelacion
## 4              4 3.17 hours Poca_antelacion
## 5              4 2.50 hours Poca_antelacion
## 6              4 2.75 hours Poca_antelacion

Cache temporal:

Vamos a guardar un cache de datos, de forma que cuando queramos seguir trabajando desde aqui no tengamos que volver a ejecutar todo

saveRDS(renfe,'cacherenfe1.rds')

Cargamos el cache temporal

renfe <- readRDS('cacherenfe1.rds')

Modelizacion.

Establecemos una semilla para que nos salgan los mismos resultados

set.seed(12345)

4.1. Al no tener una columna ID, la creamos haciéndola coincidir con el número de filas del dataframe.

*Training (35% y 35%) y test (30%)

renfe <- renfe %>% mutate(id = row_number())

#Dividimos el dataset en 70/30
temp <- renfe %>% sample_frac(.70)
#ahora creo dos train de 35% del dataset cada una
train1 <-temp %>% sample_frac(.50)
train2 <-anti_join(temp, train1, by = 'id')

#Creamos el 30% para el test, la funcion anti_join devuelve el restante de train
test  <- anti_join(renfe, temp, by = 'id')
#borramos temp
rm(temp)

4.2. Identificamos las variables

#Las independientes seran todas menos la id y la target (precio)
independientes <- setdiff(names(renfe),c('id','price'))
target <- 'price'

4.3. Creamos la formula para usar en el modelo

formula <- reformulate(independientes,target)

4.3.1 Realizamos una regresión lineal múltiple, al ser la target una variable contínua.

#Aumentamos la memoria de trabajo, para evitar problemas
memory.limit(size = 25000)

## [1] 25000

modelolm <- lm(formula, data = train1)
summary(modelolm)

## 
## Call:
## lm(formula = formula, data = train1)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -133.429   -4.922   -0.225    5.355  105.781 
## 
## Coefficients: (4 not defined because of singularities)
##                                         Estimate  Std. Error   t value
## (Intercept)                           209.523257    1.167222   179.506
## originMADRID                           -0.331822    0.022207   -14.942
## originPONFERRADA                      -41.410054    0.063666  -650.429
## originSEVILLA                         -32.799761    0.025524 -1285.070
## originVALENCIA                        -42.421717    0.029100 -1457.788
## destinationMADRID                             NA          NA        NA
## destinationPONFERRADA                 -41.593388    0.061565  -675.601
## destinationSEVILLA                    -31.316486    0.024964 -1254.451
## destinationVALENCIA                   -42.709626    0.030024 -1422.514
## train_typeAV City                       4.318154    0.051787    83.382
## train_typeAVE                           6.091218    0.033963   179.350
## train_typeAVE-LD                     -191.719892   10.193143   -18.809
## train_typeAVE-MD                     -186.468355   10.193280   -18.293
## train_typeAVE-TGV                       6.138720    0.064540    95.115
## train_typeINTERCITY                    -5.256488    0.042086  -124.899
## train_typeLD                         -196.152561   10.193189   -19.243
## train_typeLD-MD                      -201.237197   10.193338   -19.742
## train_typeMD                         -184.741122   10.195172   -18.120
## train_typeMD-AVE                     -197.702851   10.193986   -19.394
## train_typeMD-LD                      -199.121863   10.193113   -19.535
## train_typeR. EXPRES                    66.271133   10.126656     6.544
## train_typeREGIONAL                     86.248171   10.126416     8.517
## train_typeTRENHOTEL                     3.404868    0.104014    32.735
## train_classCama Turista              -172.853301   10.195317   -16.954
## train_classPreferente                -181.579742   10.192793   -17.815
## train_classPreferenteSÃ³lo plaza H   -185.254296   10.195454   -18.170
## train_classTurista                   -199.589312   10.192775   -19.581
## train_classTurista con enlace                 NA          NA        NA
## train_classTurista Plus              -190.801355   10.192814   -18.719
## train_classTurista PlusSÃ³lo plaza H -198.126240   10.640253   -18.620
## train_classTuristaSÃ³lo plaza H      -204.002064   10.193135   -20.014
## fareAdulto ida                                NA          NA        NA
## fareCOD.PROMOCIONAL                    66.520860   10.130352     6.566
## fareDoble Familiar-Flexible           -47.824560    3.145806   -15.203
## fareFlexible                          101.662834   10.126135    10.040
## fareGrupos Ida                         81.319893   11.092615     7.331
## fareIndividual-Flexible                       NA          NA        NA
## fareMesa                              224.599928   10.216129    21.985
## farePromo                              73.285923   10.126118     7.237
## farePromo +                            83.854758   10.126323     8.281
## festivo                                -0.400706    0.030337   -13.209
## dia_compra.L                            0.216269    0.017782    12.162
## dia_compra.Q                            0.935096    0.020498    45.619
## dia_compra.C                           -0.621138    0.019522   -31.818
## dia_compra^4                            0.430989    0.017942    24.021
## dia_compra^5                           -0.166516    0.017333    -9.607
## dia_compra^6                            0.005765    0.016976     0.340
## dia_salida.L                            1.494954    0.018240    81.962
## dia_salida.Q                            0.152099    0.020685     7.353
## dia_salida.C                            0.825125    0.019431    42.465
## dia_salida^4                            2.704256    0.018542   145.849
## dia_salida^5                            2.284446    0.017658   129.375
## dia_salida^6                            1.467472    0.016688    87.935
## mismo_dia                               7.912284    0.053840   146.959
## semana_ano_compra                       1.425589    0.021537    66.192
## semana_ano_salida                      -1.279658    0.021305   -60.063
## mes_ano_compra                          0.244041    0.025196     9.686
## mes_ano_salida                         -1.310776    0.022500   -58.257
## duracion                               -3.682461    0.015736  -234.008
## antelacion_DISC2_semanas                0.450851    0.031893    14.136
## antelacion_DISC3_semanas                1.145379    0.047773    23.976
## antelacion_DISC4_semanas                2.251410    0.066478    33.867
## antelacion_DISC5_semanas                3.304881    0.086190    38.344
## antelacion_DISCDos_meses                3.940518    0.131969    29.860
## antelacion_DISCMes_y_medio              4.033425    0.106235    37.967
## antelacion_DISCPoca_antelacion          1.407531    0.032161    43.765
##                                                  Pr(>|t|)    
## (Intercept)                          < 0.0000000000000002 ***
## originMADRID                         < 0.0000000000000002 ***
## originPONFERRADA                     < 0.0000000000000002 ***
## originSEVILLA                        < 0.0000000000000002 ***
## originVALENCIA                       < 0.0000000000000002 ***
## destinationMADRID                                      NA    
## destinationPONFERRADA                < 0.0000000000000002 ***
## destinationSEVILLA                   < 0.0000000000000002 ***
## destinationVALENCIA                  < 0.0000000000000002 ***
## train_typeAV City                    < 0.0000000000000002 ***
## train_typeAVE                        < 0.0000000000000002 ***
## train_typeAVE-LD                     < 0.0000000000000002 ***
## train_typeAVE-MD                     < 0.0000000000000002 ***
## train_typeAVE-TGV                    < 0.0000000000000002 ***
## train_typeINTERCITY                  < 0.0000000000000002 ***
## train_typeLD                         < 0.0000000000000002 ***
## train_typeLD-MD                      < 0.0000000000000002 ***
## train_typeMD                         < 0.0000000000000002 ***
## train_typeMD-AVE                     < 0.0000000000000002 ***
## train_typeMD-LD                      < 0.0000000000000002 ***
## train_typeR. EXPRES                     0.000000000059815 ***
## train_typeREGIONAL                   < 0.0000000000000002 ***
## train_typeTRENHOTEL                  < 0.0000000000000002 ***
## train_classCama Turista              < 0.0000000000000002 ***
## train_classPreferente                < 0.0000000000000002 ***
## train_classPreferenteSÃ³lo plaza H   < 0.0000000000000002 ***
## train_classTurista                   < 0.0000000000000002 ***
## train_classTurista con enlace                          NA    
## train_classTurista Plus              < 0.0000000000000002 ***
## train_classTurista PlusSÃ³lo plaza H < 0.0000000000000002 ***
## train_classTuristaSÃ³lo plaza H      < 0.0000000000000002 ***
## fareAdulto ida                                         NA    
## fareCOD.PROMOCIONAL                     0.000000000051525 ***
## fareDoble Familiar-Flexible          < 0.0000000000000002 ***
## fareFlexible                         < 0.0000000000000002 ***
## fareGrupos Ida                          0.000000000000229 ***
## fareIndividual-Flexible                                NA    
## fareMesa                             < 0.0000000000000002 ***
## farePromo                               0.000000000000458 ***
## farePromo +                          < 0.0000000000000002 ***
## festivo                              < 0.0000000000000002 ***
## dia_compra.L                         < 0.0000000000000002 ***
## dia_compra.Q                         < 0.0000000000000002 ***
## dia_compra.C                         < 0.0000000000000002 ***
## dia_compra^4                         < 0.0000000000000002 ***
## dia_compra^5                         < 0.0000000000000002 ***
## dia_compra^6                                        0.734    
## dia_salida.L                         < 0.0000000000000002 ***
## dia_salida.Q                            0.000000000000194 ***
## dia_salida.C                         < 0.0000000000000002 ***
## dia_salida^4                         < 0.0000000000000002 ***
## dia_salida^5                         < 0.0000000000000002 ***
## dia_salida^6                         < 0.0000000000000002 ***
## mismo_dia                            < 0.0000000000000002 ***
## semana_ano_compra                    < 0.0000000000000002 ***
## semana_ano_salida                    < 0.0000000000000002 ***
## mes_ano_compra                       < 0.0000000000000002 ***
## mes_ano_salida                       < 0.0000000000000002 ***
## duracion                             < 0.0000000000000002 ***
## antelacion_DISC2_semanas             < 0.0000000000000002 ***
## antelacion_DISC3_semanas             < 0.0000000000000002 ***
## antelacion_DISC4_semanas             < 0.0000000000000002 ***
## antelacion_DISC5_semanas             < 0.0000000000000002 ***
## antelacion_DISCDos_meses             < 0.0000000000000002 ***
## antelacion_DISCMes_y_medio           < 0.0000000000000002 ***
## antelacion_DISCPoca_antelacion       < 0.0000000000000002 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 10.13 on 2484320 degrees of freedom
## Multiple R-squared:  0.8448, Adjusted R-squared:  0.8448 
## F-statistic: 2.217e+05 on 61 and 2484320 DF,  p-value: < 0.00000000000000022

Resultado lm: Los datos que nos da el modelo es que con todas las variables introducidas como predictores, tiene un R2 alta (0.8448), es capaz de explicar el 84,48% de la variabilidad observada en el precio. El p-value es inferior a 0,05, lo que me asegura que confirma que el modelo es bueno.

Métricas: RMSE

rmse <- sqrt(mean(modelolm$residuals^2))
rmse

## [1] 10.12592

El valor obtenido es 10.12592, lo que me indica que la predicción de precios varía en 10€, lo que significa que el modelo reduce en 2,5 veces la variabilidad del error promedio al calcular el precio.

Cache modelo: Vamos a guardar un cache de datos, de forma que cuando queramos seguir trabajando desde aqui no tengamos que volver a ejecutar todo

saveRDS(modelolm,'modelo_renfe.rds')
saveRDS(test, 'testrenfe')

Evaluación

Evaluamos las predicciones del modelo

predicciones <- round(predict(modelolm, newdata = test, type='response'),2)

## Warning in predict.lm(modelolm, newdata = test, type = "response"): prediction
## from a rank-deficient fit may be misleading

head(predicciones)

##      1      2      3      4      5      6 
## 101.28  84.19 112.86 111.68 110.53 111.09

Comparamos el precio real frente a la prediccion:

Lo haremos mediante una gráfica de líneas, representando una porción de los precios reales y los elaborados con el ML, donde crearemos, para el eje X, una secuencia desde 1 hasta el número de filas del dataset, que me va a representar la evolución en el tiempo. El motivo por el cual no ubico las fechas en este eje, es que en un mismo día se compran una cantidad elevada de billetes, lo que hace ilegible la visualización.

Cargamos el cache modelo

modelolm <- readRDS('modelo_renfe.rds')
test <- readRDS('testrenfe.rds')

Grafica

#Creamos una secuencia de numeros para abarcar el eje x desde 1 hasta el número de filas
 
x<- seq(1, (nrow(test)))

#creamos nueva variable que contiene los datos resumidos de la tabla
compara <- as.data.table(cbind(x, test$price, predicciones))

colnames(compara) <- c("x","precio", "prediccion")

compara$precio <- as.numeric(compara$precio)
compara$prediccion <- as.numeric(compara$prediccion)

df<- sample_n(compara, size= 100, replace = F)

#Gráfico de comparacion de precios
ggplotly(
ggplot(df, aes(x=x)) + 
  geom_line(aes(y=precio), colour="red") +  
  geom_line(aes(y=prediccion), colour="#33D5FF") +
  labs(x = "", y = "Euros", colour = "Legend") +
    scale_color_manual(values = colours)+
  theme_bw() +
  theme(axis.title.x = element_blank(),
        axis.text.x = element_blank()),
  tooltip = 'text'
)

La gráfica nos indica que el modelo está muy ajustado a los precios reales. La predicción del precio es un tema complejo y requiere un estudio más profundo para encontrar un modelo eficáz. Durante la elaboración de este proyecto, también recurri a la implementación de la herramienta AutoML de H2o, para buscar modelos de forma automática, aprovechándome de mayores recursos en memoria y procesado, pero tras un largo proceso, los resultados obtenidos no eran de mayor relevancia y el tiempo/recursos utilizados para esto eran elevados, por lo tanto decidí quedarme con el modelo inicial de Regresión Lineal Múltiple.

Implantación

La implantación de este modelo podría llevarse a cabo haciendo uso de herramientas complementarias que dieran forma al proyecto para dar una salida comercial. Es necesario disponer de un Servidor Cloud (AWS, AZURE, GoogleCloud…) para el alojamiento de datos y, aprovechando su tecnología, desplegar el modelo ML para el procesado en tiempo real de los mismos, mediante una integración con la propia web del cliente.

Informe Renfe

Jorge Arias

13/7/2020

Proyecto final DS4B

Contexto

Metodología aplicada

Conclusiones tras el análisis:

Detalle del trabajo realizado