In ACCCertDS/ACC: Base accident
knitr::opts_chunk$set(
fig.dpi = 96,
fig.height = 3.5,
fig.width = 7,
collapse = TRUE,
comment = "#>"
)
Dans ce document on se propose de modéliser la variable grav afin de prévoir
si un accident aura entraîné des blessures (ou le décès) ou non.
Nous chargeons les packages R nécessaires à cette étude.
library(tidyverse)
library(rsample)
library(doParallel) # pour paralléliser
library(caret)
library(glmnet)
library(skimr)
library(plotROC) # Pour la courbe ROC et l'AUC
library(ACC)
Création de l'indicatrice accident avec blessures (yc décès) oui/non
data(population, package = "ACC")
data(accidents, package = "ACC")
accidents = mutate_pour_modele(accidents, population)
accidents <- accidents %>%
mutate(Y = factor(ifelse(
grav == "Indemne","Indemne",
"Blessures"))) %>%
select(-Num_Acc,-grav) %>%
select(Y, everything()) %>%
mutate_if(is.character, factor)
skim(accidents)
Compte tenu de la taille (r nrow(accidents) observations) de nos données et des
capacités limitées de nos machines, nous sommes contraints de faire cette
modélisation sur un échantillon de nos données.
set.seed(123)
data <- sample_frac(accidents, size = .20, replace = FALSE)
Afin de s'assurer qu'on n'a pas introduit un trop grand biais dans les données,
on vérifie que les proportions de la variable d'intérêt $Y$ n'est pas très différent
entre l'échantillon ci-dessus et les données initiales.
prop.table(summary(accidents$Y))
prop.table(summary(data$Y))
On introduit les fonctions suivantes pour mesurer l'erreur de prévision de nos
modèles ultérieurement.
criteres_erreur_classif <- data.frame(Methode_abrev=character(),
Methode=character(),
Error=double(),
Sensitivity=double(),
Precision=double(),
Accuracy=double(),
Specificity=double(),
F1=double(),
AUC=double())
eval_prev_classif <- function(prev_proba, real, methode_abrev,methode){
prev <- (prev_proba>0.5)*1
cm <- table(real,prev)
print("Confusion matrix :")
print(cm)
assign(paste("cm",methode_abrev,sep="_"),cm,envir=.GlobalEnv)
cm_norm <- round(100*cm/sum(cm),digits=1)
print("Confusion matrix (%) :")
print(cm_norm)
assign(paste("cm_norm",methode_abrev,sep="_"),cm_norm,envir=.GlobalEnv)
tp <- cm[2,2]
fp <- cm[1,2]
tn <- cm[1,1]
fn <- cm[2,1]
error <- (fp+fn)/(tp+tn+fp+fn)
print(paste("Classification error : ",round(error,digits=3),sep=""))
sensitivity <- tp/(tp+fn)
print(paste("Sensitivity : ",round(sensitivity,digits=3),sep=""))
precision <- tp/(tp+fp)
print(paste("Precision : ",round(precision,digits=3),sep=""))
accuracy <- (tp+tn)/(tp+tn+fp+fn)
print(paste("Accuracy : ",round(accuracy,digits=3),sep=""))
specificity <- tn/(tn+fp)
print(paste("Specificity : ",round(specificity,digits=3),sep=""))
F1 <- 2*precision*sensitivity/(precision+sensitivity)
print(paste("F1 : ",round(F1,digits=3),sep=""))
if (is.factor(real)==TRUE){
df <- data.frame(prev_proba=prev_proba,
real=as.numeric(real)-1)
}
else{
df <- data.frame(prev_proba=prev_proba,
real=real)
}
graph <- ggplot(df,aes(d=real,m=prev_proba))+
geom_roc(labels=FALSE)
AUC <- round(calc_auc(graph)$AUC,digits=2)
print(paste("AUC : ",round(AUC,digits=3),sep=""))
tab <- get("criteres_erreur_classif",envir=globalenv())
tab <- rbind(tab,data.frame(Methode_abrev=methode_abrev,
Methode=methode,
Error=error,
Sensitivity=sensitivity,
Precision=precision,
Accuracy=accuracy,
Specificity=specificity,
F1=F1,
AUC=AUC))
assign("criteres_erreur_classif",tab,envir=.GlobalEnv)
graph+
style_roc(theme=theme_grey)+
annotate("text",x=0.75,y=0.25,label=paste("AUC=",AUC))+
labs(title="Courbe ROC")
}
On sépare d'abord nos données pour garder un échantillon de test sur lequel
appliquer le modèle finalement sélectionné. Et on évaluera nos modèles
par une méthode de validation croisée en 4 blocs.
set.seed(123)
split <- rsample::initial_split(data, prop = 3/4, strata = Y)
don_apprentissage <- rsample::training(split)
don_test <- rsample::testing(split)
nb = 4
blocs = sample(rep(1:nb, length=nrow(don_apprentissage)), replace = FALSE)
La fonction ci-après sera exécutée pour chacun des 4 blocs et permet d'ajuster
plusieurs modèles aux données.
Pour des raisons de temps de calcul nous sommes contraints de ne pas exécuter
les modèles SVM.
predict_cv <- function(bloc_ecart) {
## Pour calcul parallèle des paramètres
cl <- makePSOCKcluster(detectCores()-1L)
registerDoParallel(cl)
## Données
train <- don_apprentissage[blocs != bloc_ecart,]
test <- don_apprentissage[blocs == bloc_ecart,]
#matrices pour glmnet
train_matx <- donX[blocs != bloc_ecart,]
train_y <- donY[blocs != bloc_ecart]
test_matx <- donX[blocs == bloc_ecart,]
set.seed(123)
## Modèles
mod_lin <- train(fml , data=train, method="glm", trControl=controle, family = "binomial")
mod_ridge <- cv.glmnet(x= train_matx, y = train_y, alpha = 0, parallel = T, family = "binomial")
mod_lasso <- cv.glmnet(x= train_matx, y = train_y, alpha = 1, parallel = T, family = "binomial")
mod_elnet <- cv.glmnet(x= train_matx, y = train_y, alpha = 0.5, parallel = T, family = "binomial")
mod_rf <- train(fml ,data=train,method="ranger",trControl=controle, tuneGrid=rf_grid)
mod_Adaboost <- train(fml, data = train, method="gbm",distribution="adaboost", tuneGrid = boosting_grille, trControl=controle, verbose=FALSE)
mod_Logitboost <- train(fml, data = train, method="LogitBoost", trControl=controle, verbose=FALSE)
# mod_svm <- train(fml, data = train, method="svmLinear", tuneGrid = svr_C_Grid, trControl=controle)
# mod_svm_poly_d2 <- train(fml, data = train, method="svmPoly", tuneGrid = svr_poly_grid, trControl=controle)
mod_nnet <- train(fml, data = train, method="nnet", trControl=controle, verbose = FALSE)
stopCluster(cl)
## Previsions
tibble( Y = test$Y,
reg_lin = predict(mod_lin, test, type = "prob")[,2],
ridge = predict(mod_ridge, test_matx, type ="response", s="lambda.1se")[,1],
lasso = predict(mod_lasso, test_matx, type ="response", s="lambda.1se")[,1],
elnet = predict(mod_elnet, test_matx, type ="response", s="lambda.1se")[,1],
rf = predict(mod_rf, test, type ="prob")[,2],
adaboost = predict(mod_Adaboost, test, type ="prob")[,2],
logitboost = predict(mod_Logitboost, test, type ="prob")[,2],
# svm = predict(mod_svm, test, type ="prob")[,2],
# svm_poly_d2 = predict(mod_svm_poly_d2, test, type ="prob")[,2],
neuralnet = predict(mod_nnet, test, type ="prob")[,2]
)
}
# Paramètres pour caret
controle <- trainControl(method="cv",number=4, allowParallel = TRUE, classProbs=TRUE, verboseIter = T)
## Grilles de recherches d'hyper paramètres
rf_grid <- expand.grid(mtry=seq.int(1,ncol(don_apprentissage)-1, length.out = 5), splitrule = "gini", min.node.size=1L)
# svr_C_Grid <- expand.grid(C = seq(0.001, 2, length = 10))
# svr_poly_grid <- expand.grid(C = seq(0.001, 2, length = 10), degree =2, scale = 1)
boosting_grille <- expand.grid(n.trees = seq(1,25,5)*50, shrinkage = c(0.0001,0.001,0.01,0.1,1), n.minobsinnode = 10, interaction.depth = 2)
Dans un premier temps nous allons modéliser selon la formule suivante
fml <- as.formula("Y ~ .")
## Données format matrice pour glmnet
donX <- model.matrix(fml,data=don_apprentissage)[,-1]
donY <- don_apprentissage$Y
Les résultats de la validation croisée en 4 blocs sont les suivants :
resultats = map_dfr(1:nb,predict_cv)
data("envir_modeles_2021-03-16", package="ACC")
resultats
La fonction introduite précédemment predict_cv ajuste les types de modèles
suivants :
- régression logistique
- régression logistique ridge
- régression logistique lasso
- régression logistique elastic net
- forêt aléatoire
- gradient boosting méthode Adaboost
- gradient boosting méthode Logitboost
- réseau de neurones.
Comparons les résultats de ces différentes méthodes
eval_prev_classif(prev=resultats$reg_lin, real=resultats$Y, methode="Régression linéaire", methode_abrev="lm")
eval_prev_classif(prev=resultats$ridge, real=resultats$Y, methode="Régression pénalisée : Ridge", methode_abrev="ridge")
eval_prev_classif(prev=resultats$lasso, real=resultats$Y, methode="Régression pénalisée : Lasso", methode_abrev="lasso")
eval_prev_classif(prev=resultats$elnet, real=resultats$Y, methode="Régression pénalisée : Elastic-net", methode_abrev="elnet")
eval_prev_classif(prev=resultats$rf, real=resultats$Y, methode="Random Forest", methode_abrev="RF")
eval_prev_classif(prev=resultats$adaboost, real=resultats$Y, methode="Gradient boosting : adaboost", methode_abrev="gbm_ada")
eval_prev_classif(prev=resultats$logitboost, real=resultats$Y, methode="Gradient boosting : logitboost", methode_abrev="gbm_logit")
eval_prev_classif(prev=resultats$neuralnet, real=resultats$Y, methode="Réseau de neurones : nnet", methode_abrev="nnet")
criteres_erreur_classif
criteres_erreur_classif_plot <- criteres_erreur_classif
error_min <- min(criteres_erreur_classif_plot$Error)
error_min
error_max <- max(criteres_erreur_classif_plot$Error)
error_max
On peut également représenter graphiquement ces résultats en regroupant toutes
les courbes ROC sur un même graphique :
resultats %>%
gather(methode, prev_proba, -Y) %>%
ggplot(aes(d=Y, m=prev_proba, color = methode)) +
geom_roc(labels = FALSE) +
style_roc(theme = theme_grey)+
labs(title="Courbes ROC")
Ou bien en mesurant l'erreur :
ggplot(data=criteres_erreur_classif_plot,aes(x=Methode,y=Error))+
geom_bar(stat="identity",fill="steelblue")+
geom_hline(yintercept=error_min,color="red",size=1)+
scale_y_continuous(breaks=seq(from=0,to=ceiling(error_max),by=0.1))+
theme(axis.text.x=element_text(size=12))+
labs(x="Méthode",y="Erreur de classification")+
coord_flip()
ggplot(data=criteres_erreur_classif_plot,aes(x=Methode,y=100*Error))+
geom_bar(stat="identity",fill="steelblue")+
geom_hline(yintercept=100*error_min,color="red",size=1)+
scale_y_continuous(breaks=seq(from=0,to=ceiling(100*error_max),by=10))+
theme(axis.text.x=element_text(size=12))+
labs(x="Méthode",y="Erreur de classification (%)") +
coord_flip()
Modèle de mélange I (erreur moyenne sur tous les modèles )
moyenne_mod <- resultats %>%
rowwise() %>%
mutate(moyenne = mean(c_across(!matches("Y"))))
eval_prev_classif(prev_proba = moyenne_mod$moyenne,
real = moyenne_mod$Y,
methode_abrev = "agreg_moy",
methode = "Agrégation moyenne")
Modèle de mélange II (max)
max_mod <- resultats %>%
rowwise() %>%
mutate(max = max(c_across(!matches("Y"))))
eval_prev_classif(prev_proba = max_mod$max,
real = max_mod$Y,
methode_abrev = "agreg_max",
methode = "Agrégation moyenne")
Modèle de mélange III (min)
min_mod <- resultats %>%
rowwise() %>%
mutate(min = min(c_across(!matches("Y"))))
eval_prev_classif(prev_proba = min_mod$min,
real = min_mod$Y,
methode_abrev = "agreg_min",
methode = "Agrégation moyenne")
criteres_erreur_classif %>%
arrange(Error)
On remarque que l'aggrégation des différents modèles par la moyenne, donne de
bons résultats néanmoins, dans un souci de sélectionner un modèle parcimonieux,
nous ne retiendrons pas cette solution.
Synthèse
Ainsi pour cette étude, les méthodes de gradient boosting, plus précisément,
la méthode Adaboost, donnent de meilleures prédictions au sens du taux de mal
classés que les autres méthodes.
En optimisant les paramètres de l'algorithme de gradient boosting sur l'échantillon
d'apprentissage nous avons trouvé une erreur d'environ 23,2%.
La méthode étant choisie, il nous faut maintenant définir un modèle final.
Pour ce faire nous appliquons de nouveau la méthodologie de validation croisée
pour optimiser ces paramètres.
cl <- makePSOCKcluster(detectCores()-1L)
registerDoParallel(cl)
modele_fin <- train(fml,
data = don_apprentissage,
method="gbm",
distribution="adaboost",
tuneGrid = boosting_grille,
trControl=controle,
verbose=FALSE)
stopCluster(cl)
data("modele_fin", package="ACC")
modele_fin
Les meilleurs paramètres trouvés sont
modele_fin$bestTune
On peut alors appliquer ce modèle à de nouvelles données.
pred_fin <- tibble( Y = don_test$Y,
pred = predict(modele_fin, don_test, type ="prob")[,2]
)
eval_prev_classif(prev=pred_fin$pred, real=pred_fin$Y, methode="Gradient boosting : adaboost", methode_abrev="gbm_ada")
ACCCertDS/ACC documentation built on Dec. 17, 2021, 6:40 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
knitr::opts_chunk$set( fig.dpi = 96, fig.height = 3.5, fig.width = 7, collapse = TRUE, comment = "#>" )
Dans ce document on se propose de modéliser la variable grav afin de prévoir
si un accident aura entraîné des blessures (ou le décès) ou non.
Nous chargeons les packages R nécessaires à cette étude.
library(tidyverse) library(rsample) library(doParallel) # pour paralléliser library(caret) library(glmnet) library(skimr) library(plotROC) # Pour la courbe ROC et l'AUC library(ACC)
Création de l'indicatrice accident avec blessures (yc décès) oui/non
data(population, package = "ACC") data(accidents, package = "ACC") accidents = mutate_pour_modele(accidents, population) accidents <- accidents %>% mutate(Y = factor(ifelse( grav == "Indemne","Indemne", "Blessures"))) %>% select(-Num_Acc,-grav) %>% select(Y, everything()) %>% mutate_if(is.character, factor) skim(accidents)
Compte tenu de la taille (r nrow(accidents) observations) de nos données et des
capacités limitées de nos machines, nous sommes contraints de faire cette
modélisation sur un échantillon de nos données.
set.seed(123) data <- sample_frac(accidents, size = .20, replace = FALSE)
Afin de s'assurer qu'on n'a pas introduit un trop grand biais dans les données, on vérifie que les proportions de la variable d'intérêt $Y$ n'est pas très différent entre l'échantillon ci-dessus et les données initiales.
prop.table(summary(accidents$Y)) prop.table(summary(data$Y))
On introduit les fonctions suivantes pour mesurer l'erreur de prévision de nos modèles ultérieurement.
criteres_erreur_classif <- data.frame(Methode_abrev=character(), Methode=character(), Error=double(), Sensitivity=double(), Precision=double(), Accuracy=double(), Specificity=double(), F1=double(), AUC=double()) eval_prev_classif <- function(prev_proba, real, methode_abrev,methode){ prev <- (prev_proba>0.5)*1 cm <- table(real,prev) print("Confusion matrix :") print(cm) assign(paste("cm",methode_abrev,sep="_"),cm,envir=.GlobalEnv) cm_norm <- round(100*cm/sum(cm),digits=1) print("Confusion matrix (%) :") print(cm_norm) assign(paste("cm_norm",methode_abrev,sep="_"),cm_norm,envir=.GlobalEnv) tp <- cm[2,2] fp <- cm[1,2] tn <- cm[1,1] fn <- cm[2,1] error <- (fp+fn)/(tp+tn+fp+fn) print(paste("Classification error : ",round(error,digits=3),sep="")) sensitivity <- tp/(tp+fn) print(paste("Sensitivity : ",round(sensitivity,digits=3),sep="")) precision <- tp/(tp+fp) print(paste("Precision : ",round(precision,digits=3),sep="")) accuracy <- (tp+tn)/(tp+tn+fp+fn) print(paste("Accuracy : ",round(accuracy,digits=3),sep="")) specificity <- tn/(tn+fp) print(paste("Specificity : ",round(specificity,digits=3),sep="")) F1 <- 2*precision*sensitivity/(precision+sensitivity) print(paste("F1 : ",round(F1,digits=3),sep="")) if (is.factor(real)==TRUE){ df <- data.frame(prev_proba=prev_proba, real=as.numeric(real)-1) } else{ df <- data.frame(prev_proba=prev_proba, real=real) } graph <- ggplot(df,aes(d=real,m=prev_proba))+ geom_roc(labels=FALSE) AUC <- round(calc_auc(graph)$AUC,digits=2) print(paste("AUC : ",round(AUC,digits=3),sep="")) tab <- get("criteres_erreur_classif",envir=globalenv()) tab <- rbind(tab,data.frame(Methode_abrev=methode_abrev, Methode=methode, Error=error, Sensitivity=sensitivity, Precision=precision, Accuracy=accuracy, Specificity=specificity, F1=F1, AUC=AUC)) assign("criteres_erreur_classif",tab,envir=.GlobalEnv) graph+ style_roc(theme=theme_grey)+ annotate("text",x=0.75,y=0.25,label=paste("AUC=",AUC))+ labs(title="Courbe ROC") }
On sépare d'abord nos données pour garder un échantillon de test sur lequel appliquer le modèle finalement sélectionné. Et on évaluera nos modèles par une méthode de validation croisée en 4 blocs.
set.seed(123) split <- rsample::initial_split(data, prop = 3/4, strata = Y) don_apprentissage <- rsample::training(split) don_test <- rsample::testing(split) nb = 4 blocs = sample(rep(1:nb, length=nrow(don_apprentissage)), replace = FALSE)
La fonction ci-après sera exécutée pour chacun des 4 blocs et permet d'ajuster plusieurs modèles aux données.
Pour des raisons de temps de calcul nous sommes contraints de ne pas exécuter les modèles SVM.
predict_cv <- function(bloc_ecart) { ## Pour calcul parallèle des paramètres cl <- makePSOCKcluster(detectCores()-1L) registerDoParallel(cl) ## Données train <- don_apprentissage[blocs != bloc_ecart,] test <- don_apprentissage[blocs == bloc_ecart,] #matrices pour glmnet train_matx <- donX[blocs != bloc_ecart,] train_y <- donY[blocs != bloc_ecart] test_matx <- donX[blocs == bloc_ecart,] set.seed(123) ## Modèles mod_lin <- train(fml , data=train, method="glm", trControl=controle, family = "binomial") mod_ridge <- cv.glmnet(x= train_matx, y = train_y, alpha = 0, parallel = T, family = "binomial") mod_lasso <- cv.glmnet(x= train_matx, y = train_y, alpha = 1, parallel = T, family = "binomial") mod_elnet <- cv.glmnet(x= train_matx, y = train_y, alpha = 0.5, parallel = T, family = "binomial") mod_rf <- train(fml ,data=train,method="ranger",trControl=controle, tuneGrid=rf_grid) mod_Adaboost <- train(fml, data = train, method="gbm",distribution="adaboost", tuneGrid = boosting_grille, trControl=controle, verbose=FALSE) mod_Logitboost <- train(fml, data = train, method="LogitBoost", trControl=controle, verbose=FALSE) # mod_svm <- train(fml, data = train, method="svmLinear", tuneGrid = svr_C_Grid, trControl=controle) # mod_svm_poly_d2 <- train(fml, data = train, method="svmPoly", tuneGrid = svr_poly_grid, trControl=controle) mod_nnet <- train(fml, data = train, method="nnet", trControl=controle, verbose = FALSE) stopCluster(cl) ## Previsions tibble( Y = test$Y, reg_lin = predict(mod_lin, test, type = "prob")[,2], ridge = predict(mod_ridge, test_matx, type ="response", s="lambda.1se")[,1], lasso = predict(mod_lasso, test_matx, type ="response", s="lambda.1se")[,1], elnet = predict(mod_elnet, test_matx, type ="response", s="lambda.1se")[,1], rf = predict(mod_rf, test, type ="prob")[,2], adaboost = predict(mod_Adaboost, test, type ="prob")[,2], logitboost = predict(mod_Logitboost, test, type ="prob")[,2], # svm = predict(mod_svm, test, type ="prob")[,2], # svm_poly_d2 = predict(mod_svm_poly_d2, test, type ="prob")[,2], neuralnet = predict(mod_nnet, test, type ="prob")[,2] ) } # Paramètres pour caret controle <- trainControl(method="cv",number=4, allowParallel = TRUE, classProbs=TRUE, verboseIter = T) ## Grilles de recherches d'hyper paramètres rf_grid <- expand.grid(mtry=seq.int(1,ncol(don_apprentissage)-1, length.out = 5), splitrule = "gini", min.node.size=1L) # svr_C_Grid <- expand.grid(C = seq(0.001, 2, length = 10)) # svr_poly_grid <- expand.grid(C = seq(0.001, 2, length = 10), degree =2, scale = 1) boosting_grille <- expand.grid(n.trees = seq(1,25,5)*50, shrinkage = c(0.0001,0.001,0.01,0.1,1), n.minobsinnode = 10, interaction.depth = 2)
Dans un premier temps nous allons modéliser selon la formule suivante
fml <- as.formula("Y ~ .") ## Données format matrice pour glmnet donX <- model.matrix(fml,data=don_apprentissage)[,-1] donY <- don_apprentissage$Y
Les résultats de la validation croisée en 4 blocs sont les suivants :
resultats = map_dfr(1:nb,predict_cv)
data("envir_modeles_2021-03-16", package="ACC")
resultats
La fonction introduite précédemment predict_cv ajuste les types de modèles
suivants :
- régression logistique
- régression logistique ridge
- régression logistique lasso
- régression logistique elastic net
- forêt aléatoire
- gradient boosting méthode Adaboost
- gradient boosting méthode Logitboost
- réseau de neurones.
Comparons les résultats de ces différentes méthodes
eval_prev_classif(prev=resultats$reg_lin, real=resultats$Y, methode="Régression linéaire", methode_abrev="lm") eval_prev_classif(prev=resultats$ridge, real=resultats$Y, methode="Régression pénalisée : Ridge", methode_abrev="ridge") eval_prev_classif(prev=resultats$lasso, real=resultats$Y, methode="Régression pénalisée : Lasso", methode_abrev="lasso") eval_prev_classif(prev=resultats$elnet, real=resultats$Y, methode="Régression pénalisée : Elastic-net", methode_abrev="elnet") eval_prev_classif(prev=resultats$rf, real=resultats$Y, methode="Random Forest", methode_abrev="RF") eval_prev_classif(prev=resultats$adaboost, real=resultats$Y, methode="Gradient boosting : adaboost", methode_abrev="gbm_ada") eval_prev_classif(prev=resultats$logitboost, real=resultats$Y, methode="Gradient boosting : logitboost", methode_abrev="gbm_logit") eval_prev_classif(prev=resultats$neuralnet, real=resultats$Y, methode="Réseau de neurones : nnet", methode_abrev="nnet") criteres_erreur_classif
criteres_erreur_classif_plot <- criteres_erreur_classif error_min <- min(criteres_erreur_classif_plot$Error) error_min
error_max <- max(criteres_erreur_classif_plot$Error) error_max
On peut également représenter graphiquement ces résultats en regroupant toutes les courbes ROC sur un même graphique :
resultats %>% gather(methode, prev_proba, -Y) %>% ggplot(aes(d=Y, m=prev_proba, color = methode)) + geom_roc(labels = FALSE) + style_roc(theme = theme_grey)+ labs(title="Courbes ROC")
Ou bien en mesurant l'erreur :
ggplot(data=criteres_erreur_classif_plot,aes(x=Methode,y=Error))+ geom_bar(stat="identity",fill="steelblue")+ geom_hline(yintercept=error_min,color="red",size=1)+ scale_y_continuous(breaks=seq(from=0,to=ceiling(error_max),by=0.1))+ theme(axis.text.x=element_text(size=12))+ labs(x="Méthode",y="Erreur de classification")+ coord_flip()
ggplot(data=criteres_erreur_classif_plot,aes(x=Methode,y=100*Error))+ geom_bar(stat="identity",fill="steelblue")+ geom_hline(yintercept=100*error_min,color="red",size=1)+ scale_y_continuous(breaks=seq(from=0,to=ceiling(100*error_max),by=10))+ theme(axis.text.x=element_text(size=12))+ labs(x="Méthode",y="Erreur de classification (%)") + coord_flip()
Modèle de mélange I (erreur moyenne sur tous les modèles )
moyenne_mod <- resultats %>% rowwise() %>% mutate(moyenne = mean(c_across(!matches("Y")))) eval_prev_classif(prev_proba = moyenne_mod$moyenne, real = moyenne_mod$Y, methode_abrev = "agreg_moy", methode = "Agrégation moyenne")
Modèle de mélange II (max)
max_mod <- resultats %>% rowwise() %>% mutate(max = max(c_across(!matches("Y")))) eval_prev_classif(prev_proba = max_mod$max, real = max_mod$Y, methode_abrev = "agreg_max", methode = "Agrégation moyenne")
Modèle de mélange III (min)
min_mod <- resultats %>% rowwise() %>% mutate(min = min(c_across(!matches("Y")))) eval_prev_classif(prev_proba = min_mod$min, real = min_mod$Y, methode_abrev = "agreg_min", methode = "Agrégation moyenne")
criteres_erreur_classif %>% arrange(Error)
On remarque que l'aggrégation des différents modèles par la moyenne, donne de bons résultats néanmoins, dans un souci de sélectionner un modèle parcimonieux, nous ne retiendrons pas cette solution.
Synthèse
Ainsi pour cette étude, les méthodes de gradient boosting, plus précisément, la méthode Adaboost, donnent de meilleures prédictions au sens du taux de mal classés que les autres méthodes.
En optimisant les paramètres de l'algorithme de gradient boosting sur l'échantillon d'apprentissage nous avons trouvé une erreur d'environ 23,2%. La méthode étant choisie, il nous faut maintenant définir un modèle final.
Pour ce faire nous appliquons de nouveau la méthodologie de validation croisée pour optimiser ces paramètres.
cl <- makePSOCKcluster(detectCores()-1L) registerDoParallel(cl) modele_fin <- train(fml, data = don_apprentissage, method="gbm", distribution="adaboost", tuneGrid = boosting_grille, trControl=controle, verbose=FALSE) stopCluster(cl)
data("modele_fin", package="ACC")
modele_fin
Les meilleurs paramètres trouvés sont
modele_fin$bestTune
On peut alors appliquer ce modèle à de nouvelles données.
pred_fin <- tibble( Y = don_test$Y, pred = predict(modele_fin, don_test, type ="prob")[,2] ) eval_prev_classif(prev=pred_fin$pred, real=pred_fin$Y, methode="Gradient boosting : adaboost", methode_abrev="gbm_ada")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.