Synopsis

In the pursuit of success in the telecom industry, understanding customer behavior is paramount. Our analysis of customer retention data, sourced from the “customer_retention.csv” file, led to the development of a predictive model crucial for various company functions. This model holds potential applications across departments: marketing can leverage it for tailored promotions, while finance can forecast retention trends impacting company risk and revenue. Our report details the necessary packages, data source, and preparation process. Pre-modeling analysis explored trends and relationships, while our machine learning evaluation encompassed logistic regression, bagging, and decision tree methods. Our user-driven approach involved visualizing dataset trends, building, training, and testing diverse machine learning models to optimize predictive accuracy, ultimately enhancing Regork’s telecom service offering.

Data Preparation

The associated packages used in our analysis, including a short description:

tidymodels: Allows you to perform discrete parts of the ML workflow with discrete packages

tidyverse: A collection of packages designed for data science

baguette: Package includes tree and rule-based models for bagging

vip: A package for constructing variable importance plots

pdp: A package for constructing partial dependence plots and individual conditional expectation curves

rpart: A package for building recursive partitioning models, often used for decision tree analysis

rpart.plot: Provides enhanced plotting capabilities for visualizing decision trees created with the rpart package.

sunburstR: Enables the creation of interactive sunburst diagrams, useful for hierarchical data visualization.

treemap: Facilitates the creation of treemaps, which display hierarchical data as nested rectangles.

scales: Offers functions for scaling and formatting data, commonly used for plotting in R to adjust axes, colors, and more.

earth: Makes available functions for fitting MARS models, which can capture complex relationships in data

library(tidymodels)
library(tidyverse)
library(baguette)
library(vip)
library(pdp)
library(rpart)
library(rpart.plot)
library(sunburstR)
library(treemap)
library(scales)
library(earth)
knittedTable_ContractTypeProportions_ChurnedCustomers
Var1 Freq
Month-to-month 0.8852371
One year 0.0889009
Two year 0.0258621

Exploratory Analysis

rows_allData <- retention_df %>%
               nrow()

churned_customers_only <- retention_df %>%
  filter(Status == "Left")

count_churned_customers <- churned_customers_only %>%
                           nrow()

percent_churned_dataset <- count_churned_customers/rows_allData


densityPlot_2D_ChargesAgainstTenure <- retention_df %>% 
  ggplot( aes(x = MonthlyCharges, y = Tenure) ) +
  stat_density_2d(aes(fill = ..level..), geom = "polygon", colour= "white")+ 
  xlab("Monthly Charges $")+
  ylab("Tenure in Months") +
  geom_point(data = . %>% filter(Status == "Left"), aes(color = Status))

densityPlot_2D_ChargesAgainstTenure

This 2D density plot showcases customer retention analysis for Regork, an internet service provider, revealing the relationship between Monthly Charges and Tenure. Highlighting churned customers separately, it provides insights into their distribution and proportion relative to the total population.

churnedCustomerPaymentMethods <- churned_customers_only %>%
              select(PaymentMethod)

countsOfEachPaymentMethod <- table(churnedCustomerPaymentMethods)

countPaymentMethod_df <- data.frame(Category = names(countsOfEachPaymentMethod), Count = as.numeric(countsOfEachPaymentMethod))

sunburst_distributionPaymentMethod_churned <- countPaymentMethod_df %>%
  sunburst(
    width="100%",
    height=400,
    legend = TRUE, 
    labs(title = "Distribution of Payment Methods for Churned Customers")
  )

sunburst_distributionPaymentMethod_churned
Legend

An interactive Sunburst graph illustrates the payment method distribution among churned customers. Users can explore the percentage associated with bank transfer, mailed check, electronic check, and credit card payments, aiding in understanding customer payment preferences for retention strategies.

retention_df$IsSenior <- ifelse(retention_df$SeniorCitizen == 1,"Senior","Not Senior")

senior_vs_nonsenior_churnRates <- retention_df %>%
  ggplot(aes(x = IsSenior, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status Distribution Amongst Seniors vs. Non-Seniors",
       x = "IsSenior",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),  
        axis.ticks.y = element_blank())  

senior_vs_nonsenior_churnRates

