Introduction

For Regork to be successful in this new market we are entering it is important to look at customer retention data from the “customer_retention.csv” file. This data can help us at Regork by providing important statistics to help with all areas of the company. Throughout this report you will see our findings as well as exploratory data analysis we conducted to better understand the data, and find possible correlations between some of the data.

What is the best way for Regork to keep customers?

Data Preparation

The packages we needed:

library(tidymodels)
library(tidyverse)
library(baguette)
library(vip)
library(kernlab)
library(pdp)
library(ggplot2)
library(earth)

Package uses:

tidymodels - a “meta-package” for modeling and statistical analysis

tidyverse - a collection of packages that help in everyday data analyses

baguette - provides efficient for bagging models(which is used later in Machine Learning)

vip - used to create “Variable Importance Plots” which visualizes feature impact

kernlab - used for kernel-based machine learning methods

pdp - a general framework for constructing partial dependence plots

ggplot2 - a system for for declaratively creating graphics

earth - helps build a regression model using the MARS technique

We then import our dataset, and mutate the response variable which is Status to a factor so we can analyze based on a classification model. Null values are also removed.

df <- read_csv("customer_retention.csv")
df <- mutate(df, Status = factor(Status))
df <- na.omit(df)

Exploratory Data Analysis

We start by exploring the data and looking for correlations. We do this by creating graphs using ggplot2. We decided to look at how Payment Method correlates with all other factors.

ggplot(df, aes(MonthlyCharges)) +
  geom_bar(fill = "orange") +
  facet_wrap(~PaymentMethod) +
  ggtitle("Monthly Charges vs. Payment Method") +
  theme(plot.title = element_text(hjust = 0.5)) +
  labs(y = "Count of Customers", x = "Monthly Charge Amount")

This first graph breaks down the data into the different Payment Methods, and then looks at the monthly charge amount by customers. As seen in the graph, typically people who mail their checks have the lowest monthly charge amount. Another observation that can be made is people who send in their checks electronically tend to have the highest average monthly charge.

ggplot(df, aes(InternetService)) +
  geom_bar(fill = "green", color = "red") +
  facet_wrap(~PaymentMethod) +
  coord_flip() +
  ggtitle("Customer Internet Service and Payment Method") +
  labs(y = "Count of Payment Method", x = "Customer Internet Service")

This graph shows the relationship between the type of internet service the customer has and the method that they pay their bills. It is evident that most people pay for their internet by sending an electronic check, and of the people who send an electronic check, most of them have fiber optic internet. It is also interesting that people who mail their checks do not typically have fiber optic, which could be the reason why in the first graph they have the smallest monthly charge.

ggplot(data = df, aes(x = PaymentMethod, fill = Gender)) +
  geom_bar() +
  scale_fill_manual(values = c("pink", "blue")) +
  labs(title = "Gender Count by Payment Method",
       x = "Payment Method",
       y = "Count of Customers")

This graph looks at the correlation between gender and the method of payment customers choose. This graph seems to be evenly split between males and females. This graph does again prove that electronic check is the preferred method of payment for customers, with the number of males paying with electronic checks nearly doubling any other form of payment.

Machine Learning

The first thing we did was set the seed to 123 in order to create reproducible results. We then split the data set into a train and test set. After this we created a kfold called logistic_kfold to give us better insight into our data.

set.seed(123)
logistic_split <- initial_split(df, prop = 0.7, strata = Status)
logistic_train <- training(logistic_split)
logistic_test <- testing(logistic_split)

set.seed(123)
logistic_kfolds <- vfold_cv(logistic_train, v = 5, strata = Status)

Logistic Regression

We decided that our first machine learning model would be a logistic regression model where we look for the ‘AUC’ or Area Under the Curve. We also create a confusion matrix to look for false positives or false negatives.

#Logistic Regression Model

logistic_reg() %>%
  fit_resamples(Status ~., logistic_kfolds) %>%
  collect_metrics()
## # A tibble: 2 × 6
##   .metric  .estimator  mean     n std_err .config             
##   <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
## 1 accuracy binary     0.799     5 0.00401 Preprocessor1_Model1
## 2 roc_auc  binary     0.845     5 0.00521 Preprocessor1_Model1

As seen the logistic regression model returns a very good 0.845 mean value for AUC. We will see throughout the next few machine learning techniques if logistic regression is the most accurate for this dataset.

final_fit <- logistic_reg() %>%
  fit(Status ~., data = logistic_train)

final_fit %>%
  predict(logistic_test) %>%
  bind_cols(logistic_test %>% select(Status)) %>%
  conf_mat(truth = Status, estimate = .pred_class)
##           Truth
## Prediction Current Left
##    Current    1362  225
##    Left        178  332

We also see that there are more false positives (people who they thought were current but really they left), than there are false negatives (people who they thought left but are actually current).

MARS Model

The next machine learning method we decided to use was the Multivariate Adaptive Regression Splines (MARS) method. This method is an algorithm that automatically creates a piecewise linear model which provides an intuitive stepping block into nonlinearity.

# Create Model and Preprocessing Recipe
logistic_recipe <- recipe(Status ~ ., data = logistic_train) %>%
  step_YeoJohnson(all_numeric_predictors()) %>%
  step_normalize(all_numeric_predictors())

