Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/blog.html quarto-1.2.335 Tue, 04 Jul 2023 23:00:00 GMT Customer Lifetime Value Analytics: Case Study Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/customer-lifetime-value-post/index.html

Introduction 😉

Customer lifetime value (CLTV) is the estimated total amount a customer will spend on a business throughout their relationship with that business. It takes into account the revenue generated by the customer as well as the costs associated with acquiring and serving that customer. By analyzing the relationship between customer acquisition costs and revenue generated, we can determine which channels are the most cost-effective for acquiring and retaining high-value customers.

The given data (available from the link below) includes information about the customer’s channel, cost of acquisition, conversion rate, and revenue generated.

Download Data

Goal 🥅

The goal is to analyze the CLTV of customers across different channels and identify the most profitable channels for the business.

Load Packages ♎

Code

Load Dataset 📅

Code
customer_tbl <- read_csv("customer_acquisition_data.csv") %>% 
  mutate_if(is.character,as.factor)

glimpse(customer_tbl)
Rows: 800
Columns: 5
$ customer_id     <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16,~
$ channel         <fct> referral, paid advertising, email marketing, social me~
$ cost            <dbl> 8.320327, 30.450327, 5.246263, 9.546326, 8.320327, 30.~
$ conversion_rate <dbl> 0.12314498, 0.01634149, 0.04382223, 0.16759225, 0.1231~
$ revenue         <dbl> 4199, 3410, 3164, 1520, 2419, 3856, 1172, 700, 2137, 9~

Exploratory Data Analysis 🏁

Code
summary(customer_tbl[,-1])
             channel         cost        conversion_rate      revenue    
 email marketing :214   Min.   : 5.246   Min.   :0.01634   Min.   : 500  
 paid advertising:194   1st Qu.: 5.246   1st Qu.:0.04382   1st Qu.:1694  
 referral        :207   Median : 8.320   Median :0.04382   Median :2764  
 social media    :185   Mean   :13.148   Mean   :0.08630   Mean   :2769  
                        3rd Qu.: 9.546   3rd Qu.:0.12314   3rd Qu.:3824  
                        Max.   :30.450   Max.   :0.16759   Max.   :4998

Let’s start by visualizing the distribution of acquisition cost and revenue generated by the customer using histograms:

Code
cost <- customer_tbl %>% 
  ggplot(aes(cost)) +
  geom_histogram(fill = "steelblue", color = "white", bins = 30) +
  labs(title = "Distribution of acquisition cost",
       x = "Acquisition Cost",
       y = "Frequency")


rev <- customer_tbl %>% 
  ggplot(aes(revenue)) +
  geom_histogram(fill = "tomato", color = "white", bins = 30) +
  labs(title = "Distribution of revenue generated",
       x = "Revenue",
       y = "Frequency") +
  scale_x_continuous(labels = scales::comma)

cost/rev

Research Questions ❓

Q1

  • What’s the cost of acquisition across different channels?

Now, let’s examine the cost of acquisition across different channels and identify the most and least profitable channels:

Code
customer_tbl %>% 
  group_by(channel) %>% 
  summarise(Ave_cost = mean(cost, na.rm = TRUE)) %>% 
  ggplot(aes(x = reorder(channel, Ave_cost), y = Ave_cost)) +
  geom_bar(stat ="identity", width = 0.6) +
  labs(x = "Channel",
       y = "Average cost of acquisition",
       title = "Average cost of acquisition across channels") +
  geom_label_repel(aes(label = round(Ave_cost)))

Insight ℹ️

  • Paid advertisement is the most expensive channel whereas email marketing is the least expensive channel.

Q2

  • Which channels are most and least effective at converting customers?

Now, let’s see which channels are most and least effective at converting customers:

Code
customer_tbl %>% 
  group_by(channel) %>% 
  summarise(Ave_rate = mean(conversion_rate, na.rm = TRUE)) %>% 
  ggplot(aes(x = reorder(channel, Ave_rate), y = Ave_rate)) +
  geom_bar(stat ="identity", width = 0.6, fill = "steelblue", color = "white") +
  labs(x = "Channel",
       y = "Average conversion rate",
       title = "Average conversion rate across channels") +
  geom_label_repel(aes(label = round(Ave_rate,2)))

Insight ℹ️

  • Social media is the most effective channel for converting customers, whereas paid advertising is the least effective.

Q3

  • What are the most and least profitable channels in terms of generating revenue?

Now, let’s calculate the total revenue by channel and have a look at the most and least profitable channels in terms of generating revenue:

Code
customer_tbl %>% 
  group_by(channel) %>% 
  summarise(sum_rev = sum(revenue, na.rm = TRUE)) %>%
  mutate(Prop = sum_rev/sum(sum_rev),
         channel = factor(channel, c("email marketing", "referral",
                                     "paid advertising", "social media") )) %>%
  arrange(Prop, channel) %>% 
  ggplot(aes(x = 2, y = Prop, fill = channel)) +
  geom_bar(stat ="identity", width = 1, color = "white") +
  xlim(0.3, 2.5) +
  coord_polar(theta = "y",  start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  labs(x = "",
       y = "",
       title = "Revenue contribution by channels",
       fill = "") +
  geom_text_repel(aes(label = paste0(round(Prop*100,1),"%")), size = 3, position = position_stack(vjust = 0.5)) +
    scale_fill_brewer(palette = "Blues", direction = -1) +
    theme(legend.position = "right")

Insight ℹ️

So, email marketing is the most profitable channel in terms of generating revenue.

Q4

  • What’s the return on investment for each channel?

Let’s examine the return on investment (ROI) for each channel

Code
customer_tbl %>% 
  mutate(roi = revenue/cost) %>% 
  group_by(channel) %>% 
  summarise(Ave_ROI = mean(roi, na.rm = TRUE)) %>% 
  ggplot(aes(x= reorder(channel, Ave_ROI), y = Ave_ROI)) +
  geom_bar(stat = "identity", fill = "steelblue", color = "white",
           width = 0.6) +
  labs(x = "Channel",
       y = "Average Return on Investment",
       title =  "Average Return on Investment (ROI) by Channel")

Insight ℹ️

The ROI from email marketing is way higher than all other channels, whereas the ROI from paid advertising is the lowest.

Q5

  • What is the distribution of customer lifetime value from each channel?

Let’s calculate the customer lifetime value from each channel.

Based on the data we have, we can use the formula below to calculate CLTV


Code
customer_tbl %>% 
  mutate(CLTV = (revenue - cost)* (conversion_rate/cost)) %>% 
  group_by(channel) %>% 
  summarise(cltv = mean(CLTV, na.rm = TRUE)) %>% 
  ggplot(aes(x = reorder(channel, cltv), y = cltv, fill = channel)) +
  geom_bar(stat = "identity", width = 0.6, show.legend = FALSE) +
  labs(x = "Channel",
       y = "CLTV",
       title = "Customer Lifetime Value by Channel")

Insight ℹ️

So, the customer lifetime value from social media and the referral channels are the most significant.

Let’s compare the CLTV distributions of the CLTV across channels

Code
customer_tbl %>% 
  mutate(CLTV = (revenue - cost)* (conversion_rate/cost)) %>% 
  ggplot(aes(x = channel, y = CLTV, fill =  channel)) +
  geom_boxplot(alpha = 0.5, show.legend = FALSE, color = "black") +
  labs(x ="Channel",
       y = "CLTV",
       title = "CLTV distribution by Channel")

Insight ℹ️

The boxplot above suggested that there’s a difference in the distribution of the customer lifetime value from different channels.

Hypotheses Testing 🧪

The following research hypotheses would be considered in the subsection below;

  1. is there is a significant difference in the revenue generated by channels?
  2. does the CLTV differ significantly across the channels?

Hypothesis 1

  • Null hypothesis: There’s no significant difference in the revenue generated by channels

  • Alternative Hypothesis: There’s a significant different in the revenue generated by channels

Code
model1 <- aov(lm(revenue ~ channel, data = customer_tbl))
summary(model1)
             Df     Sum Sq Mean Sq F value Pr(>F)
channel       3    3476233 1158744    0.73  0.534
Residuals   796 1264097594 1588062

Insight ℹ️

  • The test result above suggested that there is no significant difference in the revenue across channel at 5% level of significant. As a result, we cannot reject the null hypothesis.

Hypothesis 2

  • Null Hypothesis: There’s no significant difference in the CLTV across channels

  • Alternative Hypothesis: There’s a significant difference in the CLTV across channels

Code
customer_tbl %<>% 
  mutate(CLTV = (revenue - cost)* (conversion_rate/cost))

model2 <- aov(lm(CLTV ~ channel, data = customer_tbl))
summary(model2)
             Df Sum Sq Mean Sq F value              Pr(>F)    
channel       3 237204   79068   339.6 <0.0000000000000002 ***
Residuals   796 185312     233                                
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Insight ℹ️

  • The test result above suggest that there’s a significant difference in the customer lifetime value across channels. The test is significant at 5% level of significance. As a result, the null hypothesis cannot be accepted.

As a follow-up question, it would be great to know where the difference lies. Below is a post-hoc test conducted to know where the difference lies.

Code
out <- duncan.test(model2, "channel", main = "CLTV across channels")
plot(out, variation = "IQR", main = "CLTV across channels")

Code
print(out$groups)
                      CLTV groups
social media     46.584325      a
referral         40.599817      b
email marketing  23.559595      c
paid advertising  1.500682      d
  • The post hoc test shows that there’s a significant different across all the channels at 5% level of significance.

Summary 👍

Customer lifetime value analysis is used to estimate the total value of customers to the business over the lifetime of their relationship. It helps companies determine how much to invest in customer acquisition and retention, as well as identify the most valuable customers to prioritize for retention efforts.

Take Away 🕶️

It was observed that email marketing has the least cost of acquisition with a better conversion rate than paid advertisement which cost the most among all the channels. Social media has the best conversion rate with email marketing contributing the most to the revenue generated and also has a better return on investment (ROI) than others. Social media has a better CLTV among all the channels and this is found to be statistically significant.

]]> Supply Chain Analytics Customer Lifetime Value Customer Acquisition https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/customer-lifetime-value-post/index.html Tue, 04 Jul 2023 23:00:00 GMT Analysis of Clinical Trial Data Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/survival-tidymodels-post/index.html

