Komitety CD
MŁ
Obróbka danych
żeby zadziałał gradient boosting z gbm
zmienna \(y\) jako zmienna numeryczna, \(X\) jako zmienne czynnikowe (bez wyrzucania stałej kolumny powinno zadziałać)
zmienna \(y\) jako zmienna numeryczna, \(X\) przekodowane na zmienne binarne (funkcja
dummyVarsnie 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 sredniolibrary(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
- zmienna \(y\) jako zmienna numeryczna, \(X\) przekodowane na zmienne binarne, a potem przekształcone na macierz (
xgb.DMatrixlub po prostumatrix,as.matrix)
Dane
Skorzystamy z danych Boston. Zmienna medv to mediana wartości domu i to będziemy modelować w zależności od innych zmiennych (przekodowałam na 1 - drogie domy, 0 - nie). Od razu robię podział na trening i zbiór testowy.
library(MASS)
df <- Boston
df$medv <- ifelse(df$medv < 25, "tani", "drogi")
df$medv <- make.names(df$medv)
df$medv <- factor(df$medv, levels=c("drogi", "tani"))
set.seed(123)
ind.train <- sample(1:nrow(Boston), size=350, replace=FALSE)
ind.test <- setdiff(1:nrow(Boston), ind.train)
df_train <- df[ind.train,]
df_test <- df[ind.test,]
str(df)## 'data.frame': 506 obs. of 14 variables:
## $ crim : num 0.00632 0.02731 0.02729 0.03237 0.06905 ...
## $ zn : num 18 0 0 0 0 0 12.5 12.5 12.5 12.5 ...
## $ indus : num 2.31 7.07 7.07 2.18 2.18 2.18 7.87 7.87 7.87 7.87 ...
## $ chas : int 0 0 0 0 0 0 0 0 0 0 ...
## $ nox : num 0.538 0.469 0.469 0.458 0.458 0.458 0.524 0.524 0.524 0.524 ...
## $ rm : num 6.58 6.42 7.18 7 7.15 ...
## $ age : num 65.2 78.9 61.1 45.8 54.2 58.7 66.6 96.1 100 85.9 ...
## $ dis : num 4.09 4.97 4.97 6.06 6.06 ...
## $ rad : int 1 2 2 3 3 3 5 5 5 5 ...
## $ tax : num 296 242 242 222 222 222 311 311 311 311 ...
## $ ptratio: num 15.3 17.8 17.8 18.7 18.7 18.7 15.2 15.2 15.2 15.2 ...
## $ black : num 397 397 393 395 397 ...
## $ lstat : num 4.98 9.14 4.03 2.94 5.33 ...
## $ medv : Factor w/ 2 levels "drogi","tani": 2 2 1 1 1 1 2 1 2 2 ...Komitety różnych klasyfikatorów
Pakiet caret i caretEnsemble
library(caret)
library(caretEnsemble)Ustawienia opcji:
"repeatedcv"oznacza, że kroswalidacjanumber-krotna zostanie powtórzonarepeatsrazyclassProbsczy prawdopodobieństwo klas ma być liczonesavePredictionsczy wszystkie predykcje mają być zapisywane, czy tylko te dla najlepszego modelusummaryFunction = twoClassSummarypozwoli 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 0dotplot(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.03601885Komitet 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.66169Wyniki:
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