INTRODUCCIÓN

Una empresa de telecomunicaciones ha pedido que se haga un estudio sobre el abandono de sus clientes.

Para ello, nos ha facilitado un archivo donde recoge a sus clientes y los productos-características que poseen con la compañía.

Se van a realizar distintos modelos empleando Machine Learning para conocer la raiz del abandono y poder ayudarla.

1.- IMPORTACIÓN Y MUESTREO

Preparación del entorno

Eliminación de la notación cientifica

options(scipen=999)

Se cargan e instalan las librerias

paquetes<- c('data.table',
             'dplyr',
             'tidyr',
             'ggplot2',
             'randomForest',
             'ROCR',
             'purrr',
             'smbinning',
             'rpart',
             'rpart.plot',
             'h2o',
             'faraway')
instalados<-paquetes%in%installed.packages()
if(sum(instalados==FALSE)>0){
  install.packages(paquetes[!instalados])
}
lapply(paquetes,require,character.only=TRUE)

Se cargan los datos en un df

df<-fread('Telco_Customer_Churn.csv')

2.- ANÁLISIS EXPLORATORIO

Análisis exploratorio general

Se van a arealizar las siguientes acciones:

Conocer el nombre de las variables
Tipología de las variables y una muestra de los valores que la conforman
Comprobar si la variable objetivo Churn, está balanceada

names(df)

##  [1] "customerID"       "gender"           "SeniorCitizen"    "Partner"         
##  [5] "Dependents"       "tenure"           "PhoneService"     "MultipleLines"   
##  [9] "InternetService"  "OnlineSecurity"   "OnlineBackup"     "DeviceProtection"
## [13] "TechSupport"      "StreamingTV"      "StreamingMovies"  "Contract"        
## [17] "PaperlessBilling" "PaymentMethod"    "MonthlyCharges"   "TotalCharges"    
## [21] "Churn"

glimpse(df)

## Rows: 7,043
## Columns: 21
## $ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CF...
## $ gender           <chr> "Female", "Male", "Male", "Male", "Female", "Femal...
## $ SeniorCitizen    <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ Partner          <chr> "Yes", "No", "No", "No", "No", "No", "No", "No", "...
## $ Dependents       <chr> "No", "No", "No", "No", "No", "No", "Yes", "No", "...
## $ tenure           <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, 49...
## $ PhoneService     <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", "No...
## $ MultipleLines    <chr> "No phone service", "No", "No", "No phone service"...
## $ InternetService  <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fiber ...
## $ OnlineSecurity   <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Yes"...
## $ OnlineBackup     <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "No",...
## $ DeviceProtection <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "No",...
## $ TechSupport      <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", "...
## $ Contract         <chr> "Month-to-month", "One year", "Month-to-month", "O...
## $ PaperlessBilling <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", "No...
## $ PaymentMethod    <chr> "Electronic check", "Mailed check", "Mailed check"...
## $ MonthlyCharges   <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 2...
## $ TotalCharges     <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50, 1...
## $ Churn            <chr> "No", "No", "Yes", "No", "Yes", "Yes", "No", "No",...

table(df$Churn)#Se comprueba si la variable target está bien balanceada

## 
##   No  Yes 
## 5174 1869

Gracias a este análisis inicial, se extraen las siguientes conclusiones:

Existen variables que tienen que transformarse de character a factor, hay que dividirlas en niveles
La variable Monthly Charge y la de Total Charges están relacionadas entre sí
La variable Senior Citizen diferencia a clientes menores de 65 años y mayores de 65 años
La variable Partner determina si en el hogar del cliente conviven niñ@s
La variable Churn (target) está balanceada en un 26,5% de Yes

Calidad de datos

Se realizarán una serie de análisis:

Estadísticos básicos
Análisis de nulos
Análisis de ceros
Análisis de atípicos

Estadísticos básicos

lapply(df,summary)

## $customerID
##    Length     Class      Mode 
##      7043 character character 
## 
## $gender
##    Length     Class      Mode 
##      7043 character character 
## 
## $SeniorCitizen
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.0000  0.0000  0.0000  0.1621  0.0000  1.0000 
## 
## $Partner
##    Length     Class      Mode 
##      7043 character character 
## 
## $Dependents
##    Length     Class      Mode 
##      7043 character character 
## 
## $tenure
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00    9.00   29.00   32.37   55.00   72.00 
## 
## $PhoneService
##    Length     Class      Mode 
##      7043 character character 
## 
## $MultipleLines
##    Length     Class      Mode 
##      7043 character character 
## 
## $InternetService
##    Length     Class      Mode 
##      7043 character character 
## 
## $OnlineSecurity
##    Length     Class      Mode 
##      7043 character character 
## 
## $OnlineBackup
##    Length     Class      Mode 
##      7043 character character 
## 
## $DeviceProtection
##    Length     Class      Mode 
##      7043 character character 
## 
## $TechSupport
##    Length     Class      Mode 
##      7043 character character 
## 
## $StreamingTV
##    Length     Class      Mode 
##      7043 character character 
## 
## $StreamingMovies
##    Length     Class      Mode 
##      7043 character character 
## 
## $Contract
##    Length     Class      Mode 
##      7043 character character 
## 
## $PaperlessBilling
##    Length     Class      Mode 
##      7043 character character 
## 
## $PaymentMethod
##    Length     Class      Mode 
##      7043 character character 
## 
## $MonthlyCharges
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   18.25   35.50   70.35   64.76   89.85  118.75 
## 
## $TotalCharges
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##    18.8   401.4  1397.5  2283.3  3794.7  8684.8      11 
## 
## $Churn
##    Length     Class      Mode 
##      7043 character character

Se observa lo siguiente:

Existen muchas variables categóricas en formato carácter que conviene transformar para ver su distribución
En la variable Total Charges existen 11 valores nulos NA´s

Análisis de nulos

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

##                  colSums.is.na.df..
## customerID                        0
## gender                            0
## SeniorCitizen                     0
## Partner                           0
## Dependents                        0
## tenure                            0
## PhoneService                      0
## MultipleLines                     0
## InternetService                   0
## OnlineSecurity                    0
## OnlineBackup                      0
## DeviceProtection                  0
## TechSupport                       0
## StreamingTV                       0
## StreamingMovies                   0
## Contract                          0
## PaperlessBilling                  0
## PaymentMethod                     0
## MonthlyCharges                    0
## TotalCharges                     11
## Churn                             0

df<-na.omit(df)

Se vuelve a averiguar si además de los 11 NA´s existen en otras variables. Lo cierto es que no.

Como son solo 11 clientes frente a los 7043 totales, se decide eliminarlos del df

Análisis de ceros

#Se va a crear la función para contar los ceros de las variables
contar_ceros <- function(variable){
  temp<-transmute(df,if_else(variable==0,1,0))
  sum(temp)
}
num_ceros<-sapply(df,contar_ceros)#Con sapply se aplica al df completamente
num_ceros<-data.frame(VARIABLE=names(num_ceros),CEROS=as.numeric(num_ceros),stringsAsFactors=F)
num_ceros

##            VARIABLE CEROS
## 1        customerID     0
## 2            gender     0
## 3     SeniorCitizen  5890
## 4           Partner     0
## 5        Dependents     0
## 6            tenure     0
## 7      PhoneService     0
## 8     MultipleLines     0
## 9   InternetService     0
## 10   OnlineSecurity     0
## 11     OnlineBackup     0
## 12 DeviceProtection     0
## 13      TechSupport     0
## 14      StreamingTV     0
## 15  StreamingMovies     0
## 16         Contract     0
## 17 PaperlessBilling     0
## 18    PaymentMethod     0
## 19   MonthlyCharges     0
## 20     TotalCharges     0
## 21            Churn     0

Se puede observar que existe un gran porcentaje de ceros en la variable Senior Citizen. Esto es normal, ya que esta variable hace referencia a aquellos clientes que tienen más de 65 años. Como se trata de una compañía de telecomunicaciones, es lógico que el porcentaje de clientes menores de 65 años sea superior que el de mayores.

No se realizará ninguna acción al respecto

Análisis de atípicos

Se estudiarán dos tipos de variables:

Tipología double
Tipología integer

Variables double

Se creará una función que se encargará de mostrar los 35 valores mayores de aquellas variables doubles y comprobar que el valor decrece gradualmente y no existen grandes saltos

out<-function(variable){
  t(t(head(sort(variable,decreasing=T),35)))
}
lapply(df,function(x){
  if(is.double(x))out(x)
})

