Requerimiento de negocio
Metodología
1. Importación y Muestreo
1.1 Preparación del Entorno
1.2 Importación del conjunto de datos
2. Calidad de datos
2.1 Exploración general
2.2 Estadisticos básicos
2.3 Análisis de nulos
2.4 Análisis de ceros
2.5 Análisis de atípicos
2.6 Análisis longitudinal
2.7 Ejecutar acciones concluidas de la fase de calidad de datos
3. Transformación
3.1 Creación de la variable Target
3.2 Variables predictoras
3.3 Preselección de variables
3.4 Creación de variables Sintéticas
3.5 Limpieza de variables
3.6 Discretización
3.7 Validaciónes
4. Modelización
4.1 Crear funciones de apoyo
4.2 Partición del conjunto de datos (Train y Test)
4.3 Modelización con Regresión Logistica
4.4 Modelización con Árboles de decisión
4.5 Modelización con Random Forest
4.6 Evaluamos los 3 Modelos
4.7 Calculamos los scores
5. Evaluación y Análisis de Negocio
6. Conclusiones y consideraciones generales

Requerimiento de negocio

La empresa tiene una tasa muy alta de abandono de clientes, por lo que quiere invertir 2000 dolares en campañas digitales para prevenir el abandono de los clientes. Esta iniciativa es liderada por el área de Marketing y han comunicado que estas campañas son costosas y cada acción estaria costando 2$, por lo cual el presupuesto estaria alcanzando para destinar la campaña a 1000 clientes.

El requerimiento es desarrollar un modelo predictivo de abandono de clientes, que permita a la empresa dirigir esa campaña a los 1000 clientes con mayor probabilidad de abandono.

Metodología

La metodología utilizada en este proyecto es un hibrido entre las dos grandes metodologias para la modelización avanzada de datos: CRISP-DM y SEMMA. Esta metodologia híbrida propuesta fue aprendida en el curso “Data Science for Business” de Isaac Gonzales.

A continuación, abordaremos el proyecto por cada etapa que indica la metodologia:

1. Importación y Muestreo

1.1 Preparación del Entorno

Importamos los paquetes y librerias que necesitaremos para el Proyecto

#lista de paquetes que vamos a usar
paquetes <- c('data.table',#para leer y escribir datos de forma rapida
              'dplyr',#para manipulación de datos
              'tidyr',#para manipulación de datos
              'ggplot2',#para gráficos
              'randomForest',#para crear los modelos
              'ROCR',#para evaluar modelos
              'purrr',#para usar la función map que aplica la misma funciona a varios componentes de un dataframe
              'smbinning',#para calcular la para importancia de las variables
              'rpart',#para crear arboles de decisión
              'rpart.plot'#para el gráfico del árbol
)
#Crea un vector lógico con si están instalados o no
instalados <- paquetes %in% installed.packages()
#Si hay al menos uno no instalado los instala
if(sum(instalados == FALSE) > 0) {
  install.packages(paquetes[!instalados])
}
lapply(paquetes,require,character.only = TRUE)

1.2 Importación del conjunto de datos

El conjunto de datos utilizado es un historico de Clientes de una empresa de Telecomunicaciones, para los cuales ya conocemos SI han abandonado la empresa o NO han abandonado la empresa. Primeros importamos el conjunto de datos el cual lo tenemos en archivo CSV.

df <- fread('Telco-Customer-Churn.csv')

Para trabajar de una mejor manera, renombrare las variables al Español, ya que originalmente son extraidas del Sistema en Ingles.

df <- rename(df,ClienteID=customerID, Genero=gender, Jubilado=SeniorCitizen,Pareja=Partner,Dependientes=Dependents,Tenencia=tenure,ServicioTelefono=PhoneService,MultiplesLines=MultipleLines,ServicioInternet=InternetService,SeguridadOnline=OnlineSecurity,RespaldoOnline=OnlineBackup,ProteccionDispositivo=DeviceProtection,SoporteTecnologia=TechSupport,Contrato=Contract,FacturacionElectronica=PaperlessBilling,MetodoPago=PaymentMethod,CargoMensual=MonthlyCharges,CargoTotal=TotalCharges,Abandono=Churn)

2. Calidad de datos

2.1 Exploración general

El conjunto de datos posee 7,043 Clientes y 21 variables
Notamos que hay variables de tipo “INT” que solo tienen 2 valores, por lo que deberian ser categóricas.
Notamos variables de tipo “CHR” que puede ser transformadas a tipo “FACT” o factor

glimpse(df)

## Rows: 7,043
## Columns: 21
## $ ClienteID              <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795…
## $ Genero                 <chr> "Female", "Male", "Male", "Male", "Female", "Fe…
## $ Jubilado               <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ Pareja                 <chr> "Yes", "No", "No", "No", "No", "No", "No", "No"…
## $ Dependientes           <chr> "No", "No", "No", "No", "No", "No", "Yes", "No"…
## $ Tenencia               <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58,…
## $ ServicioTelefono       <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", …
## $ MultiplesLines         <chr> "No phone service", "No", "No", "No phone servi…
## $ ServicioInternet       <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fib…
## $ SeguridadOnline        <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Y…
## $ RespaldoOnline         <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "N…
## $ ProteccionDispositivo  <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "N…
## $ SoporteTecnologia      <chr> "No", "No", "No", "Yes", "No", "No", "No", "No"…
## $ StreamingTV            <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No…
## $ StreamingMovies        <chr> "No", "No", "No", "No", "No", "Yes", "No", "No"…
## $ Contrato               <chr> "Month-to-month", "One year", "Month-to-month",…
## $ FacturacionElectronica <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", …
## $ MetodoPago             <chr> "Electronic check", "Mailed check", "Mailed che…
## $ CargoMensual           <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10…
## $ CargoTotal             <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50…
## $ Abandono               <chr> "No", "No", "Yes", "No", "Yes", "Yes", "No", "N…

Finalmente reservo en una variable, las variables que identifique que deberian ser pasadas al tipo “FACT” o factores.

a_factores <- c('Genero', 'Jubilado', 'Pareja', 'Dependientes', 'ServicioTelefono', 'MultiplesLines', 'ServicioInternet', 'SeguridadOnline', 'RespaldoOnline', 'ProteccionDispositivo','SoporteTecnologia','StreamingTV','StreamingMovies','Contrato','FacturacionElectronica','MetodoPago','Abandono')

2.2 Estadisticos básicos

Analizaremos los estadisticos básicos para las variables númericas. En este caso, el dataset solo cuenta con 3 variables númericas: “Tenencia”, “CargoMensual” y “CargoTotal”
Ubicamos nuestras variables númericas antes mencionadas y analizamos sus valores Minimos, Maximos, Media, Mediana, Primer Cuartil y Tercer Cuartil.
Analizamos desde el punto de vista de negocio que todo este correcto con estas medidas y no vemos datos que indiquen un mayor análisis.
La variable “Jubilado” esta como entera (INT) pero se transformará a factor (FACT) posteriormente.

lapply(df,summary)

## $ClienteID
##    Length     Class      Mode 
##      7043 character character 
## 
## $Genero
##    Length     Class      Mode 
##      7043 character character 
## 
## $Jubilado
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.0000  0.0000  0.0000  0.1621  0.0000  1.0000 
## 
## $Pareja
##    Length     Class      Mode 
##      7043 character character 
## 
## $Dependientes
##    Length     Class      Mode 
##      7043 character character 
## 
## $Tenencia
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00    9.00   29.00   32.37   55.00   72.00 
## 
## $ServicioTelefono
##    Length     Class      Mode 
##      7043 character character 
## 
## $MultiplesLines
##    Length     Class      Mode 
##      7043 character character 
## 
## $ServicioInternet
##    Length     Class      Mode 
##      7043 character character 
## 
## $SeguridadOnline
##    Length     Class      Mode 
##      7043 character character 
## 
## $RespaldoOnline
##    Length     Class      Mode 
##      7043 character character 
## 
## $ProteccionDispositivo
##    Length     Class      Mode 
##      7043 character character 
## 
## $SoporteTecnologia
##    Length     Class      Mode 
##      7043 character character 
## 
## $StreamingTV
##    Length     Class      Mode 
##      7043 character character 
## 
## $StreamingMovies
##    Length     Class      Mode 
##      7043 character character 
## 
## $Contrato
##    Length     Class      Mode 
##      7043 character character 
## 
## $FacturacionElectronica
##    Length     Class      Mode 
##      7043 character character 
## 
## $MetodoPago
##    Length     Class      Mode 
##      7043 character character 
## 
## $CargoMensual
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   18.25   35.50   70.35   64.76   89.85  118.75 
## 
## $CargoTotal
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##    18.8   401.4  1397.5  2283.3  3794.7  8684.8      11 
## 
## $Abandono
##    Length     Class      Mode 
##      7043 character character

2.3 Análisis de nulos

En esta etapa analizaremos todas la variables en busqueda de identificar alguna con un alto porcentaje de valores Nulos, para posteriormente decidir si eliminar esos regitros, imputar con la media, o analizar que acción tomar.

Validamos que no tenemos problemas en esta fase, solo tenemos una variable “CargoTotal” la cual posee 11 valores nulos. Lo mas probable es que elimine estos 11 registros ya que son pocos con respecto al total de clientes, asi me quedaría con un conjunto de datos con el 100% de información completa.

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

##                        colSums.is.na.df..
## ClienteID                               0
## Genero                                  0
## Jubilado                                0
## Pareja                                  0
## Dependientes                            0
## Tenencia                                0
## ServicioTelefono                        0
## MultiplesLines                          0
## ServicioInternet                        0
## SeguridadOnline                         0
## RespaldoOnline                          0
## ProteccionDispositivo                   0
## SoporteTecnologia                       0
## StreamingTV                             0
## StreamingMovies                         0
## Contrato                                0
## FacturacionElectronica                  0
## MetodoPago                              0
## CargoMensual                            0
## CargoTotal                             11
## Abandono                                0

2.4 Análisis de ceros

Al igual que los valores nulos, en esta etapa buscamos identificar ciertas variables que puedan tener una cantidad atipica de ceros, siempre relacionando todo a una interpretación coherente de negocio.

Validamos que la variable “Jubilado” tiene un 83% de ceros, esto es porque según negocio la mayoria de clientes de la empresa NO esta Jubilada, por eso poseen un valor 0 en este campo.
Validamos que la variable Tenencia tiene 11 valores en 0, esto se explica porque hay 11 clientes que no tienen Tenencia, esto es un poco raro, podriamos analizar quitarlos del conjunto de datos mas adelante.

