Introduction

In order to help Regork try and best optimize their journey in the telecommunications market, it is important to know that the costs incurred to attract new customers are much larger than the costs to retain existing customers. Here in this report are findings as to how Regork can best retain the consumer base that they have now. This can be done by using machine learning models, and measuring performance to see which model is the most accurate.

By addressing multiple models, we can take the our most optimal model and figure out which variables Regork needs to pay more attention to in order to retain customers.

Packages Required

suppressWarnings(suppressMessages(library(tidymodels)))
suppressWarnings(suppressMessages(library(tidyverse)))
suppressWarnings(suppressMessages(library(baguette)))
suppressWarnings(suppressMessages(library(vip)))
suppressWarnings(suppressMessages(library(pdp)))
suppressWarnings(suppressMessages(library(here)))
suppressWarnings(suppressMessages(library(kernlab)))
suppressWarnings(suppressMessages(library(ggplot2)))
suppressWarnings(suppressMessages(library(ranger)))
suppressWarnings(suppressMessages(library(earth)))
suppressWarnings(suppressMessages(library(glmnet)))
suppressWarnings(suppressMessages(library(rsample)))

Data Exploration

We will start off by trying to identify some trends in our data set, but first we will need to remove all null values, and factor our response variable, Status, because this is a classification problem.

retention_set <- read.csv("customer_retention.csv")
retention_set <- mutate(retention_set, Status = factor(Status))
retention_set <- na.omit(retention_set)
retention_set %>% 
  ggplot(aes(MultipleLines, fill=InternetService))+
  geom_bar() +
  labs(title = "Multiple Lines and Internet Service Relationship")

This graph shows us that people who have multiple lines tend to have Fiber optic internet service compared to those who don’t have multiple lines. The ones who don’t tend to have DSL instead. It is also interesting to note that everyone who has no phone service has DSL as their Internet service.

retention_set %>% 
  ggplot(aes(MultipleLines, fill=InternetService))+
  geom_bar() + facet_wrap(~Partner) +
  labs(title = "Partner Effect on Previous Relationship")

Adding demographics into the mix, this shows that people without partners tend to not have multiple lines, while those with partner do tend to have multiple.

retention_set %>% 
  ggplot(aes(Tenure, fill=InternetService))+
  geom_bar() +
  labs(title = "Tenure length and Internet Service Relationship")

While searching for trends in tenure length, we found that internet service tends to have a pretty proportional spread, not giving us much variety.

retention_set %>% 
  ggplot(aes(Tenure, fill=InternetService))+
  geom_bar() + facet_wrap(~Partner) +
  labs(title = "Tenure & Internet Service in Relation to Partner")

However, when you incorporate the partners demographic into the mix, you can see that those who don’t have partners tend to have very short tenures while those who have partners have longer tenures.

Machine Learning

There are going to be three different models run, and those are a Decision Tree model, Multivariate Adaptive Regression Splines, and Bagging.

Base Recipie & Split

set.seed(123)
data_split <- initial_split(retention_set, prop = .7, strata = "Status")
data_train <- training(data_split)
data_test  <- testing(data_split)

This creates a 70/30 split between our data, with one set being the training data that we will work with, and another data set that we will use to asses our models.

retention_recipe <- recipe(Status ~ ., data = data_train) %>%
  step_normalize(all_numeric_predictors()) %>%
  step_dummy(all_nominal_predictors())

This is the recipe we will be using for our models ### Decision Tree

set.seed(123)
kfolds <- vfold_cv(data_train, v = 5, strata = Status)

dt_mod <- decision_tree(mode = "classification") %>%
  set_engine("rpart")

dt_fit <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(dt_mod) %>%
  fit(data = data_train)

dt_results <- fit_resamples(dt_mod, retention_recipe, kfolds)

collect_metrics(dt_results)
## # A tibble: 2 × 6
##   .metric  .estimator  mean     n std_err .config             
##   <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
## 1 accuracy binary     0.788     5 0.00399 Preprocessor1_Model1
## 2 roc_auc  binary     0.710     5 0.00529 Preprocessor1_Model1
dt_mod <- decision_tree(
  mode = "classification",
  cost_complexity = tune(),
  tree_depth = tune(),
  min_n = tune()
) %>%
  set_engine("rpart")

dt_hyper_grid <- grid_regular(
  cost_complexity(),
  tree_depth(),
  min_n(),
  levels = 5
)


set.seed(123)
dt_results <- tune_grid(dt_mod, retention_recipe, resamples = kfolds, grid = dt_hyper_grid)

show_best(dt_results, metric = "roc_auc", n = 3)
## # A tibble: 3 × 9
##   cost_complexity tree_depth min_n .metric .estimator  mean     n std_err
##             <dbl>      <int> <int> <chr>   <chr>      <dbl> <int>   <dbl>
## 1    0.0000000001          8    30 roc_auc binary     0.816     5 0.00552
## 2    0.0000000178          8    30 roc_auc binary     0.816     5 0.00552
## 3    0.00000316            8    30 roc_auc binary     0.816     5 0.00552
## # ℹ 1 more variable: .config <chr>
dt_best_model <- select_best(dt_results, metric = 'roc_auc')

dt_final_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(dt_mod) %>%
  finalize_workflow(dt_best_model)

dt_final_fit <- dt_final_wf %>%
  fit(data = data_train)

dt_final_fit %>%
  predict(data_test) %>%
  bind_cols(data_test %>% select(Status)) %>%
  conf_mat(truth = Status, estimate = .pred_class)
##           Truth
## Prediction Current Left
##    Current    1316  243
##    Left        224  314