Introduction

Breast cancer is a disease in which cells in the breast grow out of control. There are different kinds of breast cancer. The kind of breast cancer depends on which cells in the breast turn into cancer. Breast cancer can begin in different parts of the breast. Medical professionals often opined that earlier detection of breast cancer is key to survival.

In this piece of an experimental project, we will examine factors that could lead to survival in breast cancer patients. Appropriate machine learning algorithm would be deployed to model the dataset using the tidymodels methodology in R.

Load Libraries

Code
#if(!require(pacman)) install.packages("pacman")

pacman::p_load(
  tidyverse,
  magrittr,
  reactable,
  ggthemes,
  DescTools,
  tidymodels,
  vip
)

options(scipen = 999, digits = 2)

Load Dataset

Code
# Load datasets

survival_tbl <- read_csv('dataset.csv')
Code
# structure and data types of the fields

glimpse(survival_tbl)
Rows: 120
Columns: 4
$ Age            <dbl> 45, 74, 58, 66, 57, 42, 70, 62, 43, 46, 41, 67, 56, 63,~
$ Operation_year <dbl> 68, 65, 59, 58, 64, 63, 58, 66, 64, 65, 59, 66, 67, 66,~
$ nr_of_nodes    <dbl> 0, 3, 0, 1, 1, 1, 4, 0, 0, 20, 0, 0, 0, 0, 11, 0, 8, 8,~
$ survival       <dbl> 1, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2~

Data Wrangling

Convert the dependent variable survival to factor.

Code
# Convert the dependent variable `survival` to factor

survival_tbl %<>%
  mutate(survival = if_else(survival == 1, "The patient survived 5 years or longer", "The patient died within 5 years"),
         survival = as.factor(survival))

Exploratory Data Analysis of the Dataset

Code
glimpse(survival_tbl)
Rows: 120
Columns: 4
$ Age            <dbl> 45, 74, 58, 66, 57, 42, 70, 62, 43, 46, 41, 67, 56, 63,~
$ Operation_year <dbl> 68, 65, 59, 58, 64, 63, 58, 66, 64, 65, 59, 66, 67, 66,~
$ nr_of_nodes    <dbl> 0, 3, 0, 1, 1, 1, 4, 0, 0, 20, 0, 0, 0, 0, 11, 0, 8, 8,~
$ survival       <fct> The patient survived 5 years or longer, The patient die~
Code
reactable(survival_tbl, searchable = TRUE, filterable = TRUE, sortable = TRUE, pagination = TRUE)
Code
# brief data summary

summary(survival_tbl)
      Age     Operation_year  nr_of_nodes
 Min.   :30   Min.   :58     Min.   : 0  
 1st Qu.:44   1st Qu.:60     1st Qu.: 0  
 Median :54   Median :63     Median : 0  
 Mean   :53   Mean   :63     Mean   : 4  
 3rd Qu.:62   3rd Qu.:66     3rd Qu.: 3  
 Max.   :78   Max.   :69     Max.   :46  
                                   survival 
 The patient died within 5 years       :29  
 The patient survived 5 years or longer:91
Code
# detailed summary

Desc(survival_tbl)
------------------------------------------------------------------------------ 
Describe survival_tbl (tbl_df, tbl, data.frame):

data frame: 120 obs. of  4 variables
        120 complete cases (100.0%)

  Nr  ColName         Class    NAs  Levels                                  
  1   Age             numeric  .                                            
  2   Operation_year  numeric  .                                            
  3   nr_of_nodes     numeric  .                                            
  4   survival        factor   .    (2): 1-The patient died within 5 years, 
                                    2-The patient survived 5 years or longer


