Customer Retention Analysis Project

Prerequisites

library(tidyverse)
library(tidymodels)
library(baguette)
library(utils)
library(purrr)
library(readr)
library(ggplot2)
library(RColorBrewer)
library(pdp)
library(gridExtra)
library(janitor)
library(dplyr)
library(vip)
library(rpart.plot)
data <- read_csv("customer_retention (1).csv") %>%
  clean_names() %>%
  filter(internet_service %in% c("DSL", "Fiber optic"))
## 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.

Introduction

The Problem: Our goal is to assist Regork in retaining their existing customers with their entrance in the telecommunications market, rather than spending money on new customer prospects, which is more expensive. Regork has challenged us to analyze their customer data and predict if customers will leave in the future, and how to stop it. Our analysis starts by looking at visualizations of our customer data, then developing our machine learning model, which consists of regression, decision-tree, and bagged CART models.


Retention: The following methods were used in our retention model: + Data visualization based off customer data provided by Regork to pinpoint trends. + Applied logistics regression, regularized regression, bagged CART model, and decision tree model for our prediction of whether a customer will leave or not. + Provide recommendations based off of our model to improve customer retention.

Data: We have 1 month worth of data that has been include those who use Internet Service.

Columns: 1. “Status”
2. “Gender”
3. “SeniorCitizen”
4. “Partner”
5. “Dependents”
6. “Tenure”
7. “PhoneService”
8. “MultipleLines”
9. “InternetService”
10. “OnlineSecurity”
11. “OnlineBackup”
12. “DeviceProtection”
13. “TechSupport”
14. “StreamingTV”
15. “StreamingMovies”
16. “Contract”
17. “PaperlessBilling”
18. “PaymentMethod”
19. “MonthlyCharges”
20. “TotalCharges”

Exploratory Analysis

Data cleaning!

glimpse(data)
## Rows: 5,480
## Columns: 20
## $ gender            <chr> "Female", "Male", "Male", "Male", "Female", "Female"…
## $ senior_citizen    <dbl> 0, 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", "Ye…
## $ dependents        <chr> "No", "No", "No", "No", "No", "No", "Yes", "No", "No…
## $ tenure            <dbl> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 58, 49, 25, …
## $ phone_service     <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", "No",…
## $ multiple_lines    <chr> "No phone service", "No", "No", "No phone service", …
## $ internet_service  <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fiber op…
## $ online_security   <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Yes", …
## $ online_backup     <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "No", "…
## $ device_protection <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "No", "…
## $ tech_support      <chr> "No", "No", "No", "Yes", "No", "No", "No", "No", "Ye…
## $ streaming_tv      <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No", "Y…
## $ streaming_movies  <chr> "No", "No", "No", "No", "No", "Yes", "No", "No", "Ye…
## $ contract          <chr> "Month-to-month", "One year", "Month-to-month", "One…
## $ paperless_billing <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", "No",…
## $ payment_method    <chr> "Electronic check", "Mailed check", "Mailed check", …
## $ monthly_charges   <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 29.…
## $ total_charges     <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50, 194…
## $ status            <chr> "Current", "Current", "Left", "Current", "Left", "Le…

Null Checking!

sapply(data, function(x) sum(is.na(x)))
##            gender    senior_citizen           partner        dependents 
##                 0                 0                 0                 0 
##            tenure     phone_service    multiple_lines  internet_service 
##                 0                 0                 0                 0 
##   online_security     online_backup device_protection      tech_support 
##                 0                 0                 0                 0 
##      streaming_tv  streaming_movies          contract paperless_billing 
##                 0                 0                 0                 0 
##    payment_method   monthly_charges     total_charges            status 
##                 0                 0                 5                 0

There are 5 nulls in total charges.

#Replace null with zeroes
data <- replace(data,is.na(data),0)

#Turn Status into a factor for modeling
data$status <- as.factor(data$status)

Let’s check to see what the sums of status are, and the % of customers being retained.

