#Tire Survey
##Project Objective
To investigate the the probability that a customer will probably or definitely
purchase a particular tire again depending on the wet tire performance rating
and noise performance rating.Question 1 and 2 : Develop the Model & Asses Predictor Significance
Step 1: Install and load the libraries
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 cakk the pseudo 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 package 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 and clean the data
tires_df <- read_excel("TireRatings.xlsx")
tir_df <- subset(tires_df, select= -(Buy_Again))###Step 3: Summarize the data
head(tir_df)## # A tibble: 6 × 3
## Wet Noise Purchase
## <dbl> <dbl> <dbl>
## 1 8 7.2 0
## 2 8 7.2 1
## 3 7.6 7.5 1
## 4 6.6 5.4 0
## 5 5.8 6.3 0
## 6 6.3 5.7 0Data Description: A description of some of the features are presented in the table below.
Variable | Definition
------------- | -------------
1. Wet | The average of the ratings for each tire’s wet traction performance
2. Noise | the average of the ratings for the noise level generated by each tire
3. Purchase | If the respondent would probably or definitely buy a particular tire again. (1: yes and 0: no)
summary(tir_df)## Wet Noise Purchase
## Min. :4.300 Min. :3.600 Min. :0.0000
## 1st Qu.:6.450 1st Qu.:6.000 1st Qu.:0.0000
## Median :7.750 Median :7.100 Median :0.0000
## Mean :7.315 Mean :6.903 Mean :0.4412
## 3rd Qu.:8.225 3rd Qu.:7.925 3rd Qu.:1.0000
## Max. :9.200 Max. :8.900 Max. :1.0000Interpretation: The median of Wet is 7.75 and the median of Noise is 7.10, with a median of .44, respondents would not likely purchase a particular tire again.Step 4: : Feature selection
corr <- rcorr(as.matrix(tir_df))
corr## Wet Noise Purchase
## Wet 1.00 0.76 0.74
## Noise 0.76 1.00 0.72
## Purchase 0.74 0.72 1.00
##
## n= 68
##
##
## P
## Wet Noise Purchase
## Wet 0 0
## Noise 0 0
## Purchase 0 0Step 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: 8All the independent variables were significant(p-value <0.05)Question 3 : Overall Model Significance
Lilelihood Ratio Test
#fit a null mdoel
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 ' ' 1Interpretation: The inclusion of Wet and Noise as opredictors in our LR model does
indeed significantly predict the likelihood of respondents to purchase tires again relative to a model that predicts purchase based solely on the mean of observed outcomes (i.e., 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 of 0.71 means that our LR model explains about 71.1% of the variability in the outcome relative to a mdoel with no predictors. This is considered a bad fit, where values above 0.2 to 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 purchase a particular tire again and those who will notroc_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.97 indicates that the LR model has a high level of accuracy in predicting particular tire purchases.Question 4 and 5: Predicting with New Information
# Given the new tire information
new_data1 <- data.frame(Wet = 8, Noise = 8)
new_data2 <- data.frame(Wet = 7, Noise = 7)
#Predict the probability
#(a)the 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.
prob1 <- predict(model,new_data1, type= "response")
#(b)the 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.
prob2 <- predict(model, new_data2, type="response")
prob1 * 100## 1
## 88.36964 prob2 * 100## 1
## 4.058753Interpretation
(1) There is a that a 88.37% chance 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 that a 4.06% chance 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.