** Tire Ratings **
##Step 1: Import data and summary data
library(readxl)
library(Hmisc)##
## Attaching package: 'Hmisc'## The following objects are masked from 'package:base':
##
## format.pval, unitslibrary(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, vardf <- read_excel("TireRatings.xlsx")
df## # A tibble: 68 × 5
## Tire Wet Noise Buy_Again Purchase
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 BFGoodrich g-Force Super Sport A/S 8 7.2 6.1 0
## 2 BFGoodrich g-Force Super Sport A/S H&V 8 7.2 6.6 1
## 3 BFGoodrich g-Force T/A KDWS 7.6 7.5 6.9 1
## 4 Bridgestone B381 6.6 5.4 6.6 0
## 5 Bridgestone Insignia SE200 5.8 6.3 4 0
## 6 Bridgestone Insignia SE200-02 6.3 5.7 4.5 0
## 7 Bridgestone Potenza G 019 Grid 7.7 5.2 5 0
## 8 Bridgestone Potenza RE92 5 6.2 2.5 0
## 9 Bridgestone Potenza RE92A 5.6 6.4 2.7 0
## 10 Bridgestone Potenza RE960AS Pole Position 8.8 8.5 8.1 1
## # ℹ 58 more rowshead(df)## # A tibble: 6 × 5
## Tire Wet Noise Buy_Again Purchase
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 BFGoodrich g-Force Super Sport A/S 8 7.2 6.1 0
## 2 BFGoodrich g-Force Super Sport A/S H&V 8 7.2 6.6 1
## 3 BFGoodrich g-Force T/A KDWS 7.6 7.5 6.9 1
## 4 Bridgestone B381 6.6 5.4 6.6 0
## 5 Bridgestone Insignia SE200 5.8 6.3 4 0
## 6 Bridgestone Insignia SE200-02 6.3 5.7 4.5 0summary(df)## Tire Wet Noise Buy_Again
## Length:68 Min. :4.300 Min. :3.600 Min. :1.400
## Class :character 1st Qu.:6.450 1st Qu.:6.000 1st Qu.:3.850
## Mode :character Median :7.750 Median :7.100 Median :6.150
## Mean :7.315 Mean :6.903 Mean :5.657
## 3rd Qu.:8.225 3rd Qu.:7.925 3rd Qu.:7.400
## Max. :9.200 Max. :8.900 Max. :8.900
## Purchase
## Min. :0.0000
## 1st Qu.:0.0000
## Median :0.0000
## Mean :0.4412
## 3rd Qu.:1.0000
## Max. :1.0000coll_df <- subset(df, select = -c(Buy_Again))
coll_df## # A tibble: 68 × 4
## Tire Wet Noise Purchase
## <chr> <dbl> <dbl> <dbl>
## 1 BFGoodrich g-Force Super Sport A/S 8 7.2 0
## 2 BFGoodrich g-Force Super Sport A/S H&V 8 7.2 1
## 3 BFGoodrich g-Force T/A KDWS 7.6 7.5 1
## 4 Bridgestone B381 6.6 5.4 0
## 5 Bridgestone Insignia SE200 5.8 6.3 0
## 6 Bridgestone Insignia SE200-02 6.3 5.7 0
## 7 Bridgestone Potenza G 019 Grid 7.7 5.2 0
## 8 Bridgestone Potenza RE92 5 6.2 0
## 9 Bridgestone Potenza RE92A 5.6 6.4 0
## 10 Bridgestone Potenza RE960AS Pole Position 8.8 8.5 1
## # ℹ 58 more rowshead(coll_df)## # A tibble: 6 × 4
## Tire Wet Noise Purchase
## <chr> <dbl> <dbl> <dbl>
## 1 BFGoodrich g-Force Super Sport A/S 8 7.2 0
## 2 BFGoodrich g-Force Super Sport A/S H&V 8 7.2 1
## 3 BFGoodrich g-Force T/A KDWS 7.6 7.5 1
## 4 Bridgestone B381 6.6 5.4 0
## 5 Bridgestone Insignia SE200 5.8 6.3 0
## 6 Bridgestone Insignia SE200-02 6.3 5.7 0summary(coll_df)## Tire Wet Noise Purchase
## Length:68 Min. :4.300 Min. :3.600 Min. :0.0000
## Class :character 1st Qu.:6.450 1st Qu.:6.000 1st Qu.:0.0000
## Mode :character 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###Step2: Create Model and Null-Model
model <- glm(Purchase ~ Wet + Noise, data = coll_df, family = binomial)
model##
## Call: glm(formula = Purchase ~ Wet + Noise, family = binomial, data = coll_df)
##
## Coefficients:
## (Intercept) Wet Noise
## -39.498 3.374 1.816
##
## Degrees of Freedom: 67 Total (i.e. Null); 65 Residual
## Null Deviance: 93.32
## Residual Deviance: 27.53 AIC: 33.53summary(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: 8null_model <- glm(Purchase ~ 1, data = coll_df, family = binomial)###Step 3: Anova 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 ' ' 1pR2(model)## fitting null model for pseudo-r2## llh llhNull G2 McFadden r2ML r2CU
## -13.7649516 -46.6623284 65.7947536 0.7050093 0.6199946 0.8305269roc_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.9741new_data1 <- data.frame(Wet = 8, Noise = 8, Purchase = 0) #do not purchase again
new_data2 <- data.frame(Wet = 8, Noise = 8, Purchase = 1) #purchase again
new_data3 <- data.frame(Wet = 7, Noise = 7, Purchase = 1)
prob1 <- predict(model, newdata = new_data1, type = "response")
prob1## 1
## 0.8836964prob1 * 100## 1
## 88.36964prob2 <- predict(model, newdata = new_data2, type = "response")
prob2## 1
## 0.8836964prob3 <- predict(model, newdata = new_data3, type = "response")
prob3## 1
## 0.04058753prob3 * 100## 1
## 4.058753