Introduction

The Development Team for Regork is searching for strategies to sell and retain more customers in their new market opportunities in telecommunications. The team wants to find out which factor or services that matter the most to the tenure of the customers. This is such a crucial question for the growth of company because the company can efficiently allocate its budget and capacity to attract new customers and retain the current ones.

In this project, I will first explore the effects on the internal (Streaming Services, Online Backup ,etc..) and external (Gender, Senior Citizen, etc) factors on the status of each customers. Then, I will focus only on the features that matter, and build different machine learning models. Using the ROC_AUC as the metrics, I will evaluate the accuracy of each algorithm and finalize with the best one.

This analysis will address a crucial question for the growth of company because the company can efficiently allocate its budget and capacity to attract new customers and retain the current ones.

Part 1: Data preparation

1.1.Load libraries

library(tidymodels)
library(tidyverse)
library(dplyr)
library(ggplot2)
library(kernlab)
library(modeest)
library(caret)
library(baguette)
library(randomForest)
library(vip)
library(pdp)
library(rpart.plot)
library(ranger)

1.2.Load datasets

#load data set
cust <- readr::read_csv("C:/Users/nguye/OneDrive/Desktop/FALL 22/BANA4080/Project 2/customer_retention.csv")

## Rows: 6999 Columns: 20
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (16): Gender, Partner, Dependents, PhoneService, MultipleLines, Internet...
## dbl  (4): SeniorCitizen, Tenure, MonthlyCharges, TotalCharges
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Part 2: Data exploration

summary(cust)

##     Gender          SeniorCitizen      Partner           Dependents       
##  Length:6999        Min.   :0.0000   Length:6999        Length:6999       
##  Class :character   1st Qu.:0.0000   Class :character   Class :character  
##  Mode  :character   Median :0.0000   Mode  :character   Mode  :character  
##                     Mean   :0.1619                                        
##                     3rd Qu.:0.0000                                        
##                     Max.   :1.0000                                        
##                                                                           
##      Tenure      PhoneService       MultipleLines      InternetService   
##  Min.   : 0.00   Length:6999        Length:6999        Length:6999       
##  1st Qu.: 9.00   Class :character   Class :character   Class :character  
##  Median :29.00   Mode  :character   Mode  :character   Mode  :character  
##  Mean   :32.38                                                           
##  3rd Qu.:55.00                                                           
##  Max.   :72.00                                                           
##                                                                          
##  OnlineSecurity     OnlineBackup       DeviceProtection   TechSupport       
##  Length:6999        Length:6999        Length:6999        Length:6999       
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##                                                                             
##  StreamingTV        StreamingMovies      Contract         PaperlessBilling  
##  Length:6999        Length:6999        Length:6999        Length:6999       
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##                                                                             
##  PaymentMethod      MonthlyCharges    TotalCharges       Status         
##  Length:6999        Min.   : 18.25   Min.   :  18.8   Length:6999       
##  Class :character   1st Qu.: 35.48   1st Qu.: 401.9   Class :character  
##  Mode  :character   Median : 70.35   Median :1397.5   Mode  :character  
##                     Mean   : 64.75   Mean   :2283.1                     
##                     3rd Qu.: 89.85   3rd Qu.:3796.9                     
##                     Max.   :118.75   Max.   :8684.8                     
##                                      NA's   :11

Observation:

The data set had 6999 rows and 20 columns, 16 of which are categorical features. We will need to explore the significance of these categorical features to the ‘Status’ (response variable) to implement them in our models.

Our response value ‘Status’ is currently in categorical form. We will need to dummy code it to numerical feature (0 or 1) for the prediction.

Besides, we are seeing that TotalCharges is the only column with 11 missing values, accounts for 0.1% of the original dataset. We can go ahead of remove these values.

Next Steps:

Dummy code ‘Status’(categorical) into ‘IsCurrent’ (binary)
Remove NAs in TotalCharges

2.1. Data Transformation

Transform the response value (Status) to binary feature called IsCurrent.

#adding dummy variables
cust <- cust %>% mutate(IsCurrent = case_when(Status == 'Current' ~ 1, 
                                          TRUE ~ 0))
cust <- cust %>% select(-Status)

Remove NA’s value in TotalCharges

cust <- na.omit(cust)