contar_ceros <- function(variable) {
    temp <- transmute(df,if_else(variable==0,1,0))
    sum(temp)
}

num_ceros <- sapply(df,contar_ceros)
num_ceros <- data.frame(VARIABLE=names(num_ceros),CEROS = as.numeric(num_ceros),stringsAsFactors = F) #el as.numeric es para sacar solo el valor de num_ceros, sin el nombre
num_ceros <- num_ceros %>%
  arrange(desc(CEROS)) %>%
  mutate(PORCENTAJE = CEROS / nrow(df) * 100)
num_ceros

##                  VARIABLE CEROS PORCENTAJE
## 1                Jubilado  5901 83.7853188
## 2                Tenencia    11  0.1561834
## 3               ClienteID     0  0.0000000
## 4                  Genero     0  0.0000000
## 5                  Pareja     0  0.0000000
## 6            Dependientes     0  0.0000000
## 7        ServicioTelefono     0  0.0000000
## 8          MultiplesLines     0  0.0000000
## 9        ServicioInternet     0  0.0000000
## 10        SeguridadOnline     0  0.0000000
## 11         RespaldoOnline     0  0.0000000
## 12  ProteccionDispositivo     0  0.0000000
## 13      SoporteTecnologia     0  0.0000000
## 14            StreamingTV     0  0.0000000
## 15        StreamingMovies     0  0.0000000
## 16               Contrato     0  0.0000000
## 17 FacturacionElectronica     0  0.0000000
## 18             MetodoPago     0  0.0000000
## 19           CargoMensual     0  0.0000000
## 20               Abandono     0  0.0000000
## 21             CargoTotal    NA         NA

2.5 Análisis de atípicos

En esta etapa analizaremos valores atípicos en las variables númericas de nuestro conjunto de datos. Recordar que la metodologia recomienda el uso de la DISCRETIZACIÓN, esto ayuda a mitigar cualquier variación que puedan ocasionar los datos atipicos en la etapa de modelización.

Primero, analizamos las variables de tipo númerico continuas (Double). Nos quedaremos con los primeros 20 valores de esta variable ordenados de forma descendente para validar el degradado e identificar cualquier dato atipico que se este “disparando”.

out <- function(variable){
  t(t(head(sort(variable,decreasing = T),20))) #la doble traspuesta es un truco para que se visualice la salida, si no lo que crearía es una colección de dataframes que no se ven bien
}
lapply(df,function(x){
  if(is.double(x)) out(x)
})

## $ClienteID
## NULL
## 
## $Genero
## NULL
## 
## $Jubilado
## NULL
## 
## $Pareja
## NULL
## 
## $Dependientes
## NULL
## 
## $Tenencia
## NULL
## 
## $ServicioTelefono
## NULL
## 
## $MultiplesLines
## NULL
## 
## $ServicioInternet
## NULL
## 
## $SeguridadOnline
## NULL
## 
## $RespaldoOnline
## NULL
## 
## $ProteccionDispositivo
## NULL
## 
## $SoporteTecnologia
## NULL
## 
## $StreamingTV
## NULL
## 
## $StreamingMovies
## NULL
## 
## $Contrato
## NULL
## 
## $FacturacionElectronica
## NULL
## 
## $MetodoPago
## NULL
## 
## $CargoMensual
##         [,1]
##  [1,] 118.75
##  [2,] 118.65
##  [3,] 118.60
##  [4,] 118.60
##  [5,] 118.35
##  [6,] 118.20
##  [7,] 117.80
##  [8,] 117.60
##  [9,] 117.50
## [10,] 117.45
## [11,] 117.35
## [12,] 117.20
## [13,] 117.15
## [14,] 116.95
## [15,] 116.85
## [16,] 116.80
## [17,] 116.75
## [18,] 116.60
## [19,] 116.60
## [20,] 116.55
## 
## $CargoTotal
##          [,1]
##  [1,] 8684.80
##  [2,] 8672.45
##  [3,] 8670.10
##  [4,] 8594.40
##  [5,] 8564.75
##  [6,] 8547.15
##  [7,] 8543.25
##  [8,] 8529.50
##  [9,] 8496.70
## [10,] 8477.70
## [11,] 8477.60
## [12,] 8476.50
## [13,] 8468.20
## [14,] 8456.75
## [15,] 8443.70
## [16,] 8436.25
## [17,] 8425.30
## [18,] 8425.15
## [19,] 8424.90
## [20,] 8405.00
## 
## $Abandono
## NULL

Segundo, analizamos las variables de tipo númerico enteras (INT). Para este tipo de variables hacemos el conteo por cada valor que tiene la variable, buscando identificar algun valor que tenga una frecuencia muy baja en el conjunto de datos, esto podria significar un dato atipicos siempre y cuando no tenga sustento de negocio.

out <- function(variable){
  t(t(table(variable))) #la doble traspuesta es un truco para que se visualice la salida, si no lo que crearìa es una colección de dataframes que no se ven bien
}
lapply(df,function(x){
  if(is.integer(x)) out(x)
})

## $ClienteID
## NULL
## 
## $Genero
## NULL
## 
## $Jubilado
##         
## variable [,1]
##        0 5901
##        1 1142
## 
## $Pareja
## NULL
## 
## $Dependientes
## NULL
## 
## $Tenencia
##         
## variable [,1]
##       0    11
##       1   613
##       2   238
##       3   200
##       4   176
##       5   133
##       6   110
##       7   131
##       8   123
##       9   119
##       10  116
##       11   99
##       12  117
##       13  109
##       14   76
##       15   99
##       16   80
##       17   87
##       18   97
##       19   73
##       20   71
##       21   63
##       22   90
##       23   85
##       24   94
##       25   79
##       26   79
##       27   72
##       28   57
##       29   72
##       30   72
##       31   65
##       32   69
##       33   64
##       34   65
##       35   88
##       36   50
##       37   65
##       38   59
##       39   56
##       40   64
##       41   70
##       42   65
##       43   65
##       44   51
##       45   61
##       46   74
##       47   68
##       48   64
##       49   66
##       50   68
##       51   68
##       52   80
##       53   70
##       54   68
##       55   64
##       56   80
##       57   65
##       58   67
##       59   60
##       60   76
##       61   76
##       62   70
##       63   72
##       64   80
##       65   76
##       66   89
##       67   98
##       68  100
##       69   95
##       70  119
##       71  170
##       72  362
## 
## $ServicioTelefono
## NULL
## 
## $MultiplesLines
## NULL
## 
## $ServicioInternet
## NULL
## 
## $SeguridadOnline
## NULL
## 
## $RespaldoOnline
## NULL
## 
## $ProteccionDispositivo
## NULL
## 
## $SoporteTecnologia
## NULL
## 
## $StreamingTV
## NULL
## 
## $StreamingMovies
## NULL
## 
## $Contrato
## NULL
## 
## $FacturacionElectronica
## NULL
## 
## $MetodoPago
## NULL
## 
## $CargoMensual
## NULL
## 
## $CargoTotal
## NULL
## 
## $Abandono
## NULL

Conclusiones:

Las variables continuas “CargoMensual” y “CargoTotal”, tienen un degradado bastante suave, por lo que no vemos valores que se hayan “disparado”.
Los valores de la variable entera “Tenencia” tienen una frecuencia mas que consistente, no identificamos valores que se repitan muy pocas veces para analizar mas a profundida, unicamente el valor “0” que ya habiamos identificado anteriormente que analizaremos eliminarlos del conjunto de datos porque es medio raro que 11 clientes tengan de Tenencia , un valor 0.

2.6 Análisis longitudinal

longi <- df %>% 
  summarise_all(mean) %>% #calcular la media de cada variable
  t() %>% #trasponerlo para tenerlo en una sola columna y leerlo mejor
  as.data.frame() #reconvertirlo a dataframe porque t() lo pasa a matriz
data.frame(variable = rownames(longi), media = longi$V1) %>% #crear un nuevo dataframe para poder ordenar por el nombre
  arrange(desc(variable)) #ordenar por el nombre para tener la visión longitudinal

##                  variable      media
## 1                Tenencia 32.3711487
## 2             StreamingTV         NA
## 3         StreamingMovies         NA
## 4       SoporteTecnologia         NA
## 5        ServicioTelefono         NA
## 6        ServicioInternet         NA
## 7         SeguridadOnline         NA
## 8          RespaldoOnline         NA
## 9   ProteccionDispositivo         NA
## 10                 Pareja         NA
## 11         MultiplesLines         NA
## 12             MetodoPago         NA
## 13               Jubilado  0.1621468
## 14                 Genero         NA
## 15 FacturacionElectronica         NA
## 16           Dependientes         NA
## 17               Contrato         NA
## 18              ClienteID         NA
## 19             CargoTotal         NA
## 20           CargoMensual 64.7616925
## 21               Abandono         NA

Conclusiones:

La unica meida que llama la atención es la media de la variable “Jubilacion” ya que es 0.16, sin embargo esto es porque es una variable INT pero en verdad es categórica, porque solo nos indica si el cliente es jubilado (con el valor 1) o no es jubilado (valor 0). Ya tenemos anotado esto para la fase de Transformación

2.7 Ejecutar acciones concluidas de la fase de calidad de datos

Vamos a seguir lo siguiente:

Eliminar los 11 registros que tienen valor NULL en el campo CargoTotal
Transformar a factor las variables de ‘a_factores’
Los atípicos no nos preocupan en este caso porque vamos a discretizar

df <- df[!is.na(df$CargoTotal),] #quitar filas nulas de cargototal

df <- df %>%
 mutate_at(a_factores,funs(factor)) #convertir a factor

3. Transformación

3.1 Creación de la variable Target

Creación de la variable “TARGET_ABANDONO”, y posteriormente eliminacion de la variable anterior “Abandono”

df <- df %>%

 mutate(TARGET_ABANDONO = ifelse(Abandono == "Yes",1,0)) %>% #crear columna target con 1 y 0
  select(-Abandono) #eliminar la columna "Abandono" ya que tenemos la nueva "TARGET_ABANDONO"

3.2 Variables predictoras

Preselección de variables independientes:

Creamos una lista larga con todas las variables independientes, excluyendo el Identificador de cliente “ClienteID” y la variable target “TARGET_ABANDONO”
En este proyecto ninguna de las variables tiene historia. En caso tuviera, nos quedariamos con solo uno de los meses.

