INFO-H510 Week 10 Data Dive

library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.4.4     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.0
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(dplyr)
library(ggplot2)

#Loading data
data <- read_delim("../Churn_Modelling.csv", delim = ",")
## Rows: 10002 Columns: 14
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (3): Surname, Geography, Gender
## dbl (11): RowNumber, CustomerId, CreditScore, Age, Tenure, Balance, NumOfPro...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
str(data)
## spc_tbl_ [10,002 × 14] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ RowNumber      : num [1:10002] 1 2 3 4 5 6 7 8 9 10 ...
##  $ CustomerId     : num [1:10002] 15634602 15647311 15619304 15701354 15737888 ...
##  $ Surname        : chr [1:10002] "Hargrave" "Hill" "Onio" "Boni" ...
##  $ CreditScore    : num [1:10002] 619 608 502 699 850 645 822 376 501 684 ...
##  $ Geography      : chr [1:10002] "France" "Spain" "France" "France" ...
##  $ Gender         : chr [1:10002] "Female" "Female" "Female" "Female" ...
##  $ Age            : num [1:10002] 42 41 42 39 43 44 50 29 44 NA ...
##  $ Tenure         : num [1:10002] 2 1 8 1 2 8 7 4 4 2 ...
##  $ Balance        : num [1:10002] 0 83808 159661 0 125511 ...
##  $ NumOfProducts  : num [1:10002] 1 1 3 2 1 2 2 4 2 1 ...
##  $ HasCrCard      : num [1:10002] 1 0 1 0 NA 1 1 1 0 1 ...
##  $ IsActiveMember : num [1:10002] 1 1 0 0 1 0 1 0 NA 1 ...
##  $ EstimatedSalary: num [1:10002] 101349 112543 113932 93827 79084 ...
##  $ Exited         : num [1:10002] 1 0 1 0 0 1 0 1 0 0 ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   RowNumber = col_double(),
##   ..   CustomerId = col_double(),
##   ..   Surname = col_character(),
##   ..   CreditScore = col_double(),
##   ..   Geography = col_character(),
##   ..   Gender = col_character(),
##   ..   Age = col_double(),
##   ..   Tenure = col_double(),
##   ..   Balance = col_double(),
##   ..   NumOfProducts = col_double(),
##   ..   HasCrCard = col_double(),
##   ..   IsActiveMember = col_double(),
##   ..   EstimatedSalary = col_double(),
##   ..   Exited = col_double()
##   .. )
##  - attr(*, "problems")=<externalptr>

In the dataset the columns, Exited, IsActiveMember, HasCrCard and Gender are binary attributes. So let the binary column be HasCrCard, which shows the status of an individual owning a credit card. Let the 4 explanatory variables be EstimatedSalary, Balance, NumOfProducts and Age.

library(glmnet)
## Loading required package: Matrix
## 
## Attaching package: 'Matrix'
## The following objects are masked from 'package:tidyr':
## 
##     expand, pack, unpack
## Loaded glmnet 4.1-8
model <- glm(HasCrCard ~ EstimatedSalary + Balance + NumOfProducts + Age, 
             data = data, family = "binomial")
summary(model)
## 
## Call:
## glm(formula = HasCrCard ~ EstimatedSalary + Balance + NumOfProducts + 
##     Age, family = "binomial", data = data)
## 
## Coefficients:
##                   Estimate Std. Error z value Pr(>|z|)    
## (Intercept)      1.052e+00  1.188e-01   8.856   <2e-16 ***
## EstimatedSalary -3.751e-07  3.817e-07  -0.983    0.326    
## Balance         -5.247e-07  3.694e-07  -1.420    0.155    
## NumOfProducts   -5.383e-03  3.952e-02  -0.136    0.892    
## Age             -2.377e-03  2.084e-03  -1.141    0.254    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 12123  on 9999  degrees of freedom
## Residual deviance: 12118  on 9995  degrees of freedom
##   (2 observations deleted due to missingness)
## AIC: 12128
## 
## Number of Fisher Scoring iterations: 4

Interpreting the models coefficients

coefficients <- coef(model)
coefficients
##     (Intercept) EstimatedSalary         Balance   NumOfProducts             Age 
##    1.052494e+00   -3.750511e-07   -5.247471e-07   -5.382793e-03   -2.376941e-03

It is clear that all the explanatory variables have a very low coefficient value, specifically for the columns EstimatedSalary and Balance which have a value very to zero. This indicates that these explanatory variables values reduce by only a small amount upon change from the response variable, HasCrCard.

Interpreting the Standard Error using Confidence Intervals

explanatory_variables <- c("EstimatedSalary", "Balance", "NumOfProducts", "Age")

for (explanatory_variable in explanatory_variables){
  column_coefficient <- coef(model)[explanatory_variable]
  column_se <- summary(model)$coefficients[explanatory_variable, "Std. Error"]
  
  ci <- column_coefficient + c(-1, 1) * 1.96 * column_se
  cat(explanatory_variable, ci, "\n")
}
## EstimatedSalary -1.123242e-06 3.731398e-07 
## Balance -1.248829e-06 1.993351e-07 
## NumOfProducts -0.08285012 0.07208453 
## Age -0.006460991 0.001707108

From these values it is clear that the columns EstimatedSalary and Balance have lower values, and from the previous values of coefficients it suggests that they have a very low predictive power. For the columns, NumOfProducts and Age although the value is low it is significantly larger compared to the rest 2 columns, which indicated they have a significantly larger predictive power of the two.

hist(data$Age, main = "Histogram of Column Age", xlab = "Values", ylab = "Frequency")

hist(data$Balance, main = "Histogram of Balance", xlab = "Values", ylab = "Frequency", col="blue")

