żeby zadziałał gradient boosting z gbm

1. zmienna $y$ jako zmienna numeryczna, $X$ jako zmienne czynnikowe (bez wyrzucania stałej kolumny powinno zadziałać)

2. zmienna $y$ jako zmienna numeryczna, $X$ przekodowane na zmienne binarne (funkcja dummyVars nie przyjmie stałej kolumny)

Przykład jak szybko przekodować (one-hot encoder):

x1 <- factor(c("a", "a", "b", "c", "b"), levels=c("a", "b", "c"))
x2 <- factor(c("dobrze", "dobrze", "srednio", "srednio", "srednio"), levels=c("dobrze", "srednio"))
df <- data.frame(x1, x2)
df

##   x1      x2
## 1  a  dobrze
## 2  a  dobrze
## 3  b srednio
## 4  c srednio
## 5  b srednio

library(caret)
dmy <- dummyVars(" ~ .", data = df)
df_nowe <- data.frame(predict(dmy, newdata = df))
df_nowe

##   x1.a x1.b x1.c x2.dobrze x2.srednio
## 1    1    0    0         1          0
## 2    1    0    0         1          0
## 3    0    1    0         0          1
## 4    0    0    1         0          1
## 5    0    1    0         0          1

żeby zadziałał xgboost

1. zmienna $y$ jako zmienna numeryczna, $X$ przekodowane na zmienne binarne, a potem przekształcone na macierz (xgb.DMatrix lub po prostu matrix, as.matrix)

Pakiet caret i caretEnsemble

library(caret)
library(caretEnsemble)

Ustawienia opcji:

• "repeatedcv" oznacza, że kroswalidacja number-krotna zostanie powtórzona repeats razy
• classProbs czy prawdopodobieństwo klas ma być liczone
• savePredictions czy wszystkie predykcje mają być zapisywane, czy tylko te dla najlepszego modelu
• summaryFunction = twoClassSummary pozwoli jako optymalizowaną miarę zastosować AUC

control <- trainControl(method="repeatedcv", number=5, repeats=5, 
                        classProbs=TRUE, savePredictions='all',
                        summaryFunction = twoClassSummary)

Jakie modele będziemy łączyć:

algorithmList <- c('rpart', 'glm', 'lda')

Budujemy modele wymienione w algorithmList według control, optymalizujemy AUC (metric='ROC'). Dodatkowo wyliczana będzie czułość i specyficzność dla punktu odcięcia 0.5.

set.seed(123)
stack_models <- caretList(medv~., data=df_train, trControl=control, methodList=algorithmList, metric='ROC')

Funkcja resamples pozwala zebrać i podsumować wyniki wszystkich modeli łącznie:

stacking_results <- resamples(stack_models)

Na ile modele są ze sobą skorelowane:

summary(stacking_results)

## 
## Call:
## summary.resamples(object = stacking_results)
## 
## Models: rpart, glm, lda 
## Number of resamples: 25 
## 
## ROC 
##            Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## rpart 0.7532051 0.8002137 0.8872863 0.8632692 0.9086538 0.9476496    0
## glm   0.8792735 0.9273504 0.9433761 0.9421795 0.9615385 0.9882479    0
## lda   0.8579060 0.9081197 0.9326923 0.9261538 0.9497863 0.9764957    0
## 
## Sens 
##            Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## rpart 0.5000000 0.6111111 0.7222222 0.7333333 0.8333333 0.9444444    0
## glm   0.6111111 0.7777778 0.7777778 0.7977778 0.8333333 0.9444444    0
## lda   0.5000000 0.6111111 0.7222222 0.6933333 0.7222222 0.8888889    0
## 
## Spec 
##            Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## rpart 0.8653846 0.9230769 0.9423077 0.9376923 0.9615385 1.0000000    0
## glm   0.8461538 0.9230769 0.9423077 0.9369231 0.9423077 0.9807692    0
## lda   0.9038462 0.9423077 0.9615385 0.9623077 0.9807692 1.0000000    0

dotplot(stacking_results)

Budowa komitetów:

stackControl <- trainControl(method="repeatedcv", number=5, repeats=5, 
                             savePredictions='all', classProbs=TRUE,
                             summaryFunction = twoClassSummary)

Komitet 1 (predykcje modeli połączone modelem liniowym)

model.ensemble <- caretEnsemble(stack_models, trControl=stackControl, metric = "ROC")

plot(model.ensemble)

summary(model.ensemble)

## The following models were ensembled: rpart, glm, lda 
## They were weighted: 
## 3.5438 -1.8746 -3.4883 -1.9204
## The resulting ROC is: 0.9507
## The fit for each individual model on the ROC is: 
##  method       ROC      ROCSD
##   rpart 0.8632692 0.06100930
##     glm 0.9421795 0.02724764
##     lda 0.9261538 0.03601885

Komitet 2 (predykcje modeli połączone gradient boostingiem)

library(gbm)
model.gbm <- caretStack(stack_models, method="gbm", trControl=stackControl, metric = "ROC",  verbose = FALSE)

plot(model.gbm)

summary(model.gbm)

##         var  rel.inf
## glm     glm 54.28523
## lda     lda 27.05308
## rpart rpart 18.66169

Wyniki:

predykcje <- data.frame(predict(stack_models, df_test))
predykcje[,"komitet1"] <- predict(model.ensemble, newdata=df_test, type = "prob")
predykcje[,"komitet2"] <- predict(model.gbm, newdata=df_test, type = "prob")

##       rpart       glm       lda  komitet1  komitet2
## 1 0.9058062 0.9385965 0.9381788 0.9490393 0.9417293