Duomenų gavyba
Tautvydas Merkevičius
2022-05-12
Duomenų rinkinio “BANK MARKETING” klasifikavimas
https://archive.ics.uci.edu/ml/datasets/bank+marketing
Reikalingos bibliotekos uždaviniui spręsti:
library(caret)
library(mlr)
library(dplyr)
library(tidyr)
library(readxl)
library(e1071)
library(parallelMap)
library(parallel)
library(rpart.plot)
library(GGally)
library(factoextra)
library(umap)The data is related with direct marketing campaigns of a Portuguese banking institution. The marketing campaigns were based on phone calls. Often, more than one contact to the same client was required, in order to access if the product (bank term deposit) would be (‘yes’) or not (‘no’) subscribed. The classification goal is to predict if the client will subscribe (yes/no) a term deposit (variable y).
Laboratorinio darbo užduotis sukurti klasifikatorių, kuris pagal naudojamus atliktų prognozes. Naudojami 10-hold ir holdout validavimo būdai. Klasifikatoriai turi būti: LDA, QDA, KNN, Sprendimų medis, Logistinė regresija. Reikia rasti kuris klasifikatorius turi didžiausią tikslumą.
Nuskaitykime pirmą duomenų rinkinį ir jį pavadinkime “bankclient”. Duomenų rinkinį sudaro daugiau nei 45 000 eilučių ir 17 atributų. Ištrinamos nežinomos reikšmės, sudaroma duomenų lentelė ir “dplyr” paketo pagalba parenkamos klasifikavimo uždaviniui reikalingos kiekybinių kintamųjų reikšmės.
Būtent šis uždavinys ir yra skirtas prognozuoti, ar klientas banke pasirašys terminuotą sutartį ar ne.
bankclient <- read.csv(file = 'C:/Users/Tautvydas/Desktop/DUOMENŲ GAVYBA/bank/bank-full.csv',
stringsAsFactors = FALSE,
strip.white = TRUE,
sep = ';')
data <- bankclient[complete.cases(bankclient), ] #Deleting NA values
bankdata <- data %>% dplyr::select(age, day, balance, duration, campaign, pdays, previous, y)
bankdata<- as_tibble(bankdata)
bankdata$y<- as.factor(bankdata$y)
str(bankdata)## tibble [45,211 x 8] (S3: tbl_df/tbl/data.frame)
## $ age : int [1:45211] 58 44 33 47 33 35 28 42 58 43 ...
## $ day : int [1:45211] 5 5 5 5 5 5 5 5 5 5 ...
## $ balance : int [1:45211] 2143 29 2 1506 1 231 447 2 121 593 ...
## $ duration: int [1:45211] 261 151 76 92 198 139 217 380 50 55 ...
## $ campaign: int [1:45211] 1 1 1 1 1 1 1 1 1 1 ...
## $ pdays : int [1:45211] -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ...
## $ previous: int [1:45211] 0 0 0 0 0 0 0 0 0 0 ...
## $ y : Factor w/ 2 levels "yes","no": 2 2 2 2 2 2 2 2 2 2 ...- amžius (age)
- paskutinė susisiekimo diena (day)
- sąskaitos likutis (balance)
- paskutinio skambučio trukmė (duration)
- kompanijos kontaktų skaičius (campaign)
- dienų skaičius kurios praėjo nuo paskutinio susisiekimo su klientu iš ankstesnės kompanijos (pdays)
- ankstesnis kliento kontaktų skaičius (previous)
- ar klientas sutartį pasirašo ar ne (y)
Šiek tiek panagrinėkime turimą duomenų rinkinį. Matome, kiekvieno atributo minimalias, makslimalias reikšmes, kvartilius bei mediana. Kaip faktorius klasifikavimo uždaviniui pasirenkamas sutarties pasirašymo kintamasis, kuris gali įgyti taip (yes) – 1, ne (no) – 2.
summary(bankdata)## age day balance duration
## Min. :18.00 Min. : 1.00 Min. : -8019 Min. : 0.0
## 1st Qu.:33.00 1st Qu.: 8.00 1st Qu.: 72 1st Qu.: 103.0
## Median :39.00 Median :16.00 Median : 448 Median : 180.0
## Mean :40.94 Mean :15.81 Mean : 1362 Mean : 258.2
## 3rd Qu.:48.00 3rd Qu.:21.00 3rd Qu.: 1428 3rd Qu.: 319.0
## Max. :95.00 Max. :31.00 Max. :102127 Max. :4918.0
## campaign pdays previous y
## Min. : 1.000 Min. : -1.0 Min. : 0.0000 yes: 5289
## 1st Qu.: 1.000 1st Qu.: -1.0 1st Qu.: 0.0000 no :39922
## Median : 2.000 Median : -1.0 Median : 0.0000
## Mean : 2.764 Mean : 40.2 Mean : 0.5803
## 3rd Qu.: 3.000 3rd Qu.: -1.0 3rd Qu.: 0.0000
## Max. :63.000 Max. :871.0 Max. :275.0000bankUntidy <- gather(bankdata, "Variable", "Value", -y)
ggplot(bankUntidy, aes(y, Value)) +
facet_wrap(~ Variable, scales = "free_y") +
geom_boxplot() +
theme_bw()
Box plot grafikai rodo grafinį skaitinių imties charakteristikų išsidėstymą, kurias galima palyginti. Stačiakampis brėžiamas nuo pirmojo iki trečiojo kvartilio. Stačiakampį į dvi dalis dalija brūkšnys, žymintis medianą. Nuo stačiakampio į viršų ir į apačią brėžiamos dvi tiesių atkarpos: apatinė – iki mažiausios imties reikšmės, o viršutinė – iki didžiausios imties reikšmės. Taip pat galima pastebėti išskirtis.
hist(bankdata$age, freq = FALSE, main = "Normal distribution of age", xlab = "Age")
x <- seq(min(bankdata$age), max(bankdata$age))
f <- dnorm(x, mean = mean(bankdata$age), sd = sd(bankdata$age))
lines(x, f, col = "red", lwd = 1)
Grafike matome, kokio amžiaus klientai vyrauja ir kaip atrodo normaliojo pasiskirstymo kreivė.
ggplot(bankdata, aes(x=as.factor(y) )) +
geom_bar(color="blue", fill=rgb(0.1,0.4,0.5,0.7) )+ ggtitle("y") +
xlab("Class") + ylab("Value")
Šiame grafike atvaizduojama, kiek klientų sutartį yra pasirašė ir kiek ne. Pastebėkime, kad 40 000 klientų sutarties nepasirašę, o pasirašę yra virš 5 000.
ggplot(data = bankdata, aes(x= age, fill=y)) +
geom_bar()
Šiame grafike aiškiai matoma tendencija tarp žmonių amžiaus, kurie terminuotą sutartį pasirašę, o kurie ne. Galima teigti, kad aiškios amžiaus grupės tarp pasirašytų nėra, t.y. amžius įtakos neturi.
ggplot(data = bankdata, aes(x= campaign, fill=y)) +
geom_bar()
Šiame grafike matome, kad kuo mažesnis kompanijos kontaktų skaičius, tuo didesnė tikimybė, kad bus pasirašyta terminuota sutaris.
Tolimesniems skaičiavimams nenaudosime viso duomenų rinkinio dėl per didelio jų dydžio. Naudosime 2000 pirmųjų eilučių. Sukurkime reikalingą modelį apsibrėždami klasifikatorių ir nurodykime mokymosi imtį. Šį kartą padarykime tai naudodami LDA (Linear Discriminant Analysis) ir QDA (Quadratic Discriminant Analysis) modelius.
bankdata <- bankdata[1:2000,]
summary(bankdata)## age day balance duration
## Min. :21.00 Min. :5.000 Min. :-3313.00 Min. : 2.0
## 1st Qu.:33.00 1st Qu.:6.000 1st Qu.: 29.75 1st Qu.: 124.0
## Median :39.00 Median :7.000 Median : 187.00 Median : 197.0
## Mean :40.54 Mean :7.054 Mean : 553.99 Mean : 263.1
## 3rd Qu.:47.00 3rd Qu.:8.000 3rd Qu.: 492.00 3rd Qu.: 310.0
## Max. :61.00 Max. :9.000 Max. :58544.00 Max. :2462.0
## campaign pdays previous y
## Min. :1.000 Min. :-1 Min. :0 yes: 46
## 1st Qu.:1.000 1st Qu.:-1 1st Qu.:0 no :1954
## Median :2.000 Median :-1 Median :0
## Mean :1.879 Mean :-1 Mean :0
## 3rd Qu.:2.000 3rd Qu.:-1 3rd Qu.:0
## Max. :9.000 Max. :-1 Max. :0bankdata <- bankdata %>% dplyr::select(age, day, balance, duration, campaign, y)
# Apibrėžiama klasifikavimo užduotis
bankTask <- makeClassifTask(data = bankdata, target = "y")
# Sukuriami LDA ir QDA klasifikatoriai
lda <- makeLearner("classif.lda")
qda <- makeLearner("classif.qda")
# Apmokomi LDA ir QDA klasifikatoriai
ldaModel <- train(lda, bankTask)
qdaModel <- train(qda, bankTask)Iš LDA modelio išskaičiuokime reikalingą informaciją pasinaudodami funkcija getLearnerModel() ir gaukime duomenų lentelės reikšmes kiekvienu atveju naudojant prognozavimo funkciją. Matome, kad modelis išmoko vieną diskriminantinę funkciją (DF) – LD1. Prognozės funkcija grąžina šios funkcijos reikšmes kiekvienu atveju mūsų turimo “bankdata” duomenų rinkinio.
ldaModelData <- getLearnerModel(ldaModel)
ldaPreds <- predict(ldaModelData)$x
head(ldaPreds)## LD1
## 1 -0.005623502
## 2 0.658536160
## 3 1.039689374
## 4 0.826583114
## 5 0.497906831
## 6 0.738817406LDA ir QDA k-fold validavimas.
Patikrinkime, kaip sudaryti modeliai veikia k-fold metodu:
kFold <- makeResampleDesc(method = "RepCV", folds = 10,
stratify = TRUE)
set.seed(123)
ldaCV <- resample(learner = lda, task = bankTask, resampling = kFold,
measures = list(mmce, acc))
qdaCV <- resample(learner = qda, task = bankTask, resampling = kFold,
measures = list(mmce, acc))Gauti LDA ir QDA modelių tikslumai:
ldaCV$aggr## mmce.test.mean acc.test.mean
## 0.02934908 0.97065092qdaCV$aggr## mmce.test.mean acc.test.mean
## 0.03264262 0.96735738LDA modelis teisingai klasifikavo vidutiniškai 97.07% sutarties pasirašymo prognozės, o QDA modeliui, pavyko teisingai klasifikuoti 96.74%. Išvada, kad LDA klasifikuoja šiek tiek geriau.
Patikrinkime, kaip atrodys klasifikavimo matricos (confusion matrix).
calculateConfusionMatrix(ldaCV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.54/0.40 0.46/0.01 0.46
## no 0.02/0.60 0.98/0.99 0.02
## -err.- 0.60 0.01 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 250 210 210
## no 377 19163 377
## -err.- 377 210 587calculateConfusionMatrix(qdaCV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.47/0.35 0.53/0.01 0.53
## no 0.02/0.65 0.98/0.99 0.02
## -err.- 0.65 0.01 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 215 245 245
## no 408 19132 408
## -err.- 408 245 653LDA klasifikavimo matrica rodo, kad 587 stebiniai iš 20000 klasifikuoti neteisingai, o QDA metodu neteisingai – 653.
Įvertinkime kaip modeliai veiks turint naujus duomenis (klientus).
newclient <- tibble(age = 40, day = 2, balance = 1000, duration = 10, campaign = 3)
predict(ldaModel, newdata = newclient)## Prediction: 1 observations
## predict.type: response
## threshold:
## time: 0.00
## response
## 1 nonewclient <- tibble(age = 40, day = 2, balance = 1000, duration = 10, campaign = 3)
predict(qdaModel, newdata = newclient)## Prediction: 1 observations
## predict.type: response
## threshold:
## time: 0.00
## response
## 1 noModeliai prognozuoja, kad naujas klientas terminuotos sutarties nepasirašys!
LDA ir QDA holdout testas.
Klasifikatoriui taikomas (holdout) padalijimo metodas, kai duomenys dalijami į testavimo ir apmokymo imtis. Mūsų atveju, 2/3 duomenų yra apmokinamos, o 1/3 – testuojamos. Apskaičiuojami tikslumai, atpspausdinamos klasifikavimo matricos:
holdout <- makeResampleDesc(method = "Holdout", split = 2/3,
stratify = TRUE)
set.seed(99)
lda_holdoutCV <- resample(learner = lda, task = bankTask,
resampling = holdout, measures = list(mmce, acc))
qda_holdoutCV <- resample(learner = qda, task = bankTask,
resampling = holdout, measures = list(mmce, acc))lda_holdoutCV$aggr## mmce.test.mean acc.test.mean
## 0.02694611 0.97305389qda_holdoutCV$aggr ## mmce.test.mean acc.test.mean
## 0.02994012 0.97005988calculateConfusionMatrix(lda_holdoutCV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.44/0.44 0.56/0.01 0.56
## no 0.01/0.56 0.99/0.99 0.01
## -err.- 0.56 0.01 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 7 9 9
## no 9 643 9
## -err.- 9 9 18calculateConfusionMatrix(qda_holdoutCV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.44/0.39 0.56/0.01 0.56
## no 0.02/0.61 0.98/0.99 0.02
## -err.- 0.61 0.01 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 7 9 9
## no 11 641 11
## -err.- 11 9 20Matome, kad LDA modelis klasifikuoja geriau (97.31%), kai QDA klasifikuoja 97.01%
Pastebime, kad LDA neteisingai klasifikuoja testavimo imtyje tik 18 stebinius iš 668. Klaidinai “no” priskyrė 9 kartą. QDA kladingai klasifikavo 20 kartų.
LDA ir QDA LOO validavimas.
LOO <- makeResampleDesc(method = "LOO")
bankTask <- makeClassifTask(data = bankdata, target = "y")
ldaModel <- train(lda, bankTask)
set.seed(99)
ldaLOO <- resample(learner = lda, task = bankTask, resampling = LOO,
measures = list(mmce, acc))
qdaModel <- train(qda, bankTask)
set.seed(99)
qdaLOO <- resample(learner = qda, task = bankTask, resampling = LOO,
measures = list(mmce, acc))Gauti tikslumai:
ldaLOO$aggr## mmce.test.mean acc.test.mean
## 0.0295 0.9705qdaLOO$aggr## mmce.test.mean acc.test.mean
## 0.0325 0.9675Taigi, matome, kad naudojant LOO testą, gauname, kad LDA tikslumas 97.05%, o QDA – 96.75%
KNN klasifikatorius
Tai mašininio mokymosi su mokytoju klasifikacija, kai objektas klasifikuojamas pagal daugumos jo kaimynų balsą, o objektas priskiriamas labiausiai paplitusiai k klasei. Jei k=1, tai objektas paprasčiausiai priskiriamas to vienintelio artimiausio kaimyno klasei. Jis naudojamas ne tik klasifikavime, bet ir regresijose.
Reikia rasti, optimalią k reikšmę, pasitelkiant holdout validavimu. Tikrinamos reikšmės yra nuo 1 iki 10.
knnParamSpace <- makeParamSet(makeDiscreteParam("k", values = 1:10))
gridSearch <- makeTuneControlGrid()
set.seed(99)
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
tunedKCV <- tuneParams("classif.knn", task = bankTask, resampling = holdout, par.set = knnParamSpace, control = gridSearch)
knnTuningData <- generateHyperParsEffectData(tunedKCV)plotHyperParsEffect(knnTuningData, x = "k", y = "mmce.test.mean", plot.type = "line") + theme_bw()
tunedKCV## Tune result:
## Op. pars: k=6
## mmce.test.mean=0.0209581Taikant holdout testą optimali parametro k reikšmė yra 6, neteisingai klasifikuojama tik 2.1% objektų. Patikrinkime, koks k yra optimaliausias kfold metodui.
knnParamSpace <- makeParamSet(makeDiscreteParam("k", values = 1:10))
gridSearch <- makeTuneControlGrid()
set.seed(10)
kfold <- makeResampleDesc(method = "RepCV", folds = 10)
tunedKCV1 <- tuneParams("classif.knn", task = bankTask, resampling = kfold, par.set = knnParamSpace, control = gridSearch)
knnTuningData <- generateHyperParsEffectData(tunedKCV1)plotHyperParsEffect(knnTuningData, x = "k", y = "mmce.test.mean", plot.type = "line") + theme_bw()
tunedKCV1## Tune result:
## Op. pars: k=10
## mmce.test.mean=0.0254500Gauname, kad optimaliausias k=10, kai naudojamas kfold metodas su neteisingai klasifikuojamų 2.5% reikšmių.
KNN validavimas holdout testu.
Klasifikatoriui taikomas (holdout) padalijimo metodas, kai duomenys dalijami į testavimo ir apmokymo imtis. Mūsų atveju, 2/3 duomenų yra apmokinamos, o 1/3 – testuojamos. Apskaičiuojami tikslumai, atpspausdinamos klasifikavimo matricos:
knn <- makeLearner("classif.knn", par.vals = list("k" = 3))
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
set.seed(123)
lda_holdoutCV <- resample(learner = knn, task = bankTask,
resampling = holdout, measures = list(mmce, acc))## Resampling: holdout## Measures: mmce acc## [Resample] iter 1: 0.0299401 0.9700599## ## Aggregated Result: mmce.test.mean=0.0299401,acc.test.mean=0.9700599## calculateConfusionMatrix(lda_holdoutCV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.125/0.25 0.875/0.02 0.875
## no 0.009/0.75 0.991/0.98 0.009
## -err.- 0.75 0.02 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 2 14 14
## no 6 646 6
## -err.- 6 14 20Klasifikavimo matrica rodo, kad neteisingai klasifikuojami 20 stebiniai iš 668. Iš jų visi “YES”. Gautas modelio tikslumas 97.01%
KNN validavimas k-fold testu.
knn <- makeLearner("classif.knn", par.vals = list("k" = 5))
kFold <- makeResampleDesc(method = "CV", iters = 10,
stratify = TRUE)
set.seed(123)
kFoldCV <- resample(learner = knn, task = bankTask,
resampling = kFold, measures = list(mmce, acc))kFoldCV$aggr## mmce.test.mean acc.test.mean
## 0.02750028 0.97249972Gautas modelio tikslumas, kai naudojamas k-fold testas: 97.25%
KNN validavimas LOO metodu.
LOO <- makeResampleDesc(method = "LOO")
set.seed(99)
kLOO <- resample(learner = knn, task = bankTask,
resampling = LOO, measures = list(mmce, acc))Gautas tikslumas:
kLOO$aggr## mmce.test.mean acc.test.mean
## 0.026 0.974Tikslumas siekia 98.2%
SVM
SVM – support vector machine, tai mašininio mokymosi su mokytoju algoritmas, naudojamas klasifikavimo uždaviniams spręsti. Jo tikslas yra rasti maksimalią skiriamąją liniją arba skiriamąją plokštumą, kuri turėtų didžiausią atstumą tarp artimiausių mokymo duomenų objektų. Šiam duomenų rinkiniui bus pritaikyta tiesinis ir netiesinis SVM klasifikatorius.
Tiesinis SVM holdout testas.
Duomenys dalinami į testavimo 2/3 ir apmokymo 1/3 imtis.
banktTask <- makeClassifTask(data = bankdata, target = "y")
SVM <- makeLearner("classif.svm", par.vals = list(kernel='linear', cost = 10), scale = FALSE)
SVMModel <- train(SVM, banktTask)
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
set.seed(123)
holdout_SVM_CV <- resample(learner = SVM, task = bankTask, resampling = holdout, measures = list(mmce, acc))holdout_SVM_CV$aggr## mmce.test.mean acc.test.mean
## 0.02994012 0.97005988calculateConfusionMatrix(holdout_SVM_CV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.25/0.33 0.75/0.02 0.75
## no 0.01/0.67 0.99/0.98 0.01
## -err.- 0.67 0.02 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 4 12 12
## no 8 644 8
## -err.- 8 12 20Matome, kad tiesinis SVM metodas su holdout validation 2/3 teisingai klasifikuoja su tikslumu 97.06% Modelis nesuklasifikuoja teisingai 20 kartus iš 668.
Tiesinis SVM k-fold validavimas.
Taip pat darbe patikrinta kaip SVM klasifikatorius veikia taikant k-fold cross validation, kai k=10.
kFold <- makeResampleDesc(method = "RepCV", folds = 10, stratify = TRUE)
set.seed(123)
kfold_SVM_CV <- resample(learner = SVM, task = bankTask, resampling = kFold)Klasifikavimo matrica ir modelio tikslumas:
1- kfold_SVM_CV$aggr## mmce.test.mean
## 0.6597759calculateConfusionMatrix(kfold_SVM_CV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.42/0.03 0.58/0.02 0.58
## no 0.33/0.97 0.67/0.98 0.33
## -err.- 0.97 0.02 0.34
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 192 268 268
## no 6536 13004 6536
## -err.- 6536 268 6804Taigi, matome, kad tiesinis SVM k-fold metodu klasifikuoja su tikslumu 65.98%, kai neteisingai klasifikuojami 6804.
Netiesinis SVM
Netiesiniui SVM klasifikatoriui reikia nustatyti optimalius parametrus: kernel, degree, cost, gamma.
kernels <- c("polynomial", "radial", "sigmoid")
svmParamSpace <- makeParamSet(
makeDiscreteParam("kernel", values = kernels),
makeIntegerParam("degree", lower = 1, upper = 3),
makeNumericParam("cost", lower = 0.1, upper = 10),
makeNumericParam("gamma", lower = 0.1, 10))
bankTask <- makeClassifTask(data = bankdata, target = "y")
set.seed(99)
randSearch <- makeTuneControlRandom(maxit = 20)
cvForTuning <- makeResampleDesc("Holdout", split = 2/3)
parallelStartSocket(cpus = detectCores())
set.seed(99)
tunedSvmPars <- tuneParams("classif.svm", task = bankTask,
resampling = cvForTuning,
par.set = svmParamSpace,
control = randSearch)
parallelStop()Gauname optimalius netiesinio SVM klasifikatoriaus parametus:
tunedSvmPars## Tune result:
## Op. pars: kernel=polynomial; degree=1; cost=3.74; gamma=2.27
## mmce.test.mean=0.0269865Toliau klasifikatorius yra sukuriamas ir apmokinamas, pasinaudojant optimalius parametrus:
tunedSvm <- setHyperPars(makeLearner("classif.svm"),
par.vals = tunedSvmPars$x)
tunedSvmModel <- train(tunedSvm, bankTask)Netiesinio SVM holdout testas.
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
set.seed(99)
holdout_SVM_CV <- resample(learner = tunedSvm, task = bankTask, resampling = holdout, measures = list(mmce, acc))Tikslumas ir klasifikavimo matrica:
holdout_SVM_CV$aggr## mmce.test.mean acc.test.mean
## 0.0239521 0.9760479calculateConfusionMatrix(holdout_SVM_CV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.00/0.00 1.00/0.02 1.00
## no 0.00/0.00 1.00/0.98 0.00
## -err.- 0.00 0.02 0.02
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 0 16 16
## no 0 652 0
## -err.- 0 16 16Gauname, kad tikslumas 97.60%, kai neteisingai klasifikuojama tik 16 stebiniai iš 668.
Netiesinio SVM k-fold validavimas.
kFold <- makeResampleDesc(method = "RepCV", folds = 10, stratify = TRUE)
set.seed(99)
kfold_SVM_CV <- resample(learner = tunedSvm, task = bankTask, resampling = kFold)Tikslumas ir klasifikavimo matrica:
1 - kfold_SVM_CV$aggr## mmce.test.mean
## 0.9770048calculateConfusionMatrix(kfold_SVM_CV$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.00/0.00 1.00/0.02 1.00
## no 0.00/0.00 1.00/0.98 0.00
## -err.- 0.00 0.02 0.02
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 0 460 460
## no 0 19540 0
## -err.- 0 460 460Gauname, kad tikslumas sieka 97.70%, kai neteisingai klasifikuojami 460 iš 20000 kartų.
Sprendimų medis
Sprendimų medis - mašininio mokymosi su mokytoju algoritmas, kai sprendimų medosi naudojamas kaip prognozavimo modelis. Medį sudaro sprendimų mazgai ir lapai. Lapai yra sprendimai kurie vaizduoja klases, o sprendimų mazgai atsiranda ten, kur duomenys yra padalijami. Medžio generavimas gali būti apribojamas nustatant stabdymo kriterijus.
Kuriamas sprendimų medžio klasifikavimo uždavinys:
tree <- makeLearner("classif.rpart")Parenkami optimalus parametrai:
treeParamSpace <- makeParamSet(
makeIntegerParam("minsplit", lower = 5, upper = 20),
makeIntegerParam("minbucket", lower = 3, upper = 10),
makeNumericParam("cp", lower = 0.01, upper = 0.1),
makeIntegerParam("maxdepth", lower = 3, upper = 10))
randSearch <- makeTuneControlRandom(maxit = 200)
cvForTuning <- makeResampleDesc("CV", iters = 5)
set.seed(99)
parallelStartSocket(cpus = detectCores())Apmokomos klasifikatorius su pasirinktais optimaliais parametrais:
tunedTreePars <- tuneParams(tree, task = bankTask,
resampling = cvForTuning,
par.set = treeParamSpace,
control = randSearch)## [Tune] Started tuning learner classif.rpart for parameter set:## Type len Def Constr Req Tunable Trafo
## minsplit integer - - 5 to 20 - TRUE -
## minbucket integer - - 3 to 10 - TRUE -
## cp numeric - - 0.01 to 0.1 - TRUE -
## maxdepth integer - - 3 to 10 - TRUE -## With control class: TuneControlRandom## Imputation value: 1## Exporting objects to slaves for mode socket: .mlr.slave.options## Mapping in parallel: mode = socket; level = mlr.tuneParams; cpus = 4; elements = 200.## [Tune] Result: minsplit=8; minbucket=8; cp=0.089; maxdepth=10 : mmce.test.mean=0.0230000parallelStop()## Stopped parallelization. All cleaned up.tunedTree <- setHyperPars(tree, par.vals = tunedTreePars$x)
tunedTreeModel <- train(tunedTree, bankTask)
treeModelData <- getLearnerModel(tunedTreeModel)Sprendimų medis holdout testu.
Sprendimų medis validuojamas pasinaudojant holdout testą, kai testavimo imtis sudaro 1/3, o apmokinama 2/3.
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
set.seed(99)
treeWrapper <- makeTuneWrapper("classif.rpart", resampling = cvForTuning,
par.set = treeParamSpace,
control = randSearch)
parallelStartSocket(cpus = detectCores())
set.seed(99)
cvWithTuning <- resample(treeWrapper, bankTask, resampling = holdout, measures = list(mmce, acc))
parallelStop()Gauname klasifikavimo matrica ir modelio tikslumą:
cvWithTuning$aggr## mmce.test.mean acc.test.mean
## 0.02694611 0.97305389calculateConfusionMatrix(cvWithTuning$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.188/0.38 0.812/0.02 0.812
## no 0.008/0.62 0.992/0.98 0.008
## -err.- 0.62 0.02 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 3 13 13
## no 5 647 5
## -err.- 5 13 18Gauname, kad tikslumas siekia 97.31%, kai neteisingai klasifikuojama 18 kartų. ### Sprendimų medis k-fold metodu. Sprendimų medžiui vykdomas cross validation, kai k=10.
kfold <- makeResampleDesc(method = "CV", iter=10)
set.seed(99)
treeWrapper <- makeTuneWrapper("classif.rpart", resampling = cvForTuning,
par.set = treeParamSpace,
control = randSearch)
parallelStartSocket(cpus = detectCores())## Starting parallelization in mode=socket with cpus=4.set.seed(99)
cvWithTuning <- resample(treeWrapper, bankTask, resampling = kfold)## Exporting objects to slaves for mode socket: .mlr.slave.options## Resampling: cross-validation## Measures: mmce## Mapping in parallel: mode = socket; level = mlr.resample; cpus = 4; elements = 10.## ## Aggregated Result: mmce.test.mean=0.0230000## parallelStop()## Stopped parallelization. All cleaned up.Gautas modelio tikslumas ir klasifikavimo matrica:
1-cvWithTuning$aggr## mmce.test.mean
## 0.977calculateConfusionMatrix(cvWithTuning$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.00/0.00 1.00/0.02 1.00
## no 0.00/0.00 1.00/0.98 0.00
## -err.- 0.00 0.02 0.02
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 0 46 46
## no 0 1954 0
## -err.- 0 46 46Tikslumas 97.70%
Logistinė regresija
Logistinis modelis yra statistinis modelis, modeliuojantis vieno įvykio tikimybę. Tai mašininio mokymosi su mokytoju algoritmas, kuris leidžia klasifikuoti naujus duomenis apskaičiuojant kiekvienai klaisei priklausančių duomenų tikimybes. Regresinėje analizėje logistinė regresija yra logistinio modelio parametrų įvertinimas.
Logistinė regresija holdout testas.
logReg <- makeLearner("classif.logreg", predict.type = "prob")
logRegModel <- train(logReg, bankTask)
logRegWrapper <- makeImputeWrapper("classif.logreg")
holdout <- makeResampleDesc(method = "Holdout", split = 2/3, stratify = TRUE)
set.seed(99)
logRegwithImpute <- resample(logRegWrapper, bankTask,
resampling = holdout,
measures = list(acc, fpr, fnr))## Resampling: holdout## Measures: acc fpr fnr## [Resample] iter 1: 0.9745509 0.0030675 0.9375000## ## Aggregated Result: acc.test.mean=0.9745509,fpr.test.mean=0.0030675,fnr.test.mean=0.9375000## Gautas tikslumas ir klasifikavimo matrica:
logRegwithImpute$aggr## acc.test.mean fpr.test.mean fnr.test.mean
## 0.974550898 0.003067485 0.937500000calculateConfusionMatrix(logRegwithImpute$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.062/0.33 0.938/0.02 0.938
## no 0.003/0.67 0.997/0.98 0.003
## -err.- 0.67 0.02 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 1 15 15
## no 2 650 2
## -err.- 2 15 17Matome, kad tikslumas siekia 97.46% kai klaidingai klasifikuojami 17 stebinių.
Logistinė regresija k-fold validavimas.
kFold <- makeResampleDesc(method = "CV", iters = 10)
set.seed(99)
logRegwithImpute <- resample(logRegWrapper, bankTask,
resampling = kFold,
measures = list(acc, fpr, fnr))## Resampling: cross-validation## Measures: acc fpr fnr## [Resample] iter 1: 0.9650000 0.0153846 0.8000000## [Resample] iter 2: 0.9800000 0.0000000 0.8000000## [Resample] iter 3: 0.9550000 0.0000000 1.0000000## [Resample] iter 4: 0.9900000 0.0050761 0.3333333## [Resample] iter 5: 0.9950000 0.0000000 1.0000000## [Resample] iter 6: 0.9800000 0.0050761 1.0000000## [Resample] iter 7: 0.9650000 0.0153061 1.0000000## [Resample] iter 8: 0.9850000 0.0000000 0.6000000## [Resample] iter 9: 0.9550000 0.0156250 0.7500000## [Resample] iter 10: 0.9700000 0.0152284 1.0000000## ## Aggregated Result: acc.test.mean=0.9740000,fpr.test.mean=0.0071696,fnr.test.mean=0.8283333## Gautas tikslumas ir klasifikavimo matrica:
logRegwithImpute$aggr## acc.test.mean fpr.test.mean fnr.test.mean
## 0.974000000 0.007169645 0.828333333calculateConfusionMatrix(logRegwithImpute$pred, relative = TRUE)## Relative confusion matrix (normalized by row/column):
## predicted
## true yes no -err.-
## yes 0.174/0.36 0.826/0.02 0.826
## no 0.007/0.64 0.993/0.98 0.007
## -err.- 0.64 0.02 0.03
##
##
## Absolute confusion matrix:
## predicted
## true yes no -err.-
## yes 8 38 38
## no 14 1940 14
## -err.- 14 38 52Taigi, matome, kad tikslumas siekia 97.4%, kai neteisingai klasifikuojami 25 stebiniai.
Logistinė regresija LOO validavimas.
LOO <- makeResampleDesc(method = "LOO")
set.seed(123)
logRegwithImpute <- resample(logRegWrapper, bankTask,
resampling = LOO,
measures = list(acc))Gautas tikslumas:
logRegwithImpute$aggr## acc.test.mean
## 0.9745Tikslumas siekia 97.45%
PCA
PCA – tiesinis dimensijų mažinimo metodas, kuris randa naujas ašis, kurios maksimaliai padidina duomenų dispersiją. Pagrindinių komponenčių analizėje tikrinės reikšmės nusako pagrindinių komponenčių dispersiją, o tikriniai vektoriai - pagrindinių ašių kryptį (rotaciją).
Nubraižomas kiekybinių kintamųjų grafikas ir tikrinama tiesinė priklausomybė tarp kintamųjų, kur mėlyna spalva žymimama kintamojo y reikšmė “no”, o raudona – “yes”.
ggpairs(bankdata, mapping = aes(col = y)) +
theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Kiekybiniams duomenims randamos pagrindinės komponentės ir išvedami rezultatai. Funkcija prcomp grąžina pagrindinių komponenčių standartinius nuokrypius, taip pat, rotacijos matricą, kurios stulpeliai yra gautos pagrindinės komponentės, arba duomenų kovariacijų matricos tikriniai vektoriai.
pca <- dplyr::select(bankdata, -y) %>%
prcomp(center = TRUE, scale = TRUE)
pca## Standard deviations (1, .., p=5):
## [1] 1.1434086 1.0334591 1.0103791 0.9617547 0.8238575
##
## Rotation (n x k) = (5 x 5):
## PC1 PC2 PC3 PC4 PC5
## age -0.64318251 0.23882273 -0.33217826 -0.07110664 0.64333615
## day 0.70949673 -0.07328534 -0.08613673 0.02706089 0.69504807
## balance -0.09035267 -0.58849430 -0.49094040 0.63358273 -0.05532912
## duration -0.10728031 -0.70587526 -0.03968428 -0.69668791 0.05729019
## campaign 0.25151139 0.30497138 -0.79977544 -0.32773531 -0.31093937bankpca <- bankdata[,6] %>%
mutate(PCA1 = pca$x[, 1], PCA2 = pca$x[, 2], PCA3 = pca$x[, 3], PCA4 = pca$x[, 4], PCA5 = pca$x[, 5] )
bankpca$y<-as.factor(bankpca$y)
bankpca## # A tibble: 2,000 x 6
## y PCA1 PCA2 PCA3 PCA4 PCA5
## <fct> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 no -2.54 -0.119 -0.283 0.572 0.397
## 2 no -1.41 0.436 0.753 0.332 -0.559
## 3 no -0.603 0.367 1.17 0.618 -1.35
## 4 no -1.66 0.255 0.298 0.932 -0.401
## 5 no -0.656 0.0227 1.15 0.278 -1.32
## 6 no -0.782 0.176 1.03 0.498 -1.20
## 7 no -0.331 -0.291 1.22 0.402 -1.68
## 8 no -1.37 -0.256 0.796 -0.300 -0.646
## 9 no -2.36 1.06 0.237 0.533 0.403
## 10 no -1.33 0.518 0.669 0.782 -0.666
## # ... with 1,990 more rowsKomponentės atvaizduojamos sklaidos diagrama:
ggpairs(bankpca, aes(col=y), upper=list(continuous = "density") ) + theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Grafikai:
pcaDat <- get_pca(pca)
fviz_pca_biplot(pca, label = "var")
fviz_pca_var(pca)
fviz_screeplot(pca, addlabels = TRUE, choice = "eigenvalue")
fviz_screeplot(pca, addlabels = TRUE, choice = "variance")
Iš šio grafiko matyti, kad pirmosios dvi komponentės paaiškina 47% duomenų (beveik pusę duomenų) ### UMAP Tai yra netiesinis dimensijų sumažinimo algoritmas, kuris naudojamas daugiamačių duomenų vizualizavimui ir matmenų mažinimui.
bankumap <- dplyr::select(bankdata, -y) %>%
as.matrix() %>%
umap(n_neighbors = 10, min_dist = 0.1,
metric = "manhattan", n_epochs = 200, verbose = TRUE)## [2022-05-23 00:53:40] starting umap## [2022-05-23 00:53:40] creating graph of nearest neighbors## [2022-05-23 00:53:43] creating initial embedding## [2022-05-23 00:53:44] optimizing embedding## [2022-05-23 00:53:49] done banktibumap <- bankdata %>%
mutate_if(.funs = scale, .predicate = is.numeric, scale = FALSE) %>%
mutate(UMAP1 = bankumap$layout[, 1], UMAP2 = bankumap$layout[, 2]) %>%
gather(key = "Variable", value = "Value", c(-UMAP1, -UMAP2, -y))
ggplot(banktibumap, aes(UMAP1, UMAP2, col = y)) +
geom_point() +
theme_bw()
Rezultatai ir išvados
| k-fold validation | holdout validation | LOO validation | |
|---|---|---|---|
| LDA | 97.07% | 97.31% | 97.05% |
| QDA | 96.74% | 97.01% | 96.75% |
| KNN | 97.25% | 97.01% | 97.40% |
| Linear SVN | 65.98% | 97.06% | - |
| Nonlinear SVN | 97.70% | 97.60% | - |
| Sprendimų medis | 97.70% | 97.31% | - |
| Logistinė regresija | 97.40% | 97.46% | 97.45% |
- Didžiausias tikslumas gaunamas naudojant netiesinę SVM ir sprendimų medį pasinaudojant k-fold validavimu: 97.70%, antroje vietoje netiesinė SVM holdout validavimu su tikslumu 97.60%
- Prasčiausiai klasifikuoja tiesinis SVM k-fold validavimu su tikslumu 65.98%
- PCA rodo, kad pirmosios dvi komponentės paaiškina daugiau nei pusę (daugiau nei 50%) visų duomenų.
- Dimensijų mažinimui tinkamiausia yra pagrindinių komponenčių analizė, kai galima matyti skirtingų klasių atsiskyrimą.