#** Project Objective
To investigate the relation of tire ratings bewteen wet and noise, and purchase intention.
Question 1 & 2 : Develop the Model & Assess Predictor Significance
Step 1 : Install and load required
if(!require(readxl)) install.packages("readxl")## 載入需要的套件：readxl## Warning: 套件 'readxl' 是用 R 版本 4.4.2 來建造的if(!require(Hmisc)) install.packages("Hmisc")## 載入需要的套件：Hmisc## Warning: 套件 'Hmisc' 是用 R 版本 4.4.2 來建造的##
## 載入套件：'Hmisc'## 下列物件被遮斷自 'package:base':
##
## format.pval, unitsif(!require(pscl)) install.packages("pscl")## 載入需要的套件：pscl## Warning: 套件 'pscl' 是用 R 版本 4.4.2 來建造的## 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.if(!require(pROC)) install.packages("pROC")## 載入需要的套件：pROC## Warning: 套件 'pROC' 是用 R 版本 4.4.2 來建造的## Type 'citation("pROC")' for a citation.##
## 載入套件：'pROC'## 下列物件被遮斷自 'package:stats':
##
## cov, smooth, varlibrary(readxl)
library(Hmisc)
library(pscl)
library(pROC)Step 2 : Import and clean the data
college_df <- read_excel(file.choose())
coll_df <- subset(college_df, select = -c(Tire))Step 3 : Summerize the data
head(coll_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 desciption: A description of the features are presented in the table below.
Variable | Defination
---------------------|------------------------------------
1.Wet | The values for the variable labeled Wet are the average of the ratings for each tire? wet traction performance.
2.Noise | The values for the variable labeled Noise are the average of the ratings for the noise level generated by each tire.
3.Buy-again | The values for the variable labeled Buy Again are the average of the buy-again responses.
summary(coll_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 model Wet is 'r median(tirerating_df$Wet)', with the median of 7.31Step 4 : Feature selection(i.e., correlation analysis)
corr <- rcorr(as.matrix(coll_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 0Step 5 : Build the logistic regression model
model <- glm(Purchase ~ Wet + Noise, data= coll_df, family = binomial)
summary(model)##
## Call:
## glm(formula = Purchase ~ Wet + Noise, family = binomial, data = coll_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 are significant, p-vale<(0.05). Question 3 : Overall model significance
likeihood Ratio Test
null_model <- glm(Purchase ~ 1, data = coll_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 ' ' 1Interpretation:The full model is significantly better than the null model (𝑝<0.05,p<0.05).
This indicates that the predictors Wet and Noise significantly improve the prediction of Purchase.
You conclude that Wet and Noise are important variables for explaining the outcome.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: McFadden R-squared of 0.705 indicates a strong model fit, as values above 0.4 are generally considered good.
#Unlike linear regression's , it does not directly explain variability but compares the model's fit to a null model.
#Here, 0.705 shows significant improvement over a model with no predictors.Area Under the Curve (QUC)
Compute ROC Curve and the AUC score
roc_curve <- roc(coll_df$Purchase, fitted(model))## Setting levels: control = 0, case = 1## Setting direction: controls < casesplot(roc_curve)
auc(roc_curve)## Area under the curve: 0.9741Question 4 & 5 : Predict with new infoemation
# Create new data for predictions
new_data1 <- data.frame(Wet = 8, Noise = 8)
new_data2 <- data.frame(Wet = 7, Noise = 7)
# Predict the probability for the first set of ratings
prob1 <- predict(model, newdata = new_data1, type = "response")
prob1_percentage <- prob1 * 100
# Predict the probability for the second set of ratings
prob2 <- predict(model, newdata = new_data2, type = "response")
prob2_percentage <- prob2 * 100
# Calculate the odds ratio for 'Wet'
coefficients <- summary(model)$coefficients
odds_ratio_Wet <- exp(coefficients["Wet", "Estimate"])
# Output results
cat("Probability for Wet = 8, Noise = 8: ", round(prob1_percentage, 2), "%\n")## Probability for Wet = 8, Noise = 8: 88.37 %cat("Probability for Wet = 7, Noise = 7: ", round(prob2_percentage, 2), "%\n")## Probability for Wet = 7, Noise = 7: 4.06 %cat("Odds ratio for Wet: ", round(odds_ratio_Wet, 2), "\n")## Odds ratio for Wet: 29.21Interpretation: There are 88.37% of 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.
There are 4.06% the probability that a customer will probably or definitely purchase a particular tire again with these performance ratings.Question 6: Odds Ratio
# Extract coefficients
coefficients <- summary(model)$coefficients
# Calculate the odds ratio for 'Wet'
odds_ratio_Wet <- exp(coefficients["Wet", "Estimate"])
# Output the odds ratio
cat("Odds ratio for Wet: ", round(odds_ratio_Wet, 2), "\n")## Odds ratio for Wet: 29.21Interpretation: the odds ratio is > 1.