ind_larga<-names(df) #lista con todas las variables
no_usar <- c('ClienteID','TARGET_ABANDONO') #identificamos las que no queremos usar como VI
sin_historia <- c('Genero','Jubilado','Pareja','Dependientes','Tenencia','ServicioTelefono','MultiplesLines','ServicioInternet','SeguridadOnline','RespaldoOnline','ProteccionDispositivo','SoporteTecnologia','StreamingTV','StreamingMovies','Contrato','FacturacionElectronica','MetodoPago','CargoMensual','CargoTotal') #identificamos las que no tienen historia, en este conjunto de datos ninguna de las variables tiene historia.
ind_larga<-setdiff(ind_larga,no_usar) #quitamos las que no usaremos

3.3 Preselección de variables

Para este proyecto obtendre una nueva metrica de evaluación de poder predictivo de variables mezclando los dos metodos de preseleccion de variablaes mas poderosos (Random Forest e Information Value)

Obtendremos primero el coeficiente de Gini de cada variable a traves del algortimo Random Forest. Para ello, se crea una tabla que ordene las variables con mayor valor predictivo al comienzo.

pre_rf <- randomForest(formula = reformulate(ind_larga,'TARGET_ABANDONO'), data= df,mtry=2,ntree=50, importance = T)
imp_rf <- importance(pre_rf)[,2] #como importance devuelve una matriz con varias métricas tenemos que extraer asi el decrecimiento en Gini que es el que mas nos interesa
imp_rf <- data.frame(VARIABLE = names(imp_rf), IMP_RF = imp_rf) #lo transformamos a dataframe
imp_rf <- imp_rf %>% arrange(desc(IMP_RF)) %>% mutate(RANKING_RF = 1:nrow(imp_rf)) #creamos el ranking
imp_rf

##                                      VARIABLE     IMP_RF RANKING_RF
## Tenencia                             Tenencia 106.264390          1
## CargoTotal                         CargoTotal 103.096101          2
## CargoMensual                     CargoMensual  83.236600          3
## Contrato                             Contrato  64.450984          4
## MetodoPago                         MetodoPago  47.690192          5
## SeguridadOnline               SeguridadOnline  46.459247          6
## ServicioInternet             ServicioInternet  39.650946          7
## SoporteTecnologia           SoporteTecnologia  38.953550          8
## RespaldoOnline                 RespaldoOnline  27.049964          9
## ProteccionDispositivo   ProteccionDispositivo  19.940151         10
## StreamingTV                       StreamingTV  19.548633         11
## StreamingMovies               StreamingMovies  17.690280         12
## FacturacionElectronica FacturacionElectronica  15.455103         13
## MultiplesLines                 MultiplesLines  14.051292         14
## Jubilado                             Jubilado  12.745886         15
## Pareja                                 Pareja  12.739879         16
## Genero                                 Genero  12.430018         17
## Dependientes                     Dependientes  10.292017         18
## ServicioTelefono             ServicioTelefono   3.436354         19

Conclusiones:

Eliminar la variable “ServicioTelefono” por su bajo aporte predictivo según su coeficiente de Gini.
Las variables con mayor poder predictivo son: “CargoTotal”, “Tenencia”, “Contrato” y “CargoMensual”.

En segundo lugar, obtendremos los resultados según la metrica de Information Value

temp <- mutate(df,TARGET_ABANDONO = as.numeric(as.character(TARGET_ABANDONO))) %>% as.data.frame() #transformo la target a numérico temporalmente porque este algoritmo necesita que este en numérico, y el as.character es para que lo convierta a 0 y 1, y no a 1 y 2
imp_iv <- smbinning.sumiv(temp[c(ind_larga,'TARGET_ABANDONO')],y="TARGET_ABANDONO")
imp_iv <- imp_iv %>% mutate(Ranking = 1:nrow(imp_iv), IV = ifelse(is.na(.$IV),0,IV)) %>% select(-Process)
names(imp_iv) <- c('VARIABLE','IMP_IV','RANKING_IV')#este ultimo paso es más tema de formato

imp_iv

##                  VARIABLE IMP_IV RANKING_IV
## 15               Contrato 1.2332          1
## 5                Tenencia 0.8773          2
## 9         SeguridadOnline 0.7153          3
## 12      SoporteTecnologia 0.6971          4
## 8        ServicioInternet 0.6152          5
## 10         RespaldoOnline 0.5265          6
## 11  ProteccionDispositivo 0.4976          7
## 18           CargoMensual 0.4824          8
## 17             MetodoPago 0.4557          9
## 14        StreamingMovies 0.3799         10
## 13            StreamingTV 0.3787         11
## 19             CargoTotal 0.3202         12
## 16 FacturacionElectronica 0.2020         13
## 4            Dependientes 0.1532         14
## 3                  Pareja 0.1179         15
## 2                Jubilado 0.1051         16
## 7          MultiplesLines 0.0081         17
## 6        ServicioTelefono 0.0007         18
## 1                  Genero 0.0004         19

Conclusiones:

Identificamos que la variable “ServicioTelefono” tambien aparece entre las ultimas según su valor predictivo.

Finalmente, Sumaremos los valores obtenidos en ambas metricas (RandomForest e Information Value) para obtener un Ranking Final

imp_final <- inner_join(imp_rf,imp_iv,by='VARIABLE') %>% 
  select(VARIABLE,IMP_RF,IMP_IV,RANKING_RF,RANKING_IV) %>% #ponerlos en orden mas legible
  mutate(RANKING_TOT = RANKING_RF + RANKING_IV) %>% 
  arrange(RANKING_TOT)
imp_final

##                  VARIABLE     IMP_RF IMP_IV RANKING_RF RANKING_IV RANKING_TOT
## 1                Tenencia 106.264390 0.8773          1          2           3
## 2                Contrato  64.450984 1.2332          4          1           5
## 3         SeguridadOnline  46.459247 0.7153          6          3           9
## 4            CargoMensual  83.236600 0.4824          3          8          11
## 5        ServicioInternet  39.650946 0.6152          7          5          12
## 6       SoporteTecnologia  38.953550 0.6971          8          4          12
## 7              CargoTotal 103.096101 0.3202          2         12          14
## 8              MetodoPago  47.690192 0.4557          5          9          14
## 9          RespaldoOnline  27.049964 0.5265          9          6          15
## 10  ProteccionDispositivo  19.940151 0.4976         10          7          17
## 11            StreamingTV  19.548633 0.3787         11         11          22
## 12        StreamingMovies  17.690280 0.3799         12         10          22
## 13 FacturacionElectronica  15.455103 0.2020         13         13          26
## 14         MultiplesLines  14.051292 0.0081         14         17          31
## 15               Jubilado  12.745886 0.1051         15         16          31
## 16                 Pareja  12.739879 0.1179         16         15          31
## 17           Dependientes  10.292017 0.1532         18         14          32
## 18                 Genero  12.430018 0.0004         17         19          36
## 19       ServicioTelefono   3.436354 0.0007         19         18          37

Decisión:

Descartar aquellas variables que no hayan salido entre las 13 mas importantes en el ranking total, ya que si nos damos cuenta, la diferencia entre la 13 y la 14 es de 5 puntos en el raking total, antes el degradado era de máximo 3 puntos entre cada variable, se nota en el resultado un punto de corte para la elección de las variables.

Creamos la variable “ind_corta” donde alojaremos unicamente las variables predictoras con las que nos quedaremos en nuestro conjunto de datos

#Incluimos las 13 primeras en la lista

ind_corta <- c('Tenencia','Contrato','SeguridadOnline','CargoMensual','ServicioInternet','SoporteTecnologia','CargoTotal','MetodoPago','ProteccionDispositivo','RespaldoOnline','StreamingTV','StreamingMovies','FacturacionElectronica')

Finalmente, creo una variable “finales” donde tenga mi listado total de variables, incluyendo el ID del cliente y la variable TARGET que habiamos quitado previamente

finales <- union(ind_corta,c('ClienteID','TARGET_ABANDONO'))#creamos la lista de variables finales, incluyendo las que no tienen historia y la target

Se procede a modificar el dataframe original para que se quede unicamente con las variables preseleccionadas

df <- df %>% 
  select(one_of(finales))
glimpse(df)

## Rows: 7,032
## Columns: 15
## $ Tenencia               <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58,…
## $ Contrato               <fct> Month-to-month, One year, Month-to-month, One y…
## $ SeguridadOnline        <fct> No, Yes, Yes, Yes, No, No, No, Yes, No, Yes, Ye…
## $ CargoMensual           <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10…
## $ ServicioInternet       <fct> DSL, DSL, DSL, DSL, Fiber optic, Fiber optic, F…
## $ SoporteTecnologia      <fct> No, No, No, Yes, No, No, No, No, Yes, No, No, N…
## $ CargoTotal             <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50…
## $ MetodoPago             <fct> Electronic check, Mailed check, Mailed check, B…
## $ ProteccionDispositivo  <fct> No, Yes, No, Yes, No, Yes, No, No, Yes, No, No,…
## $ RespaldoOnline         <fct> Yes, No, Yes, No, No, No, Yes, No, No, Yes, No,…
## $ StreamingTV            <fct> No, No, No, No, No, Yes, Yes, No, Yes, No, No, …
## $ StreamingMovies        <fct> No, No, No, No, No, Yes, No, No, Yes, No, No, N…
## $ FacturacionElectronica <fct> Yes, No, Yes, No, Yes, Yes, Yes, No, Yes, No, Y…
## $ ClienteID              <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795…
## $ TARGET_ABANDONO        <dbl> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0,…

3.4 Creación de variables Sintéticas

Creación de variables de TENENCIA

Las tenencias son variables 0/1 que indican si el cliente tiene o no el producto en la ventana de análisis.

El conjunto de datos de este Proyecto intrinsicamente ya muestra ciertas variables de Tenencia como por ejemplo la variable “StremingTV” la cual tiene valoers “SI” y “NO”, lo que faltaria es pasarlo al formato 0 y 1

Creamos la función para calcular tenencias En este caso mi funcion lo unico que hara es convertir a 0 y 1

tenencia_3M <- function(m1){
  temp <- as.factor(if_else(m1 == "Yes", 1, 0))
  return(temp)
}

Creamos el indicador de tenencia para las variables que aplican

