suppressPackageStartupMessages(library('ISLR'))
package 㤼㸱ISLR㤼㸲 was built under R version 3.6.3
summary(Default)
 default    student       balance           income     
 No :9667   No :7056   Min.   :   0.0   Min.   :  772  
 Yes: 333   Yes:2944   1st Qu.: 481.7   1st Qu.:21340  
                       Median : 823.6   Median :34553  
                       Mean   : 835.4   Mean   :33517  
                       3rd Qu.:1166.3   3rd Qu.:43808  
                       Max.   :2654.3   Max.   :73554  
attach(Default)

In Chapter 4, we used logistic regression to predict the probability of default using income and balance on the Default data set. We will now estimate the test error of this logistic regression model using the validation set approach. Do not forget to set a random seed before beginning your analysis.

1. Fit a logistic regression model that uses income and balance to predict default.

set.seed(1)
glm.fit = glm(default ~ income + balance, data = Default, family = binomial)

2.Using the validation set approach, estimate the test error of this model. In order to do this, you must perform the following steps:

train = sample(dim(Default)[1], dim(Default)[1]/2) ## i
glm.fit = glm(default ~ income + balance, data = Default, family = binomial, subset = train) ## ii
## iii
glm.pred = rep("No", dim(Default)[1]/2)
glm.probs = predict(glm.fit, Default[-train, ], type = "response")
glm.pred[glm.probs > 0.5] = "Yes"
mean(glm.pred != Default[-train, ]$default) ##iv
[1] 0.0254

I get a test error rate of 0.0254.

3. Repeat the process in (b) three times, using three different splits of the observations into a training set and a validation set. Comment on the results obtained.

train = sample(dim(Default)[1], dim(Default)[1]/2) ## i
glm.fit = glm(default ~ income + balance, data = Default, family = binomial, subset = train) ## ii
## iii
glm.pred = rep("No", dim(Default)[1]/2)
glm.probs = predict(glm.fit, Default[-train, ], type = "response")
glm.pred[glm.probs > 0.5] = "Yes"
mean(glm.pred != Default[-train, ]$default) ##iv
[1] 0.0274
train = sample(dim(Default)[1], dim(Default)[1]/2) ## i
glm.fit = glm(default ~ income + balance, data = Default, family = binomial, subset = train) ## ii
## iii
glm.pred = rep("No", dim(Default)[1]/2)
glm.probs = predict(glm.fit, Default[-train, ], type = "response")
glm.pred[glm.probs > 0.5] = "Yes"
mean(glm.pred != Default[-train, ]$default) ##iv
[1] 0.0244
train = sample(dim(Default)[1], dim(Default)[1]/2) ## i
glm.fit = glm(default ~ income + balance, data = Default, family = binomial, subset = train) ## ii
## iii
glm.pred = rep("No", dim(Default)[1]/2)
glm.probs = predict(glm.fit, Default[-train, ], type = "response")
glm.pred[glm.probs > 0.5] = "Yes"
mean(glm.pred != Default[-train, ]$default) ##iv
[1] 0.0244

Looks like the test error rate hovers around 2.5 percent.

4. Now consider a logistic regression model that predicts the probability of default using income, balance, and a dummy variable for student. Estimate the test error for this model using the validation set approach. Comment on whether or not including a dummy variable for student leads to a reduction in the test error rate.

train = sample(dim(Default)[1], dim(Default)[1]/2)
glm.fit = glm(default ~ income + balance + student, data = Default, family = binomial, 
    subset = train)
glm.pred = rep("No", dim(Default)[1]/2)
glm.probs = predict(glm.fit, Default[-train, ], type = "response")
glm.pred[glm.probs > 0.5] = "Yes"
mean(glm.pred != Default[-train, ]$default)
[1] 0.0278

It doesn’t appear adding the student dummy variable leads to a reduction in the test error rate.