2.2. Distribution of left customers’ tenure

First, the analysis will explore how long the customers usually stayed with the service before leaving.

left_cust <- cust %>% filter(IsCurrent == 0) 
current_cust <- cust %>% filter(IsCurrent ==1)


plot_1 <- ggplot(data=left_cust, aes(x=Tenure)) +
     geom_histogram(color="#811331", fill="#FFC0CB") +
     labs(title = "Regork Tenure Distribution for former customers",
          subtitle = "Insight: Most of the customers left after their 1st month with the company",
          y = "Number of Leaving Customers",
          x = "Tenure (Months)") +
     scale_y_continuous(labels=comma) +
     theme(plot.title = element_text(face = "bold"),
           plot.subtitle = element_text(face = "italic"),
           panel.background = element_rect(fill = "white"),
           panel.grid.major = element_line(color = "lightgray"))
plot_1

We find out that the majority of former customers left the services after their 1st month with the service. Besides, the length of tenure and the number of leaving customers are moving in a negative trend, showing that the longer the customers stay, the less chance that they would leave.

Hence, tenure of a customer could be a great feature to determine the possibility of leaving or staying of a customer (response variables).

2.3. Senior Citizen

Next, we will take a closer look at the tendency to leave among senior (1) and non-senior (0) citizens.

cust %>% 
     group_by(SeniorCitizen, IsCurrent) %>% 
     summarize(cnt = n()) %>% 
     mutate(rate = cnt/sum(cnt))

## # A tibble: 4 × 4
## # Groups:   SeniorCitizen [2]
##   SeniorCitizen IsCurrent   cnt  rate
##           <dbl>     <dbl> <int> <dbl>
## 1             0         0  1384 0.236
## 2             0         1  4471 0.764
## 3             1         0   472 0.417
## 4             1         1   661 0.583

senior_rates = data.frame(SeniorCitizen <- c("0","0","1","1"),
                    IsCurrent <- c("0","1","0","1"),
                    rate <- c(0.236,0.764,0.417,0.583))
senior_rates$SeniorCitizen <- factor(senior_rates$SeniorCitizen)
senior_rates$IsCurrent <- factor(senior_rates$IsCurrent) 

plot_2 <- ggplot(data=senior_rates, aes(x=" ", y=rate, group=IsCurrent, fill=IsCurrent)) +
              geom_bar(stat = "identity") +
              coord_polar("y", start=0) + 
              facet_grid(.~ SeniorCitizen) +
              scale_fill_manual(name = "Status", 
                                labels = c("Leave", "Stay"),
                                values = c("#770737", "#FFC0CB")) +
              labs(title = "Percentage of leaving customers in Senior and Non-Senior Groups",
              subtitle = "Insights: More of the senior citizens are leaving the service",
              y = "",
              x = "") +
              theme(plot.title = element_text(face = "bold"),
                    plot.subtitle = element_text(face = "italic"),
                    panel.background = element_rect(fill = "white"),
                    panel.grid.major = element_line(color = "lightgray"))
plot_2

From the graph above, for senior citizens (1), almost half of the population (41.7%) have left the service, meanwhile, non-senior citizens (0), nearly a quarter of the population (23.6%) have done so. We might assume that the seniority of the customers might affect their decision to stay with the service.

2.4. Internet Services & others

We are seeing in the data set that the internet services include other columns’ values: OnlineSecurity, OnlineBackup, DeviceProtection, TechSupport, StreamingTV, StreamingMovies (if they don’t have internet service, they won’t have access to these features). Thus, we will look at the influences of all of these features at once to determine whether any of these sub-features are different from its main feature InternetService

cust$InternetService <- factor(cust$InternetService)
plot_3 <- cust %>% 
               group_by(InternetService, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(InternetService, -rate),
                          y=rate,
                          fill = InternetService)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "Leave-to-total Ratio by Internet Services and others",
                    subtitle = "Insight: Customers with 'no internet service' has lowest ratio to leave",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#9F2B68","#FFC0CB")) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())

#StreamingTV
cust$StreamingTV <- factor(cust$StreamingTV)
plot_4 <- cust %>% 
               group_by(StreamingTV, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(StreamingTV, -rate),
                          y=rate,
                          fill = StreamingTV)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "StreamingTV",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#StreamingMovies