df$SeguridadOnline_TENENCIA <- tenencia_3M(df$SeguridadOnline)
df$SoporteTecnologia_TENENCIA <- tenencia_3M(df$SoporteTecnologia)
df$ProteccionDispositivo_TENENCIA <- tenencia_3M(df$ProteccionDispositivo)
df$RespaldoOnline_TENENCIA <- tenencia_3M(df$RespaldoOnline)
df$StreamingTV_TENENCIA <- tenencia_3M(df$StreamingTV)
df$StreamingMovies_TENENCIA <- tenencia_3M(df$StreamingMovies)
df$FacturacionElectronica_TENENCIA <- tenencia_3M(df$FacturacionElectronica)

Para este proyecto, el conjunto de datos entregado no contenia historico de las variables, por lo tanto no aplica para la creación de variables sinteticas de TENDENCIA, CANCELACION, CONTRATACION Y MEDIA.

3.5 Limpieza de variables

A partir de ahora ya sólo vamos a utilizar las variables sintéticas que hemos creado (más las originales no trasformadas como la edad y la antigüedad). Así que vamos a eliminar todas las originales que ya son sustituidas por sintéticas para que no nos molesten.

El objetivo aqui es quitar las que ya converti a Tenencia

df <- df %>% select(-SeguridadOnline,-SoporteTecnologia,-ProteccionDispositivo,-RespaldoOnline,-StreamingTV,-StreamingMovies,-FacturacionElectronica) %>% as.data.frame()

glimpse(df)

## Rows: 7,032
## Columns: 15
## $ Tenencia                        <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13…
## $ Contrato                        <fct> Month-to-month, One year, Month-to-mon…
## $ CargoMensual                    <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.…
## $ ServicioInternet                <fct> DSL, DSL, DSL, DSL, Fiber optic, Fiber…
## $ CargoTotal                      <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.6…
## $ MetodoPago                      <fct> Electronic check, Mailed check, Mailed…
## $ ClienteID                       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYB…
## $ TARGET_ABANDONO                 <dbl> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0,…
## $ SeguridadOnline_TENENCIA        <fct> 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0,…
## $ SoporteTecnologia_TENENCIA      <fct> 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0,…
## $ ProteccionDispositivo_TENENCIA  <fct> 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1,…
## $ RespaldoOnline_TENENCIA         <fct> 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0,…
## $ StreamingTV_TENENCIA            <fct> 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1,…
## $ StreamingMovies_TENENCIA        <fct> 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1,…
## $ FacturacionElectronica_TENENCIA <fct> 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0,…

3.6 Discretización

Primero vamos a crear la función que va a discretizar de forma automática maximizando la capacidad predictiva de la nueva variable Ademas, como vamos a usar en la modelización un algoritmo lineal, que es la regresión logística, vamos a intentar que la discretización sea monotónica

discretizar <- function(vi,target){
  temp_df <- data.frame(vi = vi, target = target)
  #smbinning necesita que la target sea numérica
  temp_df$target <- as.numeric(as.character(temp_df$target))
  disc <- smbinning(temp_df, y = 'target', x = 'vi')
  return(disc)
}

Discretizamos todas las variables numéricas

#TENENCIA:
disc_temp_Tenencia <- discretizar(df$Tenencia,df$TARGET_ABANDONO)
df_temp <- select(df,Tenencia,TARGET_ABANDONO) #creamos este temporal porque smbinning.gen necesita que el df tenga el mismo numero de columnas que la salida de la funcion discretizar
df_temp <- smbinning.gen(df_temp,disc_temp_Tenencia,chrname = 'Tenencia_DISC')
#Metemos en df la nueva variable discretizada y eliminamos la original
df <- cbind(df,df_temp[3])

#CARGO MENSUAL:
disc_temp_CargoMensual <- discretizar(df$CargoMensual,df$TARGET_ABANDONO)
df_temp <- select(df,CargoMensual,TARGET_ABANDONO) #creamos este temporal porque smbinning.gen necesita que el df tenga el mismo numero de columnas que la salida de la funcion discretizar
df_temp <- smbinning.gen(df_temp,disc_temp_CargoMensual,chrname = 'CargoMensual_DISC')
#Metemos en df la nueva variable discretizada y eliminamos la original
df <- cbind(df,df_temp[3])


#CARGO TOTAL:
disc_temp_CargoTotal <- discretizar(df$CargoTotal,df$TARGET_ABANDONO)
df_temp <- select(df,CargoTotal,TARGET_ABANDONO) #creamos este temporal porque smbinning.gen necesita que el df tenga el mismo numero de columnas que la salida de la funcion discretizar
df_temp <- smbinning.gen(df_temp,disc_temp_CargoTotal,chrname = 'CargoTotal_DISC')
#Metemos en df la nueva variable discretizada y eliminamos la original
df <- cbind(df,df_temp[3])

3.7 Validaciónes

Validar una de las variables discretizadas a ver como salio

table(df$CargoMensual_DISC) %>% as.data.frame()

##           Var1 Freq
## 1   01 <= 26.9 1600
## 2  02 <= 55.95 1119
## 3   03 <= 68.8  563
## 4 04 <= 106.75 3380
## 5  05 > 106.75  370

Conclusiones: * Validamos que para la variable “CargoMensual” nos armo 5 categorias, desde los que tienen menos de 26.9$ hasta los que tienen mas de 106.75 dólares de cargo mensual, asi como tambien visualizamos la cantidad de clientes en cada tramo.

Validar distribución de las variables originales vs variables discretizadas

Esta subfase tiene como objetivo validar que la distribución de la variable discretizada respete en lo posible la distribución original de la variable

Variable “CargoMensual” Original

ggplot(df,aes(CargoMensual)) + geom_density()

Variable “CargoMensual” Discretizada

ggplot(df,aes(CargoMensual_DISC)) + geom_bar()

Variable “Tenencia” Original

ggplot(df,aes(Tenencia)) + geom_density()

Variable “Tenencia” Discretizada

ggplot(df,aes(Tenencia_DISC)) + geom_bar()

Conclusiones:

Vemos que la discretización de cierta forma si captura la distribución original, podriamos modificar los tramos para buscar que se parezca aun mas a la distribución original, pero en este caso lo dejaremos asi.
Eliminar del conjunto de datos las variables originales, ya no se necesitarán.

df <- df %>%  select(-Tenencia) 
df <- df %>%  select(-CargoMensual)  
df <- df %>%  select(-CargoTotal)

Validar si la penetración de la variable TARGET es MONOTÓNICA

Variable “Tenencia” Discretizada

ggplot(df,aes(Tenencia_DISC,fill=TARGET_ABANDONO)) + geom_bar(position='fill')

Conclusión:

Es una variable Monotonica, mientras menor es el tramo de la discretización, mayor es la cantidad de abandonos (churn)

Variable “CargoMensual” Discretizada

ggplot(df,aes(CargoMensual_DISC,fill=TARGET_ABANDONO)) + geom_bar(position='fill')

Conclusión:

No es una variable Monotónica.Podriamos hacer los cortes de esta variable de forma manual, es decir discretización manual. Sin embargo, para efectos de este proyecto, tiene sentido de negocio asi que lo dejaremos asi.

Variable “CargoTotal” Discretizada

ggplot(df,aes(CargoTotal_DISC,fill=TARGET_ABANDONO)) + geom_bar(position='fill')

Conclusión:

Si es una variable Monotónica. En los rangos con menor importe de cargo total hay mayor penetración de la variable target, es decir, hay mas clientes que abandonan en el tramo “01 <=198” de clientes con menos de 198 dolares de cargo total.

Realizó una inspección visual de todas las variables a ver si han salido bien

df %>% 
  select_if(is.factor) %>% 
  gather() %>% 
  ggplot(aes(value)) +
    geom_bar() +
    facet_wrap(~ key, scales = "free") +
    theme(axis.text=element_text(size=4))#esto es para cambiar el tamaño del texto del eje y que se lea bien

Procedemos a analizar la penetración de la target en cada categoría para ver si las variables han salido monotónicas

a <- function(var1,var2) {
  df_temp <- data.frame(var1 = df[[var1]],var2 = df[[var2]])
  df_temp %>% 
    group_by(var1) %>% 
    summarise(Conteo = n(), Porc = mean(as.numeric(as.character(var2)))) %>% 
  ggplot(aes(var1,Porc)) + geom_bar(stat='identity') + xlab(var1)
}
df2_nombres <- df %>% select_if(is.factor) %>% names()

lapply(df2_nombres,function(x){a(x,'TARGET_ABANDONO')})

## [[1]]

## 
## [[2]]

## 
## [[3]]

## 
## [[4]]

## 
## [[5]]

## 
## [[6]]

## 
## [[7]]

## 
## [[8]]

## 
## [[9]]

## 
## [[10]]

## 
## [[11]]

## 
## [[12]]

## 
## [[13]]

## 
## [[14]]

Conclusiónes generales de esta fase:

Luego de una inspección minusiosa de cada variable, validamos que todas las variables factor de nustro dataframe estan correctas, no se visualizan escenarios atipicos, aseguranod un correcto trabajo en el proceso de creación de varialbes sinteticas y en la fase de discretización.
La variable discretizada “CargoMensual_DISC” no salio de forma monotónica. Se puede hacer el ajuste de los tramos de forma manual. Sin embargo, tiene sentido de negocio por lo que la dejaremos como esta.
Nuestro conjunto de datos esta conformado por mas variables categóricas que númericas, por lo general el proceso de discretización y validación de formas monotonicas aplica un poco mas para variables continuas numericas.

Antes de continuar vamos a guardar en un objeto de R las discretizaciones, porque las necesitaremos después para poner el modelo en producción

#Vamos a crear un objeto de tipo lista que es lo ideal para guardar objetos complejos como las discretizaciones
discretizaciones <- list(
 disc_temp_Tenencia = disc_temp_Tenencia,
 disc_temp_CargoMensual = disc_temp_CargoMensual,
 disc_temp_CargoTotal = disc_temp_CargoTotal
)
saveRDS(discretizaciones,'02_CortesDiscretizaciones.rds')

visualizar nuestro conjunto de datos que pasará a la fase de Modelización

#creamos un vector con las variables centrales
centrales <- setdiff(names(df),c('ClienteID','TARGET_ABANDONO'))
df <- df %>% select(
  ClienteID,
  one_of(centrales),
  TARGET_ABANDONO)

glimpse(df)