Customer_retention <- data %>% select(status) %>% 
  mutate(Current_customer = ifelse(status == "Current",1,0),
         Left_customer = ifelse(status == "Left",1,0)) %>% 
  summarize(Current_ct = sum(Current_customer),
            Left_ct = sum(Left_customer),
            Customer_retention = sum(Left_customer)/sum(Current_customer))
Customer_retention
## # A tibble: 1 × 3
##   Current_ct Left_ct Customer_retention
##        <dbl>   <dbl>              <dbl>
## 1       3737    1743              0.466

Only 46.6% of Regork customers are being retained.

Trend and Relationship Analysis!

ggplot(data, aes(x = tenure, fill = internet_service)) + 
  geom_histogram(position = "dodge", binwidth = 1) +
  labs(title = "Distribution of Tenure by Internet Service", x = "Tenure (months)", y = "Count")

This plot explains the distribution of our customer’s off of their internet provider. There are 2 main providers of internet service: DSL and Fiber Optic. We notice that the majority of our customers have had a short or long tenure with us, with the middle is consistently lower. This symbolizes that we had an influx of initial customers, which then leveled off. As well as that we have a large number of new customers, but these thin out as they decide if they want to stay with Regork or not. We know that only 46.6% of our customers stay with us, so that explains the steep drop off after the first month of tenure. This analysis stays true to customers who choose DSL or Fiber Optic as their internet service provider.

ggplot(data, aes(x = monthly_charges, fill = status)) + 
  geom_density(alpha = 0.7) +
  labs(title = "Density of Monthly Charges by Customer Status", x = "Monthly Charges", y = "Density")

This plot visualizes the density of our customer’s status in comparison to their monthly charges. We can see that the majority of customers who have churned were charged $75-$100 per month and had the highest density, whereas those who are still with us pay similar amounts, but at a slighter density. This shows that the majority of our customers, current and churned, pay between $75-$100, so this does not necessarily help to explain why these customers left.

a <- ggplot(data, aes(x = monthly_charges, fill = status)) +
  geom_histogram(position = "identity", alpha = 0.5, bins = 30) +
  labs(title = "Distribution of Monthly Charges by Customer Status", x = "Monthly Charges", y = "Count") +
  theme_minimal()
a

This plot visualizes the distribution of monthly charges of our customer’s status by count. While viewing the distribution of monthly charges among our existing and churned customers, we noticed that a majority of our current customers are paying more than our churned customers at their point of exit, which is when they cancelled our services. Intuition would lead us to assume that our churned customers would’ve had the higher count of higher monthly charges, especially since there is only a 46.6% retention rate, but that is not the case here.

b <- ggplot(data, aes(x = status, y = monthly_charges, fill = status)) +
  geom_boxplot() +
  labs(title = "Box Plot of Monthly Charges by Customer Status", x = "Customer Status", y = "Monthly Charges") +
  theme_minimal()
b

This box and whisker plot shows information on the monthly charges by customer’s status. From a box and whisker plot, we see the min, max, lower & upper quartile, median, and IQR. With this visualization, we know that both customers types have nearly identical upper quartiles, which means that 75% of the customers fall underneath the corresponding monthly charge.

c <- ggplot(data, aes(x = tenure, fill = status)) +
  geom_histogram(position = "identity", alpha = 0.5, bins = 30) +
  labs(title = "Distribution of Tenure by Customer Status", x = "Tenure", y = "Count") +
  theme_minimal()

c

This plot shows the relationship between the count of customer’s status and their tenure. Our assumption was that there would not be many customers who would leave after 20 months, and the data proves us right. As the tenure of our customers increases, they are continuously less likely to cancel our service.

d <- ggplot(data, aes(x = internet_service, y = monthly_charges, fill = internet_service)) +
  geom_boxplot() +
  labs(title = "Box Plot of Monthly Charges by Internet Service", x = "Internet Service", y = "Monthly Charges") +
  theme_minimal()