------------------------------------------------------------------------------ 
1 - Age (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     120     120      0      44      0  53.02   50.95
          100.0%   0.0%           0.0%          55.10
                                                     
     .05     .10    .25  median    .75    .90     .95
   36.90   38.00  43.75   53.50  62.00  69.10   71.05
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
   48.00   11.50   0.22   13.34  18.25   0.05   -0.90
                                                     
lowest : 30.0 (2), 31.0, 33.0, 34.0, 35.0
highest: 72.0, 73.0, 74.0 (2), 76.0, 78.0

' 95%-CI (classic)

------------------------------------------------------------------------------ 
2 - Operation_year (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     120     120      0      12      0  63.10   62.48
          100.0%   0.0%           0.0%          63.72
                                                     
     .05     .10    .25  median    .75    .90     .95
   58.00   58.00  60.00   63.00  66.00  67.00   68.05
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
   11.00    3.41   0.05    4.45   6.00  -0.01   -1.26
                                                     

    value  freq   perc  cumfreq  cumperc
1      58    14  11.7%       14    11.7%
2      59    13  10.8%       27    22.5%
3      60     7   5.8%       34    28.3%
4      61     9   7.5%       43    35.8%
5      62    10   8.3%       53    44.2%
6      63     8   6.7%       61    50.8%
7      64    14  11.7%       75    62.5%
8      65     8   6.7%       83    69.2%
9      66    12  10.0%       95    79.2%
10     67    14  11.7%      109    90.8%
11     68     5   4.2%      114    95.0%
12     69     6   5.0%      120   100.0%

' 95%-CI (classic)

------------------------------------------------------------------------------ 
3 - nr_of_nodes (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     120     120      0      20     60   3.57    2.31
          100.0%   0.0%          50.0%           4.82
                                                     
     .05     .10    .25  median    .75    .90     .95
    0.00    0.00   0.00    0.50   3.00  13.00   15.20
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
   46.00    6.96   1.95    0.74   3.00   3.26   13.42
                                                     
lowest : 0.0 (60), 1.0 (14), 2.0 (8), 3.0 (9), 4.0 (3)
highest: 19.0 (2), 20.0, 22.0, 35.0, 46.0

heap(?): remarkable frequency (50.0%) for the mode(s) (= 0)

' 95%-CI (classic)

------------------------------------------------------------------------------ 
4 - survival (factor - dichotomous)

  length      n    NAs unique
     120    120      0      2
         100.0%   0.0%       

                                        freq   perc  lci.95  uci.95'
The patient died within 5 years           29  24.2%   17.4%   32.6%
The patient survived 5 years or longer    91  75.8%   67.4%   82.6%

' 95%-CI (Wilson)

Code
# Survival Distribution

survival_tbl %>% 
  group_by(survival) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = survival))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c("#fc0394","#03adfc")) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = "Patient survival distribution",
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Age Distribution

ggplot(survival_tbl, aes(Age)) +
  geom_histogram(fill = "steelblue", color = "white") +
  labs(title = 'Patient age distribution',
       x = "Age",
       y = "Frequency",
       fill = "") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16)) +
  theme_clean()

Code
# Distribution of positive auxiliary nodes detected

ggplot(survival_tbl, aes(nr_of_nodes)) +
  geom_histogram(fill = "steelblue", color = "white") +
  labs(title = 'Distribution of positive auxiliary nodes',
       x = "# of Auxiliary Nodes",
       y = "Frequency",
       fill = "") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16)) +
  theme_clean()

Code
# Counts of surgery performed yearly

survival_tbl %>% 
  mutate(Operation_year = paste0("19", Operation_year)) %>% 
  group_by(Operation_year) %>% 
  summarise(Count = n()) %>% 
  ggplot(aes(x = Operation_year, y = Count)) +
  geom_bar(stat = "identity", width = 0.5, fill = "steelblue", color = "white") +
  labs(title = 'Count of surgery performed yearly',
       x = "Year of operation") +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::comma) +
  geom_text(aes(label = Count), size = 4)

Modelling

Data Quality

Check dataframe for NAs

Code
any(is.na(survival_tbl))
[1] FALSE
  • No NA is found. The dataset is complete without any missing values.
Code
# split data to train and test set

set.seed(1234)

split <- survival_tbl %>% 
  initial_split(prop = 0.75, strata = survival) # 75% training set | 25% testing set

df_train <- split %>% 
  training()

df_test <- split %>% 
  testing()

Model Recipe

Code
rec <- recipe(survival ~ ., data = df_train)

# add preprocessing

prepro <- rec %>% 
  step_normalize(all_numeric_predictors()) %>% 
  prep()

prepro

Define the model with parsnip

Code
## Logistic Regression

lr <- logistic_reg(
  mode = "classification"
) %>% 
  set_engine("glm")

Define models workflow

Code
## Logistic Regression

lr_wf <- workflow() %>% 
  add_recipe(prepro) %>% 
  add_model(lr)

Model Fitting

Code
set.seed(1234)

## Logistic Regression

lr_wf %>% 
  fit(df_train) %>% 
 tidy()
# A tibble: 4 x 5
  term           estimate std.error statistic    p.value
  <chr>             <dbl>     <dbl>     <dbl>      <dbl>
1 (Intercept)      1.29       0.283     4.57  0.00000483
2 Age             -0.147      0.286    -0.515 0.606     
3 Operation_year  -0.0605     0.278    -0.218 0.828     
4 nr_of_nodes     -1.09       0.324    -3.37  0.000745

Obtaining Predictions

Code
set.seed(1234)

## Logistic Regression

lr_pred <- lr_wf %>% 
  fit(df_train) %>% 
  predict(df_test) %>% 
  bind_cols(df_test)

Evaluating model performance

  • kap: Kappa
  • sens: Sensitivity
  • spec: Specificity
  • f_meas: F1
  • mcc: Matthews correlation coefficient

Logistic Regression

Code
lr_pred %>% 
  conf_mat(truth = survival, estimate = .pred_class) %>% 
  autoplot(type = "heatmap")

Code
lr_pred %>% 
  conf_mat(truth = survival, estimate = .pred_class) %>% 
  summary()
# A tibble: 13 x 3
   .metric              .estimator .estimate
   <chr>                <chr>          <dbl>
 1 accuracy             binary         0.710
 2 kap                  binary         0.136
 3 sens                 binary         0.25 
 4 spec                 binary         0.870
 5 ppv                  binary         0.4  
 6 npv                  binary         0.769
 7 mcc                  binary         0.142
 8 j_index              binary         0.120
 9 bal_accuracy         binary         0.560
10 detection_prevalence binary         0.161
11 precision            binary         0.4  
12 recall               binary         0.25 
13 f_meas               binary         0.308

Roc Curve and AUC estimate

Code
prob_preds <- lr_wf %>% 
  fit(df_train) %>% 
  predict(df_test, type = "prob") %>% 
  bind_cols(df_test)


threshold_df <- prob_preds %>% 
  roc_curve(truth = survival, estimate = `.pred_The patient survived 5 years or longer`)

threshold_df %>% 
  autoplot()

Code
roc_auc(prob_preds, truth = survival, estimate = `.pred_The patient survived 5 years or longer`)
# A tibble: 1 x 3
  .metric .estimator .estimate
  <chr>   <chr>          <dbl>
1 roc_auc binary         0.402

Variable Importance Plot

Relative variable importance plot

Code
final_lr_model <-
  lr_wf %>%
  fit(data = df_train)

final_lr_model
== Workflow [trained] ==========================================================
Preprocessor: Recipe
Model: logistic_reg()

-- Preprocessor ----------------------------------------------------------------
1 Recipe Step

* step_normalize()

-- Model -----------------------------------------------------------------------

Call:  stats::glm(formula = ..y ~ ., family = stats::binomial, data = data)

Coefficients:
   (Intercept)             Age  Operation_year     nr_of_nodes  
        1.2929         -0.1472         -0.0605         -1.0910  

Degrees of Freedom: 88 Total (i.e. Null);  85 Residual
Null Deviance:      97 
Residual Deviance: 81   AIC: 89
Code
final_lr_model %>% 
  extract_fit_parsnip() %>% 
  tidy()
# A tibble: 4 x 5
  term           estimate std.error statistic    p.value
  <chr>             <dbl>     <dbl>     <dbl>      <dbl>
1 (Intercept)      1.29       0.283     4.57  0.00000483
2 Age             -0.147      0.286    -0.515 0.606     
3 Operation_year  -0.0605     0.278    -0.218 0.828     
4 nr_of_nodes     -1.09       0.324    -3.37  0.000745
Code
## variable importance plot