# Create ridge model object
mars_mod <- mars(num_terms = tune(), prod_degree = tune()) %>%
  set_mode('classification')

# Create our hyperparameter search grid
mars_grid <- grid_regular(num_terms(range = c(1, 30)), prod_degree(), levels = 25)

# Create workflow object to combine the recipe & model
mars_wf <- workflow() %>%
  add_recipe(logistic_recipe) %>%
  add_model(mars_mod)

# Perform hyperparameter search
tuning_results <- mars_wf %>%
  tune_grid(resamples = logistic_kfolds, grid = mars_grid)

# assess results
tuning_results %>%
  collect_metrics() %>%
  filter(.metric == "roc_auc") %>%
  arrange(desc(mean))
## # A tibble: 50 × 8
##    num_terms prod_degree .metric .estimator  mean     n std_err .config         
##        <int>       <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>           
##  1        15           1 roc_auc binary     0.850     5 0.00509 Preprocessor1_M…
##  2        16           1 roc_auc binary     0.849     5 0.00502 Preprocessor1_M…
##  3        19           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  4        20           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  5        21           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  6        22           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  7        23           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  8        25           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
##  9        26           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
## 10        27           1 roc_auc binary     0.849     5 0.00503 Preprocessor1_M…
## # ℹ 40 more rows
# Create a plot
autoplot(tuning_results)

As seen by the results the MARS method is extremely effective with an average AUC of 0.85 for the top result. This is more accurate than the Linear Regression Model and now we will look to see if it is more accurate than the Bagging Model.

Bagging Model

The bagging model is designed to improve the stability and accuracy of regression and classification algorithms, it helps to reduce variance and minimize overfitting.

# Create a bagged CART model object and start with 5 bagged trees
bag_mod <- bag_tree() %>%
  set_engine("rpart", times = 5) %>%
  set_mode("classification")

# train model
bag_results <- fit_resamples(bag_mod, logistic_recipe, logistic_kfolds)

#model results
collect_metrics(bag_results)
## # A tibble: 2 × 6
##   .metric  .estimator  mean     n std_err .config             
##   <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
## 1 accuracy binary     0.760     5 0.00528 Preprocessor1_Model1
## 2 roc_auc  binary     0.768     5 0.00484 Preprocessor1_Model1
# Create a bagged CART model object with tuning option set for number of bagged trees
bag_mod <- bag_tree() %>%
  set_engine("rpart", times = tune()) %>%
  set_mode("classification")

# create the hyperparameter grid
bag_hyper_grid <- expand.grid(times = c(5, 25, 50, 100, 200, 300))

# train the model across the hyperparameter grid
set.seed(123)
bag_results <- tune_grid(bag_mod, logistic_recipe, resamples = logistic_kfolds, grid = bag_hyper_grid)

# model results
show_best(bag_results, metric = "roc_auc")
## # A tibble: 5 × 7
##   times .metric .estimator  mean     n std_err .config             
##   <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>               
## 1   200 roc_auc binary     0.825     5 0.00349 Preprocessor1_Model5
## 2   300 roc_auc binary     0.825     5 0.00357 Preprocessor1_Model6
## 3   100 roc_auc binary     0.824     5 0.00320 Preprocessor1_Model4
## 4    50 roc_auc binary     0.821     5 0.00363 Preprocessor1_Model3
## 5    25 roc_auc binary     0.816     5 0.00650 Preprocessor1_Model2

As seen in the data the Bagging Method provides the lowest average AUC, showing that it is the least accurate model for this dataset. This does not mean that it will be the least accurate for every dataset though.

The Optimal Model is the MARS model

By running these three different machine learning methods we were able to see the MARS model was the most accurate. So now we are going to look to see which variable appears to be most influential in customers staying or leaving the company.

# Step 1. Finalize our workflow object with the optimal hyperparameter values
best_hyperparameters <- select_best(tuning_results, metric = "roc_auc")

final_wf <- workflow() %>%
  add_recipe(logistic_recipe) %>%
  add_model(mars_mod) %>%
  finalize_workflow(best_hyperparameters)

# Step 2. Fit our final workflow object across the full training set data
final_fit <- final_wf %>%
  fit(data = logistic_train)

# Step 3. Plot the top 10 most influential features
final_fit %>%
  extract_fit_parsnip() %>%
  vip()

As we can see in the VIP chart the variable that is most influential is Tenure. Which makes sense because if you have already been with the company for a long time, why would you leave. Opposed to people who just joined and maybe want to try something new the second something goes wrong.

Business Analysis and Conclusion

Which variables should Regork focus on during their new rebrand?

From the MARS model we are able to see that the most influential variables for people who stay with or leave the company are Tenure, Total Charges, Monthly Charges, if they pay through electronic check, and if they have online security.

Tenure is definitely the most influential variable, so Regork should make sure they continue to market and keep people who have been with them for a long time. This also means that now they know they need to do a better job of keeping people with them for as long as possible because the longer they stay with them, the better chance they do not leave.

The second and third most important variables are the length of contract they have with Regork. This shows the importance of getting people to sign those longer contracts with you.

Conclusion

Regork has as chance to be very successful in this new market they are entering. If they are able to use the data we have given them they should be able to keep customers for the long run, and bring in new customers to keep the company growing. Overall, Regork is in a good position and will most likely grow fairly rapidly.