Destapando Promedios V2

Unos días atrás escribí el articulo Destapando Promedios que básicamente lo que hacía era abrir un valor promedio en factores utilizando arboles, por favor leer el articulo antes de seguir. En ese análisis de ejemplo yo cree el dataset y por ende sabia exactamente donde estaba el cambio, el cual estaba en la columna causa, solo en el caso colectividad, pero dado que el árbol no se abría en esta dimension, quedaba solo un «indicio sobre donde buscar». Como este mundo del Data Science es una mezcla entre obsesión y creatividad, estuve dándole vueltas y vueltas al como hacer que todos los factores aparecieran hasta que di con el clavo en usar una regresión lineal. La metodología es la misma, lo que cambia es que el beta corresponde a la nota promedio y el promedio de cada variable predictora la tasa. Lo primero que hacemos es cargar los dataset el cual se ve del siguiente modo:
library(tidyverse)
library(broom)
library(caret)

data1 = readRDS('dataset1.rds')
data2 = readRDS('dataset2.rds')

> head(data1)
  id        causa genero region nota
1  1       equipo hombre  norte    6
2  2        saldo  mujer  norte    8
3  3  facturacion hombre  norte    2
4  4        saldo  mujer centro    6
5  5 conectividad  mujer centro    9
6  6 conectividad hombre centro    4
Luego dumificamos las variables de modo que las categorías queden con redundancia:
encoder <- dummyVars( ~ nota + causa + genero + region, data1)
dataset1 <- predict(encoder, data1)
dataset2 <- predict(encoder, data2)
Y corremos un modelo para cada periodo y usamos tidy de broom para formatear los parámetros de la regresión como data.frame: (nótese que tidy elimino los parámetros que no se pudieron estimar por dependencia lineal, en el fondo es por que son un contraste y el estimate es 0, eso lo necesitaremos más adelante).
fit1 = lm(nota ~ .,data.frame(dataset1))
fit2 = lm(nota ~ .,data.frame(dataset2))

params1 = tidy(fit1) %>% select(term,estimate)
params2 = tidy(fit2) %>% select(term,estimate)
params1
> params1
  term              estimate
1 (Intercept)         7.87  
2 causaconectividad  -1.98  
3 causaequipo        -0.844 
4 causafacturacion   -2.88  
5 generohombre       -1.02  
6 regioncentro       -0.925 
7 regionnorte         0.0486
Ahora calculamos la porción o valor promedio de cada columna del dataset dumificado:
porciones1 = dataset1 %>% data.frame() %>% summarise_all(mean) %>% gather(term,porcion)
porciones2 = dataset2 %>% data.frame() %>% summarise_all(mean) %>% gather(term,porcion)
porciones1
                term porcion
1               nota   5.577
2  causaconectividad   0.293
3        causaequipo   0.216
4   causafacturacion   0.101
5         causasaldo   0.390
6       generohombre   0.704
7        generomujer   0.296
8       regioncentro   0.576
9        regionnorte   0.213
10         regionsur   0.211
Y cruzamos los dataset anteriores y rellenamos con 0 los betas de contraste y en el intercepto la porción sera 1 por que afecta a todos los elementos:
dataset = params1 %>% 
  left_join(params2, by = "term",suffix = c("_1","_2")) %>% 
  full_join(porciones1,by = "term") %>% 
  left_join(porciones2,by = "term",suffix = c("_1","_2")) %>% 
  filter(term!="nota") %>% 
  mutate_at(vars(starts_with("e")),~replace_na(.,0)) %>% 
  mutate_at(vars(starts_with("p")),~replace_na(.,1))
> dataset
   term              estimate_1 estimate_2 porcion_1 porcion_2
 1 (Intercept)           7.87        7.80      1        1     
 2 causaconectividad    -1.98       -2.87      0.293    0.304 
 3 causaequipo          -0.844      -0.966     0.216    0.212 
 4 causafacturacion     -2.88       -2.98      0.101    0.0985
 5 generohombre         -1.02       -1.00      0.704    0.290 
 6 regioncentro         -0.925      -0.864     0.576    0.586 
 7 regionnorte           0.0486      0.174     0.213    0.201 
 8 causasaldo            0           0         0.39     0.386 
 9 generomujer           0           0         0.296    0.71  
10 regionsur             0           0         0.211    0.213
Nótese que el promedio de la columna estimate por la columna porción, dan el promedio, por ende podemos decir que tenemos el promedio descompuesto en factores:
sum(dataset$estimate_1 * dataset$porcion_1)
[1] 5.577
> mean(data1$nota)
[1] 5.577
> sum(dataset$estimate_2 * dataset$porcion_2)
[1] 5.6705
> mean(data2$nota)
[1] 5.6705
Lo anterior es debido a que la suma de los cuadrados residuales en una regresión lineal suman 0. Ahora usamos el mismo truco del articulo anterior en que calculamos el cambio en el beta y el cambio en la muestra y con ello determinamos los aportes:
dataset = dataset %>% 
  mutate(
    delta_freq = porcion_2 - porcion_1,
    delta_nota = estimate_2 - estimate_1
  )
dataset = dataset %>% 
  mutate(aporte_dfreq = estimate_1 * delta_freq,
         aporte_dnota =  porcion_2 * delta_nota
  )
Lo interesante es que la suma de los aportes es el cambio en la nota:
sum(dataset$aporte_dnota) + sum(dataset$aporte_dfreq)
[1] 0.0935
> mean(data2$nota) - mean(data1$nota)
[1] 0.0935
Por ende podemos decir que tenemos el promedio descompuesto y al igual que en el resultado anterior, si vemos cuando cambio el promedio por la nota y por la muestra, obtenemos el siguiente resultado:
sum(dataset$aporte_dfreq)
[1] 0.4012351
> sum(dataset$aporte_dnota)
[1] -0.3077351
Resultado simular al articulo anterior. Por otro lado, volviendo a la tabla de aportes, podemos ver que una disminución de 41% en la cantidad de hombres encuestados causo un aumento de 0.42 en la nota, lo que anula la disminución de 0.27 puntos causada por la peor evaluación de los casos de conectividad. Por ultimo este modelo parece superior al de los arboles, pero para realizar regresiones lineales, se necesitan cierto supuestos que no se necesitan para los arboles, por ende, hay que ser un poco mas cuidadoso. Espero que les sirva y estaré viendo los comentarios a ver si hay algo que quieran que aborde. Saludos!
Print Friendly, PDF & Email