Uczenie maszynowe w R - zaglądamy do czarnej skrzynki

Opis wydarzenia: Uczenie maszynowe to dziedzina sztucznej inteligencji zajmująca się tworzeniem algorytmów, które potrafią uczyć się ze zbioru danych. W przypadku niektórych algorytmów, szczególnie tych bardziej skomplikowanych, trudno jest zrozumieć, jak dokładnie działają, stąd określenie “czarna skrzynka”. Podczas warsztatów, wykorzystując pakiet R zbudujemy kilka takich czarnych skrzynek, a potem spróbujemy do nich zajrzeć.

Kod

Wykorzystywane biblioteki:

library("DALEX") # pakiet umożliwi analizę czarnych skrzynek
library("rms") # pakiet umożliwi modelowanie zależności krzywoliniowych za pomocą regresji 
library("randomForest") # lasy losowe
library("gbm") # gradient boosting
library("e1071") # support vector machine (maszyna wektorów nośnych)
library("ggplot2") # wykresy i wizualizacja danych
library("RCurl") # ????

Tabela titanic to dane przygotowane przez prof. P. Biecka opisujące pasażerów Titanika.

titanic<-archivist::aread("pbiecek/models/27e5c")

Można zajrzeć, co jest w tych danych stosując np. Hmisc::describe(titanic) lub View(titanic) (w Rstudio).

Model regresji logistycznej:

titanic_lmr <- rms::lrm(survived == "yes" ~ gender + rms::rcs(age) + class +
                     sibsp + parch + fare + embarked, titanic)

Model lasów losowych:

set.seed(1313)
titanic_rf <- randomForest::randomForest(survived ~ class + gender + age + 
                             sibsp + parch + fare + embarked, data = titanic, na.action=na.roughfix)

Model gradient boosting:

set.seed(1313)
titanic_gbm <- gbm::gbm(survived == "yes" ~ class + gender + age + 
                     sibsp + parch + fare + embarked, data = titanic, 
                   n.trees = 15000, distribution = "bernoulli")

Model maszyny wektorów nośnych:

set.seed(1313)
titanic_svm <- e1071::svm(survived == "yes" ~ class + gender + age + 
                     sibsp + parch + fare + embarked, data = titanic, 
                   type = "C-classification", probability = TRUE)

Zapakowanie modeli do podobnych opakowań (explainerów):

titanic_lmr_exp <- explain(model = titanic_lmr, 
                           data = titanic[, -9],
                           y = titanic$survived == "yes", 
                           label = "Logistic Regression",
                           type = "classification")

titanic_rf_exp <- explain(model = titanic_rf, 
                          data = titanic[, -9],
                          y = titanic$survived == "yes", 
                          label = "Random Forest")

titanic_gbm_exp <- explain(model = titanic_gbm, 
                           data = titanic[, -9],
                           y = titanic$survived == "yes", 
                           label = "Generalized Boosted Regression")

titanic_svm_exp <- explain(model = titanic_svm, 
                           data = titanic[, -9],
                           y = titanic$survived == "yes", 
                           label = "Support Vector Machine")

Porównanie siły predykcyjnej modeli:

model_performance(titanic_lmr_exp)$measures$auc

## [1] 0.8174447

model_performance(titanic_rf_exp)$measures$auc

## [1] 0.8636533

model_performance(titanic_gbm_exp)$measures$auc

## [1] 0.8666712

model_performance(titanic_svm_exp)$measures$auc

## [1] 0.8129198

Dwóch przykładowych (fikcyjnych?) pasażerów:

johnny_d<-archivist::aread("pbiecek/models/e3596")
henry<-archivist::aread("pbiecek/models/a6538")
{print(johnny_d)
print(henry)}

##   class gender age sibsp parch fare    embarked
## 1   1st   male   8     0     0   72 Southampton
##   class gender age sibsp parch fare  embarked
## 1   1st   male  47     0     0   25 Cherbourg

Przewidywania modeli dla Johnny’ego:

{print(predict(titanic_lmr_exp, johnny_d))
 print(predict(titanic_rf_exp, johnny_d))
 print(predict(titanic_gbm_exp, johnny_d))
 print(predict(titanic_svm_exp, johnny_d))
  }

##         1 
## 0.7677036 
## [1] 0.422
## [1] 0.6632574
## [1] 0.2218065

… i dla Henry’ego:

{print(predict(titanic_lmr_exp, henry))
 print(predict(titanic_rf_exp, henry))
 print(predict(titanic_gbm_exp, henry))
 print(predict(titanic_svm_exp, henry))
  }

##         1 
## 0.4318245 
## [1] 0.246
## [1] 0.3073358
## [1] 0.1784181

Próba wyjaśnienia, dlaczego model lasów losowych (random forest) dla Johnny’ego podał taką prawdopodobieństwo przeżycia równe 0,422:

bd_rf <- predict_parts(explainer = titanic_rf_exp,
                       new_observation = johnny_d,
                       type = "break_down")
plot(bd_rf)

A gdyby Johnny był starszy albo miał droższy bilet?

cp_titanic_rf <- predict_profile(explainer = titanic_rf_exp, 
                                 new_observation = johnny_d)

library("ggplot2")
plot(cp_titanic_rf, variables = c("age", "fare")) +
  ggtitle("Ceteris-paribus profile", "") + ylim(0, 0.8)

A gdyby był w innej klasie, wsiadł gdzie indziej? A gdyby był dziewczynką?

plot(cp_titanic_rf, variables = c("class", "embarked", "gender"), 
     variable_type = "categorical", categorical_type = "bars") +
  ggtitle("Ceteris-paribus profile", "")

Generalnie, od jakich zmiennych zależy predykcja prawdopodobieństwa:

w modelu regresji liniowej:

vip_lm  <- model_parts(explainer = titanic_rf_exp,  B = 50, N = NULL)
plot(vip_lm)

w modelu random forest:

vip_lm  <- model_parts(explainer = titanic_lmr_exp,  B = 50, N = NULL)
plot(vip_lm)

W jaki sposób średnio przeżywalność zależy wieku?

plot(model_profile(explainer = titanic_rf_exp, variables = "age"), geom="profiles")

W jaki sposób średnio przeżywalność zależy wieku w podziale na płeć?

plot(model_profile(explainer = titanic_rf_exp, variables = "age", groups = "gender"), geom="profiles")