d

This plot shows the information on the monthly charges compared to internet services, where all of our customers (current and churned) are included. We can easily see that Fiber Optic is more expensive that DSL, with Fiber Optic’s lower surtitle being significantly higher than DSL’s upper quartile. As well as Fiber Optic’s minimum being in between DSL’s median and upper quartile.

e <- ggplot(data, aes(x = monthly_charges, fill = internet_service)) +
  geom_density(alpha = 0.5) +
  labs(title = "Density Plot of Monthly Charges by Internet Service", x = "Monthly Charges", y = "Density") +
  theme_minimal()

e

This plot visualizes the density of our customer’s monthly charges by internet service. We can see that th majority of our customer’s who choose DSL pay less monthly than their counterparts who choose Fiber Optic’s.

plot_feature <- function(feature) {
  ggplot(data, aes_string(x = "internet_service", y = "monthly_charges", fill = "internet_service")) +
    geom_boxplot() +
    facet_wrap(~get(feature), scales = "free") +
    labs(title = paste("Monthly Charges by Internet Service with", feature), x = "Internet Service", y = "Monthly Charges") +
    theme_minimal()
}

features <- c("online_security", "online_backup", "device_protection", "tech_support", "streaming_tv", "streaming_movies")
plots <- lapply(features, plot_feature)
## Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
## ℹ Please use tidy evaluation idioms with `aes()`.
## ℹ See also `vignette("ggplot2-in-packages")` for more information.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
print(plots[])  # Example to print the first plot
## [[1]]

## 
## [[2]]

## 
## [[3]]

## 
## [[4]]

## 
## [[5]]

## 
## [[6]]

These box and whisker plots show information on the monthly charges compared to online security, online backup, device protection, tech support, streaming tv, and streaming movies, which are all optional services we provide at additional charge. These plots are also split by whether the customer is current (yes), or churned (no). All 6 plots show strikingly similar results, with Fiber Optic’s median hanging around DSL’s max monthly price.

Machine Learning

Logistic Regression

set.seed(123)
split <- initial_split(data, prop = .7, strata = 'status')
filtered_data_train <- training(split)
filtered_data_test <- testing(split)

set.seed(123)
kfold <- vfold_cv(filtered_data_train, v = 5)

###Logistic Reg
results <- logistic_reg() %>%
  fit_resamples(status ~ ., kfold)

collect_metrics(results, summarize = FALSE) %>% filter(.metric == "roc_auc")
## # A tibble: 5 × 5
##   id    .metric .estimator .estimate .config             
##   <chr> <chr>   <chr>          <dbl> <chr>               
## 1 Fold1 roc_auc binary         0.856 Preprocessor1_Model1
## 2 Fold2 roc_auc binary         0.808 Preprocessor1_Model1
## 3 Fold3 roc_auc binary         0.824 Preprocessor1_Model1
## 4 Fold4 roc_auc binary         0.811 Preprocessor1_Model1
## 5 Fold5 roc_auc binary         0.826 Preprocessor1_Model1
collect_metrics(results) %>% filter(.metric == "roc_auc")
## # A tibble: 1 × 6
##   .metric .estimator  mean     n std_err .config             
##   <chr>   <chr>      <dbl> <int>   <dbl> <chr>               
## 1 roc_auc binary     0.825     5 0.00846 Preprocessor1_Model1

We see that the initial roc_auc value for our logistic regression is 82.5%, which is acceptable to our performance standards of 80%. This tells us that there is an .824 chance the model will assign a larger probability to a random positive observation than a random negative one. Although, there is a possibility that a better model can be produced.

# retrain the model across the entire training data
final_fit <- logistic_reg() %>%
  fit(status ~ ., data = filtered_data_train)

# Creating tests against test data.
final_fit %>%
  predict(filtered_data_train) %>%
  bind_cols(filtered_data_train %>% select(status)) %>%
  conf_mat(truth = status, estimate = .pred_class)