## $customerID
## NULL
## 
## $gender
## NULL
## 
## $SeniorCitizen
## NULL
## 
## $Partner
## NULL
## 
## $Dependents
## NULL
## 
## $tenure
## NULL
## 
## $PhoneService
## NULL
## 
## $MultipleLines
## NULL
## 
## $InternetService
## NULL
## 
## $OnlineSecurity
## NULL
## 
## $OnlineBackup
## NULL
## 
## $DeviceProtection
## NULL
## 
## $TechSupport
## NULL
## 
## $StreamingTV
## NULL
## 
## $StreamingMovies
## NULL
## 
## $Contract
## NULL
## 
## $PaperlessBilling
## NULL
## 
## $PaymentMethod
## NULL
## 
## $MonthlyCharges
##         [,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
## [21,] 116.50
## [22,] 116.45
## [23,] 116.40
## [24,] 116.30
## [25,] 116.25
## [26,] 116.25
## [27,] 116.25
## [28,] 116.20
## [29,] 116.15
## [30,] 116.10
## [31,] 116.10
## [32,] 116.05
## [33,] 116.05
## [34,] 116.05
## [35,] 116.00
## 
## $TotalCharges
##          [,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
## [21,] 8404.90
## [22,] 8399.15
## [23,] 8375.05
## [24,] 8349.70
## [25,] 8349.45
## [26,] 8337.45
## [27,] 8333.95
## [28,] 8332.15
## [29,] 8331.95
## [30,] 8317.95
## [31,] 8312.75
## [32,] 8312.40
## [33,] 8310.55
## [34,] 8309.55
## [35,] 8308.90
## 
## $Churn
## NULL

Solo existen dos variables double Monthly Charges y Total Charges, donde se observa en ambas que los variables decrecen gradualmente.

Variables integer

Se creará una función que se encargará de mostrar los valores que toman a aquellas variables integer y comprobar como se distribuyen

out<-function(variable){
  t(t(table(variable)))
}
lapply(df,function(x){
  if(is.integer(x))out(x)
})

## $customerID
## NULL
## 
## $gender
## NULL
## 
## $SeniorCitizen
##         
## variable [,1]
##        0 5890
##        1 1142
## 
## $Partner
## NULL
## 
## $Dependents
## NULL
## 
## $tenure
##         
## variable [,1]
##       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
## 
## $PhoneService
## NULL
## 
## $MultipleLines
## NULL
## 
## $InternetService
## NULL
## 
## $OnlineSecurity
## NULL
## 
## $OnlineBackup
## NULL
## 
## $DeviceProtection
## NULL
## 
## $TechSupport
## NULL
## 
## $StreamingTV
## NULL
## 
## $StreamingMovies
## NULL
## 
## $Contract
## NULL
## 
## $PaperlessBilling
## NULL
## 
## $PaymentMethod
## NULL
## 
## $MonthlyCharges
## NULL
## 
## $TotalCharges
## NULL
## 
## $Churn
## NULL

La variable tenure, es la única tipo integer. Recoge la permanencia de cada cliente en la compañía, contabilizado en meses. De ella se extrae lo siguiente:

Se observa un gran número de clientes en el mes 1–> 613. Esto se puede deber a clientes que han empezado un mes antes de la adquisición de datos y de clientes que solo usan contratos de un mes de duración
Se observa un gran número de contratos en el mes 72, es el valor máximo–> 362, esto se puede dar porque, la empresa abrió hace 72 meses o porque empezaron a realizar la captación de datos hace 72 meses.

Preselección de variables

Se genera una lista donde se recogen las variables que se van a convertir a factor para continuar con la creación del modelo

a_factor<-(c('gender','Partner','Dependents','PhoneService','MultipleLines','InternetService','OnlineSecurity','OnlineBackup','DeviceProtection','TechSupport','StreamingTV','StreamingMovies','Contract','PaperlessBilling','PaymentMethod','Churn'))

Conclusiones

Como ya se intuyó previamente, se observan dos grandes concentraciones en los meses 1 y 72, debido, tanto a los contratos de un mes y por el comienzo de la toma de datos hace 72 meses.

hist(df$tenure,breaks=50)

Total Charges = MontlyCharges*tenure, por lo tanto existen 2 variables que están dando la misma información, Total Charges y MontlyCharges. Lo que se va hacer es eliminar Total Charges y mantener MontlyCharges

df$TotalCharges<-NULL

Se crea una copia del df ahora para emplearlo posteriormente en el Information Value

df1<-df

Se pasan las variables preseleccionadas a factor y a parte se pasa Senior Citizen a factor también. Senior Citizen se hace por separado porque su transformación a factor será diferente que las de a_factor de la lista:

df<-df%>%
  mutate_at(a_factor,.funs=factor)

df <- df%>%
  mutate(SeniorCitizen=as.factor(as.character(SeniorCitizen)))#Se emplea as.character para que los valores sean 0 y 1 al pasarlos a factor y no se transformen en 1 y 2
glimpse(df)# Se observa el resultado de los cambios.

## Rows: 7,032
## Columns: 20
## $ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CF...
## $ gender           <fct> Female, Male, Male, Male, Female, Female, Male, Fe...
## $ SeniorCitizen    <fct> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ Partner          <fct> Yes, No, No, No, No, No, No, No, Yes, No, Yes, No,...
## $ Dependents       <fct> No, No, No, No, No, No, Yes, No, No, Yes, Yes, No,...
## $ tenure           <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, 49...
## $ PhoneService     <fct> No, Yes, Yes, No, Yes, Yes, Yes, No, Yes, Yes, Yes...
## $ MultipleLines    <fct> No phone service, No, No, No phone service, No, Ye...
## $ InternetService  <fct> DSL, DSL, DSL, DSL, Fiber optic, Fiber optic, Fibe...
## $ OnlineSecurity   <fct> No, Yes, Yes, Yes, No, No, No, Yes, No, Yes, Yes, ...
## $ OnlineBackup     <fct> Yes, No, Yes, No, No, No, Yes, No, No, Yes, No, No...
## $ DeviceProtection <fct> No, Yes, No, Yes, No, Yes, No, No, Yes, No, No, No...
## $ TechSupport      <fct> No, No, No, Yes, No, No, No, No, Yes, No, No, No i...
## $ StreamingTV      <fct> No, No, No, No, No, Yes, Yes, No, Yes, No, No, No ...
## $ StreamingMovies  <fct> No, No, No, No, No, Yes, No, No, Yes, No, No, No i...
## $ Contract         <fct> Month-to-month, One year, Month-to-month, One year...
## $ PaperlessBilling <fct> Yes, No, Yes, No, Yes, Yes, Yes, No, Yes, No, Yes,...
## $ PaymentMethod    <fct> Electronic check, Mailed check, Mailed check, Bank...
## $ MonthlyCharges   <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 2...
## $ Churn            <fct> No, No, Yes, No, Yes, Yes, No, No, Yes, No, No, No...

3.- TRANSFORMACIÓN DE DATOS

En esta fase se van a realizar tres funciones

Preparar las variables independientes
Estudiar dichas variables empleando dos métodos:
- RandomForest
- Information Value –> Posee un comportamiento lineal
Comparar los resulados de ambos métodos y hacer la selección final de variables

Preparación de las variables independientes

Las variables independientes son aquellas distintas a la variable target (Churn) y a la identidad del cliente CustomerID. Esta lista se empleará en Random Forest

ind_larga<-names(df) #Lista con los nombres de todas las variables
no_usar<- c('customerID','Churn') #No se van a usar ni codigo de cliente ni la target
ind_larga<-setdiff(ind_larga,no_usar)
ind_larga

##  [1] "gender"           "SeniorCitizen"    "Partner"          "Dependents"      
##  [5] "tenure"           "PhoneService"     "MultipleLines"    "InternetService" 
##  [9] "OnlineSecurity"   "OnlineBackup"     "DeviceProtection" "TechSupport"     
## [13] "StreamingTV"      "StreamingMovies"  "Contract"         "PaperlessBilling"
## [17] "PaymentMethod"    "MonthlyCharges"

Se crea una copia del entorno para poder empezar desde este punto

save.image(file='sesion1.RData')

Para poder cargar la copia

load(file='sesion1.RData')

Preselección con RandomForest

El número de variables que cogerá de todas las disponibles será de 1, para poder obtener la mejor correlación entre RandomForest e Information Value

#Es necesario que la variable target esté en formato factor
pre_rf<-randomForest(formula=reformulate(ind_larga,'Churn'),data=df,mtry=1,ntree=400,importance=T)
imp_rf<-importance(pre_rf)[,4]
imp_rf<-data.frame(VARIABLE=names(imp_rf),IMP_RF=imp_rf)
imp_rf<-imp_rf %>% arrange(desc(IMP_RF))%>%mutate(RANKING_RF=1:nrow(imp_rf))
imp_rf