LS0tDQp0aXRsZTogIklTTFIgQ2hhcHRlciA1IFByb2JsZW0gNSINCm91dHB1dDogDQogIGh0bWxfbm90ZWJvb2sNCi0tLQ0KYGBge3J9DQpzdXBwcmVzc1BhY2thZ2VTdGFydHVwTWVzc2FnZXMobGlicmFyeSgnSVNMUicpKQ0Kc3VtbWFyeShEZWZhdWx0KQ0KYXR0YWNoKERlZmF1bHQpDQpgYGANCg0KIyMjIEluIENoYXB0ZXIgNCwgd2UgdXNlZCBsb2dpc3RpYyByZWdyZXNzaW9uIHRvIHByZWRpY3QgdGhlIHByb2JhYmlsaXR5IG9mIGRlZmF1bHQgdXNpbmcgaW5jb21lIGFuZCBiYWxhbmNlIG9uIHRoZSBEZWZhdWx0IGRhdGEgc2V0LiBXZSB3aWxsIG5vdyBlc3RpbWF0ZSB0aGUgdGVzdCBlcnJvciBvZiB0aGlzIGxvZ2lzdGljIHJlZ3Jlc3Npb24gbW9kZWwgdXNpbmcgdGhlIHZhbGlkYXRpb24gc2V0IGFwcHJvYWNoLiBEbyBub3QgZm9yZ2V0IHRvIHNldCBhIHJhbmRvbSBzZWVkIGJlZm9yZSBiZWdpbm5pbmcgeW91ciBhbmFseXNpcy4NCg0KKioxLiBGaXQgYSBsb2dpc3RpYyByZWdyZXNzaW9uIG1vZGVsIHRoYXQgdXNlcyBpbmNvbWUgYW5kIGJhbGFuY2UgdG8gcHJlZGljdCBkZWZhdWx0LioqDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMSkNCmdsbS5maXQgPSBnbG0oZGVmYXVsdCB+IGluY29tZSArIGJhbGFuY2UsIGRhdGEgPSBEZWZhdWx0LCBmYW1pbHkgPSBiaW5vbWlhbCkNCmBgYA0KDQoqKjIuVXNpbmcgdGhlIHZhbGlkYXRpb24gc2V0IGFwcHJvYWNoLCBlc3RpbWF0ZSB0aGUgdGVzdCBlcnJvciBvZiB0aGlzIG1vZGVsLiBJbiBvcmRlciB0byBkbyB0aGlzLCB5b3UgbXVzdCBwZXJmb3JtIHRoZSBmb2xsb3dpbmcgc3RlcHM6KioNCg0KIC0gU3BsaXQgdGhlIHNhbXBsZSBzZXQgaW50byBhIHRyYWluaW5nIHNldCBhbmQgYSB2YWxpZGF0aW9uIHNldC4NCiAtIEZpdCBhIG11bHRpcGxlIGxvZ2lzdGljIHJlZ3Jlc3Npb24gbW9kZWwgdXNpbmcgb25seSB0aGUgdHJhaW5pbmcgb2JzZXJ2YXRpb25zLg0KIC0gT2J0YWluIGEgcHJlZGljdGlvbiBvZiBkZWZhdWx0IHN0YXR1cyBmb3IgZWFjaCBpbmRpdmlkdWFsIGluIHRoZSB2YWxpZGF0aW9uIHNldCBieSBjb21wdXRpbmcgdGhlIHBvc3RlcmlvciBwcm9iYWJpbGl0eSBvZiBkZWZhdWx0IGZvciB0aGF0IGluZGl2aWR1YWwsIGFuZCBjbGFzc2lmeWluZyB0aGUgaW5kaXZpZHVhbCB0byB0aGUgZGVmYXVsdCBjYXRlZ29yeSBpZiB0aGUgcG9zdGVyaW9yIHByb2JhYmlsaXR5IGlzIGdyZWF0ZXIgdGhhbiAwLjUuDQogLSBDb21wdXRlIHRoZSB2YWxpZGF0aW9uIHNldCBlcnJvciwgd2hpY2ggaXMgdGhlIGZyYWN0aW9uIG9mIHRoZSBvYnNlcnZhdGlvbnMgaW4gdGhlIHZhbGlkYXRpb24gc2V0IHRoYXQgYXJlIG1pc2NsYXNzaWZpZWQuDQoNCmBgYHtyfQ0KdHJhaW4gPSBzYW1wbGUoZGltKERlZmF1bHQpWzFdLCBkaW0oRGVmYXVsdClbMV0vMikgIyMgaQ0KZ2xtLmZpdCA9IGdsbShkZWZhdWx0IH4gaW5jb21lICsgYmFsYW5jZSwgZGF0YSA9IERlZmF1bHQsIGZhbWlseSA9IGJpbm9taWFsLCBzdWJzZXQgPSB0cmFpbikgIyMgaWkNCiMjIGlpaQ0KZ2xtLnByZWQgPSByZXAoIk5vIiwgZGltKERlZmF1bHQpWzFdLzIpDQpnbG0ucHJvYnMgPSBwcmVkaWN0KGdsbS5maXQsIERlZmF1bHRbLXRyYWluLCBdLCB0eXBlID0gInJlc3BvbnNlIikNCmdsbS5wcmVkW2dsbS5wcm9icyA+IDAuNV0gPSAiWWVzIg0KbWVhbihnbG0ucHJlZCAhPSBEZWZhdWx0Wy10cmFpbiwgXSRkZWZhdWx0KSAjI2l2DQpgYGANCg0KSSBnZXQgYSB0ZXN0IGVycm9yIHJhdGUgb2YgMC4wMjU0Lg0KDQoqKjMuIFJlcGVhdCB0aGUgcHJvY2VzcyBpbiAoYikgdGhyZWUgdGltZXMsIHVzaW5nIHRocmVlIGRpZmZlcmVudCBzcGxpdHMgb2YgdGhlIG9ic2VydmF0aW9ucyBpbnRvIGEgdHJhaW5pbmcgc2V0IGFuZCBhIHZhbGlkYXRpb24gc2V0LiBDb21tZW50IG9uIHRoZSByZXN1bHRzIG9idGFpbmVkLioqDQoNCmBgYHtyfQ0KdHJhaW4gPSBzYW1wbGUoZGltKERlZmF1bHQpWzFdLCBkaW0oRGVmYXVsdClbMV0vMikgIyMgaQ0KZ2xtLmZpdCA9IGdsbShkZWZhdWx0IH4gaW5jb21lICsgYmFsYW5jZSwgZGF0YSA9IERlZmF1bHQsIGZhbWlseSA9IGJpbm9taWFsLCBzdWJzZXQgPSB0cmFpbikgIyMgaWkNCiMjIGlpaQ0KZ2xtLnByZWQgPSByZXAoIk5vIiwgZGltKERlZmF1bHQpWzFdLzIpDQpnbG0ucHJvYnMgPSBwcmVkaWN0KGdsbS5maXQsIERlZmF1bHRbLXRyYWluLCBdLCB0eXBlID0gInJlc3BvbnNlIikNCmdsbS5wcmVkW2dsbS5wcm9icyA+IDAuNV0gPSAiWWVzIg0KbWVhbihnbG0ucHJlZCAhPSBEZWZhdWx0Wy10cmFpbiwgXSRkZWZhdWx0KSAjI2l2DQpgYGANCg0KYGBge3J9DQp0cmFpbiA9IHNhbXBsZShkaW0oRGVmYXVsdClbMV0sIGRpbShEZWZhdWx0KVsxXS8yKSAjIyBpDQpnbG0uZml0ID0gZ2xtKGRlZmF1bHQgfiBpbmNvbWUgKyBiYWxhbmNlLCBkYXRhID0gRGVmYXVsdCwgZmFtaWx5ID0gYmlub21pYWwsIHN1YnNldCA9IHRyYWluKSAjIyBpaQ0KIyMgaWlpDQpnbG0ucHJlZCA9IHJlcCgiTm8iLCBkaW0oRGVmYXVsdClbMV0vMikNCmdsbS5wcm9icyA9IHByZWRpY3QoZ2xtLmZpdCwgRGVmYXVsdFstdHJhaW4sIF0sIHR5cGUgPSAicmVzcG9uc2UiKQ0KZ2xtLnByZWRbZ2xtLnByb2JzID4gMC41XSA9ICJZZXMiDQptZWFuKGdsbS5wcmVkICE9IERlZmF1bHRbLXRyYWluLCBdJGRlZmF1bHQpICMjaXYNCmBgYA0KDQpgYGB7cn0NCnRyYWluID0gc2FtcGxlKGRpbShEZWZhdWx0KVsxXSwgZGltKERlZmF1bHQpWzFdLzIpICMjIGkNCmdsbS5maXQgPSBnbG0oZGVmYXVsdCB+IGluY29tZSArIGJhbGFuY2UsIGRhdGEgPSBEZWZhdWx0LCBmYW1pbHkgPSBiaW5vbWlhbCwgc3Vic2V0ID0gdHJhaW4pICMjIGlpDQojIyBpaWkNCmdsbS5wcmVkID0gcmVwKCJObyIsIGRpbShEZWZhdWx0KVsxXS8yKQ0KZ2xtLnByb2JzID0gcHJlZGljdChnbG0uZml0LCBEZWZhdWx0Wy10cmFpbiwgXSwgdHlwZSA9ICJyZXNwb25zZSIpDQpnbG0ucHJlZFtnbG0ucHJvYnMgPiAwLjVdID0gIlllcyINCm1lYW4oZ2xtLnByZWQgIT0gRGVmYXVsdFstdHJhaW4sIF0kZGVmYXVsdCkgIyNpdg0KYGBgDQoNCkxvb2tzIGxpa2UgdGhlIHRlc3QgZXJyb3IgcmF0ZSBob3ZlcnMgYXJvdW5kIDIuNSBwZXJjZW50Lg0KDQoqKjQuIE5vdyBjb25zaWRlciBhIGxvZ2lzdGljIHJlZ3Jlc3Npb24gbW9kZWwgdGhhdCBwcmVkaWN0cyB0aGUgcHJvYmFiaWxpdHkgb2YgZGVmYXVsdCB1c2luZyBpbmNvbWUsIGJhbGFuY2UsIGFuZCBhIGR1bW15IHZhcmlhYmxlIGZvciBzdHVkZW50LiBFc3RpbWF0ZSB0aGUgdGVzdCBlcnJvciBmb3IgdGhpcyBtb2RlbCB1c2luZyB0aGUgdmFsaWRhdGlvbiBzZXQgYXBwcm9hY2guIENvbW1lbnQgb24gd2hldGhlciBvciBub3QgaW5jbHVkaW5nIGEgZHVtbXkgdmFyaWFibGUgZm9yIHN0dWRlbnQgbGVhZHMgdG8gYSByZWR1Y3Rpb24gaW4gdGhlIHRlc3QgZXJyb3IgcmF0ZS4qKg0KDQpgYGB7cn0NCnRyYWluID0gc2FtcGxlKGRpbShEZWZhdWx0KVsxXSwgZGltKERlZmF1bHQpWzFdLzIpDQpnbG0uZml0ID0gZ2xtKGRlZmF1bHQgfiBpbmNvbWUgKyBiYWxhbmNlICsgc3R1ZGVudCwgZGF0YSA9IERlZmF1bHQsIGZhbWlseSA9IGJpbm9taWFsLCANCiAgICBzdWJzZXQgPSB0cmFpbikNCmdsbS5wcmVkID0gcmVwKCJObyIsIGRpbShEZWZhdWx0KVsxXS8yKQ0KZ2xtLnByb2JzID0gcHJlZGljdChnbG0uZml0LCBEZWZhdWx0Wy10cmFpbiwgXSwgdHlwZSA9ICJyZXNwb25zZSIpDQpnbG0ucHJlZFtnbG0ucHJvYnMgPiAwLjVdID0gIlllcyINCm1lYW4oZ2xtLnByZWQgIT0gRGVmYXVsdFstdHJhaW4sIF0kZGVmYXVsdCkNCmBgYA0KSXQgZG9lc24ndCBhcHBlYXIgYWRkaW5nIHRoZSBzdHVkZW50IGR1bW15IHZhcmlhYmxlIGxlYWRzIHRvIGEgcmVkdWN0aW9uIGluIHRoZSB0ZXN0IGVycm9yIHJhdGUu