> library(pacman)
> p_load(dplyr, caret)
集成模型方法：
1、裝袋-使用同一個數(shù)據(jù)集的不同樣本（可通過有放回的抽樣創(chuàng)建）來訓(xùn)練同一個模型的多個版本，然后這些模型會對新的觀測數(shù)據(jù)進(jìn)行投票，并根據(jù)問題的類型作出平均或多數(shù)的決策。
對非線性模型裝袋才有意義，因?yàn)檠b袋過程就是對產(chǎn)生的模型進(jìn)行一次取平均值（線性運(yùn)算）的處理，從而在線性回歸里就不會看到任何改善，因?yàn)闆]有增加模型的表達(dá)力。
ipred包包含了為通過rpart()構(gòu)建的樹構(gòu)建一個裝袋預(yù)測器的工具，可以通過bagging()函數(shù)實(shí)現(xiàn)。
2、增強(qiáng)-訓(xùn)練一序列模型，并給沒有正確分類或遠(yuǎn)離其預(yù)測值的觀測數(shù)據(jù)分配權(quán)重，以便增強(qiáng)后續(xù)訓(xùn)練的模型把它們放在優(yōu)先地位。
增強(qiáng)在默認(rèn)情況下會用到所有的訓(xùn)練數(shù)據(jù)，并在沒有任何懲罰或收縮準(zhǔn)則的情況下逐步嘗試糾正它犯的錯誤（雖然要訓(xùn)練的單個模型本身可以是正則化的），因此，增強(qiáng)有時(shí)候也會過擬合。另外，很多增強(qiáng)算法在分類過程中對產(chǎn)生的假陽性分類誤差和假陰性分類誤差是沒有差別的處理其權(quán)值，即具有一個對稱的損失函數(shù)，也是其局限性。
fastAdaboost包和gbm包可以實(shí)現(xiàn)集成模型中的增強(qiáng)算法。
任務(wù)：分析望遠(yuǎn)鏡照相機(jī)拍下的輻射中出現(xiàn)的模式，預(yù)測某個模式是來源于泄露到大氣中的伽馬射線還是常規(guī)的背景輻射。
1、數(shù)據(jù)準(zhǔn)備
> magic <- readr::read_csv("data_set/magic04.data", col_names = F)
> names(magic) <- c("flength", "fwidth", "fsize", "fconc", "fconc1", "fasym",
+ "fm3long", "fm3trans", "falpha", "fdisk", "class")
>
> str(magic)
## tibble [19,020 × 11] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
## $ flength : num [1:19020] 28.8 31.6 162.1 23.8 75.1 ...
## $ fwidth : num [1:19020] 16 11.72 136.03 9.57 30.92 ...
## $ fsize : num [1:19020] 2.64 2.52 4.06 2.34 3.16 ...
## $ fconc : num [1:19020] 0.3918 0.5303 0.0374 0.6147 0.3168 ...
## $ fconc1 : num [1:19020] 0.1982 0.3773 0.0187 0.3922 0.1832 ...
## $ fasym : num [1:19020] 27.7 26.27 116.74 27.21 -5.53 ...
## $ fm3long : num [1:19020] 22.01 23.82 -64.86 -6.46 28.55 ...
## $ fm3trans: num [1:19020] -8.2 -9.96 -45.22 -7.15 21.84 ...
## $ falpha : num [1:19020] 40.09 6.36 76.96 10.45 4.65 ...
## $ fdisk : num [1:19020] 81.9 205.3 256.8 116.7 356.5 ...
## $ class : chr [1:19020] "g" "g" "g" "g" ...
## - attr(*, "spec")=
## .. cols(
## .. X1 = col_double(),
## .. X2 = col_double(),
## .. X3 = col_double(),
## .. X4 = col_double(),
## .. X5 = col_double(),
## .. X6 = col_double(),
## .. X7 = col_double(),
## .. X8 = col_double(),
## .. X9 = col_double(),
## .. X10 = col_double(),
## .. X11 = col_character()
## .. )
> DataExplorer::profile_missing(magic)
## # A tibble: 11 x 3
## feature num_missing pct_missing
## <fct> <int> <dbl>
## 1 flength 0 0
## 2 fwidth 0 0
## 3 fsize 0 0
## 4 fconc 0 0
## 5 fconc1 0 0
## 6 fasym 0 0
## 7 fm3long 0 0
## 8 fm3trans 0 0
## 9 falpha 0 0
## 10 fdisk 0 0
## 11 class 0 0
不存在缺失值。
> table(magic$class)
##
## g h
## 12332 6688
g表示伽馬射線，h表示背景輻射，重新編碼為1和-1。
> magic$class <- as.factor(ifelse(magic$class == "g", 1, -1))
2、標(biāo)準(zhǔn)化和中心化
> pre <- preProcess(magic[, -11], method = c("center", "scale"))
> magic.new <- predict(pre, magic[, -11]) %>%
+ bind_cols(class = magic$class)
> str(magic.new)
## tibble [19,020 × 11] (S3: tbl_df/tbl/data.frame)
## $ flength : num [1:19020] -0.577 -0.511 2.568 -0.695 0.517 ...
## $ fwidth : num [1:19020] -0.337 -0.57 6.206 -0.687 0.476 ...
## $ fsize : num [1:19020] -0.381 -0.649 2.616 -1.029 0.711 ...
## $ fconc : num [1:19020] 0.0628 0.8204 -1.8758 1.282 -0.3475 ...
## $ fconc1 : num [1:19020] -0.149 1.472 -1.773 1.607 -0.285 ...
## $ fasym : num [1:19020] 0.541 0.5169 2.0449 0.5328 -0.0202 ...
## $ fm3long : num [1:19020] 0.225 0.26 -1.478 -0.334 0.353 ...
## $ fm3trans: num [1:19020] -0.406 -0.49 -2.183 -0.355 1.037 ...
## $ falpha : num [1:19020] 0.477 -0.815 1.889 -0.659 -0.881 ...
## $ fdisk : num [1:19020] -1.498 0.153 0.843 -1.031 2.176 ...
## $ class : Factor w/ 2 levels "-1","1": 2 2 2 2 2 2 2 2 2 2 ...
3、拆分訓(xùn)練集和測試集
> ind <- createDataPartition(magic.new$class, p = 0.8, list = F)
> dtrain <- magic.new[ind, ]
> dtest <- magic.new[-ind, ]
4、邏輯回歸
使用基本的邏輯回歸模型，其結(jié)果作為基準(zhǔn)對比。
> fit.glm <- glm(class ~ ., data = dtrain, family = binomial(link = "logit"))
> hat.train <- ifelse(fit.glm$fitted.values >= 0.5, 1, -1) %>%
+ as.factor()
> hat.test <- predict(fit.glm, newdata = dtest, type = "response")
> hat.test <- ifelse(hat.test >= 0.5, 1, -1) %>%
+ as.factor()
> res <- tibble(model = "glm",
+ train_acc = mean(hat.train == dtrain$class),
+ test_acc = mean(hat.test == dtest$class))
> res
## # A tibble: 1 x 3
## model train_acc test_acc
## <chr> <dbl> <dbl>
## 1 glm 0.789 0.796
5、裝袋算法
> ctrl <- trainControl(method = "cv", number = 3L)
>
> set.seed(123)
> fit.bag <- train(class ~ ., method = "treebag", data = dtrain, trControl = ctrl)
> fit.bag$finalModel
##
## Bagging classification trees with 25 bootstrap replications
> train_acc <- mean(predict(fit.bag, newdata = dtrain, type = "raw") == dtrain$class)
> test_acc <- mean(predict(fit.bag, newdata = dtest, type = "raw") == dtest$class)
> res <- res %>%
+ bind_rows(tibble(model = "bag",
+ train_acc = train_acc,
+ test_acc = test_acc))
> res
## # A tibble: 2 x 3
## model train_acc test_acc
## <chr> <dbl> <dbl>
## 1 glm 0.789 0.796
## 2 bag 0.997 0.879
6、增強(qiáng) - AdaBoost自適應(yīng)增強(qiáng)
> set.seed(123)
> fit.adaboost <- train(class ~ ., method = "adaboost", data = dtrain, trControl = ctrl)
> res <- res %>%
+ bind_rows(tibble(model = "adaboost",
+ train_acc = mean(predict(fit.adaboost, newdata = dtrain,
+ type = "raw") == dtrain$class),
+ test_acc = mean(predict(fit.adaboost, newdata = dtest,
+ type = "raw") == dtest$class)))
> res
## # A tibble: 3 x 3
## model train_acc test_acc
## <chr> <dbl> <dbl>
## 1 glm 0.789 0.796
## 2 bag 0.997 0.879
## 3 adaboost 1 0.888
7、增強(qiáng) - gbm隨機(jī)梯度增強(qiáng)
> set.seed(123)
> fit.gbm <- train(class ~ ., method = "gbm", data = dtrain, trControl = ctrl)
> res <- res %>%
+ bind_rows(tibble(model = "gbm",
+ train_acc = mean(predict(fit.gbm, newdata = dtrain,
+ type = "raw") == dtrain$class),
+ test_acc = mean(predict(fit.gbm, newdata = dtest,
+ type = "raw") == dtest$class)))
> res
## # A tibble: 4 x 3
## model train_acc test_acc
## <chr> <dbl> <dbl>
## 1 glm 0.789 0.796
## 2 bag 0.997 0.879
## 3 adaboost 1 0.888
## 4 gbm 0.876 0.874
8、隨機(jī)森林
隨機(jī)森林是一種基于裝袋決策樹的非常流行和強(qiáng)大的算法。
> set.seed(123)
> fit.rf <- train(class ~ ., method = "rf", data = dtrain, trControl = ctrl)
> res <- res %>%
+ bind_rows(tibble(model = "rf",
+ train_acc = mean(predict(fit.rf, newdata = dtrain,
+ type = "raw") == dtrain$class),
+ test_acc = mean(predict(fit.rf, newdata = dtest,
+ type = "raw") == dtest$class)))
> res
## # A tibble: 5 x 3
## model train_acc test_acc
## <chr> <dbl> <dbl>
## 1 glm 0.789 0.796
## 2 bag 0.997 0.879
## 3 adaboost 1 0.888
## 4 gbm 0.876 0.874
## 5 rf 1 0.885
可以看到，所有集成模型的性能都優(yōu)于單純的邏輯回歸模型。
而本實(shí)例中，隨機(jī)梯度增強(qiáng)模型（gbm）在訓(xùn)練集和測試集上的準(zhǔn)確度最接近，擬合效果較好，所以應(yīng)該選擇使用該模型。