final_lr_model %>%
  extract_fit_parsnip() %>%
  vip() +
  labs(title = 'Variables relative importance',
       x = "") +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::comma)

]]> Machine Learning Tidymodels Clinical Data Classification Predictive Analytics R Tidyverse https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/survival-tidymodels-post/index.html Thu, 02 Mar 2023 23:00:00 GMT Telco Customer Churn Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/telco-churn-tidymodels-post/index.html

Introduction

The ultimate goals of any business enterprise is to maximize profit, minimize cost, ensure efficiency in service delivery among others. In order to achieve this, the business ensures that the estimate customer base is maintained over time. In terms of cost, it’s cost effective to maintain an existing customer than to acquire a new one. To this effect, every business enterprise ensures that the churn rate to minimized and also endeavor to identify factors that could be responsible for customer churn and addresses them accordingly.

This experimental project addresses the customer churn in a telecommunication company.

Different classification models are considered in the modeling section using the tidymodels methodology in R.

Load Libraries and Datasets

Code
Code
# Load datasets

telco_df <- read_csv('WA_Fn-UseC_-Telco-Customer-Churn.csv')
Code
# structure and data types of the fields

glimpse(telco_df)
Rows: 7,043
Columns: 21
$ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CFOCW~
$ gender           <chr> "Female", "Male", "Male", "Male", "Female", "Female",~
$ SeniorCitizen    <dbl> 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           <dbl> 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 Wrangling

Convert character typed data to factor except the customerID field

Code
# convert character typed data to factor except the customerID

telco_df %<>%
  select_if(is.character) %>% 
  mutate(across(c(where(is.character), -c(customerID)), as.factor))

Exploratory Data Analysis of the Dataset

Code
glimpse(telco_df)
Rows: 7,043
Columns: 17
$ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CFOCW~
$ gender           <fct> Female, Male, Male, Male, Female, Female, Male, Femal~
$ Partner          <fct> Yes, No, No, No, No, No, No, No, Yes, No, Yes, No, Ye~
$ Dependents       <fct> No, No, No, No, No, No, Yes, No, No, Yes, Yes, No, No~
$ PhoneService     <fct> No, Yes, Yes, No, Yes, Yes, Yes, No, Yes, Yes, Yes, Y~
$ MultipleLines    <fct> No phone service, No, No, No phone service, No, Yes, ~
$ InternetService  <fct> DSL, DSL, DSL, DSL, Fiber optic, Fiber optic, Fiber o~
$ OnlineSecurity   <fct> No, Yes, Yes, Yes, No, No, No, Yes, No, Yes, Yes, No ~
$ OnlineBackup     <fct> Yes, No, Yes, No, No, No, Yes, No, No, Yes, No, No in~
$ DeviceProtection <fct> No, Yes, No, Yes, No, Yes, No, No, Yes, No, No, No in~
$ TechSupport      <fct> No, No, No, Yes, No, No, No, No, Yes, No, No, No inte~
$ StreamingTV      <fct> No, No, No, No, No, Yes, Yes, No, Yes, No, No, No int~
$ StreamingMovies  <fct> No, No, No, No, No, Yes, No, No, Yes, No, No, No inte~
$ Contract         <fct> Month-to-month, One year, Month-to-month, One year, M~
$ PaperlessBilling <fct> Yes, No, Yes, No, Yes, Yes, Yes, No, Yes, No, Yes, No~
$ PaymentMethod    <fct> Electronic check, Mailed check, Mailed check, Bank tr~
$ Churn            <fct> No, No, Yes, No, Yes, Yes, No, No, Yes, No, No, No, N~
Code
reactable(telco_df, searchable = TRUE, filterable = TRUE, sortable = TRUE, pagination = TRUE)
Code
# brief data summary

summary(telco_df)
  customerID           gender     Partner    Dependents PhoneService
 Length:7043        Female:3488   No :3641   No :4933   No : 682    
 Class :character   Male  :3555   Yes:3402   Yes:2110   Yes:6361    
 Mode  :character                                                   
                                                                    
          MultipleLines     InternetService             OnlineSecurity
 No              :3390   DSL        :2421   No                 :3498  
 No phone service: 682   Fiber optic:3096   No internet service:1526  
 Yes             :2971   No         :1526   Yes                :2019  
                                                                      
              OnlineBackup             DeviceProtection
 No                 :3088   No                 :3095   
 No internet service:1526   No internet service:1526   
 Yes                :2429   Yes                :2422   
                                                       
              TechSupport                StreamingTV  
 No                 :3473   No                 :2810  
 No internet service:1526   No internet service:1526  
 Yes                :2044   Yes                :2707  
                                                      
            StreamingMovies           Contract    PaperlessBilling
 No                 :2785   Month-to-month:3875   No :2872        
 No internet service:1526   One year      :1473   Yes:4171        
 Yes                :2732   Two year      :1695                   
                                                                  
                   PaymentMethod  Churn     
 Bank transfer (automatic):1544   No :5174  
 Credit card (automatic)  :1522   Yes:1869  
 Electronic check         :2365             
 Mailed check             :1612
Code
# detailed summary

Desc(telco_df)
------------------------------------------------------------------------------ 
Describe telco_df (tbl_df, tbl, data.frame):

data frame: 7043 obs. of  17 variables
        7043 complete cases (100.0%)

  Nr  ColName           Class      NAs  Levels                            
  1   customerID        character  .                                      
  2   gender            factor     .    (2): 1-Female, 2-Male             
  3   Partner           factor     .    (2): 1-No, 2-Yes                  
  4   Dependents        factor     .    (2): 1-No, 2-Yes                  
  5   PhoneService      factor     .    (2): 1-No, 2-Yes                  
  6   MultipleLines     factor     .    (3): 1-No, 2-No phone service,    
                                        3-Yes                             
  7   InternetService   factor     .    (3): 1-DSL, 2-Fiber optic, 3-No   
  8   OnlineSecurity    factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  9   OnlineBackup      factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  10  DeviceProtection  factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  11  TechSupport       factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  12  StreamingTV       factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  13  StreamingMovies   factor     .    (3): 1-No, 2-No internet service, 
                                        3-Yes                             
  14  Contract          factor     .    (3): 1-Month-to-month, 2-One year,
                                        3-Two year                        
  15  PaperlessBilling  factor     .    (2): 1-No, 2-Yes                  
  16  PaymentMethod     factor     .    (4): 1-Bank transfer (automatic), 
                                        2-Credit card (automatic),        
                                        3-Electronic check, 4-Mailed check
  17  Churn             factor     .    (2): 1-No, 2-Yes                  


------------------------------------------------------------------------------ 
1 - customerID (character)

  length      n    NAs unique levels  dupes
   7'043  7'043      0  7'043  7'043      n
         100.0%   0.0%                     

         level  freq  perc  cumfreq  cumperc
1   0002-ORFBO     1  0.0%        1     0.0%
2   0003-MKNFE     1  0.0%        2     0.0%
3   0004-TLHLJ     1  0.0%        3     0.0%
4   0011-IGKFF     1  0.0%        4     0.1%
5   0013-EXCHZ     1  0.0%        5     0.1%
6   0013-MHZWF     1  0.0%        6     0.1%
7   0013-SMEOE     1  0.0%        7     0.1%
8   0014-BMAQU     1  0.0%        8     0.1%
9   0015-UOCOJ     1  0.0%        9     0.1%
10  0016-QLJIS     1  0.0%       10     0.1%
11  0017-DINOC     1  0.0%       11     0.2%
12  0017-IUDMW     1  0.0%       12     0.2%
... etc.
 [list output truncated]