##           Truth
## Prediction Current Left
##    Current    2231  491
##    Left        384  729

Shown above is a confusion matrix over the predicted and true metrics of our customers who are current and churned. We see that the majority were true positives and true negatives, showing the accuracy of our model. However, there is still a large amount of false negatives and false positives.

log_regression_auc_plot <-final_fit %>%
  predict(filtered_data_train, type = "prob") %>%
  mutate(truth = filtered_data_train$status) %>% 
  roc_curve(truth, .pred_Current) %>% 
  autoplot()

log_regression_auc_plot

This visualization shows the roc_auc curve from the corresponding logistic regression model.

log_regression_auc <- final_fit %>%
  predict(filtered_data_train, type = "prob") %>%
  mutate(truth = filtered_data_train$status) %>% 
  roc_auc(truth, .pred_Current)

log_regression_auc
## # A tibble: 1 × 3
##   .metric .estimator .estimate
##   <chr>   <chr>          <dbl>
## 1 roc_auc binary         0.830

The roc_auc from our logistic regression model is .829, which is above our performance standard of .80, symbolizing that our model has very good performance in assigning a larger probability a random positive observation.

log_regression_level <- vip(final_fit$fit, num_features = 20)

log_regression_level

Above is a feature interpretation chart ranking the top influential variables in our logistic regression model.

Our logistic regression model does a great job at predicting if a customer will churn or stay. This is evident with an roc_auc value of .829. Any inaccuracies in our model can be seen in the confusion matrix, which shows that there was both false positives and false negatives in the model. This model had more false positives than false negatives, which means the model may predict that a customer is current when they have left.

Logisitcs Regression with classification

set.seed(123)
split <- initial_split(data, prop = 0.7, strata = status)
data_train <- training(split)
data_test <- testing(split)

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

# Assuming 'status' is binary or multinomial, prepare the recipe and model
data_recipe <- recipe(status ~ ., data = data_train) %>%
  step_YeoJohnson(all_numeric_predictors()) %>%
  step_normalize(all_numeric_predictors()) %>% 
  step_dummy(all_nominal_predictors())


# Define the logistic regression model
class_model <- logistic_reg(mixture = tune(), penalty = tune()) %>%
  set_engine("glmnet") %>%
  set_mode("classification")

# Create a hyperparameter grid
class_grid <- grid_regular(mixture(), penalty(range = c(-10, 5)), levels = 10)

# Combine recipe and model into a workflow
data_wf_class <- workflow() %>%
  add_recipe(data_recipe) %>%
  add_model(class_model)

# Perform hyperparameter tuning
tuning_results_class <- data_wf_class %>%
  tune_grid(resamples = kfolds, grid = class_grid)

# Check results and select the best model based on ROC AUC
tuning_results_class %>%
  collect_metrics() %>%
  filter(.metric == "roc_auc") %>%
  arrange(desc(mean))
## # A tibble: 100 × 8
##          penalty mixture .metric .estimator  mean     n std_err .config         
##            <dbl>   <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>           
##  1 0.0000000001    0     roc_auc binary     0.829     5 0.00912 Preprocessor1_M…
##  2 0.00000000464   0     roc_auc binary     0.829     5 0.00912 Preprocessor1_M…
##  3 0.000000215     0     roc_auc binary     0.829     5 0.00912 Preprocessor1_M…
##  4 0.00001         0     roc_auc binary     0.829     5 0.00912 Preprocessor1_M…
##  5 0.000464        0     roc_auc binary     0.829     5 0.00912 Preprocessor1_M…
##  6 0.000464        0.111 roc_auc binary     0.828     5 0.00925 Preprocessor1_M…
##  7 0.0215          0     roc_auc binary     0.828     5 0.00913 Preprocessor1_M…
##  8 0.0215          0.111 roc_auc binary     0.828     5 0.00893 Preprocessor1_M…
##  9 0.000464        0.222 roc_auc binary     0.828     5 0.00925 Preprocessor1_M…
## 10 0.0000000001    0.111 roc_auc binary     0.828     5 0.00925 Preprocessor1_M…
## # ℹ 90 more rows
# Finalize the workflow with the best parameters
best_hyperparameters_class <- select_best(tuning_results_class, metric = "roc_auc")
final_wf_class <- workflow() %>%
  add_recipe(data_recipe) %>%
  add_model(class_model) %>%
  finalize_workflow(best_hyperparameters_class)