## Rows: 7,032
## Columns: 15
## $ ClienteID                       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYB…
## $ Contrato                        <fct> Month-to-month, One year, Month-to-mon…
## $ ServicioInternet                <fct> DSL, DSL, DSL, DSL, Fiber optic, Fiber…
## $ MetodoPago                      <fct> Electronic check, Mailed check, Mailed…
## $ SeguridadOnline_TENENCIA        <fct> 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0,…
## $ SoporteTecnologia_TENENCIA      <fct> 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0,…
## $ ProteccionDispositivo_TENENCIA  <fct> 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1,…
## $ RespaldoOnline_TENENCIA         <fct> 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0,…
## $ StreamingTV_TENENCIA            <fct> 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1,…
## $ StreamingMovies_TENENCIA        <fct> 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1,…
## $ FacturacionElectronica_TENENCIA <fct> 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0,…
## $ Tenencia_DISC                   <fct> 01 <= 1, 05 <= 49, 02 <= 5, 05 <= 49, …
## $ CargoMensual_DISC               <fct> 02 <= 55.95, 03 <= 68.8, 02 <= 55.95, …
## $ CargoTotal_DISC                 <fct> 01 <= 198, 02 <= 3233.85, 01 <= 198, 0…
## $ TARGET_ABANDONO                 <fct> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0,…

4. Modelización

4.1 Crear funciones de apoyo

Función para crear una matriz de confusión

confusion<-function(real,scoring,umbral){ 
  conf<-table(real,scoring>=umbral)
  if(ncol(conf)==2) return(conf) else return(NULL)
}

Funcion para calcular las métricas de los modelos: acierto, precisión, cobertura y F1

metricas<-function(matriz_conf){
  acierto <- (matriz_conf[1,1] + matriz_conf[2,2]) / sum(matriz_conf) *100
  precision <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[1,2]) *100
  cobertura <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[2,1]) *100
  F1 <- 2*precision*cobertura/(precision+cobertura)
  salida<-c(acierto,precision,cobertura,F1)
  return(salida)
}

Función para probar distintos umbrales y ver el efecto sobre precisión y cobertura

umbrales<-function(real,scoring){
  umbrales<-data.frame(umbral=rep(0,times=19),acierto=rep(0,times=19),precision=rep(0,times=19),cobertura=rep(0,times=19),F1=rep(0,times=19))
  cont <- 1
  for (cada in seq(0.05,0.95,by = 0.05)){
    datos<-metricas(confusion(real,scoring,cada))
    registro<-c(cada,datos)
    umbrales[cont,]<-registro
    cont <- cont + 1
  }
  return(umbrales)
}

Funciones que calculan la curva ROC y el AUC

roc<-function(prediction){
  r<-performance(prediction,'tpr','fpr')
  plot(r)
}

auc<-function(prediction){
  a<-performance(prediction,'auc')
  return(a@y.values[[1]])
}

4.2 Partición del conjunto de datos (Train y Test)

Establecemos una semilla

set.seed(12345)

Generamos una variable aleatoria con una distribución 70-30 (70% para entrenamiento y 30% para la validación)

df$random<-sample(0:1,size = nrow(df),replace = T,prob = c(0.3,0.7))

Creamos los dos dataframes

train<-filter(df,random==1)
test<-filter(df,random==0)
#Eliminamos la random
df$random <- NULL

4.3 Modelización con Regresión Logistica

Identificamos las variables

#Las independientes serán todas menos el código cliente y la target
independientes <- setdiff(names(df),c('ClienteID','TARGET_ABANDONO'))
target <- 'TARGET_ABANDONO'

Creamos la formula para usar en el modelo

formula <- reformulate(independientes,target)

Primero vamos a hacer un modelo con todas las variables

formula_rl <- formula
rl<- glm(formula_rl,train,family=binomial(link='logit'))
summary(rl)

## 
## Call:
## glm(formula = formula_rl, family = binomial(link = "logit"), 
##     data = train)
## 
## Coefficients:
##                                   Estimate Std. Error z value
## (Intercept)                        0.19708    0.32230   0.611
## ContratoOne year                  -0.64704    0.12788  -5.060
## ContratoTwo year                  -1.42773    0.22240  -6.420
## ServicioInternetFiber optic        1.16358    0.21215   5.485
## ServicioInternetNo                -1.01128    0.31871  -3.173
## MetodoPagoCredit card (automatic) -0.12476    0.13494  -0.925
## MetodoPagoElectronic check         0.23150    0.11236   2.060
## MetodoPagoMailed check            -0.29827    0.13743  -2.170
## SeguridadOnline_TENENCIA1         -0.34761    0.10273  -3.384
## SoporteTecnologia_TENENCIA1       -0.25480    0.10361  -2.459
## ProteccionDispositivo_TENENCIA1    0.10031    0.09596   1.045
## RespaldoOnline_TENENCIA1          -0.11531    0.09293  -1.241
## StreamingTV_TENENCIA1              0.42835    0.09837   4.355
## StreamingMovies_TENENCIA1          0.38374    0.09689   3.960
## FacturacionElectronica_TENENCIA1   0.37183    0.09004   4.130
## Tenencia_DISC02 <= 5              -0.73481    0.16963  -4.332
## Tenencia_DISC03 <= 16             -1.17277    0.22112  -5.304
## Tenencia_DISC04 <= 22             -1.46899    0.25259  -5.816
## Tenencia_DISC05 <= 49             -1.81151    0.23493  -7.711
## Tenencia_DISC06 <= 59             -2.00163    0.29547  -6.774
## Tenencia_DISC07 <= 70             -2.23580    0.34709  -6.442
## Tenencia_DISC08 > 70              -3.44927    0.51444  -6.705
## CargoMensual_DISC02 <= 55.95       0.28091    0.31059   0.904
## CargoMensual_DISC03 <= 68.8       -0.35234    0.35825  -0.983
## CargoMensual_DISC04 <= 106.75     -0.19205    0.37692  -0.510
## CargoMensual_DISC05 > 106.75      -0.22360    0.46653  -0.479
## CargoTotal_DISC02 <= 3233.85      -0.29553    0.19112  -1.546
## CargoTotal_DISC03 <= 5643.4       -0.56899    0.25949  -2.193
## CargoTotal_DISC04 > 5643.4        -0.30502    0.35885  -0.850
##                                             Pr(>|z|)    
## (Intercept)                                 0.540881    
## ContratoOne year                  0.0000004196404546 ***
## ContratoTwo year                  0.0000000001366681 ***
## ServicioInternetFiber optic       0.0000000414237574 ***
## ServicioInternetNo                          0.001509 ** 
## MetodoPagoCredit card (automatic)           0.355179    
## MetodoPagoElectronic check                  0.039364 *  
## MetodoPagoMailed check                      0.029974 *  
## SeguridadOnline_TENENCIA1                   0.000715 ***
## SoporteTecnologia_TENENCIA1                 0.013923 *  
## ProteccionDispositivo_TENENCIA1             0.295879    
## RespaldoOnline_TENENCIA1                    0.214690    
## StreamingTV_TENENCIA1             0.0000133317340178 ***
## StreamingMovies_TENENCIA1         0.0000748238647745 ***
## FacturacionElectronica_TENENCIA1  0.0000362987457964 ***
## Tenencia_DISC02 <= 5              0.0000147768983987 ***
## Tenencia_DISC03 <= 16             0.0000001134436518 ***
## Tenencia_DISC04 <= 22             0.0000000060343533 ***
## Tenencia_DISC05 <= 49             0.0000000000000125 ***
## Tenencia_DISC06 <= 59             0.0000000000124867 ***
## Tenencia_DISC07 <= 70             0.0000000001182107 ***
## Tenencia_DISC08 > 70              0.0000000000201629 ***
## CargoMensual_DISC02 <= 55.95                0.365770    
## CargoMensual_DISC03 <= 68.8                 0.325373    
## CargoMensual_DISC04 <= 106.75               0.610379    
## CargoMensual_DISC05 > 106.75                0.631740    
## CargoTotal_DISC02 <= 3233.85                0.122034    
## CargoTotal_DISC03 <= 5643.4                 0.028329 *  
## CargoTotal_DISC04 > 5643.4                  0.395333    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5796.6  on 4933  degrees of freedom
## Residual deviance: 4064.1  on 4905  degrees of freedom
## AIC: 4122.1
## 
## Number of Fisher Scoring iterations: 6

El R cuadrado nos arroja un valor de 0.2988

pr2_rl <- 1 -(rl$deviance / rl$null.deviance)
pr2_rl

## [1] 0.2988757

En busqueda de incrementar el valor de la métrica R cuadrado. Nos quedariamos con ciertas variables basandonos en que tan significativas son para la predicción. En este caso, probaremos manteniendo unicamente las variables que tengan de 2 a más estrellas.

a_mantener <- c(
  'Contrato',
  'ServicioInternet',
  'SeguridadOnline_TENENCIA',
  'SoporteTecnologia_TENENCIA',
  'StreamingTV_TENENCIA',
  'StreamingMovies_TENENCIA',
  'FacturacionElectronica_TENENCIA',
  'Tenencia_DISC'
)

Volvemos a modelizar

formula_rl <- reformulate(a_mantener,target)
rl<- glm(formula_rl,train,family=binomial(link='logit'))
summary(rl)