This bar chart illustrates the churn rates of senior and non-senior customers with internet providers. It provides a clear comparison between the two groups, offering insights into how age might influence customer retention within the analyzed dataset.

churnRates_Across_Genders <- retention_df %>%
  ggplot(aes(x = Gender, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status Distribution Amongst Males vs. Female",
       x = "Gender",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),   
        axis.ticks.y = element_blank())  

churnRates_Across_Genders

This bar chart presents the churn rates of female and male customers with internet providers, offering a direct comparison between the two genders. By visualizing churn rates separately for females and males, it provides insights into potential gender-related patterns in customer retention within the analyzed dataset.

churnRates_Across_Partner_vs_NoPartner <- retention_df %>%
  ggplot(aes(x = Partner, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status Distribution Amongst Customers with Partners vs. without Partners",
       x = "Partner",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),   
        axis.ticks.y = element_blank())  

churnRates_Across_Partner_vs_NoPartner

This bar chart contrasts the churn rates between single and married households subscribing to internet services. By visually comparing churn rates across these household types, it offers insights into how marital status may impact customer retention within the analyzed dataset.

churnRates_Across_Dependent_vs_NoDependent <- retention_df %>%
  ggplot(aes(x = Dependents, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status Distribution Amongst Customers with Dependents vs. without Dependents",
       x = "Dependents",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),   
        axis.ticks.y = element_blank())  

churnRates_Across_Dependent_vs_NoDependent

This bar chart compares churn rates between customers with and without dependents for internet providers. It visually contrasts the proportion of churned and current customers in each category, shedding light on how the presence of dependents may influence customer retention within the analyzed dataset.

retention_df <- retention_df %>%
  mutate(dependents_and_partners = case_when(
    Partner == "Yes" & Dependents == "Yes" ~ "P:Y,D:Y",
    Partner == "Yes" & Dependents == "No" ~ "P:Y,D:N",
    Partner == "No" & Dependents == "Yes" ~ "P:N,D:Y",
    Partner == "No" & Dependents == "No" ~ "P:N,D:N",
    TRUE ~ "N/A"  
  ))
