Logistic Regression Test
library(dplyr) #For Data Wrangling
library(UBL) #for upsampling data
library(caret) #for model evaluation cust <- read.csv("cust.csv", sep = ";", stringsAsFactors = T) %>%
select(y,marital,education,housing,loan,poutcome)
glimpse(cust)## Rows: 45,211
## Columns: 6
## $ y <fct> no, no, no, no, no, no, no, no, no, no, no, no, no, no, no, …
## $ marital <fct> married, single, married, married, single, married, single, …
## $ education <fct> tertiary, secondary, secondary, unknown, unknown, tertiary, …
## $ housing <fct> yes, yes, yes, yes, no, yes, yes, yes, yes, yes, yes, yes, y…
## $ loan <fct> no, no, yes, no, no, no, yes, no, no, no, no, no, no, no, no…
## $ poutcome <fct> unknown, unknown, unknown, unknown, unknown, unknown, unknow…Data Structure
- marital : marital status (categorical: “married”,“divorced”,“single”; note: “divorced” means divorced or widowed)
- education (categorical: “unknown”,“secondary”,“primary”,“tertiary”)
- housing: has housing loan? (binary: “yes”,“no”)
- loan: has personal loan? (binary: “yes”,“no”)
- poutcome: outcome of the previous marketing campaign (categorical: “unknown”,“other”,“failure”,“success”)
Output variable (target):
- y - has the client subscribed a term deposit? (binary: “yes”,“no”)
NA Value check
From the results checking , there is no null data
anyNA(cust)## [1] FALSEmake train and test data
I make the proportion of data for train as much as 80% of the total data and 20% for test/prediction data
RNGkind(sample.kind = "Rounding")
set.seed(100)
# index sampling
index <- sample(x = nrow(cust) , size = nrow(cust) * 0.8)
# splitting
cust_train <- cust[index , ]
cust_test <- cust[-index , ]Proportion Check of train data
if we see that the number of data proportions in the “y” field of the custom table is unbalanced, then it needs to be balanced so that the model can be trained better
prop.table(table(cust_train$y))##
## no yes
## 0.8828799 0.1171201Balancing the proportion of train data with upsampling
cust_train_smote <- SmoteClassif(form = y ~ .,
dat = cust_train,
C.perc = "balance",
dist = "HVDM")recheck proportion of target variable after balancing
prop.table(table(cust_train_smote$y))##
## no yes
## 0.5 0.5Build logistic regression model with all predictor
model_cust1 <- glm(formula = y~. ,
data = cust_train_smote,
family = "binomial")
summary(model_cust1)##
## Call:
## glm(formula = y ~ ., family = "binomial", data = cust_train_smote)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.58735 -1.11797 -0.06127 1.11044 2.20265
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.71546 0.05459 13.105 < 2e-16 ***
## maritalmarried -1.04298 0.03247 -32.121 < 2e-16 ***
## maritalsingle -0.28975 0.03483 -8.319 < 2e-16 ***
## educationsecondary -0.01776 0.03420 -0.519 0.604
## educationtertiary 0.28325 0.03554 7.969 1.60e-15 ***
## educationunknown -0.38677 0.06771 -5.712 1.12e-08 ***
## housingyes -0.70928 0.02330 -30.444 < 2e-16 ***
## loanyes -1.11355 0.04019 -27.710 < 2e-16 ***
## poutcomeother 0.15666 0.06940 2.257 0.024 *
## poutcomesuccess 2.31266 0.07840 29.499 < 2e-16 ***
## poutcomeunknown 0.20385 0.04060 5.021 5.15e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 50139 on 36167 degrees of freedom
## Residual deviance: 44411 on 36157 degrees of freedom
## AIC: 44433
##
## Number of Fisher Scoring iterations: 4# Build logistic regression model with selected predictor
model_cust2 <- glm(formula = y ~ education + marital,
data = cust_train_smote,
family = "binomial")
summary(model_cust2)##
## Call:
## glm(formula = y ~ education + marital, family = "binomial", data = cust_train_smote)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.59875 -1.13109 -0.04557 1.12177 1.48380
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.59596 0.03584 16.628 < 2e-16 ***
## educationsecondary -0.12213 0.03236 -3.775 0.000160 ***
## educationtertiary 0.35549 0.03378 10.522 < 2e-16 ***
## educationunknown -0.23103 0.06447 -3.584 0.000339 ***
## maritalmarried -1.06139 0.03100 -34.234 < 2e-16 ***
## maritalsingle -0.34153 0.03326 -10.269 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 50139 on 36167 degrees of freedom
## Residual deviance: 48053 on 36162 degrees of freedom
## AIC: 48065
##
## Number of Fisher Scoring iterations: 4Build logistic regression model with all predictor II
model_cust3 <- glm(formula = y ~ loan+ housing,
data = cust_train_smote,
family = "binomial")
summary(model_cust3)##
## Call:
## glm(formula = y ~ loan + housing, family = "binomial", data = cust_train_smote)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.3943 -1.0595 0.1684 0.9750 1.8394
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.49683 0.01542 32.23 <2e-16 ***
## loanyes -1.20427 0.03873 -31.09 <2e-16 ***
## housingyes -0.78060 0.02181 -35.80 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 50139 on 36167 degrees of freedom
## Residual deviance: 47599 on 36165 degrees of freedom
## AIC: 47605
##
## Number of Fisher Scoring iterations: 4Model Comparation with AIC value
The Akaike information criterion (AIC) is a mathematical method for evaluating how well a model fits the data it was generated from. The smaller the AIC value, the better the model. So, we choose the model with all the predictor variables (model1)
model_cust1$aic## [1] 44432.54model_cust2$aic## [1] 48064.92model_cust3$aic## [1] 47604.97Interpretation
exp(model_cust1$coefficients)## (Intercept) maritalmarried maritalsingle educationsecondary
## 2.0451233 0.3524028 0.7484540 0.9823988
## educationtertiary educationunknown housingyes loanyes
## 1.3274343 0.6792499 0.4919983 0.3283898
## poutcomeother poutcomesuccess poutcomeunknown
## 1.1695958 10.1012982 1.2261091- Married customers are 0.35 times more likely to subscribe to a term deposit
- for a single customer, it is 0.74 times more likely to subscribe to a term deposit
- customers with secondary education are 0.98 times more likely to subscribe to term deposits
- customers with tertiary education are 1.32 times more likely to subscribe to term deposits
Prediction
cust_test$pred.Risk <- predict(object = model_cust1,
newdata = cust_test,
type = "response")cust_test$pred.Label <- ifelse(cust_test$pred.Risk > 0.7 , yes = "yes" , no = "no")
cust_test$pred.Label <- as.factor(cust_test$pred.Label)
head(cust_test)## y marital education housing loan poutcome pred.Risk pred.Label
## 2 no single secondary yes no unknown 0.4756494 no
## 4 no married unknown yes no unknown 0.2279853 no
## 12 no single secondary yes no unknown 0.4756494 no
## 21 no married secondary yes yes unknown 0.1230059 no
## 22 no married tertiary yes no unknown 0.3659321 no
## 23 no single primary yes yes unknown 0.2326736 noModel Evaluation
confusionMatrix(data = cust_test$pred.Label, reference = cust_test$y , positive = "yes")## Confusion Matrix and Statistics
##
## Reference
## Prediction no yes
## no 7320 739
## yes 670 314
##
## Accuracy : 0.8442
## 95% CI : (0.8365, 0.8516)
## No Information Rate : 0.8836
## P-Value [Acc > NIR] : 1.00000
##
## Kappa : 0.2206
##
## Mcnemar's Test P-Value : 0.07005
##
## Sensitivity : 0.29820
## Specificity : 0.91615
## Pos Pred Value : 0.31911
## Neg Pred Value : 0.90830
## Prevalence : 0.11644
## Detection Rate : 0.03472
## Detection Prevalence : 0.10881
## Balanced Accuracy : 0.60717
##
## 'Positive' Class : yes
## - Accuracy value (0.8442), means +-84% predicted data is correct
- The sensitivity value and the small post press value illustrate the proportion of the test data that is indeed imbalance but prediction still acurate