cust$StreamingMovies <- factor(cust$StreamingMovies)
plot_5 <- cust %>% 
               group_by(StreamingMovies, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(StreamingMovies, -rate),
                          y=rate,
                          fill = StreamingMovies)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "StreamingMovies",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#OnlineSecurity
cust$OnlineSecurity <- factor(cust$OnlineSecurity)
plot_6 <- cust %>% 
               group_by(OnlineSecurity, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(OnlineSecurity, -rate),
                          y=rate,
                          fill = OnlineSecurity)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "OnlineSecurity",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#OnlineBackup
cust$OnlineBackup <- factor(cust$OnlineBackup)
plot_7 <- cust %>% 
               group_by(OnlineBackup, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(OnlineBackup, -rate),
                          y=rate,
                          fill = OnlineBackup)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "OnlineBackup",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#DeviceProtection
cust$DeviceProtection <- factor(cust$DeviceProtection)
plot_8 <- cust %>% 
               group_by(DeviceProtection, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(DeviceProtection, -rate),
                          y=rate,
                          fill = DeviceProtection)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "DeviceProtection",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#TechSupport
cust$TechSupport <- factor(cust$TechSupport)
plot_9 <- cust %>% 
               group_by(TechSupport, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(TechSupport, -rate),
                          y=rate,
                          fill = TechSupport)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.5) +
               labs(title = "TechSupport",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#Plot all together
lay <- rbind(c(1,1,1),
             c(2,3,4),
             c(5,6,7))
plot_10 <-  grid.arrange(grobs = list(plot_3, plot_4, plot_5, plot_6, plot_7,plot_8, plot_9),
                                layout_matrix = lay)

With the combination of bar graphs above, we are seeing that customer with No internet services has the lowest ratio to leave compared to the according population.

In the other features coming along with having Yes internet service, there are no significant differences in the leave-to-total ratio whether the customers have accesses to these features (StreamingTV, Streaming Movies, Online Backup & Device Protection) or not.Hence, to reduce the complexity of our model, we can keep only the InternetService to represent these 4 following features.

Meanwhile there are significant differences in leave-to-all ratio for customers having accesses to OnlineSecurity and TechSupport. We will keep OnlineSecurity and TechSupport for our prediction of the leave or stay tendency.

2.5. Phone Services and Multiple Lines

Another two features that having values relating to each other are Phone Services and Multiple Lines (if they don’t have phone services, they don’t have multiple lines).

#phoneservice
cust$PhoneService <- factor(cust$PhoneService)
plot_11 <- cust %>% 
               group_by(PhoneService, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(PhoneService, -rate),
                          y=rate,
                          fill = PhoneService)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.3) +
               labs(title = "Phone Service",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#FFC0CB","#9F2B68","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
#multiplelines
cust$MultipleLines <- factor(cust$MultipleLines)
plot_12 <- cust %>% 
               group_by(MultipleLines, IsCurrent) %>% 
               summarize(cnt = n()) %>% 
                    mutate(rate = round(cnt/sum(cnt),2)) %>% 
                    filter(IsCurrent == 0) %>% 
               ggplot(aes(x=reorder(MultipleLines, -rate),
                          y=rate,
                          fill = MultipleLines)) +
               geom_bar(stat="identity", show.legend = FALSE) +
               ylim(0,0.3) +
               labs(title = "Multiple Lines",
                    x = "Type",
                    y = "") +
               scale_fill_manual(values = c("#9F2B68","#FFC0CB","#9F2B68")) +
               scale_x_discrete(labels = function(x) str_wrap(x, width = 15)) +
               geom_text(aes(label = rate), vjust = -0.5) +
               theme(plot.title = element_text(face = "bold"),
                     plot.subtitle = element_text(face = "italic"),
                     panel.background = element_rect(fill = "white"),
                     panel.grid.major = element_line(color = "lightgray"),
                     axis.title.x=element_blank())
plot_13 <- grid.arrange(plot_11,plot_12,ncol=2)

As the charts suggest, there are no significant difference in the tendency to leave for each customer groups: have phone services vs. not/ have multiple lines vs.not vs. no phone service. For the complexity of our model, we can remove these two features in the feature engineering steps.

2.6. Contract

#contract
contract <- cust %>% 
          group_by(Contract, IsCurrent) %>% 
          summarize(cnt = n()) %>% 
          mutate(rate = round(cnt/sum(cnt),2)) %>% 
          filter(IsCurrent == 0)
plot_14 <- ggplot(data = contract, aes(x=reorder(Contract, -rate),
                y=rate,
                fill = Contract)) +
          geom_bar(stat="identity", show.legend = FALSE) +
          scale_fill_manual(values = c("#FFC0CB","#FFC0CB", "#770737")) +
          labs(title = "Leave-to-total Ratio by Contract Ttpe",
               subtitle = "Insight: The longer the contract type, the longer the customers stay",
               x = "",
               y = "") +
          geom_text(aes(label=rate), vjust = -0.5) +
          theme(plot.title = element_text(face = "bold"),
                plot.subtitle = element_text(face = "italic"),
                panel.background = element_rect(fill = "white"),
                panel.grid.major = element_line(color = "lightgray"),
                axis.title.x=element_blank())  
plot_14

We are seeing that Month-to-month type of contract have a significantly high churn rate compared to other types.

2.7. Payment & Billing Methods

2.7.1 Paperless Billing

#paperlessbiling
billing <- cust %>% 
          group_by(PaperlessBilling, IsCurrent) %>% 
          summarize(cnt = n()) %>% 
          mutate(rate = round(cnt/sum(cnt),2)) %>% 
          filter(IsCurrent == 0)
plot_15 <- ggplot(data = billing, aes(x=reorder(PaperlessBilling, -rate),
                y=rate,
                fill = PaperlessBilling)) +
          geom_bar(stat="identity", show.legend = FALSE) +
          scale_fill_manual(values = c("#FFC0CB","#770737")) +
          labs(title = "Leave-to-total Ratio by Billing methods",
               subtitle = "Insight: More of the customers with paperlessbilling have left",
               x = "",
               y = "") +
          geom_text(aes(label=rate), vjust = -0.5) +
          theme(plot.title = element_text(face = "bold"),
                plot.subtitle = element_text(face = "italic"),
                panel.background = element_rect(fill = "white"),
                panel.grid.major = element_line(color = "lightgray"),
                axis.title.x=element_blank())  
plot_15

2.7.2. Payment Methods

#payment methods
payment <- cust %>% 
          group_by(PaymentMethod, IsCurrent) %>% 
          summarize(cnt = n()) %>% 
          mutate(rate = round(cnt/sum(cnt),2)) %>% 
          filter(IsCurrent == 0)
plot_16 <- ggplot(data = payment, aes(x=reorder(PaymentMethod, -rate),
                y=rate,
                fill = PaymentMethod)) +
          geom_bar(stat="identity", show.legend = FALSE) +
          scale_fill_manual(values = c("#9F2B68","#770737","#FFC0CB", "#F2D2BD")) +
          labs(title = "Leave-to-total Ratio by Payment methods",
               subtitle = "Insight: Customers paying with electronic check have the highest tendency to leave",
               x = "",
               y = "") +
          geom_text(aes(label=rate), vjust = -0.5) +
          theme(plot.title = element_text(face = "bold"),
                plot.subtitle = element_text(face = "italic"),
                panel.background = element_rect(fill = "white"),
                panel.grid.major = element_line(color = "lightgray"),
                axis.title.x=element_blank())  
plot_16

From the two above graphs, we are sure that both payment and billing methods are important to our model.

2.8. Family Size

Last but not least, we will look at how family size can affect the possibility of leaving for each customer.

2.8.1. Partners

partner <- cust %>% 
          group_by(Partner, IsCurrent) %>% 
          summarize(cnt = n()) %>% 
          mutate(rate = round(cnt/sum(cnt),2)) %>% 
          filter(IsCurrent == 0)
plot_17 <- ggplot(data = partner, aes(x=Partner,
                y=rate,
                fill = Partner)) +
          geom_bar(stat="identity", show.legend = FALSE) +
          scale_fill_manual(values = c("#770737","#FFC0CB")) +
          labs(title = "Leave-to-total Ratio by Partner Status",
               subtitle = "Insight: There are NO strong difference between different status",
               x = "",
               y = "") +
          geom_text(aes(label=rate), vjust = -0.5) +
          theme(plot.title = element_text(face = "bold"),
                plot.subtitle = element_text(face = "italic"),
                panel.background = element_rect(fill = "white"),
                panel.grid.major = element_line(color = "lightgray"),
                axis.title.x=element_blank()) 
plot_17

2.8.2. Dependents

#dependent
depnd <- cust %>% 
          group_by(Dependents, IsCurrent) %>% 
          summarize(cnt = n()) %>% 
          mutate(rate = round(cnt/sum(cnt),2)) %>% 
          filter(IsCurrent == 0)
plot_18 <-ggplot(data = depnd, aes(x=Dependents,
                y=rate,
                fill = Dependents)) +
          geom_bar(stat="identity", show.legend = FALSE) +
          labs(title = "Leave-to-total Ratio by Dependent Status",
               subtitle = "Insight: There are noticeable difference between customers with and without dependents",
               x = "Type",
               y = "") +
          scale_fill_manual(values = c("#770737","#FFC0CB")) +
          geom_text(aes(label=rate), vjust = -0.5) +
          theme(plot.title = element_text(face = "bold"),
                plot.subtitle = element_text(face = "italic"),
                panel.background = element_rect(fill = "white"),
                panel.grid.major = element_line(color = "lightgray"),
                axis.title.x=element_blank())  
plot_18

Quick Summary

Observation:

Most of our former customers are leaving after the first month
More of the Senior citizens have left the services.
There are a few features that having values dependent on each other, and their effects on the response variables are quite similar, such as InternetService and PhoneService with its according features.
The longer the Contract, the more likely the customer will stay with the service.
Paper Billing and Electronic Check has a high proportion of its population leave in comparision to others.
Customers with Dependents have left the firm more than that of without dependents.

Next Steps:

Remove insignificant features: StreamingTV, StreamingMovies, OnlineBackup, DeviceProtection, PhoneService, MultipleLines, and Partner
One hot Coding other categorical features.

3. Feature Engineering

3.1. Data Transformation

Remove insignificant data.

cust <- cust %>% 
     select(-c(Partner, PhoneService, MultipleLines, OnlineBackup, DeviceProtection, StreamingTV, StreamingMovies))

Reduce the complexity of other categorical features (InternetService, OnlineSecurity, TechSupport, Contract, PaymentMethod) to 2 levels.

cust <- cust %>% 
     mutate(Internet = case_when(InternetService == 'No' ~ 'No',
                                 TRUE ~ 'Yes'),
            Security = case_when(OnlineSecurity == 'Yes' ~ 'Yes',
                                 TRUE ~ 'No'),
            Tech = case_when(TechSupport == 'Yes' ~ 'Yes',
                                 TRUE ~ 'No'),
            ContractType = case_when(Contract == 'Month-to-month' ~ 'Monthly',
                                 TRUE ~ 'Yearly'),
            Payment = case_when(PaymentMethod == 'Electronic check' | PaymentMethod == 'Mailed check' ~ 'Check',
                                TRUE ~ 'Automatic')) %>% 
     select(-c(InternetService, OnlineSecurity, TechSupport, Contract, PaymentMethod))

3.2. Split data

cust$IsCurrent <- as.factor(cust$IsCurrent)
cust$Gender <- as.factor(cust$Gender)
cust$Dependents <- as.factor(cust$Dependents)
cust$PaperlessBilling <- as.factor(cust$PaperlessBilling)
cust$Internet <- as.factor(cust$Internet)
cust$Security <- as.factor(cust$Security)
cust$Tech <- as.factor(cust$Tech)
cust$ContractType <- as.factor(cust$ContractType)
cust$Payment <- as.factor(cust$Payment)

set.seed(123)
split <- initial_split(cust, prop = .7, strata = "IsCurrent")
cust_train <- training(split)
cust_test  <- testing(split)

3.3. Recipes

Normalize all numeric predictor variables using a Yeo-Johnson transformation
Standardize all numeric predictor variables
One hot coding for all other categorical features

lvls <- c("0","1")
cust_recipe <- cust %>% 
     recipe(IsCurrent ~., data=cust_train) %>% 
     step_YeoJohnson(all_numeric_predictors()) %>%
     step_normalize(all_numeric_predictors()) %>% 
     step_string2factor(all_nominal(),levels = lvls, ordered = TRUE) 
cust_recipe

## Recipe
## 
## Inputs:
## 
##       role #variables
##    outcome          1
##  predictor         12
## 
## Operations:
## 
## Yeo-Johnson transformation on all_numeric_predictors()
## Centering and scaling for all_numeric_predictors()
## Factor variables from all_nominal()

3.4. Resampling object

We will create 50fold cross validation resampling object

set.seed(123)
kfolds <- vfold_cv(cust_train, v = 5, strata = IsCurrent)

4. Machine Learning Algorithms

4.1 Logistic Regression

Our interest is in predicting whether or not a customer will stay. Because the variable we want to predict is binary (IsCurrent = 1)if the customers stayed and IsCurrent = 0 if they did not), logistic regression is appropriate.

