Ryan R final project

## package 'rpart.plot' successfully unpacked and MD5 sums checked
## 
## The downloaded binary packages are in
##  C:\Users\user1\AppData\Local\Temp\RtmpMTJ7i4\downloaded_packages

Packages used

suppressPackageStartupMessages({
  library(tidymodels)
  library(corrplot)
  library(tidyverse)
  library(baguette)
  library(vip)
  library(pdp)
  library(here)
  library(kernlab)
  library(ggplot2)
  library(ranger)
  library(earth)
  library(rpart.plot, lib.loc = "C:/Users/user1/OneDrive/Desktop/BANA4081/Labs")
})

Loading and cleaning the data

data <- read.csv("C:/Users/user1/Downloads/customer_retention.csv")

str(data)
summary(data)
data <- na.omit(data)
data
data$Gender <- as.factor(data$Gender)
data$Status <- as.factor(data$Status)

Identifying trends in our data

To help better understand customer churning we can begin our analysis with identifying basic trends in the data.

ggplot(data, aes(x = Tenure, fill = Status)) +
  geom_histogram(position = "identity", alpha = 0.6, bins = 30) +
  labs(title = "Distribution of Tenure by Churn Status", x = "Tenure (months)", y = "Number of Customers")

When comparing tenure to churn status it becomes obvious that the longer a customer has been with us the less likely they are to leave. This could be very important for Regork to understand as they expand into the telecommunications service.

ggplot(data, aes(x = Tenure, fill = InternetService)) +
  geom_histogram(position = "identity", alpha = 0.6, bins = 30) +
  facet_wrap(~InternetService) +
  labs(title = "Distribution of Tenure Across Internet Service Types", x = "Tenure (months)", y = "Number of Customers")

Looking at internet service type compared to tenure it seemms that our Fiber optic customers have the longest tenure comparitevly to no internet service as well as DSL. however DSL has better tenure compared to no internet service at all

data$PaymentMethod <- as.factor(data$PaymentMethod)


ggplot(data, aes(x = PaymentMethod, y = Tenure, fill = PaymentMethod)) +
  geom_boxplot() +
  coord_flip() +  
  labs(title = "Customer Tenure by Payment Method", x = "Payment Method", y = "Tenure (months)") +
  theme_minimal() +  #
  theme(legend.position = "none")  

Looking at payment methods compared to tenure we can see a surprising correlation between the two as credit card and bank transfers seem to stay with us much longer than customers using either type of check

data$OnlineSecurity <- as.factor(data$OnlineSecurity)


ggplot(data, aes(x = OnlineSecurity, y = Tenure, color = OnlineSecurity)) +
  geom_violin(trim = FALSE) +  
  geom_jitter(width = 0.2, height = 0, size = 1, alpha = 0.5) + 
  labs(title = "Tenure Distribution by Online Security Subscription",
       x = "Online Security Subscription",
       y = "Tenure (months)") +
  scale_color_brewer(palette = "Dark2") +  # Color palette for distinction
  theme_minimal() +  # Clean minimal theme
  theme(legend.position = "none")

Looking at tenure with relativity to online security subscription we cn see that our most tenative customers often subscribe to our online security service. It also appears that most of our least tenative customers do not subscribe to our online security subscription.

Machine learning

Logistic Regression

df <- data
set.seed(123)
logistic_split <- initial_split(df, 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)

logistic_reg() %>% 
  fit_resamples(Status ~ ., logistic_kfolds) %>%
  collect_metrics()

## # A tibble: 3 × 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 brier_class binary     0.136     5 0.00188 Preprocessor1_Model1
## 3 roc_auc     binary     0.845     5 0.00521 Preprocessor1_Model1

Tree Model

set.seed(123)

split <- initial_split(data, prop = 0.7, strata = Status)
train_set <- training(split)
test_set <- testing(split)

tree_model <- decision_tree(tree_depth = 5, min_n = 10) %>%
  set_engine("rpart") %>%
  set_mode("classification")


tree_recipe <- recipe(Status ~ ., data = train_set)


tree_workflow <- workflow() %>%
  add_recipe(tree_recipe) %>%
  add_model(tree_model)


tree_fit <- fit(tree_workflow, data = train_set)

tree_preds <- predict(tree_fit, new_data = test_set, type = "class")


print(head(tree_preds))


results <- test_set %>%
  bind_cols(tree_preds) %>%
  metrics(truth = Status, estimate = .pred_class)


print(results)

final_tree <- extract_fit_engine(tree_fit)
rpart.plot(final_tree)

Mars Model

set.seed(123)


data_split <- initial_split(df, prop = 0.7, strata = Status)
train_data <- training(data_split)
test_data <- testing(data_split)


status_recipe <- recipe(Status ~ ., data = train_data)


set.seed(123)

k_folds <- vfold_cv(train_data, v = 5, strata = "Status")


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


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


workflow_mars <- workflow() %>% add_recipe(status_recipe) %>% add_model(mars_model)


tune_results <- workflow_mars %>% tune_grid(resamples = k_folds, grid = tuning_grid)

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


analysis_results

best_model_selection <- select_best(tune_results, metric = "roc_auc")


finalized_workflow <- workflow() %>% 
  add_model(mars_model) %>% add_formula(Status ~ .) %>% 
  finalize_workflow(best_model_selection)


fitted_model <- finalized_workflow %>% 
  fit(data = train_data) %>%
  extract_fit_parsnip()


important_variables <- vip(fitted_model, num_features = 10, type = "rss")
print(important_variables)