The Area Under the Curve metric, which is what we are basing our effectiveness on, is at 0.816 for our Decision Tree model. We want this number to be as high as we can get it. We also have a confusion matrix, which tells us about the false positives and negatives. For this model, we have more false positives than negatives, which are the 243 and 224 values respectively. This means that we will predict 243 people to be current when they actually leave, and 224 people to leave when they actually are current.

MARS Model

set.seed(123)
mars_kfolds <- vfold_cv(data_train, v = 5, strata = "Status")

mars_model <- mars(num_terms = tune(), prod_degree = tune()) %>%
  set_mode("classification")

mars_grid <- grid_regular(num_terms(range = c(1,30)), prod_degree(), levels = 50)

mars_wf <- workflow() %>% add_recipe(retention_recipe) %>% add_model(mars_model)

mars_results <- mars_wf %>% tune_grid(resamples = mars_kfolds, grid = mars_grid)

mars_results %>% collect_metrics() %>% filter(.metric == "roc_auc") %>%
  arrange(desc(mean))
## # A tibble: 60 × 8
##    num_terms prod_degree .metric .estimator  mean     n std_err .config         
##        <int>       <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>           
##  1        20           1 roc_auc binary     0.850     5 0.00486 Preprocessor1_M…
##  2        19           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  3        18           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  4        21           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  5        22           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  6        23           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  7        24           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  8        25           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
##  9        26           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
## 10        27           1 roc_auc binary     0.849     5 0.00486 Preprocessor1_M…
## # ℹ 50 more rows
autoplot(mars_results)

mars_best <- select_best(mars_results, metric = "roc_auc")

mars_final_wf <- workflow() %>% 
  add_model(mars_model) %>% add_formula(Status ~ .) %>% 
  finalize_workflow(mars_best)

mars_f_fit <- mars_final_wf %>%
  fit(data = data_train)

mars_f_fit %>%
  predict(data_test) %>%
  bind_cols(data_test %>% select(Status)) %>%
  conf_mat(truth = Status, estimate = .pred_class)
##           Truth
## Prediction Current Left
##    Current    1383  242
##    Left        157  315

The AUC score of 0.850 for the MARS model is higher than our Decision Tree model which we can use to determine that our MARS model is more optimal. This aligns with our confusion matrix as well, since the MARS model computes a higher number of correct currents, and a smaller amount of false negatives. It is interesting to note that the false positives and correct negatives were almost identical between the MARS and Decision Tree model.

Bagged Model

bag_mod <- bag_tree() %>%
  set_engine("rpart", times = 5) %>%
  set_mode("classification")

bag_results <- fit_resamples(bag_mod, retention_recipe, kfolds)

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.00543 Preprocessor1_Model1
## 2 roc_auc  binary     0.767     5 0.00448 Preprocessor1_Model1
bag_mod <- bag_tree() %>%
  set_engine("rpart", times = tune()) %>%
  set_mode("classification")

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

set.seed(123)
bag_results <- tune_grid(bag_mod, retention_recipe, resamples = kfolds, grid = bag_hyper_grid)

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.822     5 0.00352 Preprocessor1_Model5
## 2   300 roc_auc binary     0.821     5 0.00432 Preprocessor1_Model6
## 3   100 roc_auc binary     0.821     5 0.00462 Preprocessor1_Model4
## 4    50 roc_auc binary     0.815     5 0.00361 Preprocessor1_Model3
## 5    25 roc_auc binary     0.809     5 0.00457 Preprocessor1_Model2
bag_best <- select_best(bag_results, metric = 'roc_auc')

bag_f_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(bag_mod) %>%
  finalize_workflow(bag_best)

bag_f_fit <- bag_f_wf %>%
  fit(data = data_train)

bag_f_fit %>%
  predict(data_test) %>%
  bind_cols(data_test %>% select(Status)) %>%
  conf_mat(truth = Status, estimate = .pred_class)
##           Truth
## Prediction Current Left
##    Current    1342  263
##    Left        198  294

The confusion matrix from this model provides more correct current predictions than the Decision Tree model, but not the MARS model. This model provides the most false positives out of the models, so the MARS model should still be the one we use. This aligns with our AUC score, as it is lower than that of the MARS model as well, being only .822 for the best model.

Analysis

mars_final_wf %>% 
  fit(data = data_train) %>%
  extract_fit_parsnip() %>%
  vip(10, type = "rss")

Based on our most optimal model, the MARS model, the most important features are Tenure, TotalCharges, and MonthlyCharges. What this means for Regork is that as they expand to the Telecommunications market they should try and target customers that they have had the longest tenure with, meaning the longest time spent with Regork, as they are the ones who are most likely to return. Regork should also try and be weary of the amount they are charging, as that has a significant impact on whether or not the customer will stay or not.

If no action is taken, we believe that Regork will lose $491,489.33. While this is only a prediction, the severity of this must not be lost because this profit loss is significant.

Recommendations

We recommend that Regork try and offer longer Tenures, along with marketing to those customers that they have had relationships with the longest. This variable has much significance, and customers would like to see that Regork appreciates their loyalty. We also recommend that Regork offer sales and loyalty programs to customers who purchase multiple times with them, since price is a very important factor in this. This allows for a customer to enjoy a lower price, and Regork to maintain their business.

Limitations

Some limitations of the analysis done is the reasoning for these findings. With more details, we could perhaps dive into why customers and certain demographics care about certain variables and we could cater to them better. There also might be a better machine learning algorithm that we could use that wasn’t implemented in the analysis.