------------------------------------------------------------------------------ 
2 - gender (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

         freq   perc  lci.95  uci.95'
Female  3'488  49.5%   48.4%   50.7%
Male    3'555  50.5%   49.3%   51.6%

' 95%-CI (Wilson)

------------------------------------------------------------------------------ 
3 - Partner (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

      freq   perc  lci.95  uci.95'
No   3'641  51.7%   50.5%   52.9%
Yes  3'402  48.3%   47.1%   49.5%

' 95%-CI (Wilson)

------------------------------------------------------------------------------ 
4 - Dependents (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

      freq   perc  lci.95  uci.95'
No   4'933  70.0%   69.0%   71.1%
Yes  2'110  30.0%   28.9%   31.0%

' 95%-CI (Wilson)

------------------------------------------------------------------------------ 
5 - PhoneService (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

      freq   perc  lci.95  uci.95'
No     682   9.7%    9.0%   10.4%
Yes  6'361  90.3%   89.6%   91.0%

' 95%-CI (Wilson)

------------------------------------------------------------------------------ 
6 - MultipleLines (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

              level   freq   perc  cumfreq  cumperc
1                No  3'390  48.1%    3'390    48.1%
2               Yes  2'971  42.2%    6'361    90.3%
3  No phone service    682   9.7%    7'043   100.0%

------------------------------------------------------------------------------ 
7 - InternetService (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

         level   freq   perc  cumfreq  cumperc
1  Fiber optic  3'096  44.0%    3'096    44.0%
2          DSL  2'421  34.4%    5'517    78.3%
3           No  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
8 - OnlineSecurity (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  3'498  49.7%    3'498    49.7%
2                  Yes  2'019  28.7%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
9 - OnlineBackup (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  3'088  43.8%    3'088    43.8%
2                  Yes  2'429  34.5%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
10 - DeviceProtection (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  3'095  43.9%    3'095    43.9%
2                  Yes  2'422  34.4%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
11 - TechSupport (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  3'473  49.3%    3'473    49.3%
2                  Yes  2'044  29.0%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
12 - StreamingTV (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  2'810  39.9%    2'810    39.9%
2                  Yes  2'707  38.4%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
13 - StreamingMovies (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

                 level   freq   perc  cumfreq  cumperc
1                   No  2'785  39.5%    2'785    39.5%
2                  Yes  2'732  38.8%    5'517    78.3%
3  No internet service  1'526  21.7%    7'043   100.0%

------------------------------------------------------------------------------ 
14 - Contract (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      3      3      y
         100.0%   0.0%                     

            level   freq   perc  cumfreq  cumperc
1  Month-to-month  3'875  55.0%    3'875    55.0%
2        Two year  1'695  24.1%    5'570    79.1%
3        One year  1'473  20.9%    7'043   100.0%

------------------------------------------------------------------------------ 
15 - PaperlessBilling (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

      freq   perc  lci.95  uci.95'
No   2'872  40.8%   39.6%   41.9%
Yes  4'171  59.2%   58.1%   60.4%

' 95%-CI (Wilson)

------------------------------------------------------------------------------ 
16 - PaymentMethod (factor)

  length      n    NAs unique levels  dupes
   7'043  7'043      0      4      4      y
         100.0%   0.0%                     

                       level   freq   perc  cumfreq  cumperc
1           Electronic check  2'365  33.6%    2'365    33.6%
2               Mailed check  1'612  22.9%    3'977    56.5%
3  Bank transfer (automatic)  1'544  21.9%    5'521    78.4%
4    Credit card (automatic)  1'522  21.6%    7'043   100.0%

------------------------------------------------------------------------------ 
17 - Churn (factor - dichotomous)

  length      n    NAs unique
   7'043  7'043      0      2
         100.0%   0.0%       

      freq   perc  lci.95  uci.95'
No   5'174  73.5%   72.4%   74.5%
Yes  1'869  26.5%   25.5%   27.6%

' 95%-CI (Wilson)

Code
# Gender Distribution

telco_df %>% 
  group_by(gender) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = gender))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c("#fc0394","#03adfc")) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = "Customer Distribution by Gender",
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Distribution of Churned Customer


telco_df %>% 
  mutate(Churn = case_when(Churn == "No" ~ "Not Churned",
                            TRUE ~ "Churned")) %>% 
  group_by(Churn) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = Churn))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = 'Distribution of Churned Customer',
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Payment Methods used by Customer


telco_df %>% 
  group_by(PaymentMethod) %>% 
  summarise(Count = n()) %>% 
  ggplot(aes(x = reorder(PaymentMethod, Count), y = Count)) +
  geom_bar(stat = "identity", width = 0.3, fill = "steelblue", color = "white") +
  labs(title = 'Payment Methods used by Customer',
       x = "Payment Method") +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::comma) +
  geom_text(aes(label = Count), size = 3.5)

Code
# Distribution of Customers by Internet Service

telco_df %>% 
  group_by(InternetService) %>% 
  summarise(Count = n()) %>% 
  ggplot(aes(x = reorder(InternetService, Count), y = Count)) +
  geom_bar(stat = "identity", width = 0.3, fill = "steelblue", color = "white") +
  labs(title = 'Distribution of Customers by Internet Service',
       x = "Internet Service") +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::comma) +
  geom_text(aes(label = Count), size = 3.5)

Code
# Distribution of Customer by Phone service

telco_df %>% 
  group_by(PhoneService) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = PhoneService))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = 'Distribution of Customer by \nPhone Service',
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Distribution of Customer by Paperless Billing

telco_df %>% 
  group_by(PaperlessBilling) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = PaperlessBilling))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = 'Distribution of Customer by \nPaperless Billing',
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Distribution of Customers by Contract

telco_df %>% 
  group_by(Contract) %>% 
  summarise(Count = n()) %>% 
  ggplot(aes(x = reorder(Contract, Count), y = Count)) +
  geom_bar(stat = "identity", width = 0.3, fill = "steelblue", color = "white") +
  labs(title = 'Distribution of Customers by Contract',
       x = "Contract Type") +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::comma) +
  geom_text(aes(label = Count), size = 3.5)

Code
# Distribution of Customer by Online Security

telco_df %>% 
  group_by(OnlineSecurity) %>%
  summarise(Freq = n()) %>% 
  mutate(prop = Freq/sum(Freq)) %>% 
  filter(Freq != 0) %>% 
  
  ggplot(mapping = aes(x = 2, y = prop, fill = OnlineSecurity))+
  geom_bar(width = 1, color = "white", stat = "identity") +
  xlim(0.5, 2.5) +
  coord_polar(theta = "y", start = 0) +
  theme_void() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(prop*100, 1), "%")), size = 4, position = position_stack(vjust = 0.5)) +
  scale_fill_manual(values = c('#FF0000', 'tomato', 'darkorange')) +
  #theme(axis.text.x = element_text(angle = 90), legend.position = "top")+
  labs(title = 'Distribution of Customer by \nOnline Security',
       x = "",
       y = "",
       fill = "") +
  theme(legend.position = "top") +
   theme(title = element_text(family = "Sans", face = "bold", size = 16))

Code
# Proportion of Churn by Gender


telco_df %>% 
  mutate(Churn = case_when(Churn == "No" ~ "Not Churned",
                            TRUE ~ "Churned")) %>% 
  group_by(gender, Churn) %>%
  summarise(Count = n()) %>% 
  mutate(Prop = Count/sum(Count)) %>% 
  ggplot(aes(x = reorder(gender, Prop), y = Prop, fill = Churn)) +
  geom_bar(stat = "identity", width = 0.3, color = "white", position = "fill") +
  labs(title = 'Proportion of Churn by Gender',
       x = "",
       y = "") +
   scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(Prop*100,1),"%")), size = 3.5, position = position_fill(vjust = 0.5))