# Fit the final model
final_fit_class <- final_wf_class %>%
  fit(data = data_train)

# Plot the top 10 most influential features
final_fit_class %>%
  extract_fit_parsnip() %>%
  vip()

Shown above is a feature interpretation chart ranking the most influential variables in our logistic regression with classification model.

reg_regression_auc_plot <- final_fit_class %>% 
  predict(data_train, type = "prob") %>%
  mutate(truth = data_train$status) %>% 
  roc_curve(truth, .pred_Current) %>% 
  autoplot()

reg_regression_auc_plot

Shown above is a visualization of the roc_auc curve corresponding to our logistic regression with classification model.

reg_regression_conf_matrix <- final_fit_class %>%
  predict(data_train) %>%
  bind_cols(data_train %>% select(status)) %>%
  conf_mat(truth = status, estimate = .pred_class)

reg_regression_conf_matrix
##           Truth
## Prediction Current Left
##    Current    2291  534
##    Left        324  686

This confusion matrix is based off our logistic regression with classification model. This matrix yields similar results to the previous logistic regression moedel.

reg_regression_auc <- final_fit_class %>% 
  predict(data_train, type = "prob") %>%
  mutate(truth = data_train$status) %>% 
  roc_auc(truth, .pred_Current)

reg_regression_auc
## # A tibble: 1 × 3
##   .metric .estimator .estimate
##   <chr>   <chr>          <dbl>
## 1 roc_auc binary         0.832

The roc_auc from our logistic regression with classification model is .831, which is above our performance standard of .80, symbolizing that our model has very good performance in assigning a larger probability a random positive observation.

Our logistic regression model does a great job at predicting if a customer will churn or stay. This is evident with an roc_auc value of .831. Any inaccuracies in our model can be seen in the confusion matrix, which shows that there was both false positives and false negatives in the model. This model had more false positives than false negatives, which means the model may predict that a customer is current when they have left.

Decision tree

set.seed(123)
split <- initial_split(data, prop = 0.7, strata = status)
data_train <- training(split)
data_test <- testing(split)

# Create decision tree model object
dt_mod <- decision_tree(mode = 'classification') %>%
  set_engine("rpart")

# Create model recipe
model_recipe <- recipe(status ~ ., data = data_train)

# Fit model workflow
dt_fit <- workflow() %>%
  add_recipe(model_recipe) %>%
  add_model(dt_mod) %>%
  fit(data = data_train)
rpart.plot::rpart.plot(dt_fit$fit$fit$fit)
## Warning: Cannot retrieve the data used to build the model (model.frame: object '..y' not found).
## To silence this warning:
##     Call rpart.plot with roundint=FALSE,
##     or rebuild the rpart model with model=TRUE.

# Create resampling procedure
set.seed(123)
kfold <- vfold_cv(data_train, v = 5)

# Train model and collect metrics
dt_results <- fit_resamples(dt_fit, kfold)
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.755     5 0.00984 Preprocessor1_Model1
## 2 roc_auc  binary     0.789     5 0.00708 Preprocessor1_Model1

The roc_auc from our decision tree model is .789, which is below our performance standard of .8, symbolizing that our model has good, not very good, performance in assigning a larger probability a random positive observation.

# Tune the decision tree model
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 model across the hyperparameter grid
set.seed(123)
dt_results <- tune_grid(dt_mod, model_recipe, resamples = kfold, grid = dt_hyper_grid)