hist(data$EstimatedSalary, main = "Histogram of EstimatedSalary", xlab = "Values", ylab = "Frequency", col="pink")

hist(data$NumOfProducts, main = "Histogram of NumOfProducts", xlab = "Values", ylab = "Frequency", col="green")

From the plots it is clear that the data is not normally distributed, hence we need to transform it!

Transforming the data to normally dsitribution

normal_distribution <- function(data, mean, sd) {
  transformed_data <- rnorm(n = length(data), mean = mean, sd = sd)
  return(transformed_data)
}
transformed_data <- data

for (explanatory_variable in explanatory_variables){
  column <- data[[explanatory_variable]]
  column_transformed <- normal_distribution(column, mean(column, na.rm=TRUE), sd(column, na.rm=TRUE))
  
  transformed_data[explanatory_variable] <- column_transformed
}
str(transformed_data)
## spc_tbl_ [10,002 × 14] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ RowNumber      : num [1:10002] 1 2 3 4 5 6 7 8 9 10 ...
##  $ CustomerId     : num [1:10002] 15634602 15647311 15619304 15701354 15737888 ...
##  $ Surname        : chr [1:10002] "Hargrave" "Hill" "Onio" "Boni" ...
##  $ CreditScore    : num [1:10002] 619 608 502 699 850 645 822 376 501 684 ...
##  $ Geography      : chr [1:10002] "France" "Spain" "France" "France" ...
##  $ Gender         : chr [1:10002] "Female" "Female" "Female" "Female" ...
##  $ Age            : num [1:10002] 50.2 38.7 26 49.6 38.7 ...
##  $ Tenure         : num [1:10002] 2 1 8 1 2 8 7 4 4 2 ...
##  $ Balance        : num [1:10002] 56183 201863 64111 76241 186354 ...
##  $ NumOfProducts  : num [1:10002] 1.3 1.76 1.26 1.89 1.68 ...
##  $ HasCrCard      : num [1:10002] 1 0 1 0 NA 1 1 1 0 1 ...
##  $ IsActiveMember : num [1:10002] 1 1 0 0 1 0 1 0 NA 1 ...
##  $ EstimatedSalary: num [1:10002] 71048 77243 89191 96474 40538 ...
##  $ Exited         : num [1:10002] 1 0 1 0 0 1 0 1 0 0 ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   RowNumber = col_double(),
##   ..   CustomerId = col_double(),
##   ..   Surname = col_character(),
##   ..   CreditScore = col_double(),
##   ..   Geography = col_character(),
##   ..   Gender = col_character(),
##   ..   Age = col_double(),
##   ..   Tenure = col_double(),
##   ..   Balance = col_double(),
##   ..   NumOfProducts = col_double(),
##   ..   HasCrCard = col_double(),
##   ..   IsActiveMember = col_double(),
##   ..   EstimatedSalary = col_double(),
##   ..   Exited = col_double()
##   .. )
##  - attr(*, "problems")=<externalptr>
Transformed Columns
hist(transformed_data$Age, main = "Histogram of Column Age", xlab = "Values", ylab = "Frequency")

hist(transformed_data$Balance, main = "Histogram of Balance", xlab = "Values", ylab = "Frequency", col="blue")

hist(transformed_data$EstimatedSalary, main = "Histogram of EstimatedSalary", xlab = "Values", ylab = "Frequency", col="pink")

hist(transformed_data$NumOfProducts, main = "Histogram of NumOfProducts", xlab = "Values", ylab = "Frequency", col="green")

Re-modelling using transformed columns

model <- glm(HasCrCard ~ EstimatedSalary + Balance + NumOfProducts + Age, 
             data = transformed_data, family = "binomial")
summary(model)
## 
## Call:
## glm(formula = HasCrCard ~ EstimatedSalary + Balance + NumOfProducts + 
##     Age, family = "binomial", data = transformed_data)
## 
## Coefficients:
##                  Estimate Std. Error z value Pr(>|z|)    
## (Intercept)     6.428e-01  1.129e-01   5.691 1.26e-08 ***
## EstimatedSalary 3.544e-08  3.845e-07   0.092   0.9266    
## Balance         9.130e-08  3.499e-07   0.261   0.7941    
## NumOfProducts   1.134e-02  3.790e-02   0.299   0.7647    
## Age             5.242e-03  2.107e-03   2.488   0.0128 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 12123  on 10000  degrees of freedom
## Residual deviance: 12117  on  9996  degrees of freedom
##   (1 observation deleted due to missingness)
## AIC: 12127
## 
## Number of Fisher Scoring iterations: 4
coefficients <- coef(model)
coefficients
##     (Intercept) EstimatedSalary         Balance   NumOfProducts             Age 
##    6.428170e-01    3.543808e-08    9.130469e-08    1.134455e-02    5.242094e-03

A slight variation among the columns EstimatedSalary and Balance can be observed, but since they still very small values (e-07 order) both these columns still have a very low impact. However, even though the columns Age and NumOfProducts have low values their coefficients have increased significantly compared to the previous values which were of the order e-05, indicating an increase in predictive power.

for (explanatory_variable in explanatory_variables){
  column_coefficient <- coef(model)[explanatory_variable]
  column_se <- summary(model)$coefficients[explanatory_variable, "Std. Error"]
  
  ci <- column_coefficient + c(-1, 1) * 1.96 * column_se
  cat(explanatory_variable, ci, "\n")
}
## EstimatedSalary -7.182566e-07 7.891327e-07 
## Balance -5.944818e-07 7.770912e-07 
## NumOfProducts -0.06293538 0.08562448 
## Age 0.001112649 0.009371539

The confidence variables show a similar pattern from before transforming, the former 2 columns have low predictive power from the earlier value and low CI value here. Similarly the later 2 columns also have a similar pattern, with roughly similar values.