# Install libraries if not already installed
#install.packages("readxl")
#install.packages("Hmisc")
#install.packages("pscl")


library(readxl)  # Import Excel files
## Warning: package 'readxl' was built under R version 4.2.3
library(Hmisc)   # Correlation functions
## Warning: package 'Hmisc' was built under R version 4.2.3
## 
## Attaching package: 'Hmisc'
## The following objects are masked from 'package:base':
## 
##     format.pval, units
library(pscl)    # Pseudo R-squared evaluation
## Warning: package 'pscl' was built under R version 4.2.3
## 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)    # ROC Curve and AUC scoring
## Warning: package 'pROC' was built under R version 4.2.3
## Type 'citation("pROC")' for a citation.
## 
## Attaching package: 'pROC'
## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var

Data Import & Cleaning

Data Summary

head(rating_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
summary(rating_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

Wet Average score for tire wet traction performance (1-10)

Noise Average score for tire noise level (1-10)

Purchase Likelihood of buying the tire again (1 = Yes, 0 = No)

Correlation Analysis

corr <- rcorr(as.matrix(rating_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

Logistic Regression

model <- glm(Purchase ~ Wet + Noise, data = rating_df, family = binomial)
summary(model)
## 
## Call:
## glm(formula = Purchase ~ Wet + Noise, family = binomial, data = rating_df)
## 
## Deviance Residuals: 
##      Min        1Q    Median        3Q       Max  
## -1.90595  -0.07829  -0.00213   0.21082   2.25564  
## 
## 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

Conclusion: Both predictors (Wet and Noise) are statistically significant (𝑝<0.05).

Overall Model Significance

# Compare the full model with the null model
null_model <- glm(Purchase ~ 1, data = rating_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

Insight: Including the predictors (Wet and Noise) significantly improves the model’s predictive power.

#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

McFadden R-squared: 0.705 β†’ Explains 71% of variability, indicating a strong model fit.

#ROC Curve & AUC Score

roc_curve <- roc(rating_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

AUC Score:

0.97 β†’ Excellent predictive performance.

data1 <- data.frame(Wet = 8, Noise = 8)
data2 <- data.frame(Wet = 7, Noise = 7)

# Predict probabilities
prob1 <- predict(model, newdata = data1, type = "response")
prob1 * 100  # Probability for Wet = 8, Noise = 8
##        1 
## 88.36964
prob2 <- predict(model, newdata = data2, type = "response")
prob2 * 100  # Probability for Wet = 7, Noise = 7
##        1 
## 4.058753

Prediction Results:

For Wet = 8, Noise = 8: 88.37% likelihood of repurchase

For Wet = 7 , Noise = 7: 4.06% likelihood of repurchase