Twoja kolej!
Teraz nadszedł czas na przetestowanie tych metod (regresja grzbietowa i lasso) oraz metod oceny (zestaw walidacyjny, walidacja krzyżowa) na innych zbiorach danych. Możesz pracować z zespołem nad tą częścią laboratorium.
Możesz użyć dowolnego zbioru danych zawartego w ISLR lub wybrać jeden z pakietów danych na Kaggle/Data World itp. (zmienna zależna musi być ciągła).
Pobierz zbiór danych i spróbuj określić optymalny zestaw parametrów, które należy użyć do jego modelowania!
# Wasz kod tutaj
coll=na.omit(College)
head(coll, 20)## Private Apps Accept Enroll Top10perc
## Abilene Christian University Yes 1660 1232 721 23
## Adelphi University Yes 2186 1924 512 16
## Adrian College Yes 1428 1097 336 22
## Agnes Scott College Yes 417 349 137 60
## Alaska Pacific University Yes 193 146 55 16
## Albertson College Yes 587 479 158 38
## Albertus Magnus College Yes 353 340 103 17
## Albion College Yes 1899 1720 489 37
## Albright College Yes 1038 839 227 30
## Alderson-Broaddus College Yes 582 498 172 21
## Alfred University Yes 1732 1425 472 37
## Allegheny College Yes 2652 1900 484 44
## Allentown Coll. of St. Francis de Sales Yes 1179 780 290 38
## Alma College Yes 1267 1080 385 44
## Alverno College Yes 494 313 157 23
## American International College Yes 1420 1093 220 9
## Amherst College Yes 4302 992 418 83
## Anderson University Yes 1216 908 423 19
## Andrews University Yes 1130 704 322 14
## Angelo State University No 3540 2001 1016 24
## Top25perc F.Undergrad P.Undergrad
## Abilene Christian University 52 2885 537
## Adelphi University 29 2683 1227
## Adrian College 50 1036 99
## Agnes Scott College 89 510 63
## Alaska Pacific University 44 249 869
## Albertson College 62 678 41
## Albertus Magnus College 45 416 230
## Albion College 68 1594 32
## Albright College 63 973 306
## Alderson-Broaddus College 44 799 78
## Alfred University 75 1830 110
## Allegheny College 77 1707 44
## Allentown Coll. of St. Francis de Sales 64 1130 638
## Alma College 73 1306 28
## Alverno College 46 1317 1235
## American International College 22 1018 287
## Amherst College 96 1593 5
## Anderson University 40 1819 281
## Andrews University 23 1586 326
## Angelo State University 54 4190 1512
## Outstate Room.Board Books Personal PhD
## Abilene Christian University 7440 3300 450 2200 70
## Adelphi University 12280 6450 750 1500 29
## Adrian College 11250 3750 400 1165 53
## Agnes Scott College 12960 5450 450 875 92
## Alaska Pacific University 7560 4120 800 1500 76
## Albertson College 13500 3335 500 675 67
## Albertus Magnus College 13290 5720 500 1500 90
## Albion College 13868 4826 450 850 89
## Albright College 15595 4400 300 500 79
## Alderson-Broaddus College 10468 3380 660 1800 40
## Alfred University 16548 5406 500 600 82
## Allegheny College 17080 4440 400 600 73
## Allentown Coll. of St. Francis de Sales 9690 4785 600 1000 60
## Alma College 12572 4552 400 400 79
## Alverno College 8352 3640 650 2449 36
## American International College 8700 4780 450 1400 78
## Amherst College 19760 5300 660 1598 93
## Anderson University 10100 3520 550 1100 48
## Andrews University 9996 3090 900 1320 62
## Angelo State University 5130 3592 500 2000 60
## Terminal S.F.Ratio perc.alumni Expend
## Abilene Christian University 78 18.1 12 7041
## Adelphi University 30 12.2 16 10527
## Adrian College 66 12.9 30 8735
## Agnes Scott College 97 7.7 37 19016
## Alaska Pacific University 72 11.9 2 10922
## Albertson College 73 9.4 11 9727
## Albertus Magnus College 93 11.5 26 8861
## Albion College 100 13.7 37 11487
## Albright College 84 11.3 23 11644
## Alderson-Broaddus College 41 11.5 15 8991
## Alfred University 88 11.3 31 10932
## Allegheny College 91 9.9 41 11711
## Allentown Coll. of St. Francis de Sales 84 13.3 21 7940
## Alma College 87 15.3 32 9305
## Alverno College 69 11.1 26 8127
## American International College 84 14.7 19 7355
## Amherst College 98 8.4 63 21424
## Anderson University 61 12.1 14 7994
## Andrews University 66 11.5 18 10908
## Angelo State University 62 23.1 5 4010
## Grad.Rate
## Abilene Christian University 60
## Adelphi University 56
## Adrian College 54
## Agnes Scott College 59
## Alaska Pacific University 15
## Albertson College 55
## Albertus Magnus College 63
## Albion College 73
## Albright College 80
## Alderson-Broaddus College 52
## Alfred University 73
## Allegheny College 76
## Allentown Coll. of St. Francis de Sales 74
## Alma College 68
## Alverno College 55
## American International College 69
## Amherst College 100
## Anderson University 59
## Andrews University 46
## Angelo State University 34Przeprowadzono regresję grzbietową i lasso, aby przewidzieć Grand.Rate na danych College.
- Regresja grzbietowa ze zmienną Grad.Rate jako objaśnianą.
x1 <- model.matrix(Grad.Rate ~ ., coll)[, -1]
y1 <- coll %>%
select(Grad.Rate) %>%
unlist() %>%
as.numeric()Dopasowanie modelu regresji grzbietowej:
grid <- 10^seq(10, -2, length = 100)
library(glmnet)
ridge_mod <- glmnet(x1, y1, alpha = 0, lambda = grid)
plot(ridge_mod)
Współczynniki, gdy λ=11498, wraz z ich normą l2:
ridge_mod$lambda[50] ## [1] 11497.57coef(ridge_mod)[,50] ## (Intercept) PrivateYes Apps Accept Enroll
## 6.524147e+01 1.924300e-02 9.686567e-07 7.024066e-07 -6.112685e-07
## Top10perc Top25perc F.Undergrad P.Undergrad Outstate
## 7.153334e-04 6.143038e-04 -4.144832e-07 -4.310351e-06 3.619870e-06
## Room.Board Books Personal PhD Terminal
## 9.873884e-06 1.194325e-07 -1.014868e-05 4.754458e-04 5.000512e-04
## S.F.Ratio perc.alumni Expend
## -1.970232e-03 1.009748e-03 1.899832e-06sqrt(sum(coef(ridge_mod)[-1,50]^2)) ## [1] 0.01940515Funkcja predict() do uzyskania współczynników regresji grzbietowej dla λ=50:
predict(ridge_mod, s = 50, type = "coefficients")[1:18,]## (Intercept) PrivateYes Apps Accept Enroll
## 4.671830e+01 1.903498e+00 1.234870e-04 1.146584e-04 3.405181e-06
## Top10perc Top25perc F.Undergrad P.Undergrad Outstate
## 6.176559e-02 5.629912e-02 -3.664026e-05 -5.169350e-04 3.385363e-04
## Room.Board Books Personal PhD Terminal
## 9.118980e-04 -5.822815e-04 -1.095459e-03 3.462916e-02 3.067362e-02
## S.F.Ratio perc.alumni Expend
## -1.141984e-01 1.039575e-01 1.091441e-04Następnym krokiem było podzielenie próbek na zbiór treningowy i testowy w celu oszacowania błędu testu regresji grzbietowej i lasso.
set.seed(1)
train <- coll %>%
sample_frac(0.5)
test <- setdiff(coll, train)
x_train <- model.matrix(Grad.Rate ~ ., train)[, -1]
x_test <- model.matrix(Grad.Rate ~ ., test)[, -1]
y_train <- train %>%
select(Grad.Rate) %>%
unlist() %>%
as.numeric()
y_test <- test %>%
select(Grad.Rate) %>%
unlist() %>%
as.numeric()Dopasowano model regresji grzbietowej na zbiorze treningowym, a następnie oceniłem jego średni błąd kwadratowy (MSE) na zbiorze testowym dla wybranej wartości λ.
ridge_model <- glmnet(
x = x_train,
y = y_train,
alpha = 0,
lambda = grid,
thresh = 1e-12
)
ridge_predictions <- predict(
ridge_model,
s = 3,
newx = x_test
)
ridge_mse <- mean((ridge_predictions - y_test)^2)
print(paste("MSE dla lambda = 3:", ridge_mse))## [1] "MSE dla lambda = 3: 167.367026659918"Porównanie MSE dla różnych wartości λ w regresji grzbietowej.
options(digits = 10)
lambdas <- c(0, 2, 3, 4, 10)
mse_results <- sapply(lambdas, function(l) {
predictions <- predict(ridge_model, s = l, newx = x_test)
mean((predictions - y_test)^2)
})
results <- data.frame(Lambda = lambdas, MSE = mse_results)
print(results)## Lambda MSE
## 1 0 168.3202586
## 2 2 166.9836605
## 3 3 167.3670267
## 4 4 167.8002561
## 5 10 170.8162343Najniższe MSE (164.0627) uzyskano dla λ=2. Dla innych wartości λ MSE jest wyższe, co wskazuje na optymalność tej wartości regularizacji w dopasowaniu modelu regresji grzbietowej.
min_mse <- min(results$MSE)
best_lambda <- results$Lambda[which.min(results$MSE)]
print(paste("Najlepsza lambda:", best_lambda))## [1] "Najlepsza lambda: 2"print(paste("Najmniejsze MSE:", min_mse))## [1] "Najmniejsze MSE: 166.983660451605"Szuaknie najlepszej lambdy, wynik jest bliższy do 3, co oznacza że dokonano optymalnego wyboru wartości.
set.seed(125)
cv.out = cv.glmnet(x_train, y_train, alpha = 0)
bestlam2 = cv.out$lambda.min
bestlam2## [1] 2.821480778plot(cv.out)
ridge_predictions_classic <- predict(ridge_model, s = 0, newx = x_test)
classic_mse <- mean((ridge_predictions_classic - y_test)^2)
print(paste("MSE dla modelu klasycznego (lambda = 0):", classic_mse))## [1] "MSE dla modelu klasycznego (lambda = 0): 168.320258619288"print(paste("Porównanie: MSE klasyczne vs najlepsze lambda:", classic_mse, "vs", min_mse))## [1] "Porównanie: MSE klasyczne vs najlepsze lambda: 168.320258619288 vs 166.983660451605"coef_best <- predict(ridge_model, s = best_lambda, type = "coefficients")
print("Współczynniki dla najlepszej lambdy:")## [1] "Współczynniki dla najlepszej lambdy:"print(coef_best)## 18 x 1 sparse Matrix of class "dgCMatrix"
## s1
## (Intercept) 34.9659683153745
## PrivateYes 3.0554970116521
## Apps 0.0003686658602
## Accept 0.0002240157730
## Enroll 0.0015818087842
## Top10perc 0.0922427512477
## Top25perc 0.0968866076751
## F.Undergrad -0.0001354456372
## P.Undergrad -0.0017799453677
## Outstate 0.0007457667977
## Room.Board 0.0018492240553
## Books -0.0030080161805
## Personal -0.0028294216742
## PhD 0.0789861937558
## Terminal -0.0020520817887
## S.F.Ratio 0.0173415148359
## perc.alumni 0.2264772106186
## Expend -0.0002045316898coef_classic <- predict(ridge_model, s = 0, type = "coefficients")
print("Współczynniki dla modelu klasycznego:")## [1] "Współczynniki dla modelu klasycznego:"print(coef_classic)## 18 x 1 sparse Matrix of class "dgCMatrix"
## s1
## (Intercept) 34.3390554500468
## PrivateYes 2.4433687718963
## Apps 0.0010142146035
## Accept -0.0013205299709
## Enroll 0.0076338297890
## Top10perc 0.0395564696241
## Top25perc 0.1223166262183
## F.Undergrad -0.0009717872239
## P.Undergrad -0.0018151895189
## Outstate 0.0009692031122
## Room.Board 0.0019333570528
## Books -0.0026600736164
## Personal -0.0028335583143
## PhD 0.1153062666273
## Terminal -0.0457212411877
## S.F.Ratio 0.0207052181020
## perc.alumni 0.2336039536165
## Expend -0.0003604071364lasso_mod2 = glmnet(x_train,
y_train,
alpha = 1,
lambda = grid)
plot(lasso_mod2) ## Warning in regularize.values(x, y, ties, missing(ties), na.rm = na.rm):
## collapsing to unique 'x' values
set.seed(1)
cv.out2 = cv.glmnet(x_train, y_train, alpha = 1)
plot(cv.out2)
bestlam2 = cv.out2$lambda.min
lasso_pred2 = predict(lasso_mod2, s = bestlam2, newx = x_test)
mean((lasso_pred2 - y_test)^2)## [1] 166.8336411x1 <- model.matrix(Apps ~ ., data = College)[, -1]
y1 <- College$Apps
out2 <- glmnet(
x = x1,
y = y1,
alpha = 1,
lambda = grid
)
cv_out <- cv.glmnet(x1, y1, alpha = 1, lambda = grid)
bestlam <- cv_out$lambda.min
lasso_coef2 <- predict(out2, type = "coefficients", s = bestlam)[1:18, ]
print(lasso_coef2)## (Intercept) PrivateYes Accept Enroll
## -534.58544143071 -475.05987161563 1.52062511659 -0.41038980103
## Top10perc Top25perc F.Undergrad P.Undergrad
## 41.62753673744 -7.92479344585 0.00000000000 0.03965307779
## Outstate Room.Board Books Personal
## -0.07296233753 0.13966824253 0.00000000000 0.01861582813
## PhD Terminal S.F.Ratio perc.alumni
## -7.22837492218 -3.09141097444 10.46744778266 -0.57357971336
## Expend Grad.Rate
## 0.07377378946 6.80832895567lasso_coef2[lasso_coef2 != 0]## (Intercept) PrivateYes Accept Enroll
## -534.58544143071 -475.05987161563 1.52062511659 -0.41038980103
## Top10perc Top25perc P.Undergrad Outstate
## 41.62753673744 -7.92479344585 0.03965307779 -0.07296233753
## Room.Board Personal PhD Terminal
## 0.13966824253 0.01861582813 -7.22837492218 -3.09141097444
## S.F.Ratio perc.alumni Expend Grad.Rate
## 10.46744778266 -0.57357971336 0.07377378946 6.80832895567MSE zbioru testowego jest większe niż MSE modelu regresji grzbietowej, co sugeruje, że Lasso nie dopasowało się lepiej do danych testowych.
Który zbiór danych wybrałeś? Wybrano zbiór danych College z pakietu ISLR. Zostały z niego usunięte brakujące wartości za pomocą funkcji na.omit.
Jaka była Twoja zmienna zależna (tzn. co próbowałeś modelować)? Zmienną zależną była Grad.Rate (wskaźnik ukończenia studiów).
Czy oczekiwałeś, że regresja grzbietowa będzie lepsza od Lasso, czy odwrotnie? Jak wypada w stosunku do OLS? Pokaż odpowiednie raporty, miary dopasowania i krótko je omów (porównaj).
Które predyktory okazały się ważne w ostatecznym modelu (modelach)? Zastosowano regresję grzbietową i Lasso, aby przewidzieć Grad.Rate. Regresja grzbietowa osiągnęła najniższe średnie błędy kwadratowe (MSE) dla optymalnej wartości regularizacji (λ = 2), co wskazuje na jej lepsze dopasowanie w porównaniu do Lasso. W przypadku Lasso błędy testowe były wyższe, co sugeruje, że metoda ta była mniej skuteczna dla tego zestawu danych. Porównując z modelem klasycznym (OLS, λ = 0), regresja grzbietowa dla optymalnej λ dała niższe MSE, co oznacza lepsze uogólnienie na dane testowe. W regresji grzbietowej wszystkie predyktory miały pewien wpływ, ponieważ metoda ta nigdy nie wyzerowuje współczynników. W przypadku Lasso tylko niektóre współczynniki były różne od zera (zostały zachowane). Na przykład, po optymalizacji dla Lasso istotne predyktory obejmowały te o współczynnikach różniących się od zera (widoczne w końcowym wyniku).