# Get best results
show_best(dt_results, metric = "roc_auc", n = 5)
## # A tibble: 5 × 9
##   cost_complexity tree_depth min_n .metric .estimator  mean     n std_err
##             <dbl>      <int> <int> <chr>   <chr>      <dbl> <int>   <dbl>
## 1    0.0000000001          4     2 roc_auc binary     0.801     5 0.00731
## 2    0.0000000178          4     2 roc_auc binary     0.801     5 0.00731
## 3    0.00000316            4     2 roc_auc binary     0.801     5 0.00731
## 4    0.0000000001          4    11 roc_auc binary     0.798     5 0.00705
## 5    0.0000000178          4    11 roc_auc binary     0.798     5 0.00705
## # ℹ 1 more variable: .config <chr>
# Get best hyperparameter values
dt_best_model <- select_best(dt_results, metric = 'roc_auc')

# Put together final workflow
dt_final_wf <- workflow() %>%
  add_recipe(model_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 = data_train)

# Plot feature importance
dt_final_fit %>%
  extract_fit_parsnip() %>%
  vip(20)

Shown above is a feature interpretation chart ranking the most influential variables in our decision tree model.

decision_tree_conf_matrix <- dt_final_fit %>% 
  predict(data_train) %>% 
  mutate(truth = data_train$status) %>% 
  conf_mat(truth = truth, estimate = .pred_class)

decision_tree_conf_matrix
##           Truth
## Prediction Current Left
##    Current    2251  529
##    Left        364  691
decision_tree_auc_plot <- dt_final_fit %>% 
  predict(data_train, type = "prob") %>% 
  mutate(truth = data_train$status) %>%  
  roc_curve(truth, .pred_Current) %>% 
  autoplot()

decision_tree_auc_plot

Our decision tree model does a decent job at predicting if a customer will churn or stay. This is evident with an roc_auc value of .789. Any inaccuracies in our model can be seen in the confusion matrix, which shows that there was both false positives and false negatives in the model. This model had more false positives than false negatives, which means the model may predict that a customer is current when they have left.

Bagging

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

# Train model and collect metrics
bag_results <- fit_resamples(bag_mod, model_recipe, kfold)
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.732     5 0.00892 Preprocessor1_Model1
## 2 roc_auc  binary     0.747     5 0.00430 Preprocessor1_Model1
# Set up the bagged CART model with tuning for the number of 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, model_recipe, resamples = kfold, grid = bag_hyper_grid)

# Display the best 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.796     5 0.00799 Preprocessor1_Model5
## 2   300 roc_auc binary     0.794     5 0.00712 Preprocessor1_Model6
## 3   100 roc_auc binary     0.793     5 0.00826 Preprocessor1_Model4
## 4    50 roc_auc binary     0.790     5 0.00605 Preprocessor1_Model3
## 5    25 roc_auc binary     0.782     5 0.00993 Preprocessor1_Model2

Business Analysis

Prediction

current_month_prediction <- as.data.frame(predict(dt_final_fit, data_test))

customer_rentention_amount <- data_test %>% 
  mutate(prediction = current_month_prediction$.pred_class) %>% 
  filter(status == "Current", prediction == "Left")

head(customer_rentention_amount %>% select(status, prediction))
## # A tibble: 6 × 2
##   status  prediction
##   <fct>   <fct>     
## 1 Current Left      
## 2 Current Left      
## 3 Current Left      
## 4 Current Left      
## 5 Current Left      
## 6 Current Left

It’s predicted that 6 customers are likely to leave this month.

customer_rentention_amount %>% 
  summarize(potential_losses = sum(monthly_charges),
            avg_loss_per_customer = sum(monthly_charges)/n())
## # A tibble: 1 × 2
##   potential_losses avg_loss_per_customer
##              <dbl>                 <dbl>
## 1           10201.                  67.1

Conclusion