results <- logistic_reg() %>%
     fit_resamples(IsCurrent ~., kfolds)

results %>% 
     collect_metrics() %>% 
     filter(.metric == "roc_auc") %>% 
     arrange(desc(mean)) %>% 
     View()

Mean ROC_AUC for logistic regression is 0.8432147

final_fit <- logistic_reg() %>%
     fit(IsCurrent ~ ., data = cust_train)

final_fit %>%
     predict(cust_test) %>%
     bind_cols(cust_test %>% select(IsCurrent)) %>%
     conf_mat(truth = IsCurrent, estimate = .pred_class)

##           Truth
## Prediction    0    1
##          0  285  179
##          1  272 1361

Comment: We see a slightly greater number of observations where our model predicts staying (Prediction = 1) but the customers left (Truth = 0 ) than where our models predicts leaving (Prediction = 0) but the customers stayed (Truth = 1). This shows that our models is more optimistic.

4.2. Decision Tree

# decision tree model object
dt_mod <- decision_tree(mode = "classification") %>%
     set_engine("rpart")
fit <- rpart(IsCurrent~., data = cust_train, method = 'class')
# fit model workflow
dt_fit <- workflow() %>%
     add_recipe(cust_recipe) %>%
     add_model(dt_mod) %>%
     fit(data = cust_train)
