Predicting Respondent Tire Experiences at Tire Rack
Project Objective
To investigate the relationship between long-term tire experiences and purchasing at Tire RackQuestion 1 & 2: Develop The Logistic Regression Model & Assess Predictor Significance
Step 1: Install & load required libraries
# Set CRAN mirror
options(repos = "https://cran.r-project.org/")
# Install required packages
install.packages("Readxl")## Warning: package 'Readxl' is not available for this version of R
##
## A version of this package for your version of R might be available elsewhere,
## see the ideas at
## https://cran.r-project.org/doc/manuals/r-patched/R-admin.html#Installing-packages## Warning: Perhaps you meant 'readxl' ?install.packages("Hmisc")##
## The downloaded binary packages are in
## /var/folders/lm/7q9jv5rx5gz0mnz2f3p9v59c0000gn/T//RtmpQyNooH/downloaded_packagesinstall.packages("pscl")##
## The downloaded binary packages are in
## /var/folders/lm/7q9jv5rx5gz0mnz2f3p9v59c0000gn/T//RtmpQyNooH/downloaded_packagesif(!require(pROC)) install.packages("pROC")## Loading required package: pROC## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, var# Load libraries
library(readxl)
library(Hmisc)##
## Attaching package: 'Hmisc'## The following objects are masked from 'package:base':
##
## format.pval, unitslibrary(pscl)## 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)Step 2: Import & clean the data
#import the data
tire_df <- read_excel("/Users/ethanma/Desktop/R markdown/Class Exercise 15_TireRatings.xlsx")
#drop irrelevant column/clean the data
tir_df <- subset(tire_df, select = -c(Tire))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 0Data Description: A description of the features are presented in the table below.
Variable | Definition
----------- | -------------
1. Wet | Average rating for each tire's wet traction performance
2. Noise | Average rating for the noise level generated by each tire
3. Buy_Again| Average of the buy-again responses
4. Purchase | A respondent buying a tire again (1: yes and 0: no)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.0000Interpretation: The mean wet score is 7.75, the mean noise score is 6.90, and the mean buy again score is 5.66Step 4: Feature Selection (ie: correlation analysis)
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#Interpretation: All the predictors are significant with the target variableStep 5: Build 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: 8Interpretation: All the independent variables were significant (p-value < 0.05)Question 3: Overall Model Significance
Liklihood Ratio Test
#fit a null model
null_model <- glm(Purchase ~ 1, data = tir_df, family = binomial)
#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#Interpretation: The inclusion of Wet and Noise as predictors in our LR model do indeed significantly predict the likelihood of respondents purchasing at Tire Rack, relative to a model that predicts return based solely on the mean observed outcomes (ie: 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.8305269Interpretation: A McFadden R-squared value of 0.705 means that our LR model explains about 70.50% of the variability in the outcome relative to a model with no predictors. This is considered a good fit, where values above 0.2 and 0.4 are often seen as indicative of a useful model.Area Under the Curve (AUC)
The Area Under the Curve (AUC) score represents the ability of the model to correctly classify respondents who will return to Tire Rack and buy again#Area under the curve
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.9741Interpretation: An AUC score of 0.974 indicates that the LR model has a high level of accuracy in predicting respondent purchasing.Question 4 & 5: Predicting with New Information
#Given the new information
new_data1 <- data.frame(Wet = 8, Noise = 8, Buy_Again = 1)
new_data2 <- data.frame(Wet = 7, Noise = 7, Buy_Again = 1)
#predict the probability
prob1 <- predict(model, newdata = new_data1, type = "response")
prob1## 1
## 0.8836964prob2 <- predict(model, newdata = new_data2, type = "response")
prob2## 1
## 0.04058753Interpretation
(1) There is a 88.37% probability that a customer will probably or definitely purchase a particular tire again with a Wet performance rating of 8 and a Noise performance rating of 8.
(2) There is a 4.06% probability that a customer will probably or definitely purchase a particular tire again with a Wet performance rating of 7 and a Noise performance rating of 7.Question 6: Odds Ratio
# Calculate odds ratio for 'Wet' and 'Noise'
odds_ratio_wet <- exp(coef(model)["Wet"])
odds_ratio_noise <- exp(coef(model)["Noise"])
# Print the odds ratios
odds_ratio_wet## Wet
## 29.20949odds_ratio_noise## Noise
## 6.148919Interpretation: The odd ratio is greater than 1 and this indicates that purchasing a new tire is associated with the performance rating of wet tires and the noise performance score of tires.