Why Customers Are Leaving Regork

Introduction

As new Data Scientists at the Regork Company, we have decided to find out why the company hasn’t been able to retain the number of customers that they’d like to have regularly. In this analysis, we used the “customer_retention.csv” to provide information based on the company’s data to show some of our predictions regarding Regork’s customer retention.

The future analysis of the company relies on our analysis of this data and we believe that we have found Regork’s best solution to retain their needed customers. As you look through our analysis, you will find packages needed for the report as well as our data preparation process, our exploratory analysis, and our overall business analysis of our findings. As we tried to find trends between predictor variables and response variables, you will find various models and many types of analysis based on our findings in the data.

Here is our analysis of Regork’s customer retention data.

Packages Required

To retain the best findings for our analysis, we used the following packages: # Load necessary libraries

library(tidyverse)  # For data manipulation
library(caret)  # For data splitting and model training
library(randomForest)   # For random forest algorithm
library(vip)    # For variable importance
library(pdp)    # For variable relationships
library(tidymodels) # For splitting data models
library(kernlab)    # For Machine Learning
library(baguette)   # For efficient functions while bagging
library(dplyr)  # For data manipulation
library(dials)  # For data-specific parameter changes
library(rpart)  # For regression trees
library(rpart.plot) # For plotting regression trees

Data Preparation/Exploratory Analysis

Data Import

customer_data<-read.csv("customer_retention.csv")

First we had to prepare our data and make it easy to manipulate and explore. We found that within our data there were some values that were not available. We cleared these from our data set then proceeded to make our SeniorCitizen Observations more easy to use down the road by making sure they were recognized as binary variables.

sum(is.na(customer_data))
## [1] 11
customer_data <- drop_na(customer_data)
customer_data$SeniorCitizen <- factor(customer_data$SeniorCitizen, levels = c(0, 1), 
                                      labels = c("No", "Yes"))

We began to poke around the data looking for any sort of correlations we could find.

We had the suspicion that customers who did not have phone service would be less likely to retain their contracts with the company. Therefore, we created a plot that would show us the distribution of contract lengths and how many of them were retained when a customer had access to a phone versus when they did not. We were able to find pretty distinct results implying that customers with access to phone service were more likely to retain their business with us.

ggplot(customer_data, aes(Contract)) + 
  geom_bar(fill = "green") + 
  facet_wrap(~ PhoneService, labeller = labeller(PhoneService = c("Yes" = "Has Phone Service", "No" = "Does Not Have Phone Service"))) +
  ggtitle("Customers Contract Length Without Phone Service VS. Customers With Phone Service") +
  theme(plot.title = element_text(hjust = 0.5)) +
  labs(y = "Customer Count", x = "")

Distribution of tenure:

After seeing the different bar graphs in the above table we wanted to further investigate a possible correlation between customer attrition and the length of their contract. We were able to distinctly see that it was more common for there to be people with who had just recently started business with us to have a month to month contract, while customers we have had business with for a long time are very likely to get involved in a more long term contract.

ggplot(customer_data, aes(x = Tenure)) +
  geom_histogram(bins = 30, fill = "blue", color = "black") +
  facet_wrap(~ Contract) +
  labs(title = "Distribution of Customer Tenure by Contract Type", x = "Tenure (months)", y = "Frequency")

We wanted to explore the relationship above in further detail. We speculated that senior citizens might be more inclined to get involved in our long year contracts even more than the general public because of the security provided by a long term contract and also because they are less likely to move around and strike business with new stores. However, we found that distributions were roughly the same amongst all ages of customers.

ggplot(customer_data, aes(x = Tenure)) +
  geom_histogram(bins = 30, fill = "blue", color = "black") +
  facet_grid(SeniorCitizen ~ Contract, 
             labeller = labeller(Contract = c("Month-to-month" = "Month-to-month", 
                                               "One year" = "One year", 
                                               "Two year" = "Two year"),
                                 SeniorCitizen = c("0" = "Not Senior Citizens", 
                                                   "1" = "Senior Citizens"))) +
  labs(title = "Distribution of Customer Tenure by Contract Type and SeniorCitizen",
       x = "Tenure (months)", y = "Frequency")

We then developed a curiosity about different contract and retainment patterns between genders and wondered if there might be any general purchasing power disparities between men and women, so we made this comparative plot as well. However, we found that there was not a notable difference in our sales between men and women, so we did not investigate this relationship further.

 customer_data %>%
     ggplot(aes(x = MonthlyCharges, fill = Gender)) +
     geom_density(alpha = 0.5) +
  labs(title = "Density Plot of Monthly Charges by Gender", x = "Monthly Charges", y = "Density")

Data Preparation/Machine Learning

Machine Learning Data Preparation: Here we split our data with a 70/30 split into a stratified training and testing set so that we can train the model with a similar distribution of data to the test set. We then create our model object and cross validation folds to train our logistic model on. From our model object we are able to gain an accurate predictor considering that our mean is between 0.7 and 0.9.

customer_data <- mutate(customer_data, Status = factor(Status))

set.seed(123)
logistic_split <- initial_split(customer_data, prop = .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)

log_mod <- logistic_reg()

log_result <- log_mod %>% 
  fit_resamples(Status ~ ., logistic_kfolds) 
  
collect_metrics(log_result) %>% 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.845     5 0.00521 Preprocessor1_Model1