## 
## Call:
## glm(formula = formula_rl, family = binomial(link = "logit"), 
##     data = train)
## 
## Coefficients:
##                                  Estimate Std. Error z value
## (Intercept)                       0.30961    0.13743   2.253
## ContratoOne year                 -0.72985    0.12575  -5.804
## ContratoTwo year                 -1.54869    0.21841  -7.091
## ServicioInternetFiber optic       0.91302    0.09307   9.810
## ServicioInternetNo               -1.23570    0.15664  -7.889
## SeguridadOnline_TENENCIA1        -0.42604    0.09888  -4.309
## SoporteTecnologia_TENENCIA1      -0.34372    0.09856  -3.487
## StreamingTV_TENENCIA1             0.40714    0.09310   4.373
## StreamingMovies_TENENCIA1         0.38515    0.09251   4.163
## FacturacionElectronica_TENENCIA1  0.39219    0.08906   4.403
## Tenencia_DISC02 <= 5             -0.84285    0.15111  -5.578
## Tenencia_DISC03 <= 16            -1.41868    0.14364  -9.876
## Tenencia_DISC04 <= 22            -1.74829    0.17982  -9.723
## Tenencia_DISC05 <= 49            -2.14081    0.15035 -14.239
## Tenencia_DISC06 <= 59            -2.39328    0.20132 -11.888
## Tenencia_DISC07 <= 70            -2.50563    0.21374 -11.723
## Tenencia_DISC08 > 70             -3.68142    0.42367  -8.689
##                                              Pr(>|z|)    
## (Intercept)                                  0.024265 *  
## ContratoOne year                  0.00000000647261721 ***
## ContratoTwo year                  0.00000000000133453 ***
## ServicioInternetFiber optic      < 0.0000000000000002 ***
## ServicioInternetNo                0.00000000000000305 ***
## SeguridadOnline_TENENCIA1         0.00001642224736475 ***
## SoporteTecnologia_TENENCIA1                  0.000488 ***
## StreamingTV_TENENCIA1             0.00001225791389906 ***
## StreamingMovies_TENENCIA1         0.00003134821953536 ***
## FacturacionElectronica_TENENCIA1  0.00001065540842510 ***
## Tenencia_DISC02 <= 5              0.00000002437867736 ***
## Tenencia_DISC03 <= 16            < 0.0000000000000002 ***
## Tenencia_DISC04 <= 22            < 0.0000000000000002 ***
## Tenencia_DISC05 <= 49            < 0.0000000000000002 ***
## Tenencia_DISC06 <= 59            < 0.0000000000000002 ***
## Tenencia_DISC07 <= 70            < 0.0000000000000002 ***
## Tenencia_DISC08 > 70             < 0.0000000000000002 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5796.6  on 4933  degrees of freedom
## Residual deviance: 4111.7  on 4917  degrees of freedom
## AIC: 4145.7
## 
## Number of Fisher Scoring iterations: 6

Vemos que ahora ya todas las variables tienen al menos una categoría con 3 estrellas de significación

Vamos a mirar el signo de los coeficientes, que deberá seguir la lógica de negocio: todas las variables tienen lógica, asi que vamos a comprobar este modelo sobre el conjunto de test

Y calculamos el pseudo R cuadrado:

pr2_rl <- 1 -(rl$deviance / rl$null.deviance)
pr2_rl

## [1] 0.2906622

Como el R cuadrado nos sale un poco bajo vamos a volver probar con otra combinación de variables.

Agrego la variable “CargoMensual_DISC” y “CargoTotal_DISC” que si bien no habia obtenido las estrellas necesarias, a nuestro criterio de negocio es importante esta variable.

a_mantener <- c(
  'Contrato',
  'ServicioInternet',
  'SeguridadOnline_TENENCIA',
  'SoporteTecnologia_TENENCIA',
  'StreamingTV_TENENCIA',
  'StreamingMovies_TENENCIA',
  'FacturacionElectronica_TENENCIA',
  'Tenencia_DISC',
  'CargoTotal_DISC',
  'CargoMensual_DISC'
)

Volvemos a modelizar

formula_rl <- reformulate(a_mantener,target)
rl<- glm(formula_rl,train,family=binomial(link='logit'))
summary(rl)

Y calculamos el pseudo R cuadrado:

pr2_rl <- 1 -(rl$deviance / rl$null.deviance)
pr2_rl

## [1] 0.2941717

Conclusiones:

No solo hay que fiarse de las estrellas que arroja el algoritmo de Regresión Logistica, sino tambien poder jugar con las variables de acuerdo a nuestro criterio de negocio

Aplicamos el modelo al conjunto de test, generando un vector con las probabilidades

rl_predict<-predict(rl,test,type = 'response')

Vemos que para cada cliente nos ha dado una probabilidad de abandono (churn)

 head(rl_predict)

##          1          2          3          4          5          6 
## 0.69224302 0.03376255 0.42838329 0.04714540 0.52991937 0.01685703

Elaboramos un gráfico de cajas

plot(rl_predict~test$TARGET_ABANDONO)

Despues de analizar el grafico boxplot, podemos anotar estas conclusiones:

Vemos que para los que SI ABANDONARON (1) al maximo le ha puesto aproximadamente 70% de probabilidad. Esperiamos que al maximo le haya puesto 95% y que la media este al rededor de los 70%, sin embargo la media esta en 50%.
Para los que NO ABANDONARÁN (0) el panorama es similiar, a pesar que la media esta rondando el 10%, esta distribución esta mas cerca a lo que esperariamos.
Una opción para obtener mejores resultados podria ser volver a hacer toda la metodologia pero con nuevas variables, es decir agregar mas variables de negocio al conjunto de datos que puedan aportar más información al modelo.

Ahora tenemos que transformar la probabilidad en una decisión de si el cliente va abandonar o no va abandonar

Con la función umbrales probamos diferentes cortes

umb_rl<-umbrales(test$TARGET_ABANDONO,rl_predict)
umb_rl

##    umbral  acierto precision  cobertura         F1
## 1    0.05 51.23928  33.22303 97.2868217 49.5313271
## 2    0.10 59.67588  37.38532 94.7674419 53.6184211
## 3    0.15 65.58627  41.16638 93.0232558 57.0749108
## 4    0.20 69.97140  44.51923 89.7286822 59.5115681
## 5    0.25 73.35558  47.69561 86.2403101 61.4216701
## 6    0.30 75.97712  50.75758 77.9069767 61.4678899
## 7    0.35 78.74166  54.92958 75.5813953 63.6215334
## 8    0.40 79.79028  57.54098 68.0232558 62.3445826
## 9    0.45 80.88656  60.91082 62.2093023 61.5532119
## 10   0.50 80.98189  62.97118 55.0387597 58.7383661
## 11   0.55 81.50620  69.04762 44.9612403 54.4600939
## 12   0.60 81.74452  71.80328 42.4418605 53.3495737
## 13   0.65 79.02765  70.43011 25.3875969 37.3219373
## 14   0.70 79.31363  78.87324 21.7054264 34.0425532
## 15   0.75 78.02669  83.13253 13.3720930 23.0383973
## 16   0.80 77.35939  85.96491  9.4961240 17.1029668
## 17   0.85 76.12011  89.47368  3.2945736  6.3551402
## 18   0.90 75.45281  66.66667  0.3875969  0.7707129
## 19   0.95  0.95000   0.95000  0.9500000  0.9500000

Conclusiones:

Vemos que el maximo de precision es de 89%, en mi opinion es una de las metricas mas importantes debido a que te indica Cuantos de los que “SI ABANDONARAN” en verdad “ABANDONARON”. Esperaria encontrar un pico mas alto y obviamente con una reduccion de cobertura, pero seguimos para adelante.
Mi F1 Alcanza el maximo en el punto de corte 63.6215334. El cual corresponde a hacer un corte de umbral a los 0.35, es decir de 0.35 para abajo no van a abandonaron y de 0.35 para arriba, si van a abandonar, pero eso solo tendra una precisión del 54%

Seleccionamos el umbral que maximiza la F1 y coincide con el analisis manual, es decir, 0.35

umbral_final_rl<-umb_rl[which.max(umb_rl$F1),1]
umbral_final_rl

## [1] 0.35

Evaluamos la matriz de confusión y las métricas con el umbral optimizado

confusion(test$TARGET_ABANDONO,rl_predict,umbral_final_rl)
rl_metricas<-filter(umb_rl,umbral==umbral_final_rl)

rl_metricas

##   umbral  acierto precision cobertura       F1
## 1   0.35 78.74166  54.92958   75.5814 63.62153

Conclusiones:

Luego modelizaremos con Otros algoritmos los cuales compararemos y veremos si tenemos mejores resultados con Random Forest o con arboles de decision, etc.

Evaluamos la ROC

#creamos el objeto prediction
rl_prediction<-prediction(rl_predict,test$TARGET_ABANDONO)

roc(rl_prediction)

Sacamos las métricas definitivas incluyendo el AUC

rl_metricas<-cbind(rl_metricas,AUC=round(auc(rl_prediction),2)*100)
print(t(rl_metricas))

##               [,1]
## umbral     0.35000
## acierto   78.74166
## precision 54.92958
## cobertura 75.58140
## F1        63.62153
## AUC       85.00000

Conclusion:

El AUC es de 85%.Nos quedaremos con estas metricas y procederemos a usar arboles de decision y ver que tal nos va con esas metricas para finalmente comprar y escoger el mejor algortimo.

4.4 Modelización con Árboles de decisión

Creamos el primer modelo

formula_ar <- formula
ar<-rpart(formula_ar, train, method = 'class', parms = list(
  split = "information"), 
  control = rpart.control(cp = 0.00001))

Revisamos donde el error de validación cruzada empieza a crecer

printcp(ar)

## 
## Classification tree:
## rpart(formula = formula_ar, data = train, method = "class", parms = list(split = "information"), 
##     control = rpart.control(cp = 0.00001))
## 
## Variables actually used in tree construction:
##  [1] CargoMensual_DISC               CargoTotal_DISC                
##  [3] Contrato                        FacturacionElectronica_TENENCIA
##  [5] MetodoPago                      ProteccionDispositivo_TENENCIA 
##  [7] RespaldoOnline_TENENCIA         SeguridadOnline_TENENCIA       
##  [9] ServicioInternet                SoporteTecnologia_TENENCIA     
## [11] StreamingMovies_TENENCIA        StreamingTV_TENENCIA           
## [13] Tenencia_DISC                  
## 
## Root node error: 1353/4934 = 0.27422
## 
## n= 4934 
## 
##            CP nsplit rel error  xerror     xstd
## 1  0.05691057      0   1.00000 1.00000 0.023161
## 2  0.01219512      3   0.79084 0.79897 0.021474
## 3  0.00739098      5   0.76644 0.80783 0.021559
## 4  0.00665188      8   0.74427 0.80266 0.021510
## 5  0.00443459      9   0.73762 0.76792 0.021167
## 6  0.00406504     10   0.73319 0.75905 0.021077
## 7  0.00369549     15   0.71027 0.75905 0.021077
## 8  0.00295639     16   0.70658 0.75388 0.021024
## 9  0.00221729     17   0.70362 0.75166 0.021001
## 10 0.00184775     18   0.70140 0.75388 0.021024
## 11 0.00172456     20   0.69771 0.75610 0.021047
## 12 0.00147820     23   0.69254 0.75831 0.021069
## 13 0.00110865     37   0.67184 0.76349 0.021122
## 14 0.00098546     42   0.66593 0.77088 0.021197
## 15 0.00073910     50   0.65706 0.77236 0.021212
## 16 0.00055432     57   0.65188 0.77901 0.021278
## 17 0.00049273     61   0.64967 0.80118 0.021496
## 18 0.00036955     64   0.64819 0.80118 0.021496
## 19 0.00032849     70   0.64597 0.81596 0.021636
## 20 0.00024637     81   0.64228 0.82040 0.021678
## 21 0.00018477     93   0.63932 0.82262 0.021699
## 22 0.00012318     97   0.63858 0.83075 0.021775
## 23 0.00001000    103   0.63784 0.83518 0.021815