Code
# Proportion of Churn by PaymentMethod


telco_df %>% 
  mutate(Churn = case_when(Churn == "No" ~ "Not Churned",
                            TRUE ~ "Churned")) %>% 
  group_by(PaymentMethod, Churn) %>%
  summarise(Count = n()) %>% 
  mutate(Prop = Count/sum(Count)) %>% 
  ggplot(aes(x = reorder(PaymentMethod, Prop), y = Prop, fill = Churn)) +
  geom_bar(stat = "identity", width = 0.5, color = "white", position = "fill") +
  labs(title = 'Proportion of Churn by Payment Method',
       x = "",
       y = "") +
   scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(Prop*100,1),"%")), size = 3.5, position = position_fill(vjust = 0.5))

Code
# Proportion of Churn by Contract Type


telco_df %>% 
  mutate(Churn = case_when(Churn == "No" ~ "Not Churned",
                            TRUE ~ "Churned")) %>% 
  group_by(Contract, Churn) %>%
  summarise(Count = n()) %>% 
  mutate(Prop = Count/sum(Count)) %>% 
  ggplot(aes(x = reorder(Contract, Prop), y = Prop, fill = Churn)) +
  geom_bar(stat = "identity", width = 0.5, color = "white", position = "fill") +
  labs(title = 'Proportion of Churn by Contract Type',
       x = "",
       y = "") +
   scale_fill_manual(values = c('#FF0000', '#0000FF')) +
  theme(title = element_text(family = "Sans", face = "bold", size = 16),
        axis.title = element_text(family = "sans", size = 10, face = "plain")) +
  theme_clean() +
  scale_y_continuous(labels = scales::percent) +
  geom_text(aes(label = paste0(round(Prop*100,1),"%")), size = 3.5, position = position_fill(vjust = 0.5))

Modelling

Data Quality

Check dataframe for NAs

Code
any(is.na(telco_df))
[1] FALSE
  • No NA is found. The dataset is complete without any missing values.
Code
# split data to train and test set

set.seed(1234)

split <- telco_df %>% 
  select(-customerID) %>% 
  initial_split(prop = 0.75, strata = Churn) # 75% training set | 25% testing set

df_train <- split %>% 
  training()

df_test <- split %>% 
  testing()

Model Recipe

Code
rec <- recipe(Churn ~ ., data = df_train)

# add preprocessing

prepro <- rec %>% 
  step_dummy(all_nominal_predictors()) %>% 
  step_other(all_nominal_predictors()) %>% 
  step_filter_missing(all_nominal_predictors(),threshold = 0) %>% 
  prep()

prepro

Define the model with parsnip

Code
## Logistic Regression

lr <- logistic_reg(
  mode = "classification"
) %>% 
  set_engine("glm")


## Nearest Neighbor

knn <- nearest_neighbor(
  mode = "classification"
) %>% 
  set_engine("kknn")

## Random Forest

rf <- rand_forest(mode = "classification") %>% 
  set_engine("ranger", importance='impurity')

## Gradient Boost

gb <- boost_tree(mode = "classification") %>% 
  set_engine("xgboost")

Define models workflow

Code
## Logistic Regression

lr_wf <- workflow() %>% 
  add_recipe(prepro) %>% 
  add_model(lr)


## Nearest Neighbor

knn_wf <- workflow() %>% 
  add_recipe(prepro) %>% 
  add_model(knn)

## Random Forest

rf_wf <- workflow() %>% 
  add_recipe(prepro) %>% 
  add_model(rf)


## Gradient Boost

gb_wf <- workflow() %>% 
  add_recipe(prepro) %>% 
  add_model(gb)

Obtaining Predictions

Code
set.seed(1234)

## Logistic Regression

lr_pred <- lr_wf %>% 
  fit(df_train) %>% 
  predict(df_test) %>% 
  bind_cols(df_test)


## Nearest Neighbor

knn_pred <- knn_wf %>% 
  fit(df_train) %>% 
  predict(df_test) %>% 
  bind_cols(df_test)

## Random Forest

rf_pred <- rf_wf %>% 
  fit(df_train) %>% 
  predict(df_test) %>% 
  bind_cols(df_test)


## Gradient Boost

gb_pred <- gb_wf %>% 
  fit(df_train) %>% 
  predict(df_test) %>% 
  bind_cols(df_test)

Evaluating model performance

  • kap: Kappa
  • sens: Sensitivity
  • spec: Specificity
  • f_meas: F1
  • mcc: Matthews correlation coefficient

Logistic Regression

Code
lr_pred %>% 
  conf_mat(truth = Churn, estimate = .pred_class) %>% 
  summary()
# A tibble: 13 x 3
   .metric              .estimator .estimate
   <chr>                <chr>          <dbl>
 1 accuracy             binary         0.786
 2 kap                  binary         0.410
 3 sens                 binary         0.894
 4 spec                 binary         0.487
 5 ppv                  binary         0.828
 6 npv                  binary         0.625
 7 mcc                  binary         0.416
 8 j_index              binary         0.381
 9 bal_accuracy         binary         0.691
10 detection_prevalence binary         0.793
11 precision            binary         0.828
12 recall               binary         0.894
13 f_meas               binary         0.860

Nearest Neighbor

Code
knn_pred %>% 
  conf_mat(truth = Churn, estimate = .pred_class) %>% 
  summary()
# A tibble: 13 x 3
   .metric              .estimator .estimate
   <chr>                <chr>          <dbl>
 1 accuracy             binary         0.708
 2 kap                  binary         0.122
 3 sens                 binary         0.884
 4 spec                 binary         0.220
 5 ppv                  binary         0.758
 6 npv                  binary         0.407
 7 mcc                  binary         0.131
 8 j_index              binary         0.104
 9 bal_accuracy         binary         0.552
10 detection_prevalence binary         0.856
11 precision            binary         0.758
12 recall               binary         0.884
13 f_meas               binary         0.816

Random Forest

Code
rf_pred %>% 
  conf_mat(truth = Churn, estimate = .pred_class) %>% 
  summary()
# A tibble: 13 x 3
   .metric              .estimator .estimate
   <chr>                <chr>          <dbl>
 1 accuracy             binary         0.780
 2 kap                  binary         0.369
 3 sens                 binary         0.911
 4 spec                 binary         0.419
 5 ppv                  binary         0.813
 6 npv                  binary         0.630
 7 mcc                  binary         0.382
 8 j_index              binary         0.330
 9 bal_accuracy         binary         0.665
10 detection_prevalence binary         0.823
11 precision            binary         0.813
12 recall               binary         0.911
13 f_meas               binary         0.859

Gradient Boost

Code
gb_pred %>% 
  conf_mat(truth = Churn, estimate = .pred_class) %>% 
  summary()
# A tibble: 13 x 3
   .metric              .estimator .estimate
   <chr>                <chr>          <dbl>
 1 accuracy             binary         0.774
 2 kap                  binary         0.367
 3 sens                 binary         0.895
 4 spec                 binary         0.440
 5 ppv                  binary         0.815
 6 npv                  binary         0.602
 7 mcc                  binary         0.374
 8 j_index              binary         0.335
 9 bal_accuracy         binary         0.668
10 detection_prevalence binary         0.806
11 precision            binary         0.815
12 recall               binary         0.895
13 f_meas               binary         0.853

The random forest seems to be better off going by the sensitivity and the specificity metrics.

Random Forest Roc Curve

