Introduction

Intro goes here.



Data Preparation

Load The Packages Required To Run This Report:

library(tidymodels)
library(tidyverse)
library(vip)
library(pdp)
library(ggplot2)
library(rpart)
library(rpart.plot)
library(caret)
library(pROC)
library(dials)


Import The Data and Clear Missing Values:

churn <- read_csv("Data/customer_retention.csv")
churn <- churn %>% 
  mutate(Status = as.factor(Status))

churn <- drop_na(churn)
sum(is.na(churn))
## [1] 0


Prepare the data:

set.seed(123)
split <- initial_split(churn, prop = 0.7, strata = Status)
churn_train <- training(split)
churn_test <- testing(split)


Tuning the data:

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


Exploratory Data Analysis

Graph 1

table(churn$Status) %>% prop.table()
## 
##   Current      Left 
## 0.7344018 0.2655982


ggplot(churn, aes(Tenure, fill = Contract)) + 
  geom_bar() +
  facet_wrap(~Dependents + Contract) +
  ggtitle("Customer Tenure vs. Dependents") +
  labs(y = "Number of Customers", x = "Length of Stay (Months)") +
    theme(legend.position = "bottom")


Graph 2

# Average monthly price by internet services
churn %>%
  filter(Dependents == "No") %>%
  group_by(InternetService) %>%
  summarize(average = mean(MonthlyCharges))
## # A tibble: 3 × 2
##   InternetService average
##   <chr>             <dbl>
## 1 DSL                56.4
## 2 Fiber optic        90.7
## 3 No                 21.0


internet_counts <- churn %>%
  group_by(InternetService, Status, Dependents) %>%
  summarize(count = n()) %>%
  ungroup()


ggplot(internet_counts, aes(x = InternetService, y = count, fill = Status)) +
  geom_bar(position = "dodge", stat = "identity") +
  facet_wrap(~Dependents) +
  scale_y_continuous(name = "Number of Customers", labels = comma_format()) +
  xlab("Internet Service") +
  ggtitle("Internet Service vs. Dependents") +
  scale_fill_manual(values = c("#AFCBFF", "#FF9CEE")) +
  theme(legend.position = "bottom")


Graph 3

lr_mod <- logistic_reg()

lr_fit3 <- lr_mod %>% 
  fit(Status ~ MonthlyCharges + Contract, data = churn_train)

tidy(lr_fit3)
## # A tibble: 4 × 5
##   term             estimate std.error statistic  p.value
##   <chr>               <dbl>     <dbl>     <dbl>    <dbl>
## 1 (Intercept)       -1.59     0.104       -15.4 3.35e-53
## 2 MonthlyCharges     0.0193   0.00139      13.9 4.42e-44
## 3 ContractOne year  -1.92     0.111       -17.2 1.13e-66
## 4 ContractTwo year  -3.19     0.172       -18.6 2.58e-77
lr_fit3 %>% 
  predict(churn_train, type = "prob") %>%
  mutate(
    MonthlyCharges = churn_train$MonthlyCharges,
    Contract = churn_train$Contract
  ) %>%
  ggplot(aes(MonthlyCharges, .pred_Left, color = Contract)) +
  geom_point(alpha = 0.5, size = 0.8) +
  scale_y_continuous("Probability of Churn", limits = c(0, 1)) +
  ggtitle("Predicted probabilities for Monthly Charges and Contract")


Machine Learning

Logistic Model

Heading

dt_model <- rpart(Status ~ ., data = churn_train, method = "class")
predictions <- predict(dt_model, churn_test, type = "class")
confusionMatrix(predictions, churn_test$Status)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction Current Left
##    Current    1398  294
##    Left        142  263
##                                           
##                Accuracy : 0.7921          
##                  95% CI : (0.7741, 0.8093)
##     No Information Rate : 0.7344          
##     P-Value [Acc > NIR] : 5.004e-10       
##                                           
##                   Kappa : 0.4162          
##                                           
##  Mcnemar's Test P-Value : 4.774e-13       
##                                           
##             Sensitivity : 0.9078          
##             Specificity : 0.4722          
##          Pos Pred Value : 0.8262          
##          Neg Pred Value : 0.6494          
##              Prevalence : 0.7344          
##          Detection Rate : 0.6667          
##    Detection Prevalence : 0.8069          
##       Balanced Accuracy : 0.6900          
##                                           
##        'Positive' Class : Current         
## 


rpart.plot(dt_model)


log_mod <- logistic_reg()

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

log_results <- log_mod %>% 
  fit_resamples(Status ~ ., kfolds)

collect_metrics(log_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.845     5 0.00521 Preprocessor1_Model1


final_fit <- log_mod %>%
  fit(Status ~ ., data = churn_train)

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


Key takeaway


MARS

Heading




Key takeaway


Model 3

Heading




Key takeaway


Summary

The Problem Statement

…

Methodology To Address The Problem Statement

…

Interesting Insights From Our Analysis

…

Our Implications and Recommendations For Regork

…

Limitations of The Analysis

…


Works Cited

…