Now we can test the accuracy of our model and see how frequently it is correct when applied to the test data. Of these models positive predictions 14.2% are false positives. Of these models predictions 34.9% are false negatives. This indicates that our model is more prone to false negatives. This could be a result of simply having more observations on current data rather than people who have left.

customer_data <- mutate(customer_data, Status = factor(Status))

set.seed(123)
logistic_split <- initial_split(customer_data, prop = .7, strata = Status)
train <- training(logistic_split)
test <- testing(logistic_split)

log_fit1 <- log_mod %>%
  fit(Status ~., data = train)

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

Here we have plotted our AUC to display the reliability of our logistic regression model.

log_fit1 %>% 
   predict(train, type = "prob") %>%
   mutate(truth = train$Status) %>%
   roc_curve(truth, .pred_Current) %>%
   autoplot()

Now we want to see what are the 10 most influential features acting upon customer retention. When visualizing this we found that tenure and contract length were in the leading factors, which coincides with the implications of our exploratory analysis.

vip(log_fit1, num_features = 10)

For our decision tree first we will split our data again into trainable groups. Then we specify our decision tree model object and train it on the training data.

set.seed(123)  
split <- initial_split(customer_data, prop = 0.75, strata = Status)
train_data <- training(split)
test_data <- testing(split)


tree_model <- rpart(Status ~ ., data = train_data, method = "class")

Then we want to visually look at our decision tree to analyze its results. In this chunk we also test our model on the testing split that we created earlier on. We will also test our AUC to see if we can find our results dependable or not. After testing our AUC we find that our model is looking generally dependable. This model is more likely to produce false negatives with 19.9% of its positive answers being false positives and 32.7% of observations are false negatives.

rpart.plot(tree_model, main="Decision Tree for Customer Status Based on All Variables")

predictions <- predict(tree_model, test_data, type = "class")
confusion_matrix <- table(Predicted = predictions, Actual = test_data$Status)
print(confusion_matrix)
##          Actual
## Predicted Current Left
##   Current    1203  299
##   Left         80  165
collect_metrics(log_result)
## # 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

Now we will analyze the AUC to see how reliable our results actually are from the previous test. We will also produce a visualization in this chunk so that we are able to compare our AUC curves from other ML models. Upon using some hyperparameter tuning we are able to increase our accuracy factor by roughly 0.001. This indicates that an AUC of 0.8002 is roughly as accurate as our decision tree model is going to get.

train_control <- trainControl(method = "cv", number = 10,
                              summaryFunction = twoClassSummary,
                              classProbs = TRUE, savePredictions = TRUE,
                              search = "grid")

tune_grid <- expand.grid(cp = seq(0.001, 0.1, by = 0.002))

tree_model <- train(Status ~ ., data = train_data, method = "rpart",
                    trControl = train_control, tuneGrid = tune_grid,
                    metric = "ROC")

best_model_auc <- max(tree_model$results$ROC)
print(paste("Best AUC:", best_model_auc))
## [1] "Best AUC: 0.800183317747472"

Business Analysis/Conclusion

Business Analysis

As we analyzed our data across all our predictor models, we have found that Tenure, ContractTwo Year, ContractOne Year, TotalCharges, PaperlessBillingYes are the most important features in our models for the “customer_retention.csv” dataset.

Tenure - this was our most important predictor variable. This one should be obvious since the longer someone is with a company, the more likely they are to stay with that company. So analyzing this, when Regork decides to expand, they should first look at the customers who have been with Regork the longest since they are the ones that are most likely to stay with Regork when/if the customer decides to buy something within the telecommunications realm.

Contract Year One and Two - these were our second and third most important predictor variables. These two represent how long a customer’s contract lasted. The two year contracts seem to be more important than the one year contracts, but they are very close. But if Regork is expanding into telecommunications, I’d recommend looking for customers with two year contracts first, then looking for customers with one year contracts second, but both seem to be very important when deciding who to try to bring back to Regork.

Total Charges - Another important predictor variable found in our model. This shows how much customers have spent on telecommunications. Regork should try to target the customers in their expected range of prices and look at those customers who fit their ideal price range, aka their “Total Charges”.

Paperless Billing (Yes) - This rounds out the top 5 most important predictor variables in our model. THis variable tells Regork that customers who want Paperless Billing for the telecommunications charges, would most likely be an ideal target for their company.

Conclusion

To conclude our report of the Regork telecommunications analysis, we believe that the best way to retain customers is by offering incentives for longer tenured customers. More specifically, customers under one or two year contracts. We think that Regork has a great variety of choices when it comes to finding customers to help boost their new telecommunications market. Although there aren’t many customers leaving Regork, it is safe to say that we took a great amount of time to find out the best ways to help retain those customers through our analysis of the given data. Overall, we hope that Regork can take our analysis and find the best ways to retain their customers and hopefully they can find ways to retain their customers in the future using our data as well.

Limitations

For our limitations, most of them stem from the fact that our data was of a limited size. If for example, we had more observations in which our Status variable showed cases of customers who had discontinued their business with the company we strongly believe that our results would be varied. A lot of our models indicated a more accurate prediction of the ‘Current’ outcome in the Status variable, but we believe that is just because there were more ‘Current’ cases for the models to be trained on. Another way in which our results could be built is if we had information on the times at which people left. If we had this information we would have further insights into when they are most likely to leave and could more deeply explore the relationship between when people leave and their contract lengths as well as the relationship between when they were most likely to leave and their overall tenure, data regarding age would also be applicable in the same way.