Code
## Random Forest

prob_preds <- rf_wf %>% 
  fit(df_train) %>% 
  predict(df_test, type = "prob") %>% 
  bind_cols(df_test)


threshold_df <- prob_preds %>% 
  roc_curve(truth = Churn, estimate = .pred_No)

threshold_df %>% 
  autoplot()

Code
roc_auc(prob_preds, truth = Churn, estimate = .pred_No)
# A tibble: 1 x 3
  .metric .estimator .estimate
  <chr>   <chr>          <dbl>
1 roc_auc binary         0.824

Variable Importance Plot

Relative variable importance plot

Code
final_rf_model <-
  rf_wf %>%
  fit(data = df_train)

final_rf_model
== Workflow [trained] ==========================================================
Preprocessor: Recipe
Model: rand_forest()

-- Preprocessor ----------------------------------------------------------------
3 Recipe Steps

* step_dummy()
* step_other()
* step_filter_missing()

-- Model -----------------------------------------------------------------------
Ranger result

Call:
 ranger::ranger(x = maybe_data_frame(x), y = y, importance = ~"impurity",      num.threads = 1, verbose = FALSE, seed = sample.int(10^5,          1), probability = TRUE) 

Type:                             Probability estimation 
Number of trees:                  500 
Sample size:                      5281 
Number of independent variables:  26 
Mtry:                             5 
Target node size:                 10 
Variable importance mode:         impurity 
Splitrule:                        gini 
OOB prediction error (Brier s.):  0.1469603
Code
final_rf_model %>% 
  pull_workflow_fit()
parsnip model object

Ranger result

Call:
 ranger::ranger(x = maybe_data_frame(x), y = y, importance = ~"impurity",      num.threads = 1, verbose = FALSE, seed = sample.int(10^5,          1), probability = TRUE) 

Type:                             Probability estimation 
Number of trees:                  500 
Sample size:                      5281 
Number of independent variables:  26 
Mtry:                             5 
Target node size:                 10 
Variable importance mode:         impurity 
Splitrule:                        gini 
OOB prediction error (Brier s.):  0.1469603
Code
## variable importance plot

library(vip)

final_rf_model %>%
  extract_fit_parsnip() %>%
  vip()

]]> Machine Learning Tidymodels Clinical Data Classification Predictive Analytics R Tidyverse https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/telco-churn-tidymodels-post/index.html Thu, 02 Mar 2023 23:00:00 GMT Creating Animated Visualization in R Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/plot-animation-post/index.html

How to create animated visualizations using R

Static visualizations that are publication ready are readily available in R using the ggplot2 package. However, there are times where it’s required to illustrate the change in an event overtime. This is a particular use case of the gganimate package in R which is an extension of the ggplot2 package for creating animated ggplots.

It provides a range of functionalities that can be added to the plot object in order to customize how it should change with time.

The gganimate package is available on CRAN and it can be installed by running the code chunk below from the Rstudio console.

Code
install.packages("gganimate")

The Data

The gapminder dataset in R is an excerpt of the Gapminder data on life expectancy, GDP per capita, and population by country.

The gapminder package is available on CRAN and it can be installed by running the code chunk below from the Rstudio console.

Code
install.packages("gapminder")

Load Packages

Code 
Loading required package: pacman
Warning: package 'pacman' was built under R version 4.0.5
Code
pacman::p_load(
  tidyverse,
  gganimate,
  gapminder
)

theme_set(theme_bw())

Load Demo Dataset

Code
data(gapminder)

A closer look at the dataset

  • If you’re new to the gapminder dataset, below is the structure of the dataset which includes the variables and sample data.
Code
glimpse(gapminder)
Rows: 1,704
Columns: 6
$ country   <fct> "Afghanistan", "Afghanistan", "Afghanistan", "Afghanistan", ~
$ continent <fct> Asia, Asia, Asia, Asia, Asia, Asia, Asia, Asia, Asia, Asia, ~
$ year      <int> 1952, 1957, 1962, 1967, 1972, 1977, 1982, 1987, 1992, 1997, ~
$ lifeExp   <dbl> 28.801, 30.332, 31.997, 34.020, 36.088, 38.438, 39.854, 40.8~
$ pop       <int> 8425333, 9240934, 10267083, 11537966, 13079460, 14880372, 12~
$ gdpPercap <dbl> 779.4453, 820.8530, 853.1007, 836.1971, 739.9811, 786.1134, ~

Static Plot

Code
p <- ggplot(
  gapminder, 
  aes(x = gdpPercap, y=lifeExp, size = pop, colour = country)
  ) +
  geom_point(show.legend = FALSE, alpha = 0.7) +
  scale_color_viridis_d() +
  scale_size(range = c(2, 12)) +
  scale_x_continuous(labels = scales::comma) +
  labs(x = "GDP per capita", y = "Life expectancy")
p

Transition through distinct states in time

Basics

Key R function: transition_time().

  • The transition length between the states will be set to correspond to the actual time difference between them.

Label variables: frame_time.

  • Gives the time that the current frame corresponds to.
Code
p + transition_time(year) +
  labs(title = "Year: {frame_time}")
Warning: No renderer available. Please install the gifski, av, or magick
package to create animated output
NULL

Create facets by continent:

Code
p + facet_wrap(~continent) +
  transition_time(year) +
  labs(title = "Year: {frame_time}")
Warning: No renderer available. Please install the gifski, av, or magick
package to create animated output
NULL

Let the view follow the data in each frame

Code
p + transition_time(year) +
  labs(title = "Year: {frame_time}") +
  view_follow(fixed_y = TRUE)
Warning: No renderer available. Please install the gifski, av, or magick
package to create animated output
NULL
Code
pop_ng <- gapminder %>% 
  filter(country == "Nigeria") %>% 
  ggplot(aes(x = year, y = pop, fill = pop)) +
  geom_bar(stat = "identity", show.legend = FALSE) +
  scale_fill_distiller(palette = "Reds", direction = 1) +
  theme_minimal() +
  theme(
    panel.grid = element_blank(),
    panel.grid.major.y = element_line(color = "white"),
    panel.ontop = TRUE
  ) +
  scale_y_continuous(labels = scales::unit_format(unit = "M", scale = 1e-6)) +
  geom_text(aes(label = paste0(round(pop/1000000,1), "M")))

pop_ng

Code
pop_ng + transition_time(year) +
  shadow_mark() +
  labs(x = "Year",
       y = "Population",
       title = "Year: {frame_time}")
Warning: No renderer available. Please install the gifski, av, or magick
package to create animated output
NULL

Save Animation

If you need to save the animation for later use you can use the anim_save() function.

Read more

]]> Animation Visualization ggplot R gganimate https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/plot-animation-post/index.html Wed, 25 Jan 2023 23:00:00 GMT Working with the OSRM API Olumide Oyalola https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/osrm-post/index.html

Introduction to OSRM R package

An interface between R and the OSRM (OpenStreetMap-Based Routing Service) API. OSRM is a routing service based on OpenStreetMap data. See for more information. This package allows to compute routes, trips, isochrones and travel distances matrices (travel time in minutes and distance in kilometer).

The package is available on CRAN and it can be installed by running the code chunk below from the Rstudio console.

For the purpose of this post, the osrmTable function from the osrm package in R would be used to return the distance in meter and the travel time in minutes.

Code
#install.packages("osrm")

Load Packages

Code
# Install pacman package if needed
#if(!require("pacman")) install.packages("pacman")

# load the required packages