##            VARIABLE    IMP_RF RANKING_RF
## 1            tenure 96.038525          1
## 2          Contract 83.867210          2
## 3    OnlineSecurity 53.237058          3
## 4     PaymentMethod 53.062017          4
## 5       TechSupport 52.475725          5
## 6    MonthlyCharges 48.739955          6
## 7   InternetService 45.987713          7
## 8      OnlineBackup 35.862334          8
## 9  DeviceProtection 28.771429          9
## 10      StreamingTV 20.148713         10
## 11 PaperlessBilling 19.616590         11
## 12  StreamingMovies 16.647544         12
## 13          Partner 14.701871         13
## 14    SeniorCitizen 14.209303         14
## 15       Dependents 13.775019         15
## 16    MultipleLines  8.248059         16
## 17           gender  3.745664         17
## 18     PhoneService  2.889389         18

Preselección con Information Value (IV)

Tal y como está el df actualmente, no es posible la realización del estudio sobre él.

Como estos cambios se emplearán exclusivamente para IV, se utilizará la copia del data frame llamada df1, asegurando que el df original seguirá intacto.

Transformación de carácter a número

Como se expuso antes, existen muchas variables categóricas en formato texto. Para poder realizar el estudio de IV, es necesario asignar un valor numérico a aquellos valores que conforman dichas variables y transformar estos valores a factor.

#Transformación de variables character con dos niveles
df1<-df1 %>%
  mutate(gender=ifelse((gender=="Male"),1,0),
         Partner=ifelse((Partner=="Yes"),1,0),
         Dependents=ifelse((Dependents=="Yes"),1,0),
         PhoneService=ifelse((PhoneService=="Yes"),1,0),
         PaperlessBilling=ifelse((PaperlessBilling=="Yes"),1,0),
         Churn=ifelse((Churn=="No"),0,1))%>%
  mutate(gender=as.factor(as.character(gender)),
         Partner=as.factor(as.character(Partner)),
         Dependents=as.factor(as.character(Dependents)),
         PhoneService=as.factor(as.character(PhoneService)),
         PaperlessBilling=as.factor(as.character(PaperlessBilling)),
         Churn=as.factor(as.character(Churn)))


#Transformación de variables character con tres o más niveles
df1<-df1 %>%
  mutate(InternetService=ifelse((InternetService=="No"),0,ifelse((InternetService=="DSL"),1,2)),
         OnlineSecurity=ifelse((OnlineSecurity=="No"),0,ifelse((OnlineSecurity=="Yes"),1,2)),
         OnlineBackup=ifelse((OnlineBackup=="No"),0,ifelse((OnlineBackup=="Yes"),1,2)),
         DeviceProtection=ifelse((DeviceProtection=="No"),0,ifelse((DeviceProtection=="Yes"),1,2)),
         TechSupport=ifelse((TechSupport=="No"),0,ifelse((TechSupport=="Yes"),1,2)),
         StreamingTV=ifelse((StreamingTV=="No"),0,ifelse((StreamingTV=="Yes"),1,2)),
         StreamingMovies=ifelse((StreamingMovies=="No"),0,ifelse((StreamingMovies=="Yes"),1,2)),
         Contract=ifelse((Contract=="Month-to-month"),1,ifelse((Contract=="One year"),2,3)),
         MultipleLines=ifelse((MultipleLines=="No"),0,ifelse((MultipleLines=="Yes"),1,2)),
         PaymentMethod=ifelse((PaymentMethod=="Electronic check"),1,ifelse((PaymentMethod == "Mailed check"),2,ifelse((PaymentMethod=="Bank transfer (automatic)"),3,4))))%>%
  mutate(InternetService=as.factor(as.character(InternetService)),
         OnlineSecurity=as.factor(as.character(OnlineSecurity)),
         OnlineBackup=as.factor(as.character(OnlineBackup)),
         DeviceProtection=as.factor(as.character(DeviceProtection)),
         TechSupport=as.factor(as.character(TechSupport)),
         StreamingTV=as.factor(as.character(StreamingTV)),
         StreamingMovies=as.factor(as.character(StreamingMovies)),
         Contract=as.factor(as.character(Contract)),
         MultipleLines=as.factor(as.character(MultipleLines)),
         PaymentMethod=as.factor(as.character(PaymentMethod)),)
df1$SeniorCitizen <- df$SeniorCitizen
glimpse(df1)

## Rows: 7,032
## Columns: 20
## $ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CF...
## $ gender           <fct> 0, 1, 1, 1, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0,...
## $ SeniorCitizen    <fct> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ Partner          <fct> 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0,...
## $ Dependents       <fct> 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0,...
## $ tenure           <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, 49...
## $ PhoneService     <fct> 0, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ MultipleLines    <fct> 2, 0, 0, 2, 0, 1, 1, 2, 1, 0, 0, 0, 1, 1, 0, 1, 0,...
## $ InternetService  <fct> 1, 1, 1, 1, 2, 2, 2, 1, 2, 1, 1, 0, 2, 2, 2, 2, 0,...
## $ OnlineSecurity   <fct> 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 2, 0, 0, 1, 1, 2,...
## $ OnlineBackup     <fct> 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 2, 0, 1, 0, 1, 2,...
## $ DeviceProtection <fct> 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 1, 2,...
## $ TechSupport      <fct> 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 1, 1, 2,...
## $ StreamingTV      <fct> 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 2, 1, 1, 1, 1, 2,...
## $ StreamingMovies  <fct> 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 1, 2,...
## $ Contract         <fct> 1, 2, 1, 2, 1, 1, 1, 1, 1, 2, 1, 3, 2, 1, 1, 3, 2,...
## $ PaperlessBilling <fct> 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0,...
## $ PaymentMethod    <fct> 1, 2, 2, 3, 1, 1, 4, 2, 1, 3, 2, 4, 4, 3, 1, 4, 2,...
## $ MonthlyCharges   <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 2...
## $ Churn            <fct> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0,...

Una vez transformado df1, se aplica IV

#Para poder aplicar el IV es necesario pasar la target a numeric. Antes de transformarla en numeric, se transformará en character, para que mantenga el formato 0 y 1 y no se pase como 1 y 2. Esto se hace porque para calcular el IV con smbinning.sumiv, es necesario que esté en numérico
temp <- mutate(df1,Churn = as.numeric(as.character(Churn))) %>% as.data.frame()#as.data.frame es por estética
imp_iv<-smbinning.sumiv(temp[c(ind_larga,'Churn')],y="Churn")
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')
imp_iv

##            VARIABLE IMP_IV RANKING_IV
## 1          Contract 1.2332          1
## 2            tenure 0.8773          2
## 3    OnlineSecurity 0.7153          3
## 4       TechSupport 0.6971          4
## 5   InternetService 0.6152          5
## 6      OnlineBackup 0.5265          6
## 7  DeviceProtection 0.4976          7
## 8    MonthlyCharges 0.4824          8
## 9     PaymentMethod 0.4557          9
## 10  StreamingMovies 0.3799         10
## 11      StreamingTV 0.3787         11
## 12 PaperlessBilling 0.2020         12
## 13       Dependents 0.1532         13
## 14          Partner 0.1179         14
## 15    SeniorCitizen 0.1051         15
## 16    MultipleLines 0.0081         16
## 17     PhoneService 0.0007         17
## 18           gender 0.0004         18

Ranking Final

Para poder hacer la selección final, se van a enfrentar los resultados de ambos estudios en un ranking final.

##            VARIABLE    IMP_RF IMP_IV RANKING_RF RANKING_IV RANKING_TOT
## 1            tenure 96.038525 0.8773          1          2           1
## 2          Contract 83.867210 1.2332          2          1           2
## 3    OnlineSecurity 53.237058 0.7153          3          3           3
## 4     PaymentMethod 53.062017 0.4557          4          9           4
## 5       TechSupport 52.475725 0.6971          5          4           5
## 6    MonthlyCharges 48.739955 0.4824          6          8           6
## 7   InternetService 45.987713 0.6152          7          5           7
## 8      OnlineBackup 35.862334 0.5265          8          6           8
## 9  DeviceProtection 28.771429 0.4976          9          7           9
## 10      StreamingTV 20.148713 0.3787         10         11          10
## 11 PaperlessBilling 19.616590 0.2020         11         12          11
## 12  StreamingMovies 16.647544 0.3799         12         10          12
## 13          Partner 14.701871 0.1179         13         14          13
## 14    SeniorCitizen 14.209303 0.1051         14         15          14
## 15       Dependents 13.775019 0.1532         15         13          15
## 16    MultipleLines  8.248059 0.0081         16         16          16
## 17           gender  3.745664 0.0004         17         18          17
## 18     PhoneService  2.889389 0.0007         18         17          18

