WQD7004 Group 4
Group Members
| Name | Matrix Number |
|---|---|
| JOANNE CHANG YII | 23085604 |
| MITRA ANUSRI A/P MURALITHARAN | 17163859 |
| URRMILAH A/P S SEKARAN | 23070853 |
| NUR ELISA SORAYA BINTI MOHD RIZAM | S2165789 |
| INTAN NUR NABILA BINTI ZULKEPLI | 23071379 |
Title
Telco Churn Prediction
Introduction
Companies providing communication services often face difficulty in maintaining their subscribers. Churn rate is one of the key factors for telecommunications. With the ability to predict churn, businesses can act before its occurrence comes up saving them from losing customers which finally leads into increased savings and satisfaction.
Dataset
The dataset used for this analysis can be found on Kaggle: Telco Customer Churn Dataset
Objectives
The primary objective of churn prediction is to recognize subscribers who might stop their service. With that:- To identify and uncover churn patterns using machine learning algorithms.
- To predict which customer is more likely to churn from the accuracy
of models used.
Data Understanding
Loading Libraries
library(corrplot)
library(ggplot2)
library(dplyr)
library(gridExtra)
library(grid)
library(tidyr)
library(forcats)
library(caTools)
library(caret)
library(randomForest)
library(e1071)
library(gbm)
library(cluster)
library(factoextra)
library(kernlab)
library(knitr)Reading the Data
telco_data <- read.csv("/Users/User/OneDrive/Documents/UM/WQD7004/Assignment/TelcoCustomerChurn.csv")Understanding the structure of the data
glimpse(telco_data)## Rows: 7,043
## Columns: 21
## $ customerID <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CFOCW…
## $ gender <chr> "Female", "Male", "Male", "Male", "Female", "Female",…
## $ SeniorCitizen <int> 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", "Yes…
## $ Dependents <chr> "No", "No", "No", "No", "No", "No", "Yes", "No", "No"…
## $ tenure <int> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, 49, 2…
## $ PhoneService <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", "No", …
## $ MultipleLines <chr> "No phone service", "No", "No", "No phone service", "…
## $ InternetService <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fiber opt…
## $ OnlineSecurity <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Yes", "…
## $ OnlineBackup <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "No", "N…
## $ DeviceProtection <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "No", "Y…
## $ TechSupport <chr> "No", "No", "No", "Yes", "No", "No", "No", "No", "Yes…
## $ StreamingTV <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No", "Ye…
## $ StreamingMovies <chr> "No", "No", "No", "No", "No", "Yes", "No", "No", "Yes…
## $ Contract <chr> "Month-to-month", "One year", "Month-to-month", "One …
## $ PaperlessBilling <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", "No", …
## $ PaymentMethod <chr> "Electronic check", "Mailed check", "Mailed check", "…
## $ MonthlyCharges <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 29.7…
## $ TotalCharges <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50, 1949…
## $ Churn <chr> "No", "No", "Yes", "No", "Yes", "Yes", "No", "No", "Y…Data Preprocessing
To find null/empty values in each column
null_values <- is.na(telco_data)
null_summary <- colSums(null_values)
print(null_summary)## customerID gender SeniorCitizen Partner
## 0 0 0 0
## Dependents tenure PhoneService MultipleLines
## 0 0 0 0
## InternetService OnlineSecurity OnlineBackup DeviceProtection
## 0 0 0 0
## TechSupport StreamingTV StreamingMovies Contract
## 0 0 0 0
## PaperlessBilling PaymentMethod MonthlyCharges TotalCharges
## 0 0 0 11
## Churn
## 0Out of 7043 rows, there are only 11 null values in column ‘TotalCharges’ which totals to less then 10% of the dataset. Hence, we have decided to remove all of the missing values.
print(paste("Number of rows before remove null values:" , as.character(nrow(telco_data))))## [1] "Number of rows before remove null values: 7043"telco_data <- telco_data[complete.cases(telco_data$TotalCharges), ]
print(paste("Number of rows after remove null values:" , as.character(nrow(telco_data))))## [1] "Number of rows after remove null values: 7032"Upon checking the data, we also decided to remove the ‘CustomerID’ column which could potentially affect duplicate searching operations. Additionally, the column may not provide any useful information for predicting the target variable.
telco_data <- telco_data %>% select(-customerID)Searching for duplicated rows
duplicated_rows <- duplicated(telco_data)
print(paste("Number of duplicated rows: " , as.character(sum(duplicated_rows))))## [1] "Number of duplicated rows: 22"print(paste("Number of rows before remove duplicated values:" , as.character(nrow(telco_data))))## [1] "Number of rows before remove duplicated values: 7032"telco_data <- unique(telco_data)
print(paste("Number of rows after remove duplicated values:" , as.character(nrow(telco_data))))## [1] "Number of rows after remove duplicated values: 7010"Data Transformation
Data format checking and transformation for categorical features in the dataset
print(paste("Value in Gender:" , paste(unique(telco_data$gender), collapse = ", ")))## [1] "Value in Gender: Female, Male"print(paste("Value in Partner:" , paste(unique(telco_data$Partner), collapse = ", ")))## [1] "Value in Partner: Yes, No"print(paste("Value in Dependents:" , paste(unique(telco_data$Dependents), collapse = ", ")))## [1] "Value in Dependents: No, Yes"print(paste("Value in Phone Service:" , paste(unique(telco_data$PhoneService), collapse = ", ")))## [1] "Value in Phone Service: No, Yes"print(paste("Value in Multiple Lines:" , paste(unique(telco_data$MultipleLines), collapse = ", ")))## [1] "Value in Multiple Lines: No phone service, No, Yes"telco_data$MultipleLines <- ifelse(telco_data$MultipleLines == "No phone service", "No", telco_data$MultipleLines)
print(paste("Value in Multiple Lines after transforming:" , paste(unique(telco_data$MultipleLines), collapse = ", ")))## [1] "Value in Multiple Lines after transforming: No, Yes"print(paste("Value in Internet Service:" , paste(unique(telco_data$InternetService), collapse = ", ")))## [1] "Value in Internet Service: DSL, Fiber optic, No"print(paste("Value in Online Security:" , paste(unique(telco_data$OnlineSecurity), collapse = ", ")))## [1] "Value in Online Security: No, Yes, No internet service"telco_data$OnlineSecurity <- ifelse(telco_data$OnlineSecurity == "No internet service", "No", telco_data$OnlineSecurity)
print(paste("Value in Online Security after transforming:" , paste(unique(telco_data$OnlineSecurity), collapse = ", ")))## [1] "Value in Online Security after transforming: No, Yes"print(paste("Value in Online Backup:" , paste(unique(telco_data$OnlineBackup), collapse = ", ")))## [1] "Value in Online Backup: Yes, No, No internet service"telco_data$OnlineBackup <- ifelse(telco_data$OnlineBackup== "No internet service", "No", telco_data$OnlineBackup)
print(paste("Value in Online Backup after transforming:" , paste(unique(telco_data$OnlineBackup), collapse = ", ")))## [1] "Value in Online Backup after transforming: Yes, No"print(paste("Value in Device Protection:" , paste(unique(telco_data$DeviceProtection), collapse = ", ")))## [1] "Value in Device Protection: No, Yes, No internet service"telco_data$DeviceProtection <- ifelse(telco_data$DeviceProtection== "No internet service", "No", telco_data$DeviceProtection)
print(paste("Value in Device Protection after transforming:" , paste(unique(telco_data$DeviceProtection), collapse = ", ")))## [1] "Value in Device Protection after transforming: No, Yes"print(paste("Value in Technical Support:" , paste(unique(telco_data$TechSupport), collapse = ", ")))## [1] "Value in Technical Support: No, Yes, No internet service"telco_data$TechSupport <- ifelse(telco_data$TechSupport== "No internet service", "No", telco_data$TechSupport)
print(paste("Value in Technical Support after transforming:" , paste(unique(telco_data$TechSupport), collapse = ", ")))## [1] "Value in Technical Support after transforming: No, Yes"print(paste("Value in Streaming TV:" , paste(unique(telco_data$StreamingTV), collapse = ", ")))## [1] "Value in Streaming TV: No, Yes, No internet service"telco_data$StreamingTV <- ifelse(telco_data$StreamingTV== "No internet service", "No", telco_data$StreamingTV)
print(paste("Value in Streaming TV after transforming:" , paste(unique(telco_data$StreamingTV), collapse = ", ")))## [1] "Value in Streaming TV after transforming: No, Yes"print(paste("Value in Streaming Movies:" , paste(unique(telco_data$StreamingMovies), collapse = ", ")))## [1] "Value in Streaming Movies: No, Yes, No internet service"telco_data$StreamingMovies <- ifelse(telco_data$StreamingMovies== "No internet service", "No", telco_data$StreamingMovies)
print(paste("Value in Streaming Movies after transforming:" , paste(unique(telco_data$StreamingMovies), collapse = ", ")))## [1] "Value in Streaming Movies after transforming: No, Yes"print(paste("Value in Contract:" , paste(unique(telco_data$Contract), collapse = ", ")))## [1] "Value in Contract: Month-to-month, One year, Two year"print(paste("Value in Payment Method:" , paste(unique(telco_data$PaymentMethod), collapse = ", ")))## [1] "Value in Payment Method: Electronic check, Mailed check, Bank transfer (automatic), Credit card (automatic)"print(paste("Value in Churn:" , paste(unique(telco_data$Churn), collapse = ", ")))## [1] "Value in Churn: No, Yes"Checking for outliers
detect_outliers <- function(column) {
q1 <- quantile(column, 0.25)
q3 <- quantile(column, 0.75)
iqr <- q3 - q1
lower_bound <- q1 - 1.5 * iqr
upper_bound <- q3 + 1.5 * iqr
# outliers <- column[column < lower_bound | column > upper_bound]
# return(outliers)
return(which(column < lower_bound | column > upper_bound))
}
numerical_columns <- c("tenure", "MonthlyCharges", "TotalCharges")
for (col in numerical_columns) {
outliers <- detect_outliers(telco_data[[col]])
print(paste("Outliers in column", col, ":", length(outliers)))
}## [1] "Outliers in column tenure : 0"
## [1] "Outliers in column MonthlyCharges : 0"
## [1] "Outliers in column TotalCharges : 0"Exploratory Data Analysis
Prepare the data for the pie chart for churn
churn_data <- telco_data %>%
count(Churn) %>%
mutate(pct = n / sum(n) * 100,
label = paste0(Churn, ": ", round(pct, 1), "%"))
# Define custom colors for the pie chart
churn_colors <- c("Yes" = "#FF6666", "No" = "#66B2FF")
# Create the pie chart
ggplot(churn_data, aes(x = "", y = n, fill = Churn)) +
geom_bar(stat = "identity", width = 1) +
coord_polar(theta = "y") +
geom_text(aes(label = label), position = position_stack(vjust = 0.5)) +
scale_fill_manual(values = churn_colors) +
labs(title = "Distribution of Churn", x = NULL, y = NULL) +
theme_void()
Plot relationship between ‘SeniorCitizen’, ‘Partner’, ‘Dependents’, and ‘Churn’
# Convert column SeniorCitizen, Partner, and Dependents to factors for better visualization
telco_data$SeniorCitizen <- as.factor(telco_data$SeniorCitizen)
telco_data$Partner <- as.factor(telco_data$Partner)
telco_data$Dependents <- as.factor(telco_data$Dependents)
# Plot the relationship between gender and Churn
plot_gender <- ggplot(telco_data, aes(x = gender, fill = Churn)) +
geom_bar(position = "dodge") +
geom_text(stat = 'count', aes(label=..count..), position = position_dodge(width=0.9), vjust=-0.5) + # Add count on top of bars
labs(title = "Churn by Gender", x = "Gender", y = "Count") +
theme_minimal()
# Plot the relationship between SeniorCitizen and Churn
plot_senior <- ggplot(telco_data, aes(x = SeniorCitizen, fill = Churn)) +
geom_bar(position = "dodge") +
geom_text(stat = 'count', aes(label=..count..), position = position_dodge(width=0.9), vjust=-0.5) + # Add count on top of bars
labs(title = "Churn by Senior Citizen Status", x = "Senior Citizen", y = "Count") +
theme_minimal()
# Plot the relationship between Partner and Churn
plot_partner <- ggplot(telco_data, aes(x = Partner, fill = Churn)) +
geom_bar(position = "dodge") +
geom_text(stat = 'count', aes(label=..count..), position = position_dodge(width=0.9), vjust=-0.5) + # Add count on top of bars
labs(title = "Churn by Partner Status", x = "Partner", y = "Count") +
theme_minimal()
# Plot the relationship between Dependents and Churn
plot_dependents <- ggplot(telco_data, aes(x = Dependents, fill = Churn)) +
geom_bar(position = "dodge") +
geom_text(stat = 'count', aes(label=..count..), position = position_dodge(width=0.9), vjust=-0.5) + # Add count on top of bars
labs(title = "Churn by Dependents Status", x = "Dependents", y = "Count") +
theme_minimal()
# Combine the plots side by side
grid.arrange(
arrangeGrob(
textGrob("Demographic", gp = gpar(fontsize = 16, fontface = "bold")),
arrangeGrob(plot_gender, plot_senior, plot_partner, plot_dependents, ncol = 2),
heights = c(0.1, 1)
)
) ## Warning: The dot-dot notation (`..count..`) was deprecated in ggplot2 3.4.0.
## ℹ Please use `after_stat(count)` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
- Gender: There is no significant difference between male and female
in churn fashion.
- Senior Citizen: The churn percentage for senior customer are likely
less.
- Partner: Customer with partners are more likely to churn compare to
single customers. However, the results are vary for customer with
dependents.
Less churn rate are observed for customer with dependents. We will further explore other categories.
Plot the service-related variables
# Define colors
churn_colors <- c("Yes" = "#FF6666", "No" = "#66B2FF")
# Function to create side-by-side bar plots with percentage labels inside bars
create_side_by_side_plot <- function(data, variable) {
plot_data <- data %>%
count(Churn, !!sym(variable)) %>%
mutate(percent = n / sum(n) * 100, # Calculate percentage
label = ifelse(percent >= 5, paste0(round(percent, 1), "%"), "")) # Format percentage as text if >= 5%
plot <- ggplot(plot_data, aes(x = !!sym(variable), y = percent, fill = Churn)) +
geom_bar(stat = "identity", position = "dodge") +
geom_text(aes(label = label), position = position_dodge(width = 0.9), vjust = 0.5) +
labs(title = paste("Churn by", variable), x = variable, y = "Percentage") +
scale_fill_manual(values = churn_colors) + # Set fill colors manually
theme_minimal()
return(plot)
}
# List of service-related variables
service_variables <- c("PhoneService", "MultipleLines", "InternetService",
"OnlineSecurity", "OnlineBackup", "DeviceProtection",
"TechSupport", "StreamingTV", "StreamingMovies")
# Create side-by-side plots for each service-related variable using telco_data
side_by_side_plots <- lapply(service_variables, function(var) create_side_by_side_plot(telco_data, var))
# Combine plots into a grid
grid.arrange(grobs = side_by_side_plots, ncol = 3, top = "Services") 
- Some clients do not have internet access, and an even smaller number do not have phone services.
- Our observations revealed a significant churn rate in Internet services, with variations across different categories.
- Over 40% of churn is attributed to fiber-optics, making it the leading cause.
- Several factors can influence customers’ decision to continue using
the fiber-optic service, including the cost and maintenance fees.
Plot the charges of Internet Service
# Calculate average MonthlyCharges and TotalCharges for each InternetService
avg_charges <- telco_data %>%
filter(!is.na(InternetService)) %>%
group_by(InternetService) %>%
summarise(avg_monthly_charges = mean(MonthlyCharges),
avg_total_charges = mean(TotalCharges))
# Convert the data from wide to long format
avg_charges_long <- pivot_longer(avg_charges, cols = c(avg_monthly_charges, avg_total_charges),
names_to = "Charges_Type", values_to = "Average_Charges")
# Create a bar plot with average numbers on top
charges_plot <- ggplot(avg_charges_long, aes(x = InternetService, y = Average_Charges, fill = Charges_Type)) +
geom_bar(stat = "identity", position = position_dodge()) +
geom_text(aes(label = sprintf("%.2f", Average_Charges)), vjust = -0.5, size = 3, position = position_dodge(width = 0.9)) +
labs(title = "Average Charges by Internet Service",
x = "Internet Service",
y = "Average Charges") +
scale_fill_manual(values = c("#66B2FF", "#FF6666"), name = "Charges Type",
labels = c("Monthly Charges", "Total Charges")) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
# Show the combined bar plot
print(charges_plot)
- In line with what was anticipated, the fee rate for fiber optics is the highest among all other internet services. After doing an analysis of both the total and monthly charges, we found that fiber-optic has the largest proportion in this regard.
- In addition, we are unable to arrive at a conclusion by merely carrying out an analysis of a single variable.
- As an alternative, there might be other elements that play a role in customer attrition. Each and every internet service is distributed in the form of a user package that includes supplementary services and subsequent fees.
- We need to find out whether or not such services have been
successful in attracting customers, as well as the number of customers
who have subscribed.
Plot the payment-related variables
# Function to create side-by-side bar plots for payment-related variables
create_payment_plot <- function(data, variable) {
plot_data <- data %>%
count(Churn, !!sym(variable)) %>%
mutate(percent = n / sum(n) * 100,
label = ifelse(percent >= 5, paste0(round(percent, 1), "%"), ""))
plot <- ggplot(plot_data, aes(x = !!sym(variable), y = percent, fill = Churn)) +
geom_bar(stat = "identity", position = "dodge") +
geom_text(aes(label = label), position = position_dodge(width = 0.9), vjust = -0.5, size = 3) +
labs(title = paste("Churn by", variable), x = variable, y = "Percentage") +
scale_fill_manual(values = churn_colors) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1)) # Rotate x-axis labels
return(plot)
}
#Analysis of Services and Monthly & Total Charges
#OnlineSecurity, DeviceProtection, TechSupport vs MonthlyCharges
# Filter the required columns
selected_cols <- telco_data %>%
select(OnlineSecurity, DeviceProtection, TechSupport, MonthlyCharges)
# Plot the relationship between service variables and MonthlyCharges
service_charge_plots <- lapply(names(selected_cols)[1:3], function(service_var) {
ggplot(telco_data, aes_string(x = service_var, y = "MonthlyCharges")) +
geom_boxplot(fill = "skyblue") +
labs(title = paste(service_var, "vs MonthlyCharges"), x = service_var, y = "MonthlyCharges") +
theme_minimal()
})## 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.# Combine plots into a grid
grid_arrange <- function(...) {
gridExtra::grid.arrange(..., nrow = 1)
}
# Show the combined plots
grid_arrange(grobs = service_charge_plots) 
- Based on the analysis, the subscribers who also get additional
services like OnlineSecurity, DeviceProtection, and TechSupport are more
likely to have higher and steady MonthlyCharges.
- It is possible that the event of these services, which are
presumably part of some type of a more costly and in-depth service
bundle, leads to the subscription of more profitable services for the
company.
- Therefore, improving offers on support and promoting subscription
for these services could be an overall profitable algorithm to increase
average revenue per user.
Plot the service-related variables vs. churn
# Function to create side-by-side bar plots for service-related variables vs. churn
# OnlineSecurity, DeviceProtection, TechSupport, vs Churn.
# Function to create bar plots for service-related variables vs. churn (only "Yes" churn)
create_service_churn_plot <- function(data, variable) {
plot_data <- data %>%
filter(Churn == "Yes") %>%
count(!!sym(variable)) %>%
mutate(percent = n / sum(n) * 100)
plot <- ggplot(plot_data, aes(x = !!sym(variable), y = percent)) +
geom_bar(stat = "identity", fill = "#FF6666") +
geom_text(aes(label = paste0(round(percent, 1), "%")),
position = position_dodge(width = 0.9), vjust = 0.5, hjust = 1, color = "black", size = 3) +
labs(title = paste(variable, "vs Churn (Yes)"), x = variable, y = "Percentage") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
return(plot)
}
# List of service-related variables
service_variables <- c("OnlineSecurity", "DeviceProtection", "TechSupport")
# Create plots for each service-related variable vs. churn ("Yes" churn only)
service_churn_plots <- lapply(service_variables, function(var) create_service_churn_plot(telco_data, var))
# Combine plots into a grid
grid.arrange(grobs = service_churn_plots, ncol = 1, top = "Service Variables vs Churn (Yes)")
- Comparison of the current data to the previous analysis of service subscription and monthly charges allows assessing telecom customers’ behavior and preferences. Those who choose to exclude such important services as Online Security, Device Protection, and Tech Support have higher churn rates.
- This coincides with the observed reduction in these customers’
monthly charges, which means the decision-making process is governed by
cost. - However, this group’s high churn rates suggest that while the
cost plays a role, they may not believe that these services ensure
flawless and secure telecom operations.
- Thus, to enhance customer satisfaction and decrease churn, companies
may require to reconsider their prices as well as the services provided
to ensure they are affordable but valued by the customers.
Plots for each payment-related variable
# List of payment-related variables
payment_variables <- c("Contract", "PaperlessBilling", "PaymentMethod")
# Create side-by-side plots for each payment-related variable
payment_plots <- lapply(payment_variables, function(var) create_payment_plot(telco_data, var))
# Combine plots into a grid
grid.arrange(
arrangeGrob(
textGrob("Payments", gp = gpar(fontsize = 16, fontface = "bold")),
arrangeGrob(grobs = payment_plots, ncol = 2),
heights = c(0.1, 1)
)
) 
- The analysis of contract, paperless billing, and payment method based churn rates provides relevant observations regarding customer behavior in the telecom sector.
- However, it is vital to remember that these variables, while
indicating probable drivers of churn rate, do not singularly offer a
complete picture of the churn dynamics.
- For example, although the observed churn rate in the month to month
contract case reaches 23.4% and might indicate a requirement for
reactivate strategies, it is essential to understand the reasons for
opting out of the contact. In addition, the finding that the paperless
billing users also have high churn rates, although the non-churn rates
are also high in both cases, further complicates the
interpretation.
- Electronic checks also share this pattern, with higher churn rates that the users of other payment methods except no charge. However, all the payment methods also demonstrate high non-churn rates, again suggesting that these variables do singularly influence by churn behavior.
- The complexity of these variables necessitates additional
investigation and interpretations.
- Overall, a more comprehensive and nuanced interpretation of the case
data could enable telecom companies to develop more precise churn
prediction models and implement specific retention techniques.
#Tenure, MonthlyCharges, TotalCharges vs Churn
# Analyze patterns in numerical variables
numerical_data <- telco_data %>%
select(tenure, MonthlyCharges, TotalCharges, Churn)
# Visualize the distributions
# Tenure distribution
ggplot(numerical_data, aes(x = tenure)) +
geom_histogram(fill = "skyblue", color = "black", bins = 30) +
labs(title = "Distribution of Tenure", x = "Tenure (Months)", y = "Frequency") +
theme_minimal()
# MonthlyCharges distribution
ggplot(numerical_data, aes(x = MonthlyCharges)) +
geom_histogram(fill = "skyblue", color = "black", bins = 30) +
labs(title = "Distribution of Monthly Charges", x = "Monthly Charges", y = "Frequency") +
theme_minimal()
# Explore correlation with churn
# Box plot for tenure vs. churn
ggplot(numerical_data, aes(x = Churn, y = tenure, fill = Churn)) +
geom_boxplot() +
labs(title = "Tenure vs. Churn", x = "Churn", y = "Tenure (Months)") +
theme_minimal()
# Box plot for MonthlyCharges vs. churn
ggplot(numerical_data, aes(x = Churn, y = MonthlyCharges, fill = Churn)) +
geom_boxplot() +
labs(title = "Monthly Charges vs. Churn", x = "Churn", y = "Monthly Charges") +
theme_minimal()
# Box plot for TotalCharges vs. churn
ggplot(numerical_data, aes(x = Churn, y = TotalCharges, fill = Churn)) +
geom_boxplot() +
labs(title = "Total Charges vs. Churn", x = "Churn", y = "Total Charges") +
theme_minimal() 
- The inspection of customer tenure distribution reveals a significant
share of longtime customers, where many have a tenure equal to or higher
than 70 months, which generally suggests a loyal and sustainable
customer presence.
- However, the subsequent comparison of median tenure terms among
churned and non-churned customers shows that the majority of churns
typically take place very early, with churned customers having a much
lower median tenure of around 10 months.
- This difference once more underscores the importance of early
attrition prediction and retention measures. Similarly, the examination
of monthly charges shows that although non-churned customers have a
higher median monthly spending, the median detriment for churned
customers is significantly lower.
- This may indicate that the factor of churning clients are those
unwilling to pay high monthly fees and, therefore, a lower charge may be
a predictor of eventual churn.
- Lastly, the assessment of total charges shows a noticeable gap
between churned and non-churned customers, with the former having a
limited low median total due to the brevity of their presence. This
further implies lower life value and engagement.
- Overall, these three metrics point to the importance of
churn-risk-factor tailored retention actions directed at retaining the
customers’ loyalty and lifetime profit.
- In conclusion, the above analysis of the various factors affecting
churn behavior in the telecom sector reveals that customer attrition is
a multidimensional variable that manifests itself due to multiple
variables.
- The role of demographic factors, including gender and senior citizenship, and service-related attributes, such as internet services and additional service subscriptions, should not be underestimated.
- This comprehensive analysis also demonstrates the need for an adequate understanding of the interaction between pricing, services, and customer service.
- Moreover, examining the information on the types of contracts, billing, and payment methods has enabled to emphasize the complex nature of customer decision-making and demonstrate the importance of nuanced retention.
- Customer tenure, monthly fee, and a total charge have revealed the importance of accurate predictions and appropriate early retention actions to reduce churn risk.
- Therefore, the combination of different demographic, service-related, and financial indicators is critical in predicting customer churn and retaining strategies that help improve customer satisfaction and lifetime value.
Feature Engineering
Feature Selection
# Perform chi-square test for categorical variables
chi_results <- lapply(telco_data[, !names(telco_data) %in% c('tenure', 'MonthlyCharges', 'TotalCharges', 'Churn')], function(x) chisq.test(x, telco_data$Churn))
p_values <- sapply(chi_results, function(result) result$p.value)
df_chi_results <- data.frame(Variable = names(p_values), P_value = p_values)
print(df_chi_results)## Variable P_value
## gender gender 4.833762e-01
## SeniorCitizen SeniorCitizen 1.470336e-36
## Partner Partner 2.024856e-35
## Dependents Dependents 6.488025e-42
## PhoneService PhoneService 3.781550e-01
## MultipleLines MultipleLines 5.019781e-04
## InternetService InternetService 6.611624e-159
## OnlineSecurity OnlineSecurity 4.433937e-46
## OnlineBackup OnlineBackup 1.328791e-11
## DeviceProtection DeviceProtection 6.238102e-08
## TechSupport TechSupport 1.021166e-42
## StreamingTV StreamingTV 5.985662e-08
## StreamingMovies StreamingMovies 1.795866e-07
## Contract Contract 7.985062e-256
## PaperlessBilling PaperlessBilling 4.336282e-57
## PaymentMethod PaymentMethod 1.176117e-138Dot plot
ggplot(df_chi_results, aes(x = Variable, y = P_value)) +
geom_point(size = 3, color = "blue") +
geom_hline(yintercept = 0.05, linetype = "dashed", color = "red") +
labs(title = "P-Value of Chi-square Test", x = "Categorical Variable", y = "P-value") +
theme_minimal() + theme(axis.text.x = element_text(angle = 45, hjust = 1))
- From Chi-square test result, SeniorCitizen, Partner, Dependents, MultipleLines, InternetService, OnlineSecurity, OnlineBackup, DeviceProtection, TechSupport, StreamingTV, Contract, PaperlessBilling, and PaymentMethod have p-values less than 0.05, it indicates that they are statistically significant predictors of ‘Churn’.
- The output obtained from Chi-square test above yielded a p-value of almost 0.00 for all the categorical variables except for the variable “gender” and “PhoneService”.
- This shows that all the variables except “gender” and “PhoneService” are having p-values which is more than the accepted threshold.
- This rejects the null hypothesis and conclude that there is evidence of significant association between the variables. Features with low p-values are highly important in predicting the target variable.
- Variables “gender” and “PhoneService” have relatively high p-values,
indicate that the variables are not significantly associated with the
target variable, “Churn”.
Hence, drop “gender” and “PhoneService”.
# Drop feature "gender" and "PhoneService"
telco_data$gender <- NULL
telco_data$PhoneService <- NULL
# Check correlation for numerical variables
cm <- cor(telco_data[, c("tenure", "MonthlyCharges", "TotalCharges")])
# Print the correlation matrix
print(cm)## tenure MonthlyCharges TotalCharges
## tenure 1.0000000 0.2441939 0.8252930
## MonthlyCharges 0.2441939 1.0000000 0.6505401
## TotalCharges 0.8252930 0.6505401 1.0000000corrplot(cm, method = "number")
Hence, drop “TotalCharges”.
# Drop feature"Totalcharges"
telco_data$TotalCharges <- NULLStandardize Continuous Variables
num_columns <- c("tenure", "MonthlyCharges")
telco_data[num_columns] <- sapply(telco_data[num_columns], as.numeric)
telco1<- telco_data[,c("tenure", "MonthlyCharges")]
telco1<- data.frame(scale(telco1))Binning for “tenure”
# Binning process transforming the "tenure" variable in the dataset into categorical groups or "bins". This is useful for converting continuous numerical data into discrete categories, which can make it easier to analyze patterns and trends, creating features for machine learning models.
# Create derived feature from "tenure", different bins of tenure(which is in months) such as '0-1 year', '2-3 years', '3-4 years', etc.
telco_data$tenure_bin = telco_data$tenure
telco_data$tenure_bin[telco_data$tenure_bin >= 0 & telco_data$tenure_bin <= 12] <- '0-1 year'
telco_data$tenure_bin[telco_data$tenure_bin > 12 & telco_data$tenure_bin <= 24] <- '1-2 years'
telco_data$tenure_bin[telco_data$tenure_bin > 24 & telco_data$tenure_bin <= 36] <- '2-3 years'
telco_data$tenure_bin[telco_data$tenure_bin > 36 & telco_data$tenure_bin <= 48] <- '3-4 years'
telco_data$tenure_bin[telco_data$tenure_bin > 48 & telco_data$tenure_bin <= 60] <- '4-5 years'
telco_data$tenure_bin[telco_data$tenure_bin > 60 & telco_data$tenure_bin <= 72] <- '5-6 years'Visualize the binning result
ggplot(telco_data, aes(x = tenure_bin)) +
geom_bar(fill = c("#1f78b4", "#33a02c", "#e31a1c", "#ff7f00", "#6a3d9a", "#a6cee3"))+
labs(title = "Distribution of Customers by Tenure Bins",
x = "Tenure Bin",
y = "Count of Customers") +
theme_minimal()
Based on the plot, the distribution of data in each tenure bin suggested that greater number of customers have a tenure of 0-1 years, followed by 5-6 years.
# Convert to factor
telco_data$tenure_bin <- as.factor(telco_data$tenure_bin)
# Create dummy tenure
tenure_dummy <- telco_data$tenure
# Change numerical values in "SeniorCitizen" to categorical
telco_data <- telco_data %>% mutate(SeniorCitizen = ifelse(SeniorCitizen == "0", "No", "Yes"))
# Delete tenure col
telco_data$tenure <- NULL
# Create dummy variables
telco2 = telco_data[,-c(17)]
dummy <- data.frame(sapply(telco2,function(x) data.frame(model.matrix(~x-1,data =telco2))[,-1]))
head(dummy)## SeniorCitizen Partner Dependents MultipleLines InternetService.xFiber.optic
## 1 0 1 0 0 0
## 2 0 0 0 0 0
## 3 0 0 0 0 0
## 4 0 0 0 0 0
## 5 0 0 0 0 1
## 6 0 0 0 1 1
## InternetService.xNo OnlineSecurity OnlineBackup DeviceProtection TechSupport
## 1 0 0 1 0 0
## 2 0 1 0 1 0
## 3 0 1 1 0 0
## 4 0 1 0 1 1
## 5 0 0 0 0 0
## 6 0 0 0 1 0
## StreamingTV StreamingMovies Contract.xOne.year Contract.xTwo.year
## 1 0 0 0 0
## 2 0 0 1 0
## 3 0 0 0 0
## 4 0 0 1 0
## 5 0 0 0 0
## 6 1 1 0 0
## PaperlessBilling PaymentMethod.xCredit.card..automatic.
## 1 1 0
## 2 0 0
## 3 1 0
## 4 0 0
## 5 1 0
## 6 1 0
## PaymentMethod.xElectronic.check PaymentMethod.xMailed.check Churn
## 1 1 0 0
## 2 0 1 0
## 3 0 1 1
## 4 0 0 0
## 5 1 0 1
## 6 1 0 1# Create final dataset by combining numerical and dummy data frame
df_telco <- cbind(telco1, dummy)
head(df_telco)## tenure MonthlyCharges SeniorCitizen Partner Dependents MultipleLines
## 1 -1.28547439 -1.1654394 0 1 0 0
## 2 0.06034151 -0.2640521 0 0 0 0
## 3 -1.24469209 -0.3671629 0 0 0 0
## 4 0.50894682 -0.7513334 0 0 0 0
## 5 -1.24469209 0.1932938 0 0 0 0
## 6 -0.99999829 1.1562149 0 0 0 1
## InternetService.xFiber.optic InternetService.xNo OnlineSecurity OnlineBackup
## 1 0 0 0 1
## 2 0 0 1 0
## 3 0 0 1 1
## 4 0 0 1 0
## 5 1 0 0 0
## 6 1 0 0 0
## DeviceProtection TechSupport StreamingTV StreamingMovies Contract.xOne.year
## 1 0 0 0 0 0
## 2 1 0 0 0 1
## 3 0 0 0 0 0
## 4 1 1 0 0 1
## 5 0 0 0 0 0
## 6 1 0 1 1 0
## Contract.xTwo.year PaperlessBilling PaymentMethod.xCredit.card..automatic.
## 1 0 1 0
## 2 0 0 0
## 3 0 1 0
## 4 0 0 0
## 5 0 1 0
## 6 0 1 0
## PaymentMethod.xElectronic.check PaymentMethod.xMailed.check Churn
## 1 1 0 0
## 2 0 1 0
## 3 0 1 1
## 4 0 0 0
## 5 1 0 1
## 6 1 0 1# Ensure Churn column is a factor with two levels
df_telco$Churn <- as.factor(df_telco$Churn)Split Data into Train Test
# Split Data into Train Test Datasets (70%,30%)
set.seed(123)
indices = sample.split(df_telco$Churn, SplitRatio = 0.7)
train = df_telco[indices,]
validation = df_telco[!(indices),]
# Check the size of the training set
train_size <- dim(train)
cat("Training set size:", train_size[1], "rows and", train_size[2], "columns\n")## Training set size: 4907 rows and 21 columns# Check the size of the validation set
validation_size <- dim(validation)
cat("Validation set size:", validation_size[1], "rows and", validation_size[2], "columns\n")## Validation set size: 2103 rows and 21 columnsModeling
# Define the control for train function - configure 10-fold cross validation for the model training
train_control <- trainControl(method="cv", number=10)Logistic Regression
log_model <- train(Churn ~ ., data=train, method="glm", family="binomial", trControl=train_control)
log_pred <- predict(log_model, validation)
confusionMatrix(log_pred, validation$Churn)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 1374 259
## 1 172 298
##
## Accuracy : 0.7951
## 95% CI : (0.7772, 0.8121)
## No Information Rate : 0.7351
## P-Value [Acc > NIR] : 9.598e-11
##
## Kappa : 0.446
##
## Mcnemar's Test P-Value : 3.436e-05
##
## Sensitivity : 0.8887
## Specificity : 0.5350
## Pos Pred Value : 0.8414
## Neg Pred Value : 0.6340
## Prevalence : 0.7351
## Detection Rate : 0.6534
## Detection Prevalence : 0.7765
## Balanced Accuracy : 0.7119
##
## 'Positive' Class : 0
## - The logistic regression model accurately predicts customer churn with a 79.51% accuracy, with moderate agreement between predictions and actual outcomes.
- Its sensitivity is high at 88.87%, but its specificity is lower at 53.50%, leading to potential false positives.
- The model’s precision is 84.14%, and its negative predictive value is 63.40%.
- However, it could improve in reducing false positives.
Decision Tree
dt_model <- train(Churn ~ ., data=train, method="rpart", trControl=train_control)
dt_pred <- predict(dt_model, validation)
confusionMatrix(dt_pred, validation$Churn)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 1381 294
## 1 165 263
##
## Accuracy : 0.7817
## 95% CI : (0.7635, 0.7992)
## No Information Rate : 0.7351
## P-Value [Acc > NIR] : 4.472e-07
##
## Kappa : 0.3947
##
## Mcnemar's Test P-Value : 2.308e-09
##
## Sensitivity : 0.8933
## Specificity : 0.4722
## Pos Pred Value : 0.8245
## Neg Pred Value : 0.6145
## Prevalence : 0.7351
## Detection Rate : 0.6567
## Detection Prevalence : 0.7965
## Balanced Accuracy : 0.6827
##
## 'Positive' Class : 0
## - The decision tree model accurately classifies customer churn with a 78.17% accuracy rate, with a high sensitivity of 89.33%.
- However, it has moderate success in identifying non-churn customers, with a lower specificity of 47.22%.
- The model’s positive predictive value is 82.45%, and its accuracy is
68.27%, indicating moderate agreement between predictions and actual
outcomes.
Random Forest
rf_model <- train(Churn ~ ., data=train, method="rf", trControl=train_control)
rf_pred <- predict(rf_model, validation)
confusionMatrix(rf_pred, validation$Churn)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 1395 308
## 1 151 249
##
## Accuracy : 0.7817
## 95% CI : (0.7635, 0.7992)
## No Information Rate : 0.7351
## P-Value [Acc > NIR] : 4.472e-07
##
## Kappa : 0.384
##
## Mcnemar's Test P-Value : 3.302e-13
##
## Sensitivity : 0.9023
## Specificity : 0.4470
## Pos Pred Value : 0.8191
## Neg Pred Value : 0.6225
## Prevalence : 0.7351
## Detection Rate : 0.6633
## Detection Prevalence : 0.8098
## Balanced Accuracy : 0.6747
##
## 'Positive' Class : 0
## - The random forest model has an overall accuracy of 78.17%, with a 95% confidence interval of 76.35% to 79.92%.
- It has a high sensitivity of 90.23%, but low specificity of 44.70%.
- The model’s precision is 81.91%, but its performance in identifying non-churn cases could be improved.
- The model’s balanced accuracy is 67.47%, indicating a need for
improved specificity.
Support Vector Machine
svm_model <- train(Churn ~ ., data=train, method="svmRadial", trControl=train_control)
svm_pred <- predict(svm_model, validation)
confusionMatrix(svm_pred, validation$Churn)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 1397 306
## 1 149 251
##
## Accuracy : 0.7836
## 95% CI : (0.7654, 0.8011)
## No Information Rate : 0.7351
## P-Value [Acc > NIR] : 1.528e-07
##
## Kappa : 0.3894
##
## Mcnemar's Test P-Value : 2.605e-13
##
## Sensitivity : 0.9036
## Specificity : 0.4506
## Pos Pred Value : 0.8203
## Neg Pred Value : 0.6275
## Prevalence : 0.7351
## Detection Rate : 0.6643
## Detection Prevalence : 0.8098
## Balanced Accuracy : 0.6771
##
## 'Positive' Class : 0
## - The Support Vector Machine (SVM) model has an accuracy of 78.36%, with a 95% confidence interval of 76.54% to 80.11%.
- It has a high sensitivity of 90.36%, indicating its effectiveness in identifying true positives.
- However, its specificity is low at 45.06%, and its precision is 82.03%.
- The model’s negative predictive value is 62.75%, indicating moderate
reliability in predicting non-churn cases.
Gradient Boosting Machine
gbm_model <- train(Churn ~ ., data=train, method="gbm", trControl=train_control, verbose=FALSE)
gbm_pred <- predict(gbm_model, validation)
confusionMatrix(gbm_pred, validation$Churn)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 1371 284
## 1 175 273
##
## Accuracy : 0.7817
## 95% CI : (0.7635, 0.7992)
## No Information Rate : 0.7351
## P-Value [Acc > NIR] : 4.472e-07
##
## Kappa : 0.4021
##
## Mcnemar's Test P-Value : 4.631e-07
##
## Sensitivity : 0.8868
## Specificity : 0.4901
## Pos Pred Value : 0.8284
## Neg Pred Value : 0.6094
## Prevalence : 0.7351
## Detection Rate : 0.6519
## Detection Prevalence : 0.7870
## Balanced Accuracy : 0.6885
##
## 'Positive' Class : 0
## - The Gradient Boosting Machine (GBM) model accurately predicts customer churn with a 78.17% accuracy rate.
- Its sensitivity is high at 88.68%, indicating effective churn identification.
- However, its specificity is lower at 49.01%. The model’s positive predictive value is 82.84%, and its negative predictive value is 60.94%.
- The model could improve in reducing false positives.
Model evaluation summary
model_list <- list(Logistic_Regression = log_model,
Decision_Tree = dt_model,
Random_Forest = rf_model,
SVM = svm_model,
GBM = gbm_model)
results <- resamples(model_list)
summary(results)##
## Call:
## summary.resamples(object = results)
##
## Models: Logistic_Regression, Decision_Tree, Random_Forest, SVM, GBM
## Number of resamples: 10
##
## Accuracy
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## Logistic_Regression 0.7759674 0.7865518 0.8034623 0.8043572 0.8189721 0.8452138
## Decision_Tree 0.7637475 0.7786826 0.7879733 0.7847949 0.7902240 0.8024440
## Random_Forest 0.7556008 0.7923469 0.8024440 0.8010948 0.8161914 0.8248473
## SVM 0.7698574 0.8009165 0.8073424 0.8025267 0.8121181 0.8187373
## GBM 0.7881874 0.8019348 0.8065173 0.8104743 0.8188776 0.8431772
## NA's
## Logistic_Regression 0
## Decision_Tree 0
## Random_Forest 0
## SVM 0
## GBM 0
##
## Kappa
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## Logistic_Regression 0.3852300 0.4234517 0.4671602 0.4697882 0.5145457 0.5661233
## Decision_Tree 0.3341906 0.3566283 0.4005281 0.3901805 0.4081829 0.4477197
## Random_Forest 0.2960237 0.4032861 0.4373632 0.4319859 0.4808388 0.4982533
## SVM 0.3654509 0.4321650 0.4507990 0.4412884 0.4665323 0.4956632
## GBM 0.4267990 0.4618120 0.4667919 0.4807179 0.4992355 0.5685265
## NA's
## Logistic_Regression 0
## Decision_Tree 0
## Random_Forest 0
## SVM 0
## GBM 0Conclusion
model_names <- c("Logistic Regression", "Decision Tree", "Random Forest", "Support Vector Machine", "Gradient Boosting Machine")
accuracy <- c(0.7951, 0.7817 , 0.7817, 0.7836, 0.7817) * 100
kappa <- c(0.446, 0.3947, 0.384, 0.3894, 0.4021)
sensitivity <- c(0.8887 , 0.8933, 0.9023 , 0.9036, 0.8868) * 100
specificity <- c(0.5350 , 0.4722, 0.4470, 0.4506, 0.4901) * 100
precision <- c(0.8414 , 0.8245, 0.8191, 0.8203, 0.8284) * 100
# Create a data frame
model_comparison <- data.frame(
Model = model_names,
Accuracy = paste0(accuracy, "%"),
Kappa = paste0(kappa, " "),
Sensitivity = paste0(sensitivity, "%"),
Specificity = paste0(specificity, "%"),
Precision = paste0(precision, "%")
)
# Render the table
kable(model_comparison, format = "html", caption = "Comparison of Model Performance Metrics") %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
row_spec(1, bold = TRUE, background = "#D3D3D3")| Model | Accuracy | Kappa | Sensitivity | Specificity | Precision |
|---|---|---|---|---|---|
| Logistic Regression | 79.51% | 0.446 | 88.87% | 53.5% | 84.14% |
| Decision Tree | 78.17% | 0.3947 | 89.33% | 47.22% | 82.45% |
| Random Forest | 78.17% | 0.384 | 90.23% | 44.7% | 81.91% |
| Support Vector Machine | 78.36% | 0.3894 | 90.36% | 45.06% | 82.03% |
| Gradient Boosting Machine | 78.17% | 0.4021 | 88.68% | 49.01% | 82.84% |
- Considering the balance of these metrics, Logistic Regression appears to be the best overall model.
- It offers the highest accuracy, Kappa, specificity, and precision, along with high sensitivity.
- While other models like Support Vector Machine and Random Forest have slightly higher sensitivity, the overall performance and balance of metrics make Logistic Regression the most robust choice for predicting customer churn in this case.