pacman::p_load(
  httr,
  jsonlite,
  tidyjson,
  tidyverse,
  lubridate,
  geosphere,
  anytime,
  tictoc,
  stringi,
  maptools,
  geosphere,
  sf,
  sp,
  openxlsx,
  leaflet,
  magrittr,
  janitor,
  arrow,
  osrm
)

Load Data

Code
# load  file as tibble

tic("Load the csv file")

df <- read_parquet("ml_data.parquet")

toc()
Load the csv file: 0.18 sec elapsed

Data Munging

Code
remove <- c("/Date", "(", ")/", "[[:punct:]]")

var <- c("ActualSpeed", "Address", "Altitude", "AssetClass", "AssetLocationID", "AssetStatus", "CategoryID", "CategoryName", "City", "CustomerName", "DateTimeLocal", "DateTimeReceived", "DeliveryOrderNumber", "DepartureDateTime", "DestinationArea", "DestinationCity", "DestinationSite", "DestinationStreet", "DeviceType", "DirectionString", "Distance", "DriverCode", "DriverID", "Geofence", "IgnitionStatus", "Information", "JourneyDistance", "JourneyDuration", "JourneyIdleTime", "JourneyMaxSpeed", "LastIgnitionOff", "LastIgnitionOn", "Latitude", "Load", "Longitude", "NumSatellites", "Odometer", "Reason", "ReasonString", "Reference", "Region", "SiteName", "SpeedOverGround", "Status", "Street", "TrackTrue", "TripDestination", "TripID", "TripSource", "TripType", "UTCDateTime", "WaybillNumber")
Code
# data cleaning

df %<>% 
  #dplyr::select(tidyselect::all_of(var)) %>% 
  mutate(DateTimeLocal = str_remove_all(`DateTimeLocal`, 
                                        paste(remove, collapse = "|")),
         DateTimeLocal = str_remove_all(`DateTimeLocal`, 
                                        "\\+0100|\\+0000"),
         DateTimeLocal = as.numeric(`DateTimeLocal`),
         DateTimeLocal = `DateTimeLocal`/1000,
         DateTimeLocal = anytime(`DateTimeLocal`),
         DateTimeReceived = str_remove_all(DateTimeReceived, 
                                           paste(remove, collapse = "|")),
         DateTimeReceived = str_remove_all(DateTimeReceived, 
                                           "\\+0100|\\+0000"),
         DateTimeReceived = as.numeric(DateTimeReceived),
         DateTimeReceived = DateTimeReceived/1000,
         DateTimeReceived = anytime(DateTimeReceived),
         DepartureDateTime = str_remove_all(DepartureDateTime, 
                                            paste(remove, collapse = "|")),
         DepartureDateTime = str_remove_all(DepartureDateTime, 
                                            "\\+0100|\\+0000"),
         DepartureDateTime = as.numeric(DepartureDateTime),
         DepartureDateTime = DepartureDateTime/1000,
         DepartureDateTime = anytime(DepartureDateTime),
         UTCDateTime = str_remove_all(UTCDateTime, 
                                      paste(remove, collapse = "|")),
         UTCDateTime = str_remove_all(UTCDateTime, 
                                      "\\+0100|\\+0000"),
         UTCDateTime = as.numeric(UTCDateTime),
         UTCDateTime = UTCDateTime/1000,
         UTCDateTime = anytime(UTCDateTime),
         LastIgnitionOff = str_remove_all(LastIgnitionOff, 
                                          paste(remove, collapse = "|")),
         LastIgnitionOff = str_remove_all(LastIgnitionOff, 
                                          "\\+0100|\\+0000"),
         LastIgnitionOff = as.numeric(LastIgnitionOff),
         LastIgnitionOff = LastIgnitionOff/1000,
         LastIgnitionOff = anytime(LastIgnitionOff),
         LastIgnitionOn = str_remove_all(LastIgnitionOn, 
                                         paste(remove, collapse = "|")),
         LastIgnitionOn = str_remove_all(LastIgnitionOn, 
                                         "\\+0100|\\+0000"),
         LastIgnitionOn = as.numeric(LastIgnitionOn),
         LastIgnitionOn = LastIgnitionOn/1000,
         LastIgnitionOn = anytime(LastIgnitionOn)) %>% 
  filter(!between(TripID, 9000000000, Inf)) %>% 
  filter(!TripID == 0)

df %<>% mutate(TripID = as.numeric(TripID))
Code
options(scipen = 999)

# destination dataframe

ibese_df <- data.frame(id = "ibese", lon = c(3.043568), lat = c(7.006293))


ibese <- matrix(c(3.043568,7.006293), ncol = 2)

ibese_geofence <- c("Ibese", "IBESE", "Vehicle Park", "Vehicle Park 2")

Determining the direction of the truck

Code
inbound_df <- df %>% 
  filter(AssetStatus == "InService", Longitude > 0, 
         Latitude > 0) %>% 
  filter(!between(TripID, 9000000000, Inf)) %>% 
  filter(TripID != 0) %>% 
  select(Reference, DateTimeReceived, 
         Longitude, Latitude, TripID, Geofence, Altitude) %>% 
  arrange(Reference, DateTimeReceived) %>% 
  group_by(Reference, TripID) %>% 
  mutate(.after = DateTimeReceived,
         TimeDiff = as.numeric(difftime(DateTimeReceived, 
                                        lag(DateTimeReceived, 
                                            default = first(DateTimeReceived)), 
                                        units = "hours")),
         LongLat = matrix(c(Longitude, Latitude), ncol = 2),
         DistCovered = distGeo(LongLat, lag(LongLat)),
         DistCovered = DistCovered/1000,
         DistToPlant = distGeo(LongLat, ibese),
         DistToPlant = DistToPlant/1000) %>%
  mutate(Direction = if_else(lag(DistToPlant) < DistToPlant, "Inbound", "Outbound")) %>% 
  filter(Direction == "Inbound") %>% 
  slice_tail(n = 1) %>% 
  filter(TripID != 3000071349)

Estimating the arrival time and distance

Code
duration <- osrmTable(src = df %>%
                        # filter(as.Date(DateTimeReceived) == today()) %>% 
                        select(TripID, Longitude, Latitude) %>% 
                        slice_head(n = 100),
                      dst = ibese_df, measure = "duration", osrm.profile = "car")


distance <- osrmTable(src = df %>%
                        # filter(as.Date(DateTimeReceived) == today()) %>% 
                        select(TripID, Longitude, Latitude) %>% 
                        slice_head(n = 100),
                      dst = ibese_df, measure = "distance", osrm.profile = "car")


distances <- distance$distances %>% 
  as.data.frame() %>%
  rownames_to_column() %>% 
  rename(TripID = rowname,
         Distance = ibese) %>% 
  mutate(TripID = as.numeric(TripID))


durations <- duration$durations %>% 
  as.data.frame() %>%
  rownames_to_column() %>% 
  rename(TripID = rowname,
         duration = ibese) %>% 
  mutate(TripID = as.numeric(TripID))

Data Join

Joining the durations, distances and inbound_df data frames.

Code
arrival <- df %>%
  inner_join(durations, by = 'TripID') %>% 
  inner_join(distances, by = 'TripID') %>% 
  mutate(Arrival = DateTimeReceived + minutes(round(duration))) %>% 
  select(TripID, Reference, Longitude, Latitude, Distance, DateTimeReceived, Arrival) %>% 
  arrange(Distance)

#DT::datatable(arrival)
]]> Code Analysis GIS R Routing Open Street Map (osrm) https://quartopub.com/sites/iamolumide/olumide-oyalola/posts/osrm-post/index.html Tue, 18 Oct 2022 23:00:00 GMT