# train model
dt_results <- fit_resamples(dt_mod, cust_recipe, kfolds)
# model results
collect_metrics(dt_results) %>% view()

dt_mod <- decision_tree(
     mode = "classification",
     cost_complexity = tune(),
     tree_depth = tune(),
     min_n = tune()
     ) %>%
     set_engine("rpart")
# create the hyperparameter grid
dt_hyper_grid <- grid_regular(
     cost_complexity(), 
     tree_depth(),
     min_n(),
     levels = 5
     )
# train our model across the hyper parameter grid
set.seed(123)
dt_results <- tune_grid(dt_mod, cust_recipe, resamples = kfolds, grid = dt_hyper_grid)
# get best results
show_best(dt_results, metric = "roc_auc", n = 5) %>% view()
# get best hyperparameter values
dt_best_model <- select_best(dt_results, metric = 'roc_auc')

# put together final workflow
dt_final_wf <- workflow() %>%
     add_recipe(cust_recipe) %>%
     add_model(dt_mod) %>%
     finalize_workflow(dt_best_model)
# fit final workflow across entire training data
dt_final_fit <- dt_final_wf %>%
     fit(data = cust_train)

# prediction function
pdp_pred_fun <- function(object, newdata) {
  mean(predict(object, newdata, type = "numeric")$.pred)
}