Conclusiones:

Identificamos que el error va bajando y empieza a subir en el corte xerror = 0.75388, la fila numero 8 de la tabla.
El parámetro de complejidad seria 0.00295639

Generamos un nuevo árbol con ese parámetro Ademas vamos a incluir un nuevo parametro para que el árbol no tenga mas de 7 niveles

ar<-rpart(formula, train, method = 'class', parms = list(
  split = "information"), 
  control = rpart.control(cp = 0.0029,maxdepth = 7))

Revisamos de nuevo la complejidad

printcp(ar)

## 
## Classification tree:
## rpart(formula = formula, data = train, method = "class", parms = list(split = "information"), 
##     control = rpart.control(cp = 0.0029, maxdepth = 7))
## 
## Variables actually used in tree construction:
##  [1] CargoMensual_DISC               CargoTotal_DISC                
##  [3] Contrato                        FacturacionElectronica_TENENCIA
##  [5] MetodoPago                      SeguridadOnline_TENENCIA       
##  [7] ServicioInternet                SoporteTecnologia_TENENCIA     
##  [9] StreamingMovies_TENENCIA        StreamingTV_TENENCIA           
## [11] Tenencia_DISC                  
## 
## Root node error: 1353/4934 = 0.27422
## 
## n= 4934 
## 
##          CP nsplit rel error  xerror     xstd
## 1 0.0569106      0   1.00000 1.00000 0.023161
## 2 0.0121951      3   0.79084 0.79084 0.021395
## 3 0.0073910      5   0.76644 0.80266 0.021510
## 4 0.0066519      8   0.74427 0.79749 0.021460
## 5 0.0044346      9   0.73762 0.76866 0.021175
## 6 0.0040650     10   0.73319 0.75758 0.021062
## 7 0.0036955     15   0.71027 0.76053 0.021092
## 8 0.0029564     16   0.70658 0.75610 0.021047
## 9 0.0029000     17   0.70362 0.74945 0.020978

Conclusiones:

Ya identificamos una “tendencia” ya que vemos en el grafico que baja y ya no sube.De igual forma lo apreciamos en la tabla.

Ahora parece bastante estable Vamos a crear el gráfico del árbol para analizarlo

rpart.plot(ar,type=2,extra = 7, under = TRUE,under.cex = 0.7,fallen.leaves=F,gap = 0,cex=0.2,yesno = 2,box.palette = "GnYlRd",branch.lty = 3)

Vamos a sacar las reglas que podrían ser utilizadas por ejemplo para hacer una implantación del árbol

rpart.rules(ar,style = 'tall',cover = T)
#style sirve para que la salida sea mas legible y cover añade el % de casos e los que aplica la regla

Podemos llevarnos el nodo final de cada cliente a un data.frame para poder hacer una explotacion posterior

#Para ello usaremos el predict específico de rpart y con el parámetro nn
ar_numnodos<-rpart.predict(ar,test,nn = T)
head(ar_numnodos)

Vamos a calcular los scorings y evaluar el modelo

ar_predict<-predict(ar,test,type = 'prob')[,2]

Vemos que tal sale

plot(ar_predict~test$TARGET_ABANDONO)

Conclusiones:

Nuevamente igual que en Regresion Logistica, nuestro apartado de los que abandonaran (1) tiene como media aproximadamente 0.5, esperia que esa caja esta lo mas pegada al 1 posible. De todas formas puedo corregir un poco esto con el establecimiento del umbral.

Con la función umbrales probamos diferentes cortes

umb_ar<-umbrales(test$TARGET_ABANDONO,ar_predict)
umb_ar

##    umbral  acierto precision cobertura       F1
## 1    0.05  0.05000   0.05000  0.050000  0.05000
## 2    0.10 66.15825  41.30824 89.341085 56.49510
## 3    0.15 66.15825  41.30824 89.341085 56.49510
## 4    0.20 75.45281  50.06017 80.620155 61.76689
## 5    0.25 75.40515  50.00000 80.038760 61.54993
## 6    0.30 79.07531  56.76626 62.596899 59.53917
## 7    0.35 79.07531  56.76626 62.596899 59.53917
## 8    0.40 79.64728  58.31776 60.465116 59.37203
## 9    0.45 80.12393  59.64912 59.302326 59.47522
## 10   0.50 80.21926  61.00218 54.263566 57.43590
## 11   0.55 80.21926  61.00218 54.263566 57.43590
## 12   0.60 80.88656  65.92798 46.124031 54.27594
## 13   0.65 80.74357  68.42105 40.310078 50.73171
## 14   0.70 77.16873  81.35593  9.302326 16.69565
## 15   0.75 77.16873  81.35593  9.302326 16.69565
## 16   0.80 77.16873  81.35593  9.302326 16.69565
## 17   0.85 77.16873  81.35593  9.302326 16.69565
## 18   0.90  0.90000   0.90000  0.900000  0.90000
## 19   0.95  0.95000   0.95000  0.950000  0.95000

Seleccionamos automáticamente el mejor umbral

umbral_final_ar<-umb_ar[which.max(umb_ar$F1),1]
umbral_final_ar

## [1] 0.2

Conclusiones:

En mi opinion 0.3, es un umbral demasiado bajo pero es la que nos da el mayor F1 posible.

Evaluamos la matriz de confusión y las métricas con el umbral optimizado

confusion(test$TARGET_ABANDONO,ar_predict,umbral_final_ar)

##     
## real FALSE TRUE
##    0  1167  415
##    1   100  416

ar_metricas<-filter(umb_ar,umbral==umbral_final_ar)
ar_metricas

##   umbral  acierto precision cobertura       F1
## 1    0.2 75.45281  50.06017  80.62016 61.76689

Conclusioes:

De igual forma la precisión me parece demasiado baja, Si lo comparamos con Regresión Logistica, este arbol de decision tendria un peor rendimiento pero por muy poco.

Evaluamos la ROC

#creamos el objeto prediction
ar_prediction<-prediction(ar_predict,test$TARGET_ABANDONO)
#visualizamos la ROC
roc(ar_prediction)

Sacamos las métricas definitivas incluyendo el AUC

ar_metricas<-cbind(ar_metricas,AUC=round(auc(ar_prediction),2)*100)
print(t(ar_metricas))

##               [,1]
## umbral     0.20000
## acierto   75.45281
## precision 50.06017
## cobertura 80.62016
## F1        61.76689
## AUC       82.00000

4.5 Modelización con Random Forest

Creamos el modelo

formula_rf <- formula
rf<-randomForest(formula_rf,train,importance=T)
rf

Visualizamos las variables mas importantes

varImpPlot(rf)

Como hay dos criterios vamos a crear una única variable agregada y visualizarla para tener una mejor idea de la importancia de cada variable

importancia <- importance(rf)[,3:4]
#normalizamos para poner las dos variables en la misma escala. los valores negativos son las que menos predicen y los positivos las que mas
importancia_norm <- as.data.frame(scale(importancia))
#creamos una única variable como suma de las otras
importancia_norm <- importancia_norm %>% mutate(
  Variable = rownames(importancia_norm),
  Imp_tot = MeanDecreaseAccuracy + MeanDecreaseGini) %>%
  mutate(Imp_tot = Imp_tot + abs(min(Imp_tot))) %>% 
  arrange(desc(Imp_tot)) %>% 
  select(Variable,Imp_tot,MeanDecreaseAccuracy,MeanDecreaseGini)
#hacemos un gráfico para ver la curva de caída de importancia
ggplot(importancia_norm, aes(reorder(Variable,-Imp_tot),Imp_tot)) + geom_bar(stat = "identity") + theme(axis.text.x = element_text(angle = 90,size = 7))

importancia_norm

La caída es bastante gradual, así que no hay corte claro. En este caso tambien estableceremos 0.7 como importe total como corte para quedarnos solo con las mejores variables.

a_mantener <- importancia_norm %>% 
  filter(Imp_tot > 0.7) %>% 
  select(Variable)

#Extraemos los nombres como un vector
a_mantener <- as.character((a_mantener$Variable))

Creamos de nuevo el modelo con las nuevas variables

formula_rf <- reformulate(a_mantener,target)
rf<-randomForest(formula_rf,train,importance=T)
rf

Aplicamos el modelo al conjunto de test, generando un vector con las probabilidades Notar que por el método predict de randomforest hay que poner el type=prob para tener el scoring, lo cual nos dara una matriz que nos tenemos que quedar con la segunda columna

rf_predict<-predict(rf,test,type = 'prob')[,2]

Vemos que pinta tiene

plot(rf_predict~test$TARGET_ABANDONO)

Con la función umbrales probamos diferentes cortes

umb_rf<-umbrales(test$TARGET_ABANDONO,rf_predict)
umb_rf

##    umbral  acierto precision cobertura       F1
## 1    0.05 68.68446  43.17522  86.43411 57.58554
## 2    0.10 74.21354  48.51720  79.26357 60.19132
## 3    0.15 76.59676  51.72891  72.48062 60.37127
## 4    0.20 77.97903  54.04192  69.96124 60.97973
## 5    0.25 78.93232  56.02606  66.66667 60.88496
## 6    0.30 79.07531  56.40599  65.69767 60.69830
## 7    0.35 79.69495  58.00712  63.17829 60.48237
## 8    0.40 80.36225  59.88593  61.04651 60.46065
## 9    0.45 80.40991  60.23392  59.88372 60.05831
## 10   0.50 80.50524  60.98563  57.55814 59.22233
## 11   0.55 80.45758  60.99585  56.97674 58.91784
## 12   0.60 81.12488  63.51351  54.65116 58.75000
## 13   0.65 81.31554  64.55399  53.29457 58.38641
## 14   0.70 81.36320  64.91647  52.71318 58.18182
## 15   0.75 80.12393  65.13761  41.27907 50.53381
## 16   0.80 79.98093  65.78947  38.75969 48.78049
## 17   0.85 79.55195  65.81818  35.07752 45.76485
## 18   0.90 79.79028  71.69811  29.45736 41.75824
## 19   0.95 79.50429  71.07843  28.10078 40.27778