churnRates_Across_Partner_and_Dependents_Contingency <- retention_df %>%
  ggplot(aes(x = dependents_and_partners, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status Distribution Across Partner & Dependents Contigency Table",
       x = "dependents_and_partners",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(), 
        axis.text.y = element_blank(),   
        axis.ticks.y = element_blank())  

churnRates_Across_Partner_and_Dependents_Contingency

This bar chart represents the distribution of churn status across different categories defined by the contingency table of partner and dependents for internet providers. It provides a visual representation of the proportion of churned and current customers within each combination, offering insights into potential relationships between household compositions and customer retention within the analyzed dataset.

linePlots_ChargesAgainstTenure_AcrossPaymentMethods <- churned_customers_only %>%
  ggplot(aes(x = Tenure, y = TotalCharges)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE)+
  labs(title = "Total Charges($) Against Tenure (Months)",
       x = "Tenure",
       y = "TotalCharges") +
  facet_wrap(~PaymentMethod,nrow = 2)

linePlots_ChargesAgainstTenure_AcrossPaymentMethods

This code generates a set of line plots depicting the relationship between tenure (months as a customer) and total charges ($) across various payment methods for churned customers. Each subplot represents a different payment method, allowing for a visual comparison of how charges evolve over customer tenure within each payment category for the internet provider.

retention_df_wFactorizedPaymentMethod <- retention_df
retention_df_wFactorizedPaymentMethod$PaymentMethod <- factor(retention_df_wFactorizedPaymentMethod$PaymentMethod)

violinDistribution_MonthlyCharges_AcrossPaymentMethods <- retention_df_wFactorizedPaymentMethod %>% 
  ggplot(aes(x = PaymentMethod, y = MonthlyCharges)) +
  geom_violin()

violinDistribution_MonthlyCharges_AcrossPaymentMethods

This violin distribution graph illustrates the distribution of monthly charges across different payment methods for both current and churned customers with the internet provider. Each violin plot represents the density of monthly charges within each payment method category, providing a visual comparison of the variability and distribution of charges across different payment methods.

fiberOptic_CustomersOnly <- retention_df %>%
                            filter(InternetService == "Fiber optic")

churnRates_forFiberOpticCustomers_AcrossContractTypes <- fiberOptic_CustomersOnly %>%
  ggplot(aes(x = Contract, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") + 
  labs(title = "Churn Status for Fiber-Optic customers Across Contract Types",
       x = "Contract",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),   
        axis.ticks.y = element_blank()) 

churnRates_forFiberOpticCustomers_AcrossContractTypes

This bar chart visualizes churn rates among fiber optic customers across various contract types, including month-to-month, yearly, and two-year contracts. It offers a clear comparison of the proportion of churned and current customers within each contract category, providing insights into how contract duration may influence customer retention among fiber optic subscribers.

customersWithSomeInternetType <- retention_df[retention_df$InternetService != 'No', ]

churnRates_forFiberOpticCustomers_AcrossContractTypes <- customersWithSomeInternetType %>%
  ggplot(aes(x = InternetService, y = 1, fill = Status)) +
  geom_bar(position = "fill",stat = "identity") +  
  labs(title = "Churn Status for Customers with Internet: DSL vs. Fiber-Optic",
       x = "InternetService",
       y = NULL,
       fill = "Status") +
  theme_minimal() +
  theme(axis.title.y = element_blank(),  
        axis.text.y = element_blank(),  
        axis.ticks.y = element_blank()) 

churnRates_forFiberOpticCustomers_AcrossContractTypes

This bar chart compares the churn rates between DSL and fiber-optic internet customers. It visualizes the proportion of churned and current customers within each internet service category, shedding light on potential differences in customer retention rates based on the type of internet service they subscribe to.

pie_chart <- churned_customers_only %>%
  ggplot(aes(x = "", fill = Contract)) +
  geom_bar(width = 1, color = "white") +
  coord_polar(theta = "y") +
  labs(title = "Distribution of Contracts Across All Churned Customers") +
  theme_void() +
  theme(legend.position = "right")

pie_chart

This pie chart illustrates the distribution of contract types among churned customers. Each slice represents a different contract type, providing a visual breakdown of the proportion of churned customers subscribed to each contract category. The absence of specific values along the x-axis emphasizes the relative distribution of contracts across all churned customers.

#Find percentage of each contract type for churned customers
number_of_churnedCustomers <- churned_customers_only %>%
                             nrow()
churnedCustomers_ContractTypeTable <- table(churned_customers_only$Contract)
churnedCustomers_ContractType_ProportionTable <- prop.table(churnedCustomers_ContractTypeTable)
knittedTable_ContractTypeProportions_ChurnedCustomers <- knitr::kable(churnedCustomers_ContractType_ProportionTable)

number_of_churnedCustomers
## [1] 1856

Machine Learning

#Factorize our Response Variable
retention_df <- mutate(retention_df, Status = factor(Status))
retention_df$TotalCharges <- ifelse(is.na(retention_df$TotalCharges), retention_df$MonthlyCharges, retention_df$TotalCharges)

set.seed(123)
split <- initial_split(retention_df, prop = 0.7, strata = "Status")
retention_train <- training(split)
retention_test <- testing(split)
# Model 1. Elastic Net Modelling ------------------------------------------
retention_recipe <- recipe(Status ~ ., data = retention_train) %>%
  step_YeoJohnson(all_numeric_predictors()) %>%
  step_normalize(all_numeric_predictors()) %>%
  step_dummy(all_nominal_predictors())

retention_elasticNet_Model <- logistic_reg(mixture = tune(), penalty = tune()) %>%
  set_engine('glmnet') %>%
  set_mode('classification')

set.seed(123)
retention_kfolds <- vfold_cv(retention_train, v = 5, strata = Status)

retention_hyperparameter_ElasticNet_grid <- grid_regular(mixture(), penalty(), levels =  10)


retention_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(retention_elasticNet_Model)

retention_tuning_results <- retention_wf %>%
  tune_grid(resamples = retention_kfolds, grid = retention_hyperparameter_ElasticNet_grid)

show_best(retention_tuning_results, metric = "roc_auc")
## # A tibble: 5 × 8
##         penalty mixture .metric .estimator  mean     n std_err .config          
##           <dbl>   <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>            
## 1 0.0000000001        1 roc_auc binary     0.848     5 0.00380 Preprocessor1_Mo…
## 2 0.00000000129       1 roc_auc binary     0.848     5 0.00380 Preprocessor1_Mo…
## 3 0.0000000167        1 roc_auc binary     0.848     5 0.00380 Preprocessor1_Mo…
## 4 0.000000215         1 roc_auc binary     0.848     5 0.00380 Preprocessor1_Mo…
## 5 0.00000278          1 roc_auc binary     0.848     5 0.00380 Preprocessor1_Mo…
collected_retention_TuningResults <- retention_tuning_results %>%
  collect_metrics() %>%
  filter(.metric == "roc_auc") %>%
  arrange(desc(mean))

visualized_ElasticNet_TuningResults <- autoplot(retention_tuning_results)


autoplot(retention_tuning_results)

retention_best_hyperparameters <- select_best(retention_tuning_results, metric = "roc_auc")

retention_final_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(retention_elasticNet_Model) %>%
  finalize_workflow(retention_best_hyperparameters)

retention_final_fit <- retention_final_wf %>%
  fit(data = retention_train)

mostInfluential_Retention_ElasticNet <- retention_final_fit %>%
  extract_fit_parsnip() %>%
  vip()

retention_ElasticNet_ConfusionMatrix <- retention_final_fit %>%
  predict(retention_test) %>%
  bind_cols(retention_test %>% select(Status)) %>%
  conf_mat(Status,.pred_class)



mostInfluential_Retention_ElasticNet

retention_ElasticNet_ConfusionMatrix
##           Truth
## Prediction Current Left
##    Current    1415  250
##    Left        128  307
# Model 2: MARS Modelling -------------------------------------------------

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

retention_mars_grid <- grid_regular(num_terms(range = c(1,30)), prod_degree(), levels = 20)

retention_mars_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(retention_mars_mod)

retention_mars_tuning_results <- retention_mars_wf %>%
  tune_grid(resamples = retention_kfolds, grid = retention_mars_grid)

collected_RetentionMARS_Result <- retention_mars_tuning_results %>%
  collect_metrics() %>%
  filter(.metric == "roc_auc") %>%
  arrange(desc(mean))

show_best(retention_mars_tuning_results, metric = "roc_auc")
## # A tibble: 5 × 8
##   num_terms prod_degree .metric .estimator  mean     n std_err .config          
##       <int>       <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>            
## 1        19           1 roc_auc binary     0.847     5 0.00328 Preprocessor1_Mo…
## 2        20           1 roc_auc binary     0.847     5 0.00328 Preprocessor1_Mo…
## 3        22           1 roc_auc binary     0.847     5 0.00328 Preprocessor1_Mo…
## 4        23           1 roc_auc binary     0.847     5 0.00328 Preprocessor1_Mo…
## 5        25           1 roc_auc binary     0.847     5 0.00328 Preprocessor1_Mo…
visualizedTuningResults_MARS_Retention <- autoplot(retention_mars_tuning_results)

retentionMARS_best_hyperparameters <- select_best(retention_mars_tuning_results, metric = "roc_auc")

retention_mars_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(retention_mars_mod) %>%
  finalize_workflow(retentionMARS_best_hyperparameters)

retentionMARS_final_fit <- retention_mars_wf %>%
  fit(data = retention_train)

mostInfluential_Retention_MARS <- retentionMARS_final_fit %>%
  extract_fit_parsnip() %>%
  vip()

retention_MARS_ConfusionMatrix <- retentionMARS_final_fit %>%
  predict(retention_test) %>%
  bind_cols(retention_test %>% select(Status)) %>%
  conf_mat(Status,.pred_class)

mostInfluential_Retention_MARS

retention_MARS_ConfusionMatrix
##           Truth
## Prediction Current Left
##    Current    1400  257
##    Left        143  300
# Model 3: Random Forest Modelling ----------------------------------------

rf_Retenion_mod <- rand_forest(
  mode = "classification",
  trees = tune(),
  mtry = tune(),
  min_n = tune()
) %>%
  set_engine("ranger", importance = "impurity")

rf_retention__hyperGrid <- grid_regular(
  trees(range = c(50,200)),
  mtry(range = c(2,50)),
  min_n(range = c(1,20)),
  levels = 5
)

set.seed(123)
retention_rfResults <- tune_grid(rf_Retenion_mod, retention_recipe, resamples = retention_kfolds, grid = rf_retention__hyperGrid)

show_best(retention_rfResults, metric = "roc_auc")
## # A tibble: 5 × 9
##    mtry trees min_n .metric .estimator  mean     n std_err .config              
##   <int> <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1    14    87    20 roc_auc binary     0.844     1      NA Preprocessor1_Model1…
## 2    14   200    20 roc_auc binary     0.841     1      NA Preprocessor1_Model1…
## 3    14   125    15 roc_auc binary     0.841     1      NA Preprocessor1_Model0…
## 4    14   162    20 roc_auc binary     0.841     1      NA Preprocessor1_Model1…
## 5    14   200    15 roc_auc binary     0.841     1      NA Preprocessor1_Model0…
retention_rf_bestHyperparameters <- select_best(retention_rfResults, metric = "roc_auc")

final_retention_rf_wf <- workflow() %>%
  add_recipe(retention_recipe) %>%
  add_model(rf_Retenion_mod) %>%
  finalize_workflow(retention_rf_bestHyperparameters)

retention_rf_final_fit <- final_retention_rf_wf %>%
  fit(data = retention_train)

visualized_importantFeatures_rfRetention <- retention_rf_final_fit %>%
  extract_fit_parsnip() %>%
  vip(num_features = 20)

rf_retentionModel_ConfusionMatrix <- retention_rf_final_fit %>%
  predict(retention_test) %>%
  bind_cols(retention_test %>% select(Status)) %>%
  conf_mat(Status,.pred_class)


#Most Optimal Model (according to AUC) was our MARS Model!

mostInfluential_Retention_MARS

#Top 3 most influential predictor variables are the following:
#'Tenure', 'TotalCharges', and 'MonthlyCharges'


retentionMARS_final_fit %>%
  predict(retention_test) %>%
  bind_cols(retention_test %>% select(Status)) %>%
  accuracy(truth = Status, estimate = .pred_class)
## # A tibble: 1 × 3
##   .metric  .estimator .estimate
##   <chr>    <chr>          <dbl>
## 1 accuracy binary         0.810

Business Analysis/Conclusion

Based on the conducted exploratory analysis and machine learning modeling, several key insights have emerged regarding customer churn within Regork’s telecommunications service. The analysis revealed that total charges, monthly charges, tenure, and contract length are the top three influential factors affecting churn rate. This underscores the importance of managing these variables effectively to mitigate customer attrition. Moreover, the modeling efforts showcased the efficacy of various machine learning techniques, such as logistic regression, MARS (Multivariate Adaptive Regression Splines), and random forest, in predicting churn status with reasonable accuracy.

Furthermore, the exploratory analysis provided valuable insights into customer behavior and demographic trends. For instance, visualizations highlighted differences in churn rates between demographic groups, such as seniors versus non-seniors and males versus females, suggesting potential avenues for targeted retention strategies. Additionally, the distribution of churn status across different contract types and payment methods illuminated patterns in customer preferences and engagement levels. This information can inform tailored approaches to contract offerings and payment options aimed at enhancing customer satisfaction and loyalty.

Moving forward, these findings can guide strategic decision-making within Regork’s telecommunications division. By focusing on optimizing total charges, monthly charges, tenure, and contract length, the company can proactively address factors contributing to churn and implement retention initiatives accordingly. Leveraging machine learning models alongside insightful exploratory analyses, Regork can refine its customer retention strategies, ultimately fostering long-term customer relationships and sustaining business growth in the competitive telecom market.

In conclusion, the analysis conducted on customer churn within Regork’s telecommunications service has uncovered crucial insights into factors influencing customer retention. By identifying total charges, monthly charges, tenure, and contract length as primary drivers of churn, Regork can tailor retention strategies to focus on these key areas. Leveraging advanced machine learning techniques and demographic trends revealed in the exploratory analysis, Regork can develop targeted retention initiatives, ensuring customer satisfaction, loyalty, and long-term business success.