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.5.0 ✔ 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 errorslibrary(dplyr)
library(ggthemes)
library(ggrepel)
library(broom)
library(lindia)
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 variable Tenure describes the number
of years a customer has resided with the banking organization. There
could be a possible relation with this variable, to other variables
within the dataset such as, Balance,
EstimatedSalary etc., these variables often indicate the
financial stability of the customer after can be associated with a
longer tenure of the customer. So, let Tenure be the
response variable, while Balance and
EstimatedSalary being the explanatory variables.
linear_model <- lm(Tenure ~ Balance + EstimatedSalary, data = data)
summary(linear_model)##
## Call:
## lm(formula = Tenure ~ Balance + EstimatedSalary, data = data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -5.0954 -2.0958 -0.0122 2.0829 5.0867
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.016e+00 6.768e-02 74.112 <2e-16 ***
## Balance -5.740e-07 4.635e-07 -1.238 0.216
## EstimatedSalary 4.016e-07 5.029e-07 0.799 0.425
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.892 on 9999 degrees of freedom
## Multiple R-squared: 0.0002146, Adjusted R-squared: 1.464e-05
## F-statistic: 1.073 on 2 and 9999 DF, p-value: 0.3419linear_model <- glm(Tenure ~ Balance + EstimatedSalary, data = data)
summary(linear_model)##
## Call:
## glm(formula = Tenure ~ Balance + EstimatedSalary, data = data)
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.016e+00 6.768e-02 74.112 <2e-16 ***
## Balance -5.740e-07 4.635e-07 -1.238 0.216
## EstimatedSalary 4.016e-07 5.029e-07 0.799 0.425
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for gaussian family taken to be 8.363385)
##
## Null deviance: 83643 on 10001 degrees of freedom
## Residual deviance: 83625 on 9999 degrees of freedom
## AIC: 49632
##
## Number of Fisher Scoring iterations: 2From the above summary it is clear that the model is not a good fit
for the variables, this can be seen from the p-value of the model which
is very high (0.216 and 0.425) indicating we
cannot make a confident hypothesis that the two explanatory variables
properly fit the variable Tenure . Further this is also
evident from the Multiple R-squared and the
Adjusted R-squared error values from the linear model build
above.
Furthermore diagnostics on the model can be computed using Deviance, Akaike Information Criterion, Bayesian Information Criterion and ANOVA
But these model diagnostics are best suited for comparing multiple
model and their performance. So for the new model, let
Tenure be the same response variable but changing the
explanatory variable.
linear_model2 <- lm(Tenure ~ Balance + EstimatedSalary + Exited, data = data)
summary(linear_model2)##
## Call:
## lm(formula = Tenure ~ Balance + EstimatedSalary + Exited, data = data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -5.1096 -2.1099 -0.0198 2.1467 5.1535
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.029e+00 6.841e-02 73.511 <2e-16 ***
## Balance -5.031e-07 4.668e-07 -1.078 0.281
## EstimatedSalary 4.085e-07 5.029e-07 0.812 0.417
## Exited -9.283e-02 7.230e-02 -1.284 0.199
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.892 on 9998 degrees of freedom
## Multiple R-squared: 0.0003794, Adjusted R-squared: 7.949e-05
## F-statistic: 1.265 on 3 and 9998 DF, p-value: 0.2845linear_model2 <- glm(Tenure ~ Balance + EstimatedSalary + Exited, data = data)
summary(linear_model2)##
## Call:
## glm(formula = Tenure ~ Balance + EstimatedSalary + Exited, data = data)
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.029e+00 6.841e-02 73.511 <2e-16 ***
## Balance -5.031e-07 4.668e-07 -1.078 0.281
## EstimatedSalary 4.085e-07 5.029e-07 0.812 0.417
## Exited -9.283e-02 7.230e-02 -1.284 0.199
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for gaussian family taken to be 8.362843)
##
## Null deviance: 83643 on 10001 degrees of freedom
## Residual deviance: 83612 on 9998 degrees of freedom
## AIC: 49633
##
## Number of Fisher Scoring iterations: 2From the p-values and the both the R-squared errors it is clear that this model is also a very poor fit for the variables, but there error and p-values appear to be slightly better compared to the previous linear model.
So, this should mean that these the deviance values should be very high for both model but just a little bit smaller for the second model.
paste("Model 1 Deviance", round(linear_model$deviance, 1))## [1] "Model 1 Deviance 83625.5"paste("Model 2 Deviance", round(linear_model2$deviance, 1))## [1] "Model 2 Deviance 83611.7"From the values above it can be seen that addition of the variable,
Exited made the model just slightly better, but not
perfect. Further diagnostics can be made from the using different
diagnostic measures to reveal the similar information.
paste("Model 1 AIC", round(linear_model$aic, 1))## [1] "Model 1 AIC 49632.3"paste("Model 2 AIC", round(linear_model2$aic, 1))## [1] "Model 2 AIC 49632.7"From both these values it is clean that both of then are loosing a
lot of information, which essentially is the value the
Akaike Information Criterion tries to predict. A negative
value indicates that the model is performing well, while here the
positive value indicates that the model is performing very poorly. Which
can be seen from the Deviance, p-value and the R-squared
error values seen above.
Moreover, there is slight variance among these model, which is also
observed from the Deviance metric above, but in this case
the difference among these relatively low (0.4). This could
be attributed to the non-linear nature of the data, and the information
loss is very high both these models appear to have similar values.
Similar to the Akaike Information Criterion, the Bayesian Information Criterion also utilizes the maximum likelihood estimator as well as the number of parameters in the model, while the formulation of the model slightly varies from the AIC.
paste("Model 1 AIC", round(BIC(linear_model), 1))## [1] "Model 1 AIC 49661.2"paste("Model 2 AIC", round(BIC(linear_model2), 1))## [1] "Model 2 AIC 49668.7"The BIC loss also takes into account the number of parameters that the model, but since it is small dataset and working with a linear regression model same number of parameters, the loss value should be similar to that of the AIC, but the interesting pattern that could be observed from this is that the diagnostic value of the second linear model is slightly better than that of the first, although the difference is still small compared to the magnitude of the actual error. Nevertheless, is important to note that the loss estimates using parameters leads to a slightly increase in loss of the 2nd model.
Unlike the above 2 diagnostics the ANOVA is often used while checking the residual deviance of the model upon adding new variables. And variables that penalize the model’s performance can be removed while still having a model that performs very well.
anova(linear_model, linear_model2, test = "Chisq")## Analysis of Deviance Table
##
## Model 1: Tenure ~ Balance + EstimatedSalary
## Model 2: Tenure ~ Balance + EstimatedSalary + Exited
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 9999 83625
## 2 9998 83612 1 13.786 0.1992The residual error of the models are high indicating a poor fit for the data, while is support of the inferences that are made from all the above diagnostic values, similar to the Deviance and the AIC values the first model performs slightly better than the later.
The ANOVA diagnostic can be further analyzed using the addition of
new variables to check their effect of the standard error. So, let the
new model also have NumOfProducts also as part of the
explanatory variables.
linear_model3 <- lm(Tenure ~ Balance + EstimatedSalary + Exited + NumOfProducts, data = data)
summary(linear_model3)##
## Call:
## lm(formula = Tenure ~ Balance + EstimatedSalary + Exited + NumOfProducts,
## data = data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -5.1216 -2.1224 -0.0178 2.1554 5.1633
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 4.940e+00 1.134e-01 43.580 <2e-16 ***
## Balance -3.577e-07 4.895e-07 -0.731 0.465
## EstimatedSalary 3.990e-07 5.030e-07 0.793 0.428
## Exited -9.194e-02 7.231e-02 -1.272 0.204
## NumOfProducts 5.145e-02 5.220e-02 0.986 0.324
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.892 on 9997 degrees of freedom
## Multiple R-squared: 0.0004765, Adjusted R-squared: 7.661e-05
## F-statistic: 1.192 on 4 and 9997 DF, p-value: 0.3122linear_model3 <- glm(Tenure ~ Balance + EstimatedSalary + Exited + NumOfProducts, data = data)
summary(linear_model3)##
## Call:
## glm(formula = Tenure ~ Balance + EstimatedSalary + Exited + NumOfProducts,
## data = data)
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 4.940e+00 1.134e-01 43.580 <2e-16 ***
## Balance -3.577e-07 4.895e-07 -0.731 0.465
## EstimatedSalary 3.990e-07 5.030e-07 0.793 0.428
## Exited -9.194e-02 7.231e-02 -1.272 0.204
## NumOfProducts 5.145e-02 5.220e-02 0.986 0.324
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for gaussian family taken to be 8.362867)
##
## Null deviance: 83643 on 10001 degrees of freedom
## Residual deviance: 83604 on 9997 degrees of freedom
## AIC: 49634
##
## Number of Fisher Scoring iterations: 2anova(linear_model, linear_model2, linear_model3, test = "Chisq")## Analysis of Deviance Table
##
## Model 1: Tenure ~ Balance + EstimatedSalary
## Model 2: Tenure ~ Balance + EstimatedSalary + Exited
## Model 3: Tenure ~ Balance + EstimatedSalary + Exited + NumOfProducts
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 9999 83625
## 2 9998 83612 1 13.7861 0.1992
## 3 9997 83604 1 8.1222 0.3244As we can see from the model’s residual deviation it is clear that
the upon adding the variable NumOfProducts the deviation
has gone down slightly, suggesting these set of variables being a better
fit for the model fitting.