Seleccionamos automáticamente el mejor umbral

umbral_final_rf<-umb_rf[which.max(umb_rf$F1),1]
umbral_final_rf

## [1] 0.2

Evaluamos la matriz de confusión y las métricas con el umbral optimizado

confusion(test$TARGET_ABANDONO,rf_predict,umbral_final_rf)

##     
## real FALSE TRUE
##    0  1275  307
##    1   155  361

rf_metricas<-filter(umb_rf,umbral==umbral_final_rf)
rf_metricas

##   umbral  acierto precision cobertura       F1
## 1    0.2 77.97903  54.04192  69.96124 60.97973

Evaluamos la ROC

#creamos el objeto prediction
rf_prediction<-prediction(rf_predict,test$TARGET_ABANDONO)
#visualizamos la ROC
roc(rf_prediction)

Sacamos las métricas definitivas incluyendo el AUC

rf_metricas<-cbind(rf_metricas,AUC=round(auc(rf_prediction),2)*100)
print(t(rf_metricas))

##               [,1]
## umbral     0.20000
## acierto   77.97903
## precision 54.04192
## cobertura 69.96124
## F1        60.97973
## AUC       84.00000

4.6 Evaluamos los 3 Modelos

comparativa <- rbind(rl_metricas,ar_metricas,rf_metricas)
rownames(comparativa) <- c('Regresion Logistica','Arbol Decision','Random Forest')
t(comparativa) #t simplemente transpone para leerlo mejor

##           Regresion Logistica Arbol Decision Random Forest
## umbral                0.35000        0.20000       0.20000
## acierto              78.74166       75.45281      77.97903
## precision            54.92958       50.06017      54.04192
## cobertura            75.58140       80.62016      69.96124
## F1                   63.62153       61.76689      60.97973
## AUC                  85.00000       82.00000      84.00000

Conclusión:

En general creo que la precisión alcanzada por los 3 modelos es bastante baja. Sinceramente consideraria que es un modelo medianamente bueno o no tan bueno, sin embargo creo que tampoco es malo, lo pondria en el medio, es un modelo “masomenos”.
Me quedare con el algortimo de regresión logistica por tener el mas alto AUC y la mejor precisión de los 3. De todas formas con los 3 algortimos los resultados han sido muy parecidos.

4.7 Calculamos los scores

Escribimos el scoring final en el dataset y guardamos el modelo

df$SCORING_ABANDONO <- predict(rl,df,type = 'response')
saveRDS(rl,'03_modelo_final.rds')

5. Evaluación y Análisis de Negocio

Vamos a visualizar la contratación real por tramos de scoring. Este gráfico es muy potente para ver que el modelo es consistente, ya que debe presentar una linea descendente en la tasa de contratación conforme se desciende en el scoring

#Creamos una función para visualizar la contratación real por percentiles de scoring
vis <- function(scoring,real) {
    #Preparar el dataframe de visualización
    vis_df <- data.frame(Scoring = scoring, Perc_Scoring = cut_number(scoring, 20), Real = real)
    levels(vis_df$Perc_Scoring) <- seq(from = 100,to = 5,by = -5)
    vis_gr <- vis_df %>% group_by(Perc_Scoring) %>% summarise(Tasa_Contr = mean(as.numeric(as.character(Real)))) %>% arrange(Perc_Scoring)
    #ordenar el factor para el gráfico
    vis_gr$Perc_Scoring <- factor(vis_gr$Perc_Scoring, levels = vis_gr$Perc_Scoring[order(vis_gr$Perc_Scoring, decreasing = T)])
    #hacemos el gráfico
    ggplot(vis_gr,aes(Perc_Scoring, Tasa_Contr)) + 
      geom_col(fill='grey') + 
      geom_hline(aes(yintercept =      mean(as.numeric(as.character(vis_df$Real)))), col = 'black') +
      labs(title = 'Abandono real por tramo de scoring', x = 'Tramo de Scoring', y = 'Abandono Real')
}
vis(df$SCORING_ABANDONO,df$TARGET_ABANDONO)

Conclusiones:

Por el degradado del grafico vemos que el modelo esta funcionando aparentemente bien
Vemos que los que tienen mas scoring son los que mas estan abandonando (churn)

¿Cópmo decidimos los clientes a los que lanzaremos una campaña para evitar el abandono?

Opción:

El tamaño de campaña viene definido por un criterio de negocio como por ejemplo el presupuesto total asignado a la campaña.

La empresa ha destinado a Marketing 2000 dolares para campañas de RETENCIÓN Y FIDELIZACIÓN DE CLIENTES. Cada persona tiene un coste de 2 dolares para que le llegue la campaña, eso nos permite contactar a 1000 clientes.

En este escenario es mejor utilizar el modelo que hemos desarrollado para no mandar la campaña al azar, o a toda mi base de 5000 clientes. Sino que aprovechar al maximo ya que solo tengo para llegar a 1000 clientes, de esta forma ya tengo predicho quienes tienen mas probabilidad de abandonar (chun)

tamaño_campaña <- 1000
bote_campaña <- df %>% 
  filter(TARGET_ABANDONO==1) %>% #En mi caso aca es uno porque queremos quedarnos con los que tengan la predicción de abandono (churn) ya que a esos esta dirigida mi campaña para retener o fidelizar.
  arrange(desc(SCORING_ABANDONO)) %>% 
  slice(1:tamaño_campaña) %>%
  select(ClienteID,SCORING_ABANDONO)
#Previsualizamos la salida
head(bote_campaña,50)

##     ClienteID SCORING_ABANDONO
## 1  0970-ETWGE        0.9224706
## 2  3027-ZTDHO        0.9224706
## 3  0107-YHINA        0.9224706
## 4  9497-QCMMS        0.9224706
## 5  3988-RQIXO        0.9224706
## 6  7216-EWTRS        0.9224706
## 7  3722-WPXTK        0.9224706
## 8  4910-GMJOT        0.9224706
## 9  2725-KXXWT        0.9224706
## 10 8149-RSOUN        0.9224706
## 11 5178-LMXOP        0.9224706
## 12 7274-RTAPZ        0.9224706
## 13 1455-ESIQH        0.9224706
## 14 3178-FESZO        0.9224706
## 15 9300-AGZNL        0.9224706
## 16 9725-SCPZG        0.9224706
## 17 1415-YFWLT        0.9224706
## 18 6521-YYTYI        0.9224706
## 19 5419-JPRRN        0.9224706
## 20 0295-PPHDO        0.9224706
## 21 6356-ELRKD        0.8910712
## 22 7181-BQYBV        0.8910712
## 23 0684-AOSIH        0.8910712
## 24 7294-TMAOP        0.8893569
## 25 6857-VWJDT        0.8893569
## 26 3801-HMYNL        0.8893569
## 27 5797-APWZC        0.8893569
## 28 9223-UCPVT        0.8893569
## 29 5919-TMRGD        0.8851795
## 30 5192-EBGOV        0.8851795
## 31 5494-HECPR        0.8851795
## 32 6567-HOOPW        0.8851795
## 33 3068-OMWZA        0.8851795
## 34 8580-AECUZ        0.8851795
## 35 9300-RENDD        0.8851795
## 36 2514-GINMM        0.8851795
## 37 0235-KGSLC        0.8851795
## 38 4826-XTSOH        0.8851795
## 39 1761-AEZZR        0.8851795
## 40 5960-WPXQM        0.8851795
## 41 5597-GLBUC        0.8851795
## 42 0318-QUUOB        0.8851795
## 43 8740-CRYFY        0.8851795
## 44 8058-INTPH        0.8851795
## 45 8821-XNHVZ        0.8851795
## 46 7503-ZGUZJ        0.8851795
## 47 9507-EXLTT        0.8851795
## 48 2202-CUYXZ        0.8851795
## 49 8775-LHDJH        0.8851795
## 50 5167-ZFFMM        0.8817180

#Vamos a ver gráficamente si de esta forma estamos aprovechando el potencial de nuestro modelo
penetracion_target <- mean(as.numeric(as.character(df$TARGET_ABANDONO)))
df %>% 
  arrange(desc(SCORING_ABANDONO)) %>% 
  ggplot(aes(y = SCORING_ABANDONO, x = seq_along(SCORING_ABANDONO))) +
  geom_line() + 
  geom_vline(xintercept = tamaño_campaña, col = 'orange') +
  geom_hline(yintercept = penetracion_target,col='blue') +
  labs(x = 'CLIENTES ORDENADOS POR SCORING', y = 'SCORING')

6. Conclusiones y consideraciones generales

Comunicar a la empresa que seria bueno volver a aplicar la metodologia nuevamente y enriquecer con variables historicas y de comportamiento del cliente, ya que con las variables proporcionadas nos ha salido un modelo de rendimiento mediano.
No esta mal invertir tiempo en un proyecto y no obtener las metricas esperadas. Hubieramos esperado un AUC >= 90 o un Rcuadrado de 0.80. Sin embargo, hemos podido rescatar “insights” muy valiosos para el negocio.
La metodología híbrida aplicada asegura el ahorro de muchas horas de trabajo y previene posibles errores en la modelización a traves de tecnicas como la discretización de variables.
Cada etapa tiene sus conclusiones propias que van reflejando la toma de decisiones en cada uno de las fases de la metodología

Modelo Predictivo de clientes con alta probabilidad de abandono

Alvaro Antonio Estrada Valderrama

24/10/2024

Requerimiento de negocio

Metodología

1. Importación y Muestreo

1.1 Preparación del Entorno

1.2 Importación del conjunto de datos

2. Calidad de datos

2.1 Exploración general

2.2 Estadisticos básicos

2.3 Análisis de nulos

2.4 Análisis de ceros

2.5 Análisis de atípicos

2.6 Análisis longitudinal

2.7 Ejecutar acciones concluidas de la fase de calidad de datos

3. Transformación

3.1 Creación de la variable Target

3.2 Variables predictoras

3.3 Preselección de variables

3.4 Creación de variables Sintéticas

3.5 Limpieza de variables

3.6 Discretización

3.7 Validaciónes

4. Modelización

4.1 Crear funciones de apoyo

4.2 Partición del conjunto de datos (Train y Test)

4.3 Modelización con Regresión Logistica

4.4 Modelización con Árboles de decisión

4.5 Modelización con Random Forest

4.6 Evaluamos los 3 Modelos

4.7 Calculamos los scores

5. Evaluación y Análisis de Negocio

6. Conclusiones y consideraciones generales