Predicting Tire Purchases

Project Objective

To investigate the relationship between a tire's wet traction performance and noise level generated to whether they would purchase the tire again. 

Develop the Model & Assess Predictor Significance

Install and load required libraries

# install.packages("readxl")
# install.packages("Hmisc")
# install.packages("pscl")
# if(!require(pROC)) install.packages("pROC")

library(readxl)
library(Hmisc)

## 
## Attaching package: 'Hmisc'

## The following objects are masked from 'package:base':
## 
##     format.pval, units

library(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)

## Type 'citation("pROC")' for a citation.

## 
## Attaching package: 'pROC'

## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var

Import and clean the data

tire_df <- read_excel("Class Exercise 15_TireRatings.xlsx")
tir_df <- subset(tire_df, select = -c(Tire))

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

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: The median rating of the tire's wet treaction is 7.8, and median 
rating for the noise rating is 6.9, with 5.7 being the median response of customers 
saying they would buy the tire again.  

Feature Selection (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

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: 8

Interpretation: All the independent variable were significant (p-value < 0.005)

Likelihood Ratio Test

#Overall Model Significance 
null_model <- glm(Purchase ~ 1, data = tir_df,family = binomial)

# Perform 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 traction and Noise level as predictors in our LN model does indeed significantly predict the likelihood of customers choosing to purchase a tire or 
not, relative to a model that predicts purchasing solely on the mean of observed outcomes (null model)

Psuedo 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

Interpretation: A Mcfadden R-squared of 0.705 means that our LR model  explains about 70.5% of of the variability in the outcome relative to a model with no predictors. This is considered a good fit.

Area Under the Curve (AUC)

roc_curve <- roc(tir_df$Purchase, fitted(model))

## Setting levels: control = 0, case = 1

## Setting direction: controls < cases

plot(roc_curve) 

auc(roc_curve) 

## Area under the curve: 0.9741

Interpretation: An AUC score of 0.97 indicates that the LR model has a high leve of accuracy in predicting the purchases of the tires. 

Predicting with New Information

# Predicting new values 
new_data1 <- data.frame(Wet = 7.0, Noise = 7.0, Buy_Again = 1)
new_data2 <- data.frame(Wet = 8.0, Noise = 8.0, Buy_Again = 1)

#Predict Probability Mean Wet traction and Noise equal to 7.0
prob1 <- predict(model, newdata = new_data1, type = "response")
round((prob1 * 100),2)

##    1 
## 4.06

#Predict Probability Mean Wet traction and Noise equal to 8.0
prob2 <- predict(model, newdata = new_data2, type = "response")
round((prob2 * 100),2)

##     1 
## 88.37

Interpretation
(1) There's a 4.06% chance that mean Wet traction and noise Level are equal to 7.0 
and customers will purchase the tire again. 
(2)There's a 88.37% chance that mean Wet traction and noise Level are equal to 8.0 
and customers will purchase the tire again.

Odds Ratio

coef <- summary(model)$coefficients

#Calculate the Odds Ratio for "Wet" and "Noise
odds_ratio_wet <- exp(coef(model)["Wet"])
odds_ratio_noise <- exp(coef(model)["Noise"])

odds_ratio_wet

##      Wet 
## 29.20949

odds_ratio_noise

##    Noise 
## 6.148919

The odd ratio is greater than 1 for both variables which indicates both the both the Wet traction and Noise level are associated with higher odds of customers purchasing the tires than not.