dt_predict <-predict(fit, cust_test, type = 'class')

table_mat <- table(cust_test$IsCurrent, dt_predict)
table_mat

##    dt_predict
##        0    1
##   0  178  379
##   1   98 1442

Mean ROC_AUC for decision tree is 0.823334 with tree_depth = 8, min_n = 21, and cost_complexity = 1.000000e-10.

Comment: We see a greater number of observations where our model predicts staying (Prediction = 0) but the customers left (Truth = 1) than where our models predicts leaving (Prediction = 1) but the customers stayed (Truth = 0). This shows that our models is pessimistic.

4.3. Random Forest

#create random forest model object 
rf_mod <- rand_forest(mode = "classification") %>%
     set_engine("ranger")

# create random forest model object with tuning option
rf_mod <- rand_forest(
     mode = "classification",
     trees = tune(),
     mtry = tune(),
     min_n = tune()
     ) %>%
     set_engine("ranger", importance = "impurity")
# create the hyperparameter grid
rf_hyper_grid <- grid_regular(
     trees(range = c(50,200)),
     mtry(range = c(2,50)),
     min_n(range = c(1,20)),
     levels = 5
     )
# train our model across the hyper parameter grid
set.seed(123)
rf_results <- tune_grid(rf_mod, cust_recipe, resamples = kfolds, grid = rf_hyper_grid)
# model results
show_best(rf_results, metric = "roc_auc") %>% view()
# get optimal hyperparameters
rf_best_hyperparameters <- select_best(rf_results, metric = "roc_auc")
rf_best_hyperparameters

