Assignment #6
Briley Winge
Applied
Question 6
In this exercise, you will further analyze the Wage data set considered throughout this chapter.
# install.packages("ISLR2")
# install.packages("caret", dependencies = c("Depends", "Suggests"))
# install.packages("ggplot2")
# install.packages("mgcv")
# install.packages("boot")
library("ISLR2")
library(ggplot2)
library(caret)## Loading required package: latticelibrary(mgcv)## Loading required package: nlme## This is mgcv 1.9-4. For overview type '?mgcv'.library(splines)
library(boot)##
## Attaching package: 'boot'## The following object is masked from 'package:lattice':
##
## melanomaattach(Wage)- Perform polynomial regression to predict wage using age. Use cross-validation to select the optimal degree d for the polynomial. What degree was chosen, and how does this compare to the results of hypothesis testing using ANOVA? Make a plot of the resulting polynomial fit to the data.
set.seed(1)
test_scores <- c()
for (i in 0:10) {
if (i == 0) {
glm.fit <- glm(wage ~ 1, data = Wage)
} else {
glm.fit <- glm(wage ~ poly(age, i, raw = TRUE), data = Wage)
}
cross_validation_error <- cv.glm(Wage, glm.fit, K = 10)
test_scores <- c(test_scores, cross_validation_error$delta[1])
}
min_index <- which.min(test_scores)
min_score <- min_index - 1
min_score## [1] 6From the model we can see that it performs best when the degree of the model is 6.
fit <- lm(wage ~ poly(age, 6, raw = TRUE), data = Wage)
agelims <- range(Wage$age)
age.grid <- seq(from = agelims[1], to = agelims[2])
preds <- predict(fit, newdata = list(age = age.grid),
se = TRUE)
se.bands <- cbind(preds$fit + 2 * preds$se.fit,
preds$fit - 2 * preds$se.fit)
plot(age, wage,
xlim = agelims,
cex = .5,
col = "darkgrey")
title("Degree-6 Ploynomial", outer = T)
lines(age.grid, preds$fit, lwd = 2, col = "blue")
matlines(age.grid, se.bands, lwd = 1, col = "blue", lty = 3)
set.seed(1)
test_models <- list()
for (i in 0:10) {
if (i == 0) {
test_models[[i + 1]] <- lm(wage ~ 1)
} else {
test_models[[i + 1]] <- lm(wage ~ poly(age, degree = i, raw = TRUE))
}
}
do.call(anova, test_models)## Analysis of Variance Table
##
## Model 1: wage ~ 1
## Model 2: wage ~ poly(age, degree = i, raw = TRUE)
## Model 3: wage ~ poly(age, degree = i, raw = TRUE)
## Model 4: wage ~ poly(age, degree = i, raw = TRUE)
## Model 5: wage ~ poly(age, degree = i, raw = TRUE)
## Model 6: wage ~ poly(age, degree = i, raw = TRUE)
## Model 7: wage ~ poly(age, degree = i, raw = TRUE)
## Model 8: wage ~ poly(age, degree = i, raw = TRUE)
## Model 9: wage ~ poly(age, degree = i, raw = TRUE)
## Model 10: wage ~ poly(age, degree = i, raw = TRUE)
## Model 11: wage ~ poly(age, degree = i, raw = TRUE)
## Res.Df RSS Df Sum of Sq F Pr(>F)
## 1 2999 5222086
## 2 2998 5022216 1 199870 125.5934 < 2.2e-16 ***
## 3 2997 4793430 1 228786 143.7638 < 2.2e-16 ***
## 4 2996 4777674 1 15756 9.9005 0.001669 **
## 5 2995 4771604 1 6070 3.8143 0.050909 .
## 6 2994 4770322 1 1283 0.8059 0.369398
## 7 2993 4766389 1 3932 2.4709 0.116074
## 8 2992 4763834 1 2555 1.6057 0.205199
## 9 2991 4763707 1 127 0.0796 0.777865
## 10 2990 4756703 1 7004 4.4014 0.035994 *
## 11 2989 4756701 1 3 0.0017 0.967529
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Based on the ANOVA test, it is determined that we reject the null hypothesis of the simple model being the most sufficient. We also see from the ANOVA test that once the degree is greater then 4 it does not improve the how well the model explains the data.
The two tests do not agree on what polynomial works best.
- Fit a step function to predict wage using age, and perform cross-validation to choose the optimal number of cuts. Make a plot of the fit obtained.
set.seed(1)
step_errors <- c()
step_index = 2:10
for (i in step_index) {
Wage$age_group <- cut(Wage$age, i)
glm.step <- glm(wage ~ age_group, data = Wage)
step_cv <- cv.glm(Wage, glm.step, K = 10)
step_errors <- c(step_errors, step_cv$delta[1])
}
step_min_index <- which.min(step_errors)
step_best <- step_index[step_min_index]
step_best## [1] 8plot(step_index, step_errors,
type = "l",
xlab = "Number of Cuts",
ylab = "Mean Square Error (CV)")
agelims <- range(Wage$age)
age.grid <- seq(from = agelims[1], to = agelims[2])
step_fit <- glm(wage ~ cut(age, step_best), data = Wage)
step_preds <- predict(step_fit, newdata = list(age = age.grid))
plot(wage ~ age,
data = Wage,
col = "darkgrey",
xlab = "Age",
ylab = "Wage")
lines(age.grid, step_preds, col = "blue", lwd = 2)
Question 10
This question relates to the College data set.
attach(College)- Split the data into a training set and a test set. Using out-of-state tuition as the response and the other variables as the predictors, perform forward stepwise selection on the training set in order to identify a satisfactory model that uses just a subset of the predictors.
split = 0.80
trainindex <- createDataPartition(College$Outstate, p = split, list = FALSE)
college_train <- College[ trainindex, ]
college_test <- College[ -trainindex, ]
null_model <- lm(Outstate ~ 1, data = college_train)
full_model <- lm(Outstate ~ ., data = college_train)
stepwise_model <- step(
null_model,
scope = list(lower = null_model, upper = full_model),
direction = "forward"
)## Start: AIC=10346.58
## Outstate ~ 1
##
## Df Sum of Sq RSS AIC
## + Room.Board 1 4500982596 5.6314e+09 9982.6
## + Expend 1 4484691902 5.6477e+09 9984.4
## + Grad.Rate 1 3423541677 6.7088e+09 10091.7
## + perc.alumni 1 3281392537 6.8510e+09 10104.8
## + Top10perc 1 3277904557 6.8545e+09 10105.1
## + Private 1 3107958629 7.0244e+09 10120.3
## + S.F.Ratio 1 3003104933 7.1293e+09 10129.6
## + Top25perc 1 2560513780 7.5719e+09 10167.1
## + Terminal 1 1903422890 8.2289e+09 10218.9
## + PhD 1 1637946195 8.4944e+09 10238.7
## + Personal 1 824994931 9.3074e+09 10295.7
## + P.Undergrad 1 750678368 9.3817e+09 10300.6
## + F.Undergrad 1 388548560 9.7438e+09 10324.2
## + Enroll 1 174676130 9.9577e+09 10337.7
## + Apps 1 66952817 1.0065e+10 10344.4
## <none> 1.0132e+10 10346.6
## + Books 1 23800152 1.0109e+10 10347.1
## + Accept 1 1829 1.0132e+10 10348.6
##
## Step: AIC=9982.64
## Outstate ~ Room.Board
##
## Df Sum of Sq RSS AIC
## + perc.alumni 1 1565248274 4066136523 9781.8
## + Expend 1 1478186999 4153197798 9794.9
## + Private 1 1257921455 4373463342 9827.1
## + Top10perc 1 1154244920 4477139877 9841.7
## + Grad.Rate 1 1086804034 4544580763 9851.1
## + S.F.Ratio 1 1049903243 4581481554 9856.1
## + Top25perc 1 817469299 4813915498 9886.9
## + P.Undergrad 1 588835967 5042548830 9915.8
## + Terminal 1 354976530 5276408267 9944.1
## + PhD 1 305146430 5326238366 9949.9
## + Personal 1 290603186 5340781611 9951.6
## + F.Undergrad 1 273400132 5357984664 9953.6
## + Enroll 1 150945871 5480438926 9967.7
## + Accept 1 56160691 5575224106 9978.4
## + Apps 1 25317435 5606067362 9981.8
## <none> 5631384797 9982.6
## + Books 1 7746381 5623638416 9983.8
##
## Step: AIC=9781.75
## Outstate ~ Room.Board + perc.alumni
##
## Df Sum of Sq RSS AIC
## + Expend 1 776723739 3289412784 9651.7
## + Private 1 518793448 3547343075 9698.7
## + S.F.Ratio 1 413939076 3652197447 9716.9
## + Top10perc 1 402774718 3663361805 9718.8
## + Grad.Rate 1 295813345 3770323178 9736.7
## + Top25perc 1 233609286 3832527237 9746.9
## + P.Undergrad 1 139453973 3926682550 9762.0
## + Terminal 1 128968113 3937168410 9763.7
## + PhD 1 106821740 3959314784 9767.2
## + F.Undergrad 1 59297019 4006839504 9774.6
## + Personal 1 50289001 4015847522 9776.0
## + Enroll 1 26063808 4040072715 9779.7
## <none> 4066136523 9781.8
## + Apps 1 2847895 4063288628 9783.3
## + Accept 1 310027 4065826496 9783.7
## + Books 1 4178 4066132345 9783.7
##
## Step: AIC=9651.68
## Outstate ~ Room.Board + perc.alumni + Expend
##
## Df Sum of Sq RSS AIC
## + Private 1 508157059 2781255725 9549.1
## + Grad.Rate 1 211497509 3077915275 9612.3
## + P.Undergrad 1 148065580 3141347204 9625.0
## + F.Undergrad 1 134434429 3154978355 9627.7
## + Enroll 1 93895484 3195517300 9635.6
## + Personal 1 93865661 3195547123 9635.6
## + S.F.Ratio 1 87928372 3201484412 9636.8
## + Top10perc 1 42758928 3246653856 9645.5
## + Apps 1 40845794 3248566990 9645.9
## + Top25perc 1 31275038 3258137746 9647.7
## + Accept 1 18401965 3271010820 9650.2
## + Terminal 1 14568921 3274843863 9650.9
## <none> 3289412784 9651.7
## + Books 1 7565032 3281847752 9652.2
## + PhD 1 7227290 3282185494 9652.3
##
## Step: AIC=9549.14
## Outstate ~ Room.Board + perc.alumni + Expend + Private
##
## Df Sum of Sq RSS AIC
## + Terminal 1 185973516 2595282209 9508.0
## + PhD 1 163396180 2617859545 9513.4
## + Grad.Rate 1 154146218 2627109508 9515.6
## + Top25perc 1 104705050 2676550675 9527.2
## + Top10perc 1 97176960 2684078765 9529.0
## + Accept 1 71607338 2709648387 9534.9
## + Apps 1 46323955 2734931770 9540.7
## + Personal 1 37028544 2744227181 9542.8
## + Enroll 1 12218698 2769037027 9548.4
## + P.Undergrad 1 9303269 2771952457 9549.1
## <none> 2781255725 9549.1
## + F.Undergrad 1 3977443 2777278282 9550.2
## + S.F.Ratio 1 3976477 2777279248 9550.2
## + Books 1 3768137 2777487589 9550.3
##
## Step: AIC=9508.02
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal
##
## Df Sum of Sq RSS AIC
## + Grad.Rate 1 124732906 2470549304 9479.3
## + Personal 1 46388848 2548893361 9498.8
## + Top10perc 1 43582222 2551699987 9499.5
## + Top25perc 1 39237624 2556044585 9500.5
## + Accept 1 34989251 2560292958 9501.6
## + Apps 1 21645424 2573636785 9504.8
## + P.Undergrad 1 18895760 2576386449 9505.5
## + Books 1 11647447 2583634763 9507.2
## + PhD 1 10656966 2584625244 9507.5
## <none> 2595282209 9508.0
## + S.F.Ratio 1 6497730 2588784479 9508.5
## + Enroll 1 683122 2594599087 9509.9
## + F.Undergrad 1 666522 2594615688 9509.9
##
## Step: AIC=9479.34
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate
##
## Df Sum of Sq RSS AIC
## + Personal 1 32262462 2438286841 9473.1
## + Accept 1 16939569 2453609735 9477.1
## + Top10perc 1 14876347 2455672957 9477.6
## + Books 1 12870082 2457679221 9478.1
## + Top25perc 1 9812369 2460736934 9478.9
## + S.F.Ratio 1 9494946 2461054358 9478.9
## + P.Undergrad 1 8484895 2462064409 9479.2
## <none> 2470549304 9479.3
## + Apps 1 4742575 2465806728 9480.1
## + PhD 1 3679366 2466869938 9480.4
## + F.Undergrad 1 2904382 2467644922 9480.6
## + Enroll 1 316474 2470232830 9481.3
##
## Step: AIC=9473.15
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal
##
## Df Sum of Sq RSS AIC
## + Accept 1 21298456 2416988385 9469.7
## + Top10perc 1 16745710 2421541131 9470.9
## + S.F.Ratio 1 11800863 2426485978 9472.1
## + Top25perc 1 11002188 2427284653 9472.3
## <none> 2438286841 9473.1
## + Apps 1 7477470 2430809371 9473.2
## + Books 1 7389539 2430897302 9473.3
## + PhD 1 4314217 2433972624 9474.0
## + P.Undergrad 1 3522662 2434764180 9474.2
## + F.Undergrad 1 562513 2437724329 9475.0
## + Enroll 1 54247 2438232594 9475.1
##
## Step: AIC=9469.68
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept
##
## Df Sum of Sq RSS AIC
## + Enroll 1 97608997 2319379388 9446.0
## + F.Undergrad 1 81796018 2335192367 9450.2
## + Apps 1 15945393 2401042993 9467.6
## + S.F.Ratio 1 15925943 2401062443 9467.6
## + P.Undergrad 1 14934378 2402054008 9467.8
## + Top10perc 1 13039524 2403948861 9468.3
## + Books 1 8556046 2408432340 9469.5
## <none> 2416988385 9469.7
## + Top25perc 1 7037097 2409951288 9469.9
## + PhD 1 3061740 2413926646 9470.9
##
## Step: AIC=9446
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept + Enroll
##
## Df Sum of Sq RSS AIC
## + Top10perc 1 28941054 2290438334 9440.2
## + Top25perc 1 14766756 2304612633 9444.0
## + S.F.Ratio 1 11192262 2308187126 9445.0
## + Apps 1 8471085 2310908303 9445.7
## <none> 2319379388 9446.0
## + Books 1 6222284 2313157104 9446.3
## + F.Undergrad 1 4449433 2314929955 9446.8
## + P.Undergrad 1 3634538 2315744851 9447.0
## + PhD 1 3605946 2315773442 9447.0
##
## Step: AIC=9440.18
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept + Enroll + Top10perc
##
## Df Sum of Sq RSS AIC
## + Apps 1 25290558 2265147776 9435.3
## + S.F.Ratio 1 10655495 2279782840 9439.3
## + Books 1 9528695 2280909640 9439.6
## <none> 2290438334 9440.2
## + F.Undergrad 1 5152785 2285285550 9440.8
## + P.Undergrad 1 1684081 2288754254 9441.7
## + Top25perc 1 819161 2289619173 9442.0
## + PhD 1 555813 2289882521 9442.0
##
## Step: AIC=9435.26
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept + Enroll + Top10perc + Apps
##
## Df Sum of Sq RSS AIC
## + Books 1 9429279 2255718497 9434.7
## + S.F.Ratio 1 9189109 2255958667 9434.7
## <none> 2265147776 9435.3
## + F.Undergrad 1 2799552 2262348224 9436.5
## + Top25perc 1 1989749 2263158027 9436.7
## + P.Undergrad 1 1540604 2263607173 9436.8
## + PhD 1 280704 2264867072 9437.2
##
## Step: AIC=9434.66
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept + Enroll + Top10perc + Apps +
## Books
##
## Df Sum of Sq RSS AIC
## + S.F.Ratio 1 8498776 2247219721 9434.3
## <none> 2255718497 9434.7
## + F.Undergrad 1 2709964 2253008534 9435.9
## + Top25perc 1 1867651 2253850847 9436.1
## + P.Undergrad 1 1714199 2254004299 9436.2
## + PhD 1 193489 2255525008 9436.6
##
## Step: AIC=9434.31
## Outstate ~ Room.Board + perc.alumni + Expend + Private + Terminal +
## Grad.Rate + Personal + Accept + Enroll + Top10perc + Apps +
## Books + S.F.Ratio
##
## Df Sum of Sq RSS AIC
## <none> 2247219721 9434.3
## + F.Undergrad 1 2287417 2244932305 9435.7
## + Top25perc 1 2012389 2245207332 9435.8
## + P.Undergrad 1 1471815 2245747907 9435.9
## + PhD 1 447175 2246772547 9436.2summary(full_model)##
## Call:
## lm(formula = Outstate ~ ., data = college_train)
##
## Residuals:
## Min 1Q Median 3Q Max
## -6427 -1196 -46 1256 10142
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.622e+03 8.383e+02 -1.935 0.05345 .
## PrivateYes 2.393e+03 2.665e+02 8.979 < 2e-16 ***
## Apps -2.058e-01 8.321e-02 -2.473 0.01367 *
## Accept 8.777e-01 1.502e-01 5.842 8.43e-09 ***
## Enroll -1.262e+00 4.554e-01 -2.772 0.00574 **
## Top10perc 3.105e+01 1.206e+01 2.575 0.01025 *
## Top25perc -6.425e+00 9.547e+00 -0.673 0.50124
## F.Undergrad -3.886e-02 7.132e-02 -0.545 0.58611
## P.Undergrad -3.922e-02 8.519e-02 -0.460 0.64539
## Room.Board 8.859e-01 9.518e-02 9.307 < 2e-16 ***
## Books -8.049e-01 5.299e-01 -1.519 0.12929
## Personal -2.600e-01 1.315e-01 -1.978 0.04838 *
## PhD 3.834e+00 1.023e+01 0.375 0.70793
## Terminal 3.546e+01 1.101e+01 3.222 0.00134 **
## S.F.Ratio -3.977e+01 2.640e+01 -1.506 0.13253
## perc.alumni 4.031e+01 8.414e+00 4.791 2.09e-06 ***
## Expend 1.701e-01 2.357e-02 7.215 1.62e-12 ***
## Grad.Rate 2.500e+01 6.288e+00 3.976 7.85e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1925 on 605 degrees of freedom
## Multiple R-squared: 0.7787, Adjusted R-squared: 0.7725
## F-statistic: 125.2 on 17 and 605 DF, p-value: < 2.2e-16From the forward step selection we see the model should be lm(Outstate ~ PrivateYes + Apps + Accept +Top10perc + Room.Board + Terminal + perc.alumni + Expend + Grad.Rate)
- Fit a GAM on the training data, using out-of-state tuition as the response and the features selected in the previous step as the predictors. Plot the results, and explain your findings.
college_train$PrivateYes <- ifelse(college_train$Private == "Yes", 1, 0)
gam_college <- gam(Outstate ~ PrivateYes + s(Apps, k = 5) + s(Accept, k = 5) + s(Top10perc, k = 5) + s(Room.Board, k = 5) + s(Terminal, k = 5) + s(perc.alumni, k = 5) + s(Expend, k = 5) + s(Grad.Rate, k = 5),
data = college_train)
plot.gam(gam_college, se = TRUE, col = "red")
From the graphs of the GAM, we can see that all variables have a linear
relationship except for Accept and Expend. What this means is that the
effectiveness of Accept and Expend different in the model when they have
certain values.
- Evaluate the model obtained on the test set, and explain the results obtained.
college_test$PrivateYes <- ifelse(college_test$Private == "Yes", 1, 0)
gam_college <- gam(Outstate ~ PrivateYes + s(Apps, k = 5) + s(Accept, k = 5) + s(Top10perc, k = 5) + s(Room.Board, k = 5) + s(Terminal, k = 5) + s(perc.alumni, k = 5) + s(Expend, k = 5) + s(Grad.Rate, k = 5),
data = college_test)
plot.gam(gam_college, se = TRUE, col = "blue")
When the GAM is completed using the test data, the results change. The
GAM models now show that only Room.Board and Terminal have a linear
relationship.
- For which variables, if any, is there evidence of a non-linear relationship with the response?
Based on the models, there is evidence of a non-linear relationship between Accept and Expand in the response variable.