** Predicting Tire Performance Purchasing at The Tire Rack
The Project Objective
Investigating the relationship between tire performances compared to customer repurchase.Question 1 & 2: Develop the Model & Assess Predictor Significance
Step 1: Install and load required libraries
#install.packages("readxl")
#install.packages("Hmisc")
#install.packages("pscl")
#if(!require(pROC)) install.packages("pROC")
library(readxl) #allows us to import excel files
library(Hmisc) #allows us to call the correlation function##
## Attaching package: 'Hmisc'## The following objects are masked from 'package:base':
##
## format.pval, unitslibrary(pscl) #allows us to call the psuedo R-square package to evaluate our model## Classes and Methods for R originally developed in the
## Political Science Computational Laboratory
## Department of Political Science
## Stanford University (2002-2015),
## by and under the direction of Simon Jackman.
## hurdle and zeroinfl functions by Achim Zeileis.library(pROC) #allows us to run the area under the curve (AUC) packages to get the plot and AUC score## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varStep 2: Import & clean the data
tire_df <- read_excel("/Users/salimh/Desktop/r markdown/Class Exercise 15_TireRatings.xlsx")
tir_df <- subset(tire_df, select = -c(Tire)) #doesn't contain irrelevant column#Step 3: Summarize the data
head(tir_df)## # A tibble: 6 × 4
## Wet Noise Buy_Again Purchase
## <dbl> <dbl> <dbl> <dbl>
## 1 8 7.2 6.1 0
## 2 8 7.2 6.6 1
## 3 7.6 7.5 6.9 1
## 4 6.6 5.4 6.6 0
## 5 5.8 6.3 4 0
## 6 6.3 5.7 4.5 0## # A tibble: 6 × 4
## Wet Noise Buy_Again Purchase
## <dbl> <dbl> <dbl> <dbl>
## 1 8 7.2 6.1 0
## 2 8 7.2 6.6 1
## 3 7.6 7.5 6.9 1
## 4 6.6 5.4 6.6 0
## 5 5.8 6.3 4 0
## 6 6.3 5.7 4.5 0Data Description: A description of the features are presented in the table below
Variable | Definition
------------- | -------------
1. Wet | A customer buys a tire with a Wet Tire Performance Rating
2. Noise | A customer buys a tire with a Noise Tire Performance Rating
3. Buy_Again | A customer buys a Wet/Noise Tire Again (0: Probabily and 1: Definitely)summary(tir_df)
## Wet Noise Buy_Again Purchase
## Min. :4.300 Min. :3.600 Min. :1.400 Min. :0.0000
## 1st Qu.:6.450 1st Qu.:6.000 1st Qu.:3.850 1st Qu.:0.0000
## Median :7.750 Median :7.100 Median :6.150 Median :0.0000
## Mean :7.315 Mean :6.903 Mean :5.657 Mean :0.4412
## 3rd Qu.:8.225 3rd Qu.:7.925 3rd Qu.:7.400 3rd Qu.:1.0000
## Max. :9.200 Max. :8.900 Max. :8.900 Max. :1.0000# #Interpretation: Median Wet Traction Performance is 7.75 w/ Median of 7.71 for Noise Level Generated Step 5: Feature selection; correlation analysis, etc.
corr <- rcorr(as.matrix(tir_df))
corr## Wet Noise Buy_Again Purchase
## Wet 1.00 0.76 0.91 0.74
## Noise 0.76 1.00 0.83 0.72
## Buy_Again 0.91 0.83 1.00 0.83
## Purchase 0.74 0.72 0.83 1.00
##
## n= 68
##
##
## P
## Wet Noise Buy_Again Purchase
## Wet 0 0 0
## Noise 0 0 0
## Buy_Again 0 0 0
## Purchase 0 0 0## Wet Noise Buy_Again Purchase
## Wet 1.00 0.76 0.91 0.74
## Noise 0.76 1.00 0.83 0.72
## Buy_Again 0.91 0.83 1.00 0.83
## Purchase 0.74 0.72 0.83 1.00
##
## n= 68
##
##
## P
## Wet Noise Buy_Again Purchase
## Wet 0 0 0
## Noise 0 0 0
## Buy_Again 0 0 0
## Purchase 0 0 0# Interpretation: The predictors involved are significant w/ the target variable. No multicollinearity in this Data.
Step 5: The Logistic Regression Model
model <- glm(Purchase ~ Wet + Noise, data = tir_df, family = binomial)
summary(model)##
## Call:
## glm(formula = Purchase ~ Wet + Noise, family = binomial, data = tir_df)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -39.4982 12.4779 -3.165 0.00155 **
## Wet 3.3745 1.2641 2.670 0.00760 **
## Noise 1.8163 0.8312 2.185 0.02887 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 93.325 on 67 degrees of freedom
## Residual deviance: 27.530 on 65 degrees of freedom
## AIC: 33.53
##
## Number of Fisher Scoring iterations: 8
##
## Call:
## glm(formula = Purchase ~ Wet + Noise, family = binomial, data = tir_df)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -39.4982 12.4779 -3.165 0.00155 **
## Wet 3.3745 1.2641 2.670 0.00760 **
## Noise 1.8163 0.8312 2.185 0.02887 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 93.325 on 67 degrees of freedom
## Residual deviance: 27.530 on 65 degrees of freedom
## AIC: 33.53
##
## Number of Fisher Scoring iterations: 8#InterpretationL The independent variables in the data are all significant, when p < 0.05Question 3: Overall Model Significance
Likelihood Ratio Test
# Fit a null model
null_model <- glm(Purchase ~ 1, data = tir_df, family = binomial)
# Perform a likelihood ratio test
anova(null_model, model, test = "Chisq")## Analysis of Deviance Table
##
## Model 1: Purchase ~ 1
## Model 2: Purchase ~ Wet + Noise
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 67 93.325
## 2 65 27.530 2 65.795 5.162e-15 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1## Analysis of Deviance Table
##
## Model 1: Purchase ~ 1
## Model 2: Purchase ~ Wet + Noise
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 67 93.325
## 2 65 27.530 2 65.795 5.162e-15 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1#Interpretation: As Wet and Noise are predctors in the LR model, it does significantly predict the possibility in favor of the respondents buying the tire again, and that is in comparison to a model that predicts the outcome based off of the null model Pseudo-R-squared
pR2(model)## fitting null model for pseudo-r2## llh llhNull G2 McFadden r2ML r2CU
## -13.7649516 -46.6623284 65.7947536 0.7050093 0.6199946 0.8305269## fitting null model for pseudo-r2
## llh llhNull G2 McFadden r2ML r2CU
## -13.7649516 -46.6623284 65.7947536 0.7050093 0.6199946 0.8305269#Interpretation: We have a McFadden R-squared value of 0.71, which means that the LR model shows that there is a 71% chance of variability in the outcome, in comparison to a model with no predictors. With this value, we can see it is average as values anbove 0.4 show that it is a more promising model.Area Under the Curve (AUC)
roc_curve <- roc(tir_df$Purchase, fitted(model))## Setting levels: control = 0, case = 1## Setting direction: controls < casesplot(roc_curve)
auc(roc_curve)## Area under the curve: 0.9741## Setting levels: control = 0, case = 1
## Setting direction: controls < cases## The area under the curve: 0.9741#Interpretation: The AUC score is 0.97 which means that the LR model has a high level of accurancy in accordance to the prediction of respondant purchasesQuestion 4 & 5: Predicting with New Information
# With the following data below
new_data1 <- data.frame(Wet = 7.0, Noise = 7.0, Buy_Again = 0) # The probability of purchasing tires again
new_data2 <- data.frame(Wet = 8.0, Noise = 8.0, Buy_Again = 1) # Those who definitely purchased tires again
# Predict the probability
# (a) The probability that the Wet and Noise performance ratings are 7
prob1 <- predict (model, newdata = new_data1, type = "response")
round((prob1*100),2)## 1
## 4.06## 1
## 4.06# (b) The probability that the Wet and Noise performance ratings are 8
prob2 <- predict (model, newdata = new_data2, type = "response")
round((prob2*100),2)## 1
## 88.37## 1
## 88.37#Interpretation: For
1.) 88.37% would most like purchase again
2) 4.06 would most likely purchase againQuestion 6: Odds Ratio
#Extraction of the coefficients
coefficients <- summary(model)$coefficients
#Calculate the odd ratio - Noise
odds_ratio_noise <- exp(coefficients["Noise" , "Estimate"])
odds_ratio_noise## [1] 6.148919## [1] 6.148919#Interpretation: The odd ratio is equal to 6.15 which is greater than 1, which means the odd os respondants purchasing again is higher.