## # A tibble: 1 × 4
##    mtry trees min_n .config               
##   <int> <int> <int> <chr>                 
## 1     2    87    20 Preprocessor1_Model102

# create final workflow object
final_rf_wf <- workflow() %>%
     add_recipe(cust_recipe) %>%
     add_model(rf_mod) %>%
     finalize_workflow(rf_best_hyperparameters)
# fit final workflow object
rf_final_fit <- final_rf_wf %>%
     fit(data = cust_train)
classifier <- randomForest( formula = IsCurrent~., data=cust_train)
rf_predict <- predict(classifier, cust_test, type="response")
confusionMatrix(rf_predict, cust_test$IsCurrent)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    0    1
##          0  276  170
##          1  281 1370
##                                           
##                Accuracy : 0.7849          
##                  95% CI : (0.7667, 0.8023)
##     No Information Rate : 0.7344          
##     P-Value [Acc > NIR] : 4.927e-08       
##                                           
##                   Kappa : 0.4113          
##                                           
##  Mcnemar's Test P-Value : 2.222e-07       
##                                           
##             Sensitivity : 0.4955          
##             Specificity : 0.8896          
##          Pos Pred Value : 0.6188          
##          Neg Pred Value : 0.8298          
##              Prevalence : 0.2656          
##          Detection Rate : 0.1316          
##    Detection Prevalence : 0.2127          
##       Balanced Accuracy : 0.6926          
##                                           
##        'Positive' Class : 0               
##

Mean ROC_AUC for random forest is 0.8463349 with mtry = 2, trees = 87, and min_n = 20.

Comment: We see a slight greater number of observations where our model predicts staying (Prediction = 1) but the customers left (Truth = 0) than where our models predicts leaving (Prediction = 0) but the customers stayed (Truth = 1). This shows that our models is optimistic.

4.4. Model Analysis

In summary, we have used Logistic Regression, Decision Tree, and Random Forest with the results as followed:

Model	ROC_AUC	False positive - False negative
Logistic Regression	0.843	93
Decision Tree	0.823	-281
Random Forest	0.846	108

If consider solely ROC_AUC as our metrics, Random Forest model might be the best option with the highest ROC_AUC. When comparing to the second highest ROC_AUC, which is the Logistic Regression, Random Forest is slightly higher in the sensitivity (false positive vs. false negative). However, the difference is negligible. In conclusion, Random Forest is the best algorithm to predict the tendency of leaving/staying of a customer.

Now, let’s look at the importance of the features.

rf_final_fit %>%
     extract_fit_parsnip() %>%
     vip()

From the graph above, we are seeing that the 5 most important features are Tenure, MonthlyCharges, ContractType, TotalCharges, and Internet Looking at the results, we are making a few suggestions for the Development Team in the next section.

5. Business Analysis and Recommendations

Together with our exploratory insights, our model results are suggesting that Tenure, MonthlyCharges, ContractType, TotalCharges, and Internet are the most important features that we should focus on to retain the current customers.

Followed the prediction results, the company is predicted to lose 275 customers in the future if there are actions taken, which accounts for roughly 5% of the current customer population.

As most of the customers that are leaving after their first month with the services, we should implement promotions/programs that encourage customers to stay in the next few months, using discounts on bills or longer contract terms. Besides, having Internet service included is also an important factor influencing the stay/leave chance of the customers. The Sales team should prioritize introducing the customers to the Internet services together with other services.

Customer Retention Forecast

Sue Huynh

2023-01-17