Question 1 & 2: Model and Predictor Significance
Step 1: Install and load required libraries
# install.packages("readxl")
# install.packages("pscl")
#if(!require(pROC)) install.packages("pROC")
library(readxl) # Allows us to import Excel files
library(pscl) # Pseudo R-squared package
## 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) # AUC and ROC curve package
## Type 'citation("pROC")' for a citation.
##
## Attaching package: 'pROC'
## The following objects are masked from 'package:stats':
##
## cov, smooth, var
library(Hmisc) # Correlation Function
##
## Attaching package: 'Hmisc'
## The following objects are masked from 'package:base':
##
## format.pval, units
Step 2: Import & clean the data
tire_data <- read_excel("TireRatings.xlsx")
tire_df <- tire_data[, c("Wet", "Noise", "Purchase")] # Select relevant columns
Step 3: Summarize the data
head(tire_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 0
Data Description
1. Wet: Average wet traction performance rating (1–10).
2. Noise: Average noise performance rating (1–10).
3. Purchase: Binary variable (1 = Will purchase again, 0 = Won't).
summary(tire_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.0000
Interpretation: The median Wet rating is 7.75, the median Noise rating is 7.1, and most respondents indicated they would not purchase the tire again (median Purchase = 0).
Step 4: Feature selection (correlation analysis)
corr <- rcorr(as.matrix(tire_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 0
Interpretation: All predictors are significant with the target variable (Purchase).
There is no multicollinearity in the data.
Step 5: Build the logistic regression model
model <- glm(Purchase ~ Wet + Noise, data = tire_df, family = binomial)
summary(model)
##
## Call:
## glm(formula = Purchase ~ Wet + Noise, family = binomial, data = tire_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: The model shows that both Wet and Noise ratings significantly increase the likelihood of purchasing a tire again.
Question 3: Overall Model Significance
Likelihood Ratio Test
null_model <- glm(Purchase ~ 1, data = tire_df, family = binomial)
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 model with predictors (Wet and Noise) significantly predicts the likelihood of purchasing again compared to 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
Interpretation: A McFadden R-squared of 0.71 indicates a very good model fit.
Area Under the Curve (AUC)
#Compute ROC Curve and the AUC score
roc_curve <- roc(tire_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 r round(auc(roc_curve), 2) indicates high model accuracy in predicting purchase behavior.
Question 6: Odds Ratio
coefficients <- summary(model)$coefficients
odds_ratio_wet <- exp(coefficients["Wet", "Estimate"])
odds_ratio_noise <- exp(coefficients["Noise", "Estimate"])
odds_ratio_wet
## [1] 29.20949
odds_ratio_noise
## [1] 6.148919
Interpretation: Odds ratios of 29.21 for Wet and 6.15 for Noise indicate the increase in likelihood of purchase per unit increase in Wet and Noise ratings.