In terms of relative importance how would you rate the predictors in your model. As a business manager, which factors would you focus on (for example you could invest in offering some incentives or promotions) to decrease the chances of customers leaving? For our optimal regression model, the predictor variables of tenure, contract length (1 year, 2 year, or month-to-month), and total charges were most influential. These 4 variables were the only ones with an importance score of 4 or more, and tenure was the highest of them all. As a manager, I would focus heavily on these variables to be able to retain customers more efficiently. Offering discounts, rewards, and promotions to customers who have been with Regork for 1 year or longer would help decrease the number of customers who cancel our services. These incentives and promotions can gradually increase and become more lucrative the longer the customer stays. This may lessen the profit gained per customer, as they would pay less for our services as each year goes by, but it would drastically increase our profit over the long run if even 10% more customers stay with Regork. This would also effect the customers total charge as well, as it would continually increase as time goes by, but at a lower rate than it was before.

Collect all the customers from the test dataset that you predict are going to leave. We predicted 6 current customers who are likely to churn. Our model knows this by identifying influential trends like tenure and contract type from our past customers who have already churned, and our current customers who do not plan to churn. We should immediately target these 6 individuals with an email or direct mail with an incentive based on what factor they are unhappy with.

What is the predicted loss in revenue per month if no action is taken? If no action is taken, we risk a loss in revenue of $10,201.15 per month, with an average loss of 67.11 per customer. This amount is represented by our model and is a prediction of the potential losses Regork may face if retention does not increase.

Propose an incentive scheme to your manager to retain these customers. Use your model to justify your proposal. You can do this by performing a cost benefit analysis (comparing the cost of the incentive plan to the benefit of retaining the customers). There are multiple incentive schemes that we can propose. One of which is to have a price lock guarantee for customers who sign a 2-year contract with us, as well as available incentives for each year of the contract. This is because 2-year contracts were the most influential variable for our logistic regression with classification model. This would give the customer more of a reason to stay with us long term, especially if it is a new customer that has only been with us for less than 6 months, as that is the crucial time frame where most of our lost customers leave. If most of our churned customers are leaving after only a few months, this means that they are on month-to-month contracts, or terminating their yearly contracts. If we can get those month-to-month customers to stay rather than leave by getting them to sign yearly contracts, retention would skyrocket compared to the 46.6% it is currently. Also with this, we can send out surveys to our customers to learn which holidays they partake in, and send them postcards on said holidays. This will give the customer a sense that we care about them, and create an environment where we view our customers as more than just a monthly check. Another incentive we recommend is a time based rewards program, where the customer gains points for each month they are a customer. They can then use the points as a form or currency where they can trade them in for coupons, monthly services, etc. For example, if 100 points is given to each customers every month, after 5 months they can trade in 500 points for a free month of a device protection plan. This can also give the customer a taste of what our services are, a free-trial, which can entice them to purchase that service if it highlights the inconvenience of not having that service after the free-trial ends.

Conclusion/Implications In conclusion, Regork is facing challenges in retaining their customers and came to us to look for solutions! From analyzing our model, we determined that the predictor variables of tenure, contract, and total charges were the most influential, and these should be the focus points of our planned incentives. We are confident in both of our logistic regression model and logistic regression classification model as they have roc_auc’s of 83% & 83.1%, respectively, which fit the criteria of a very good performing model. The incentive plans that we recommend be implemented are designed to attract our new customers to sign a year or multi-year contract by showing we care about them with monthly reward points, price lock guarantee’s, incentives that become more lucrative the longer a customer stays, and personalized postcards.

Limitations Overfitting Risk: Since the dataset is only 7000 rows, there is a high chance that models might overfit the data, making them perform well on training data but poorly on unseen data. This reduces their generalizability on realistic applications. External factor: To truly understand the reason why customer was leaving, we believe it would be best if there are additional resources for researching and comparison to make sure that there are no factor underlying and it’s not in the data. Temporal Relevance: We believe it would be best to have an understanding on the relevancy of this data, as the findings might not be applicable today. This can limit the utility of the models for predictive purposes.