Del ranking se van a seleccionar las 9 primeras variables, por dos motivos:

Ambos métodos las contemplan como importantes.
La significación para IV es superior o muy cerca de 0.5
Además, la correlación entre ambos métodos es alta: 0.9228053

Una vez concluido esto, se aplican los cambios al df para la próxima fase.

ind_corta<- c('tenure','Contract','OnlineSecurity','PaymentMethod','MonthlyCharges','TechSupport','InternetService','OnlineBackup','DeviceProtection')
df$Churn<-df1$Churn
df<-df%>%
  select(c(one_of(ind_corta),Churn,customerID))

Limpieza del entorno

Definido el nuevo estado del df, se va a proceder a la limpieza del entorno

ls()
rm(list=setdiff(ls(),'df'))
target<-'Churn'
indep<-setdiff(names(df),c('Churn','customerID'))

Y se va a guardar una caché, cache1 para poder partir desde este punto.

saveRDS(df,'cache1.rds')

Para poder cargar dicha caché:

df <- readRDS(file = 'cache1.rds')
df1 <- readRDS(file='cache1.rds')

4.- CREACIÓN DE VARIABLES SINTÉTICAS

En este modelo, las variables carecen de histórico, es decir, no se diferencian por meses, solo representan el ahora.

Debido a eso, no se podrán crear ni tenencias, ni tendencias, ni cancelaciones, ni contrataciones ni medias.

La única tipología de variable sintética que se puede aplicar es la discretización.

Discretización

La discretización consiste en dividir cada variable en distintos escalones en función de la penetración de cada escalón en la variable target.

Dicha penetración se debe caracterizar por dos motivos:

Que sea similar a la penetración de la variable original
Que presente un comportamiento monotónico, es decir, a medida que se avanza en la variable, esta siempre crece o siempre decrece.

Existen dos tipos de discretizaciones:

Discretización automática –> Monthly Charges y tenure
Discretización manual –> Contract, Online Security, Payment Method, Tech Support, Internet Service, Online Backup y Device Protection

Discretización automática

Para la discretización automática, se va a crear una función

discretizar <- function (vi,target){ #vi es variuable independiente
  df_temp <- data.frame(vi=vi,target=target)
  df_temp$target <- as.numeric(as.character((df_temp$target)))#smbinning necesita que la target esté en formato numérico
  disc <- smbinning(df_temp,y='target',x='vi')
  return(disc)
}

Se aplica dicha función

#Se discretiza tenure
disc_temp_tenure <- discretizar(df$tenure,df$Churn)
df_temp <- select(df,tenure,Churn)
df_temp <- smbinning.gen(df_temp,disc_temp_tenure,chrname='tenure_disc')
df<- cbind(df,df_temp[,3]) %>% select(-tenure)

#Se discretiza MonthlyCharges
disc_temp_MonthlyCharges <- discretizar(df$MonthlyCharges,df$Churn)
df_temp <- select(df,MonthlyCharges,Churn)
df_temp <- smbinning.gen(df_temp,disc_temp_MonthlyCharges,chrname='MonthlyCharges_disc')
df<- cbind(df,df_temp[,3])%>% select(-MonthlyCharges)

Discretización manual

Conforme se discretizan las variables, se van borrando las originales

#Contract
df <- df%>%
  mutate(Contract_disc=as.factor(case_when(
    Contract=='Month-to-month'~'01_Month_to_month',
    Contract=='One year'~'02_One_year',
    Contract=='Two year'~'03_Two_year',
    TRUE ~ '00_ERROR'
  )))
df$Contract<-NULL

#OnlineSecurity
df <- df%>%
  mutate(OnlineSecurity_disc=as.factor(case_when(
    OnlineSecurity=='No'~'01_No',
    OnlineSecurity=='Yes'~'02_Yes',
    OnlineSecurity=='No internet service'~'03_No_internet_service',
    TRUE ~ '00_ERROR'
  )))
df$OnlineSecurity<-NULL

#TechSupport
df <- df%>%
  mutate(TechSupport_disc=as.factor(case_when(
    TechSupport=='No'~'01_No',
    TechSupport=='Yes'~'02_Yes',
    TechSupport=='No internet service'~'03_No_internet_service',
    TRUE ~ '00_ERROR'
  )))
df$TechSupport<-NULL

#InternetService
df <- df%>%
  mutate(InternetService_disc=as.factor(case_when(
    InternetService=='No'~'01_No',
    InternetService=='DSL'~'02_DSL',
    InternetService=='Fiber optic'~'03_Fiber_optic',
    TRUE ~ '00_ERROR'
  )))
df$InternetService<-NULL

#PaymentMethod
df <- df%>%
  mutate(PaymentMethod_disc=as.factor(case_when(
    PaymentMethod=='Electronic check'~'01_Electronic_check',
    PaymentMethod=='Mailed check'~'02_Mailed_check',
    PaymentMethod=='Bank transfer (automatic)'~'03_Bank_transfer',
    PaymentMethod=='Credit card (automatic)'~'04_Credit_card',
    TRUE ~ '00_ERROR'
  )))
df$PaymentMethod<-NULL

#OnlineBackup
df <- df%>%
  mutate(OnlineBackup_disc=as.factor(case_when(
    OnlineBackup=='No'~'01_No',
    OnlineBackup=='Yes'~'02_Yes',
    OnlineBackup=='No internet service'~'03_No_internet_service',
    TRUE ~ '00_ERROR'
  )))
df$OnlineBackup<-NULL

#DeviceProtection
df <- df%>%
  mutate(DeviceProtection_disc=as.factor(case_when(
    DeviceProtection=='No'~'01_No',
    DeviceProtection=='Yes'~'02_Yes',
   DeviceProtection=='No internet service'~'03_No_internet_service',
    TRUE ~ '00_ERROR'
  )))
df$DeviceProtection<-NULL

Estudio de las discretizaciones

Se crea una función para la representación de la penetración sobre la variable target

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) + ggtitle("                                                   Penetración")
}
df2_nombres <- df %>% select_if(is.factor) %>% names()
graficos<-lapply(df2_nombres,function(x){a(x,'Churn')})

Se van a visualizar las distintas variables

Contract_disc

ggplot(df,aes(Contract_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[4]]

OnlineSecurity_disc

ggplot(df,aes(OnlineSecurity_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[5]]

TechSupport_disc

ggplot(df,aes(TechSupport_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[6]]

InternetService_disc

ggplot(df,aes(InternetService_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[7]]

PaymentMethod_disc

ggplot(df,aes(PaymentMethod_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[8]]

OnlineBackup_disc

ggplot(df,aes(OnlineBackup_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[9]]

DeviceProtection_disc

ggplot(df,aes(DeviceProtection_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[10]]

Tenure_disc

ggplot(df,aes(tenure_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[2]]

MonthlyCharges_disc

ggplot(df,aes(MonthlyCharges_disc))+geom_bar()+theme(axis.text=element_text(size=10))+ggtitle("                                                 Distribución")

graficos[[3]]

Conclusiones

Todas las variables discretizadas se comportan de forma monotónica en la penetración, excepto Monthly Charges. Hay que realizar por lo tanto una discretización manual de esta variable

Discretización manual 2ª etapa

Monthly Charges

Se realiza un gráfico de densidad. Es necesario recuperar la variable Monthly Charges antes de la discretización.

df$MonthlyCharges <- df1$MonthlyCharges
ggplot(df,aes(MonthlyCharges))+geom_density()+scale_x_continuous(limits=c(0,120))

Se observan grandes concentraciones sobre el valor 20 y sobre el valor 80. Esto se tomará en cuenta a la hora de hacer los cortes. Quedando el resultado tal que así

df <- df %>% mutate(MonthlyCharges_disc=as.factor(case_when(
  between(MonthlyCharges,-Inf,50) ~ '01_MENOR_50',
  between(MonthlyCharges,50,63) ~ '02_DE_50_A_63',
  between(MonthlyCharges,63,75) ~ '03_DE_63_A_75',
  between(MonthlyCharges,75,Inf) ~ '04_MAYOR_75',
  TRUE ~ 'ERROR'
)))
graficos<-lapply(df2_nombres,function(x){a(x,'Churn')})
graficos[[3]]

df$MonthlyCharges<-NULL

Ahora si que se comporta de forma monotónica.

Limpieza del entorno y preparación de la caché 2

Se observa el estado del df

glimpse(df)

## Rows: 7,032
## Columns: 11
## $ Churn                 <fct> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, ...
## $ customerID            <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "77...
## $ tenure_disc           <fct> 01 <= 1, 05 <= 49, 02 <= 5, 05 <= 49, 02 <= 5...
## $ MonthlyCharges_disc   <fct> 01_MENOR_50, 02_DE_50_A_63, 02_DE_50_A_63, 01...
## $ Contract_disc         <fct> 01_Month_to_month, 02_One_year, 01_Month_to_m...
## $ OnlineSecurity_disc   <fct> 01_No, 02_Yes, 02_Yes, 02_Yes, 01_No, 01_No, ...
## $ TechSupport_disc      <fct> 01_No, 01_No, 01_No, 02_Yes, 01_No, 01_No, 01...
## $ InternetService_disc  <fct> 02_DSL, 02_DSL, 02_DSL, 02_DSL, 03_Fiber_opti...
## $ PaymentMethod_disc    <fct> 01_Electronic_check, 02_Mailed_check, 02_Mail...
## $ OnlineBackup_disc     <fct> 02_Yes, 01_No, 02_Yes, 01_No, 01_No, 01_No, 0...
## $ DeviceProtection_disc <fct> 01_No, 02_Yes, 01_No, 02_Yes, 01_No, 02_Yes, ...

Se limpia el entorno

ls()
rm(list=setdiff(ls(),'df'))

Se crea la caché 2

saveRDS(df,'cache2.rds')

Se carga la caché 2

df <- readRDS(file = 'cache2.rds')

Una vez preparado todo esto, se puede empezar la modelización

5.- MODELIZACIÓN

A la hora de la creación del modelo se va a emplear:

Modelización manual –> Regresión logística, árboles de decisión y RandomForest
Modelización automática –> H2O

Modelización manual

Se van a crear las funciones de:

Matriz confusión
Métricas
Umbrales
ROC
AUC

#Matriz de confusión
confusion <- function (real,scoring,umbral){
  conf <- table(real,scoring>=umbral)
  if(ncol(conf)==2)return(conf) else return (NULL)
}

#Metricas
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)
}

#Umbrales
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)
}

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

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

Para la hora de la creación de los modelos, es necesario dividir el data frame en dos partes:

Train o entrenamiento –> 70% del df
Test o comprobación –> 30% del df

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

Se definen las variables tanto independientes como la target

indep <- setdiff(names(df),c('Churn','customerID'))
target <- 'Churn'

Creación de la formula para emplearla sobre los modelos

formula<-reformulate(indep,target)

Regresión logística

Como se trata de in modelo supervisado y la variable target es dicotómica, es decir, solo toma valores 0 y 1, se realizará la regresión logística en lugar de la lineal

Creación del primer modelo

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

## 
## Call:
## glm(formula = formula_rl, family = binomial(link = "logit"), 
##     data = train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.1267  -0.6676  -0.2765   0.5898   3.1487  
## 
## Coefficients: (4 not defined because of singularities)
##                                             Estimate Std. Error z value
## (Intercept)                                  2.02175    0.24355   8.301
## tenure_disc02 <= 5                          -0.78679    0.15296  -5.144
## tenure_disc03 <= 16                         -1.32192    0.14678  -9.006
## tenure_disc04 <= 22                         -1.64752    0.18239  -9.033
## tenure_disc05 <= 49                         -2.00486    0.15803 -12.687
## tenure_disc06 <= 59                         -2.09348    0.20728 -10.100
## tenure_disc07 <= 70                         -2.33976    0.22449 -10.422
## tenure_disc08 > 70                          -3.27599    0.45031  -7.275
## MonthlyCharges_disc02_DE_50_A_63            -0.06936    0.16343  -0.424
## MonthlyCharges_disc03_DE_63_A_75            -0.36082    0.21016  -1.717
## MonthlyCharges_disc04_MAYOR_75               0.04368    0.24324   0.180
## Contract_disc02_One_year                    -0.76253    0.12901  -5.911
## Contract_disc03_Two_year                    -1.49774    0.22009  -6.805
## OnlineSecurity_disc02_Yes                   -0.43364    0.10291  -4.214
## OnlineSecurity_disc03_No_internet_service   -2.31571    0.25835  -8.963
## TechSupport_disc02_Yes                      -0.29508    0.10482  -2.815
## TechSupport_disc03_No_internet_service            NA         NA      NA
## InternetService_disc02_DSL                  -1.02269    0.20386  -5.017
## InternetService_disc03_Fiber_optic                NA         NA      NA
## PaymentMethod_disc02_Mailed_check           -0.54103    0.11472  -4.716
## PaymentMethod_disc03_Bank_transfer          -0.44376    0.11442  -3.878
## PaymentMethod_disc04_Credit_card            -0.45825    0.11661  -3.930
## OnlineBackup_disc02_Yes                     -0.11806    0.09352  -1.262
## OnlineBackup_disc03_No_internet_service           NA         NA      NA
## DeviceProtection_disc02_Yes                  0.08594    0.09525   0.902
## DeviceProtection_disc03_No_internet_service       NA         NA      NA
##                                                         Pr(>|z|)    
## (Intercept)                                 < 0.0000000000000002 ***
## tenure_disc02 <= 5                             0.000000269319942 ***
## tenure_disc03 <= 16                         < 0.0000000000000002 ***
## tenure_disc04 <= 22                         < 0.0000000000000002 ***
## tenure_disc05 <= 49                         < 0.0000000000000002 ***
## tenure_disc06 <= 59                         < 0.0000000000000002 ***
## tenure_disc07 <= 70                         < 0.0000000000000002 ***
## tenure_disc08 > 70                             0.000000000000347 ***
## MonthlyCharges_disc02_DE_50_A_63                        0.671269    
## MonthlyCharges_disc03_DE_63_A_75                        0.086007 .  
## MonthlyCharges_disc04_MAYOR_75                          0.857482    
## Contract_disc02_One_year                       0.000000003405873 ***
## Contract_disc03_Two_year                       0.000000000010092 ***
## OnlineSecurity_disc02_Yes                      0.000025129621210 ***
## OnlineSecurity_disc03_No_internet_service   < 0.0000000000000002 ***
## TechSupport_disc02_Yes                                  0.004878 ** 
## TechSupport_disc03_No_internet_service                        NA    
## InternetService_disc02_DSL                     0.000000526148139 ***
## InternetService_disc03_Fiber_optic                            NA    
## PaymentMethod_disc02_Mailed_check              0.000002403542412 ***
## PaymentMethod_disc03_Bank_transfer                      0.000105 ***
## PaymentMethod_disc04_Credit_card               0.000085016661124 ***
## OnlineBackup_disc02_Yes                                 0.206782    
## OnlineBackup_disc03_No_internet_service                       NA    
## DeviceProtection_disc02_Yes                             0.366921    
## DeviceProtection_disc03_No_internet_service                   NA    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5714.1  on 4912  degrees of freedom
## Residual deviance: 4033.0  on 4891  degrees of freedom
## AIC: 4077
## 
## Number of Fisher Scoring iterations: 6

Conclusiones:

Existen 4 niveles que devuelven significación nula NA´s. Esto se debe a que generan una relación perfecta (-1 ó 1) con la variable target.
Se van a escoger para la creación del modelo, aquellas variables en las cuales al menos uno de sus niveles posea una significación valorada con ***

a_mantener <- c('tenure_disc','Contract_disc','OnlineSecurity_disc','InternetService_disc','PaymentMethod_disc')

Creación del segundo modelo

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

## 
## Call:
## glm(formula = formula_rl, family = binomial(link = "logit"), 
##     data = train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.0450  -0.6718  -0.2836   0.5136   3.1434  
## 
## Coefficients: (1 not defined because of singularities)
##                                           Estimate Std. Error z value
## (Intercept)                                1.95903    0.13640  14.363
## tenure_disc02 <= 5                        -0.81116    0.15306  -5.300
## tenure_disc03 <= 16                       -1.33077    0.14531  -9.158
## tenure_disc04 <= 22                       -1.64742    0.18077  -9.114
## tenure_disc05 <= 49                       -2.00501    0.15241 -13.156
## tenure_disc06 <= 59                       -2.11524    0.20047 -10.552
## tenure_disc07 <= 70                       -2.34321    0.21444 -10.927
## tenure_disc08 > 70                        -3.28184    0.44290  -7.410
## Contract_disc02_One_year                  -0.80281    0.12670  -6.336
## Contract_disc03_Two_year                  -1.58930    0.21599  -7.358
## OnlineSecurity_disc02_Yes                 -0.44382    0.10093  -4.398
## OnlineSecurity_disc03_No_internet_service -2.21695    0.15094 -14.687
## InternetService_disc02_DSL                -1.10200    0.09355 -11.780
## InternetService_disc03_Fiber_optic              NA         NA      NA
## PaymentMethod_disc02_Mailed_check         -0.56035    0.11414  -4.909
## PaymentMethod_disc03_Bank_transfer        -0.45635    0.11389  -4.007
## PaymentMethod_disc04_Credit_card          -0.47525    0.11615  -4.092
##                                                       Pr(>|z|)    
## (Intercept)                               < 0.0000000000000002 ***
## tenure_disc02 <= 5                           0.000000116010179 ***
## tenure_disc03 <= 16                       < 0.0000000000000002 ***
## tenure_disc04 <= 22                       < 0.0000000000000002 ***
## tenure_disc05 <= 49                       < 0.0000000000000002 ***
## tenure_disc06 <= 59                       < 0.0000000000000002 ***
## tenure_disc07 <= 70                       < 0.0000000000000002 ***
## tenure_disc08 > 70                           0.000000000000126 ***
## Contract_disc02_One_year                     0.000000000235452 ***
## Contract_disc03_Two_year                     0.000000000000186 ***
## OnlineSecurity_disc02_Yes                    0.000010950207134 ***
## OnlineSecurity_disc03_No_internet_service < 0.0000000000000002 ***
## InternetService_disc02_DSL                < 0.0000000000000002 ***
## InternetService_disc03_Fiber_optic                          NA    
## PaymentMethod_disc02_Mailed_check            0.000000914390304 ***
## PaymentMethod_disc03_Bank_transfer           0.000061462865454 ***
## PaymentMethod_disc04_Credit_card             0.000042813409232 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5714.1  on 4912  degrees of freedom
## Residual deviance: 4053.5  on 4897  degrees of freedom
## AIC: 4085.5
## 
## Number of Fisher Scoring iterations: 6

Se ha comprobado que las variables seleccionadas tienen una alta significación (***)

Evaluación del modelo

Correlación

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

## [1] 0.2906085

La correlación que se obtiene es 0.2906085, lo que se traduce en:

El modelo es capaz de predecir el 29.06085% de los resultados de la target con dichas variables. Cabe recordar que se han seleccionado las más significativas.
Esta correlación se encuentra por debajo del 50%, el límite a partir del cual se considera a un modelo como bueno.
Como estas son las variables y los datos que proporciona la empresa, por más que se trabaje en los datos, la correlación no mejorará mucho. Por este motivo, se va a continuar estudiando el modelo.

Comportamiento del modelo en el conjunto de test

rl_predict<-predict(rl2,test,type='response')
plot(rl_predict ~ test$Churn)

El modelo es capaz de separar el scoring de los clientes quese marchan de los que se quedan

Métricas y curvas

#Umbrales
#Para el cálculo de los umbrales se va a maximizar la variable F1=2*(Precision*Cobertura)/(Precision + Cobertura)
umb_rl<- umbrales(test$Churn,rl_predict)
umb_final_rl <- umb_rl[which.max(umb_rl$F1),1]
umb_final_rl

## [1] 0.35

#Matriz de confusion
confusion(test$Churn,rl_predict,umb_final_rl)

##     
## real FALSE TRUE
##    0  1217  351
##    1   147  404

rl_metricas<-filter(umb_rl,umbral==umb_final_rl)
rl_metricas

##   umbral  acierto precision cobertura      F1
## 1   0.35 76.49835  53.50993  73.32123 61.8683

#Evaluación ROC
rl_prediction <- prediction(rl_predict,test$Churn)
roc(rl_prediction)

#Metricas
rl_metricas <- cbind(rl_metricas,AUC=round(auc(rl_prediction),2)*100)
row.names(rl_metricas)<-'rl_metricas'
print(t(rl_metricas))

##           rl_metricas
## umbral        0.35000
## acierto      76.49835
## precision    53.50993
## cobertura    73.32123
## F1           61.86830
## AUC          84.00000

Conclusiones

El modelo presenta un AUC = 84 siendo superior al límite de 80, como para considerarlo un buen modelo.
Es capaz de diferenciar el Scoring de la variable target

Árbol de decisión

Creación del primer modelo

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

Se observa el resultado

printcp(ar1)

## 
## Classification tree:
## rpart(formula = formula_ar, data = train, method = "class")
## 
## Variables actually used in tree construction:
## [1] Contract_disc        InternetService_disc OnlineSecurity_disc 
## [4] tenure_disc         
## 
## Root node error: 1318/4913 = 0.26827
## 
## n= 4913 
## 
##         CP nsplit rel error  xerror     xstd
## 1 0.063733      0   1.00000 1.00000 0.023562
## 2 0.010622      3   0.77693 0.77693 0.021601
## 3 0.010000      5   0.75569 0.77466 0.021578

plotcp(ar1)

Solo devuelve 3 valores de complejidad. Como el error es menor en 0.01, se elige este nivel de complejidad

Creación del segundo modelo

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

Visualización del árbol

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

Reglas del árbol

rpart.rules(ar2,style='tall',cover=T)

## Churn is 0.06 with cover 45% when
##     Contract_disc is 02_One_year or 03_Two_year
## 
## Churn is 0.18 with cover 15% when
##     Contract_disc is 01_Month_to_month
##     tenure_disc is 03 <= 16 or 04 <= 22 or 05 <= 49 or 06 <= 59 or 07 <= 70 or 08 > 70
##     InternetService_disc is 01_No or 02_DSL
## 
## Churn is 0.31 with cover 5% when
##     Contract_disc is 01_Month_to_month
##     tenure_disc is 01 <= 1 or 02 <= 5
##     InternetService_disc is 01_No or 02_DSL
##     OnlineSecurity_disc is 02_Yes or 03_No_internet_service
## 
## Churn is 0.41 with cover 15% when
##     Contract_disc is 01_Month_to_month
##     tenure_disc is 04 <= 22 or 05 <= 49 or 06 <= 59 or 07 <= 70 or 08 > 70
##     InternetService_disc is 03_Fiber_optic
## 
## Churn is 0.55 with cover 5% when
##     Contract_disc is 01_Month_to_month
##     tenure_disc is 01 <= 1 or 02 <= 5
##     InternetService_disc is 01_No or 02_DSL
##     OnlineSecurity_disc is 01_No
## 
## Churn is 0.70 with cover 15% when
##     Contract_disc is 01_Month_to_month
##     tenure_disc is 01 <= 1 or 02 <= 5 or 03 <= 16
##     InternetService_disc is 03_Fiber_optic

ar_numnodos <- rpart.predict(ar2,test,nn=T)
head(ar_numnodos)

##           0          1 nn
## 1 0.4457364 0.55426357 27
## 2 0.6887160 0.31128405 26
## 3 0.9350295 0.06497047  2
## 4 0.3024194 0.69758065 15
## 5 0.5853659 0.41463415 14
## 6 0.9350295 0.06497047  2

Comportamiento del modelo en el conjunto de test

ar_predict <- predict(ar2,test,type='prob')[,2]
plot(ar_predict ~ test$Churn)

El modelo es capaz de separar el scoring de los clientes quese marchan de los que se quedan

Métricas y curvas

#Umbrales
#Para el cálculo de los umbrales se va a maximizar la variable F1=2*(Precision*Cobertura)/(Precision + Cobertura)
umb_ar<- umbrales(test$Churn,ar_predict)
umb_final_ar <- umb_rl[which.max(umb_ar$F1),1]
umb_final_ar

## [1] 0.35

#Matriz de confusion
confusion(test$Churn,ar_predict,umb_final_ar)

##     
## real FALSE TRUE
##    0  1197  371
##    1   154  397

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

##   umbral  acierto precision cobertura       F1
## 1   0.35 75.22416  51.69271  72.05082 60.19712

#Evaluación ROC
ar_prediction <- prediction(ar_predict,test$Churn)
roc(ar_prediction)

#Metricas
ar_metricas <- cbind(ar_metricas,AUC=round(auc(ar_prediction),2)*100)
row.names(ar_metricas)<-'ar_metricas'
print(t(ar_metricas))

##           ar_metricas
## umbral        0.35000
## acierto      75.22416
## precision    51.69271
## cobertura    72.05082
## F1           60.19712
## AUC          80.00000

Conclusiones

El modelo presenta un AUC = 80, siendo igual al límite de 80, como para considerarlo un buen modelo. Se tomará como bueno
Es capaz de diferenciar el Scoring de la variable target

RandomForest

Creación del primer modelo

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

Visualización de la importancia d elas variables

varImpPlot(rf1)#Visualizacion de las variables mas importantes

#Se generan dos variables a la hora de predecir la importancia, tasa de exito y estadistico de Gini. Por eso se va a crear de ambas un unico estadistico
importancia<-importance(rf1)[,3:4]
importancia_norm <- as.data.frame(scale(importancia))
#Se crea una variable única como la suma de las dos variables
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)
importancia_norm

##                Variable  Imp_tot MeanDecreaseAccuracy MeanDecreaseGini
## 1           tenure_disc 5.934439            1.2787113       1.77780196
## 2         Contract_disc 5.422180            1.0209073       1.52334700
## 3   OnlineSecurity_disc 3.193774            0.3546857      -0.03883735
## 4      TechSupport_disc 3.072365            0.4838996      -0.28946023
## 5  InternetService_disc 3.025447            0.5263328      -0.37881199
## 6    PaymentMethod_disc 2.595475           -0.2457473      -0.03670349
## 7   MonthlyCharges_disc 1.559045           -0.7254488      -0.59343270
## 8     OnlineBackup_disc 1.098608           -0.8608980      -0.91841974
## 9 DeviceProtection_disc 0.000000           -1.8324426      -1.04548347

#Histograma con la importancia de cada variable
ggplot(importancia_norm,aes(reorder(Variable,-Imp_tot),Imp_tot))+
  geom_bar(stat="identity") + theme(axis.text.x=element_text(angle=90,size=12))

Las variables que presenten una importancia total inferior a 1.2 serán desechadas

a_mantener <- importancia_norm%>%
  filter(Imp_tot>1.2)%>%
  select(Variable)
a_mantener <- as.character(a_mantener$Variable)
a_mantener

## [1] "tenure_disc"          "Contract_disc"        "OnlineSecurity_disc" 
## [4] "TechSupport_disc"     "InternetService_disc" "PaymentMethod_disc"  
## [7] "MonthlyCharges_disc"

Creación del segundo modelo

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

Comportamiento del modelo en el conjunto de test

rf_predict <- predict(rf2,test,type='prob')[,2]
plot(rf_predict ~ test$Churn)

El modelo es capaz de separar el scoring de los clientes quese marchan de los que se quedan

Métricas y curvas

#Umbrales
#Para el cálculo de los umbrales se va a maximizar la variable F1=2*(Precision*Cobertura)/(Precision + Cobertura)
umb_rf<- umbrales(test$Churn,rf_predict)
umb_final_rf <- umb_rl[which.max(umb_rf$F1),1]
umb_final_rf

## [1] 0.1

#Matriz de confusion
confusion(test$Churn,rf_predict,umb_final_rf)

##     
## real FALSE TRUE
##    0  1172  396
##    1   136  415

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

##   umbral  acierto precision cobertura       F1
## 1    0.1 74.89382  51.17139   75.3176 60.93979

#Evaluación ROC
rf_prediction <- prediction(rf_predict,test$Churn)
roc(rf_prediction)

#Metricas
rf_metricas <- cbind(rf_metricas,AUC=round(auc(rf_prediction),2)*100)
row.names(rf_metricas)<-'rf_metricas'
print(t(rf_metricas))

##           rf_metricas
## umbral        0.10000
## acierto      74.89382
## precision    51.17139
## cobertura    75.31760
## F1           60.93979
## AUC          82.00000

Conclusiones

El modelo presenta un AUC = 82, siendo superior al límite de 80, como para considerarlo un buen modelo.
Es capaz de diferenciar el Scoring de la variable target

Comparativa de los modelos manuales

Se va a generar una tabla, en la cual se van a arecoger las distintas métricas de los 3 modelos creados

comparativa <- rbind(rl_metricas,ar_metricas,rf_metricas)
rownames(comparativa)<- c('Regresion Logistica','Arbol de Decision','RandomForest')
comparativa<-t(comparativa)
comparativa%>%knitr::kable()

	Regresion Logistica	Arbol de Decision	RandomForest
umbral	0.35000	0.35000	0.10000
acierto	76.49835	75.22416	74.89382
precision	53.50993	51.69271	51.17139
cobertura	73.32123	72.05082	75.31760
F1	61.86830	60.19712	60.93979
AUC	84.00000	80.00000	82.00000

Atendiendo al valor del AUC, el modelo que mejor se comporta es la regresión logística.

Por este motivo será el seleccionado como mejor modelo dentro de los modelos manuales.

Se guarda la regresión logística para dárselo al cliente y lo utilice en futuras ocasiones

saveRDS(rl2,'01_Modelo_final_manual')

Tabla con el scoring de abandono de los clientes que no se han ido

df$SCORING_RL_MANUAL <- predict(rl2,df,type='response')
CUSTOMER_RL_MANUAL <- df%>%
  filter(Churn==0)%>%
  select(customerID,SCORING_RL_MANUAL)%>%
  arrange(desc(SCORING_RL_MANUAL))
head(CUSTOMER_RL_MANUAL)

##    customerID SCORING_RL_MANUAL
## 1: 2424-WVHPL         0.8764284
## 2: 0021-IKXGC         0.8764284
## 3: 1452-VOQCH         0.8764284
## 4: 7439-DKZTW         0.8764284
## 5: 2018-QKYGT         0.8764284
## 6: 8775-ERLNB         0.8764284

tail(CUSTOMER_RL_MANUAL)

##    customerID SCORING_RL_MANUAL
## 1: 6917-FIJHC       0.003370188
## 2: 8544-JNBOX       0.003370188
## 3: 7161-DFHUF       0.003370188
## 4: 8774-GSBUN       0.003370188
## 5: 1293-BSEUN       0.003370188
## 6: 5893-KCLGT       0.003370188

Modelización automática

Como se expuso anteriormente, para la realización de la modelización automática se va a emplear H2O

Preparación del entorno

Preparación del cluster de h2o

h2o.init()

Translado de los datos al cluster

df1<-readRDS(file = 'cache2.rds')#Se crea una copia nueva del df
df_h2o<-as.h2o(df1)

Partición del df

split<-h2o.splitFrame(df_h2o)
train_h2o<-split[[1]]
test_h2o<-split[[2]]

Definición de los roles de las variables

y <- 'Churn'
x <- setdiff(names(df_h2o),c('customerID',y))

Creación de los modelos

Como factor limitante se va a definir la duración en tiempo, concretamente 10 minutos con 3 validaciones cruzadas por modelo

Como en la modelización manual, el ranking se hará en función del AUC

automl_simple <- h2o.automl(
  y=y,
  x=x,
  training_frame = train_h2o,
  validation_frame = test_h2o,
  nfolds=3,
  max_runtime_secs = 600,
  sort_metric='AUC')

Estudio de los modelos generados

automl_simple@leaderboard

##                                              model_id       auc   logloss
## 1                        GLM_1_AutoML_20210219_103041 0.8434088 0.4154506
## 2          GBM_grid__1_AutoML_20210219_103041_model_6 0.8420711 0.4175933
## 3 StackedEnsemble_BestOfFamily_AutoML_20210219_103041 0.8420348 0.4231850
## 4          GBM_grid__1_AutoML_20210219_103041_model_7 0.8412966 0.4196583
## 5          GBM_grid__1_AutoML_20210219_103041_model_3 0.8408400 0.4178860
## 6    StackedEnsemble_AllModels_AutoML_20210219_103041 0.8405677 0.4231304
##       aucpr mean_per_class_error      rmse       mse
## 1 0.6481705            0.2363173 0.3679683 0.1354006
## 2 0.6465812            0.2381339 0.3683793 0.1357033
## 3 0.6461074            0.2380513 0.3698381 0.1367802
## 4 0.6426057            0.2367215 0.3694499 0.1364932
## 5 0.6430306            0.2331329 0.3689344 0.1361126
## 6 0.6447034            0.2380195 0.3699373 0.1368536
## 
## [30 rows x 7 columns]

Se presenta una tabla donde aparecen los 6 modelos más significativos de un total de 30 modelos que ha generado H2O

#Visualizacion grafica de los modelos
as.data.frame(automl_simple@leaderboard)%>%
  select(model_id,auc)%>%
  ggplot(aes(x=auc,y=reorder(model_id,auc)))+
  geom_point()+geom_label(aes(label=round(auc,3),color=auc),hjust='left')+expand_limits(x=c(0.86,0.820))+theme_bw()

Se visualiza una gráfica donde se ordenan todos los modelos generados en función del AUC. De todos ellos se escogerá el de mayor AUC

Selección del modelo ganador

automl_simple_winner <- automl_simple@leader
#Metricas
automl_simple_winner@model$cross_validation_metrics

## H2OBinomialMetrics: glm
## ** Reported on cross-validation data. **
## ** 3-fold cross-validation on training data (Metrics computed for combined holdout predictions) **
## 
## MSE:  0.1354006
## RMSE:  0.3679683
## LogLoss:  0.4154506
## Mean Per-Class Error:  0.2363173
## AUC:  0.8434088
## AUCPR:  0.6481705
## Gini:  0.6868175
## R^2:  0.2991486
## Residual Deviance:  4382.172
## AIC:  4452.172
## 
## Confusion Matrix (vertical: actual; across: predicted) for F1-optimal threshold:
##           0    1    Error        Rate
## 0      3123  771 0.197997   =771/3894
## 1       379 1001 0.274638   =379/1380
## Totals 3502 1772 0.218051  =1150/5274
## 
## Maximum Metrics: Maximum metrics at their respective thresholds
##                         metric threshold       value idx
## 1                       max f1  0.343103    0.635152 185
## 2                       max f2  0.154125    0.748410 285
## 3                 max f0point5  0.504672    0.615777 109
## 4                 max accuracy  0.504672    0.799772 109
## 5                max precision  0.875515    0.900000   3
## 6                   max recall  0.010501    1.000000 394
## 7              max specificity  0.890531    0.999743   0
## 8             max absolute_mcc  0.393851    0.491448 162
## 9   max min_per_class_accuracy  0.300800    0.763482 206
## 10 max mean_per_class_accuracy  0.300800    0.763988 206
## 11                     max tns  0.890531 3893.000000   0
## 12                     max fns  0.890531 1374.000000   0
## 13                     max fps  0.005074 3894.000000 399
## 14                     max tps  0.010501 1380.000000 394
## 15                     max tnr  0.890531    0.999743   0
## 16                     max fnr  0.890531    0.995652   0
## 17                     max fpr  0.005074    1.000000 399
## 18                     max tpr  0.010501    1.000000 394
## 
## Gains/Lift Table: Extract with `h2o.gainsLift(<model>, <data>)` or `h2o.gainsLift(<model>, valid=<T/F>, xval=<T/F>)`

h2o.auc(automl_simple_winner@model$cross_validation_metrics)

## [1] 0.8434088

AUC_winner<-h2o.auc(automl_simple_winner@model$cross_validation_metrics)
#Importancia de las variables
h2o.varimp_plot(automl_simple@leader)

#Se calcula el scoring
SCORING_CUSTOMER_CHURN <- as.data.frame(h2o.predict(automl_simple_winner,df_h2o)[3])

df$SCORING_GLM_H2O <- as.numeric(SCORING_CUSTOMER_CHURN$p1)
glimpse(df)

## Rows: 7,032
## Columns: 12
## $ Churn                 <fct> 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, ...
## $ customerID            <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "77...
## $ tenure_disc           <fct> 01 <= 1, 05 <= 49, 02 <= 5, 05 <= 49, 02 <= 5...
## $ MonthlyCharges_disc   <fct> 01_MENOR_50, 02_DE_50_A_63, 02_DE_50_A_63, 01...
## $ Contract_disc         <fct> 01_Month_to_month, 02_One_year, 01_Month_to_m...
## $ OnlineSecurity_disc   <fct> 01_No, 02_Yes, 02_Yes, 02_Yes, 01_No, 01_No, ...
## $ TechSupport_disc      <fct> 01_No, 01_No, 01_No, 02_Yes, 01_No, 01_No, 01...
## $ InternetService_disc  <fct> 02_DSL, 02_DSL, 02_DSL, 02_DSL, 03_Fiber_opti...
## $ PaymentMethod_disc    <fct> 01_Electronic_check, 02_Mailed_check, 02_Mail...
## $ OnlineBackup_disc     <fct> 02_Yes, 01_No, 02_Yes, 01_No, 01_No, 01_No, 0...
## $ DeviceProtection_disc <fct> 01_No, 02_Yes, 01_No, 02_Yes, 01_No, 02_Yes, ...
## $ SCORING_GLM_H2O       <dbl> 0.67343053, 0.06344229, 0.24697350, 0.0704459...

Se guarda el modelo ganador

h2o.saveModel(automl_simple_winner,path='/Users/Alberto/Desktop/Proyecto Data Science/Cursos/Ds4B/Proyecto para el certificado')

automl_simple_winner <- h2o.loadModel('/Users/Alberto/Desktop/Proyecto Data Science/Cursos/Ds4B/Proyecto para el certificado/GLM_1AutoML_20210219_103041')

Tabla con el scoring de abandono de los clientes que no se han ido

CUSTOMER_GLM_H2O <- df%>%
  filter(Churn==0)%>%
  select(customerID,SCORING_GLM_H2O)%>%
  arrange(desc(SCORING_GLM_H2O))
head(CUSTOMER_GLM_H2O)

##    customerID SCORING_GLM_H2O
## 1: 5043-TRZWM       0.8846976
## 2: 1452-VOQCH       0.8703039
## 3: 7439-DKZTW       0.8703039
## 4: 2018-QKYGT       0.8703039
## 5: 7577-SWIFR       0.8703039
## 6: 1941-HOSAM       0.8703039

tail(CUSTOMER_GLM_H2O)

##    customerID SCORING_GLM_H2O
## 1: 6917-FIJHC     0.005405614
## 2: 8544-JNBOX     0.005405614
## 3: 7161-DFHUF     0.005405614
## 4: 8774-GSBUN     0.005405614
## 5: 1293-BSEUN     0.005405614
## 6: 5893-KCLGT     0.005405614

6.-CONCLUSIÓN FINAL

Tanto por la modelización manual como por la automática se han conseguido dos modelos:

Modelización manual –> Regresión logística con AUC = 84
Modelización automática –> GLM con AUC = 0.8434088

Como ambos modelos presentan AUC muy similares, se va a elegir como ganador el modelo GLM ya que se ha realizado empleando validación cruzada

Por lo tanto, al cliente se le entregará:

Modelo GLM ganador
Tabla con las identificaciones de los clientes que siguen en la compañía vs el scoring de abandonarla

head(CUSTOMER_GLM_H2O)%>%knitr::kable()

customerID	SCORING_GLM_H2O
5043-TRZWM	0.8846976
1452-VOQCH	0.8703039
7439-DKZTW	0.8703039
2018-QKYGT	0.8703039
7577-SWIFR	0.8703039
1941-HOSAM	0.8703039

Telco Customer Churn

Alberto Diaz Macias

15/2/2021

INTRODUCCIÓN

1.- IMPORTACIÓN Y MUESTREO

Preparación del entorno

Eliminación de la notación cientifica

Se cargan e instalan las librerias

Se cargan los datos en un df

2.- ANÁLISIS EXPLORATORIO

Análisis exploratorio general

Calidad de datos

Estadísticos básicos

Análisis de nulos

Análisis de ceros

Análisis de atípicos

Variables double

Variables integer

Preselección de variables

Conclusiones

3.- TRANSFORMACIÓN DE DATOS

Preparación de las variables independientes

Preselección con RandomForest

Preselección con Information Value (IV)

Transformación de carácter a número

Ranking Final

Limpieza del entorno

4.- CREACIÓN DE VARIABLES SINTÉTICAS

Discretización

Discretización automática

Discretización manual

Estudio de las discretizaciones

Contract_disc

OnlineSecurity_disc

TechSupport_disc

InternetService_disc

PaymentMethod_disc

OnlineBackup_disc

DeviceProtection_disc

Tenure_disc

MonthlyCharges_disc

Conclusiones

Discretización manual 2ª etapa

Monthly Charges

Limpieza del entorno y preparación de la caché 2

Se observa el estado del df

Se limpia el entorno

Se crea la caché 2

Se carga la caché 2

5.- MODELIZACIÓN

Modelización manual

Regresión logística

Creación del primer modelo

Creación del segundo modelo

Evaluación del modelo

Correlación

Comportamiento del modelo en el conjunto de test

Métricas y curvas

Conclusiones

Árbol de decisión

Creación del primer modelo

Creación del segundo modelo

Visualización del árbol

Reglas del árbol

Comportamiento del modelo en el conjunto de test

Métricas y curvas

Conclusiones

RandomForest

Creación del primer modelo

Visualización de la importancia d elas variables

Creación del segundo modelo

Comportamiento del modelo en el conjunto de test

Métricas y curvas

Conclusiones

Comparativa de los modelos manuales

Se guarda la regresión logística para dárselo al cliente y lo utilice en futuras ocasiones

Tabla con el scoring de abandono de los clientes que no se han ido

Modelización automática

Preparación del entorno

Preparación del cluster de h2o