On cherche à expliquer une variable binaire \(Y\) par deux variables quantitatives \(X_1\) et \(X_2\) à l’aide du jeu de données suivant

n <- 2000
set.seed(12345)
X1 <- runif(n)
set.seed(5678)
X2 <- runif(n)
set.seed(9012)
R1 <- X1<=0.25
R2 <- (X1>0.25 & X2>=0.75)
R3 <- (X1>0.25 & X2<0.75)
Y <- rep(0,n)
Y[R1] <- rbinom(sum(R1),1,0.25)
Y[R2] <- rbinom(sum(R2),1,0.25)
Y[R3] <- rbinom(sum(R3),1,0.75)
donnees <- data.frame(X1,X2,Y)
donnees$Y <- as.factor(donnees$Y)
  1. Séparer le jeu de données en un échantillon d’apprentissage de taille 1500 et un échantillon test de taille 500.

  2. On considère la régle de classification des \(k\) plus proches voisins. Pour un entier \(k\) plus petit que \(n\) et un nouvel individu \(x\), cette règle affecte à \(x\) le label majoritaire des \(k\) plus proches voisins de \(x\). Sur R on utilise la fonction knn du package class. On peut par exemple obtenir les prévisions des individus de l’échantillon test de la règle des 3 plus proches voisins avec

library(class)
knn3 <- knn(dapp[,1:2],dtest[,1:2],cl=dapp$Y,k=3)
head(knn3)

Calculer l’erreur de classification de la règle des 3 plus proches voisins sur les données test.

  1. Expliquer la fonction knn.cv

On prédit le groupe de chaque individu par validation croisée leave-one-out :

\[\widehat y_i=g_{k,i}(x_i),\quad i=1,\dots,n\]

\(g_{k,i}\) désigne la règle de \(k\) plus proche voisins construites à partir de l’échantillon amputé de la \(i\)ème observation.

  1. Calculer l’erreur de classification de la règle des 3 plus proches voisins par validation croisée leave-one-out.

  2. On considère le vecteur de plus proches voisins suivant :

K_cand <- seq(1,500,by=20)

Proposer 2 façons de choisir une valeur de \(k\) dans ce vecteur.

err.ho <- rep(0,length(K_cand))
for (i in 1:length(K_cand)){
  ...
  ...
}
err.cv <- rep(0,length(K_cand))
for (i in 1:length(K_cand)){
  ...
  ...
} 

On souhaite maintenant utiliser le package caret pour estimer des critères d’erreur et sélectionner des paramètres. On garde le même cadre que précédemment où on cherche à sélectionner le paramètre \(k\) de la règle des plus proches voisins. On pourra consulter l’url http://topepo.github.io/caret/index.html

  1. Expliquer les sorties des commandes
library(caret)
ctrl1 <- trainControl(method="LGOCV",number=1,index=list(1:1500))
KK <- data.frame(k=K_cand)
ee1 <- train(Y~.,data=donnees,method="knn",trControl=ctrl1,tuneGrid=KK)
ee1
plot(ee1)
  1. Utiliser caret pour sélectionner \(k\) par validation croisée leave-one-out.

  2. Faire de même pour la validation croisée 10 blocs.

Les validations croisés peuvent se révéler couteuses en temps de calcul. On utlise souvent des techniques de parallélisation pour améliorer les performances computationnelles. Ces techniques sont relativement facile à mettre en oeuvre avec caret, on peut par exemple utiliser la librairie doParallel :

library(doParallel)
cl <- makePSOCKcluster(1)
registerDoParallel(cl)
system.time(ee3 <- train(Y~.,data=donnees,method="knn",trControl=ctrl3,tuneGrid=KK))
stopCluster(cl)
cl <- makePSOCKcluster(4)
registerDoParallel(cl)
system.time(ee3 <- train(Y~.,data=donnees,method="knn",trControl=ctrl3,tuneGrid=KK))
stopCluster(cl)
LS0tCnRpdGxlOiAiRXN0aW1hdGlvbiBkdSByaXNxdWUgYXZlYyBjYXJldCIKb3V0cHV0OgogIGh0bWxfbm90ZWJvb2s6IAojICAgIGNzczogc3R5bGVzLmNzcwotLS0KCgpPbiBjaGVyY2hlIMOgIGV4cGxpcXVlciB1bmUgdmFyaWFibGUgYmluYWlyZSAkWSQgcGFyIGRldXggdmFyaWFibGVzIHF1YW50aXRhdGl2ZXMgJFhfMSQgZXQgJFhfMiQgw6AgbCdhaWRlIGR1IGpldSBkZSBkb25uw6llcyBzdWl2YW50CgpgYGB7cn0KbiA8LSAyMDAwCnNldC5zZWVkKDEyMzQ1KQpYMSA8LSBydW5pZihuKQpzZXQuc2VlZCg1Njc4KQpYMiA8LSBydW5pZihuKQpzZXQuc2VlZCg5MDEyKQpSMSA8LSBYMTw9MC4yNQpSMiA8LSAoWDE+MC4yNSAmIFgyPj0wLjc1KQpSMyA8LSAoWDE+MC4yNSAmIFgyPDAuNzUpClkgPC0gcmVwKDAsbikKWVtSMV0gPC0gcmJpbm9tKHN1bShSMSksMSwwLjI1KQpZW1IyXSA8LSByYmlub20oc3VtKFIyKSwxLDAuMjUpCllbUjNdIDwtIHJiaW5vbShzdW0oUjMpLDEsMC43NSkKZG9ubmVlcyA8LSBkYXRhLmZyYW1lKFgxLFgyLFkpCmRvbm5lZXMkWSA8LSBhcy5mYWN0b3IoZG9ubmVlcyRZKQpgYGAKCjEuIFPDqXBhcmVyIGxlIGpldSBkZSBkb25uw6llcyBlbiB1biDDqWNoYW50aWxsb24gZCdhcHByZW50aXNzYWdlIGRlIHRhaWxsZSAxNTAwIGV0IHVuIMOpY2hhbnRpbGxvbiB0ZXN0IGRlIHRhaWxsZSA1MDAuCgoKMi4gT24gY29uc2lkw6hyZSBsYSByw6lnbGUgZGUgY2xhc3NpZmljYXRpb24gZGVzICRrJCBwbHVzIHByb2NoZXMgdm9pc2lucy4gUG91ciB1biBlbnRpZXIgJGskIHBsdXMgcGV0aXQgcXVlICRuJCBldCB1biBub3V2ZWwgaW5kaXZpZHUgJHgkLCBjZXR0ZSByw6hnbGUgYWZmZWN0ZSDDoCAkeCQgbGUgbGFiZWwgbWFqb3JpdGFpcmUgZGVzICRrJCBwbHVzIHByb2NoZXMgdm9pc2lucyBkZSAkeCQuIFN1ciAqKlIqKiBvbiB1dGlsaXNlIGxhIGZvbmN0aW9uICoqa25uKiogZHUgcGFja2FnZSAqKmNsYXNzKiouIE9uIHBldXQgcGFyIGV4ZW1wbGUgb2J0ZW5pciBsZXMgcHLDqXZpc2lvbnMgZGVzIGluZGl2aWR1cyBkZSBsJ8OpY2hhbnRpbGxvbiB0ZXN0IGRlIGxhIHLDqGdsZSBkZXMgMyBwbHVzIHByb2NoZXMgdm9pc2lucyBhdmVjCgpgYGB7cn0KbGlicmFyeShjbGFzcykKa25uMyA8LSBrbm4oZGFwcFssMToyXSxkdGVzdFssMToyXSxjbD1kYXBwJFksaz0zKQpoZWFkKGtubjMpCmBgYAoKQ2FsY3VsZXIgbCdlcnJldXIgZGUgY2xhc3NpZmljYXRpb24gZGUgbGEgcsOoZ2xlIGRlcyAzIHBsdXMgcHJvY2hlcyB2b2lzaW5zIHN1ciBsZXMgZG9ubsOpZXMgdGVzdC4KCgozLiBFeHBsaXF1ZXIgbGEgZm9uY3Rpb24gKiprbm4uY3YqKgoKT24gcHLDqWRpdCBsZSBncm91cGUgZGUgY2hhcXVlIGluZGl2aWR1IHBhciAqKnZhbGlkYXRpb24gY3JvaXPDqWUgbGVhdmUtb25lLW91dCoqIDoKCiQkXHdpZGVoYXQgeV9pPWdfe2ssaX0oeF9pKSxccXVhZCBpPTEsXGRvdHMsbiQkCgoKb8O5ICRnX3trLGl9JCBkw6lzaWduZSBsYSByw6hnbGUgZGUgJGskIHBsdXMgcHJvY2hlIHZvaXNpbnMgY29uc3RydWl0ZXMgw6AgcGFydGlyIGRlIGwnw6ljaGFudGlsbG9uIGFtcHV0w6kgZGUgbGEgJGkkw6htZSBvYnNlcnZhdGlvbi4KCjQuIENhbGN1bGVyIGwnZXJyZXVyIGRlIGNsYXNzaWZpY2F0aW9uIGRlIGxhIHLDqGdsZSBkZXMgMyBwbHVzIHByb2NoZXMgdm9pc2lucyBwYXIgdmFsaWRhdGlvbiBjcm9pc8OpZSAqKmxlYXZlLW9uZS1vdXQqKi4KCjUuIE9uIGNvbnNpZMOocmUgbGUgdmVjdGV1ciBkZSBwbHVzIHByb2NoZXMgdm9pc2lucyBzdWl2YW50IDoKCmBgYHtyfQpLX2NhbmQgPC0gc2VxKDEsNTAwLGJ5PTIwKQpgYGAKClByb3Bvc2VyIDIgZmHDp29ucyBkZSBjaG9pc2lyIHVuZSB2YWxldXIgZGUgJGskIGRhbnMgY2UgdmVjdGV1ci4KCiAgKiBPbiBjYWxjdWxlIGwnZXJyZXVyIGRlIGNsYXNzaWZpY2F0aW9uIHBhciAqKnZhbGlkYXRpb24gaG9sZCoqIG91dCBwb3VyIGNoYXF1ZSB2YWxldXIgZGUgJGskIDoKICAKYGBge3J9CmVyci5obyA8LSByZXAoMCxsZW5ndGgoS19jYW5kKSkKZm9yIChpIGluIDE6bGVuZ3RoKEtfY2FuZCkpewogIC4uLgogIC4uLgp9CmBgYAogIAoKICAqIE9uIGZhaXQgbGEgbcOqbWUgY2hvc2UgYXZlYyBsYSAqKnZhbGlkYXRpb24gY3JvaXPDqWUgbGVhdmUtb25lLW91dCoqIDoKYGBge3J9CmVyci5jdiA8LSByZXAoMCxsZW5ndGgoS19jYW5kKSkKZm9yIChpIGluIDE6bGVuZ3RoKEtfY2FuZCkpewogIC4uLgogIC4uLgp9IApgYGAKCgpPbiBzb3VoYWl0ZSBtYWludGVuYW50IHV0aWxpc2VyIGxlIHBhY2thZ2UgKipjYXJldCoqIHBvdXIgZXN0aW1lciBkZXMgY3JpdMOocmVzIGQnZXJyZXVyIGV0IHPDqWxlY3Rpb25uZXIgZGVzIHBhcmFtw6h0cmVzLiBPbiBnYXJkZSBsZSBtw6ptZSBjYWRyZSBxdWUgcHLDqWPDqWRlbW1lbnQgb8O5IG9uIGNoZXJjaGUgw6Agc8OpbGVjdGlvbm5lciBsZSBwYXJhbcOodHJlICRrJCBkZSBsYSByw6hnbGUgZGVzIHBsdXMgcHJvY2hlcyB2b2lzaW5zLiBPbiBwb3VycmEgY29uc3VsdGVyIGwndXJsIFtodHRwOi8vdG9wZXBvLmdpdGh1Yi5pby9jYXJldC9pbmRleC5odG1sXShodHRwOi8vdG9wZXBvLmdpdGh1Yi5pby9jYXJldC9pbmRleC5odG1sKQoKNi4gRXhwbGlxdWVyIGxlcyBzb3J0aWVzIGRlcyBjb21tYW5kZXMgCgpgYGB7ciwgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0KbGlicmFyeShjYXJldCkKY3RybDEgPC0gdHJhaW5Db250cm9sKG1ldGhvZD0iTEdPQ1YiLG51bWJlcj0xLGluZGV4PWxpc3QoMToxNTAwKSkKS0sgPC0gZGF0YS5mcmFtZShrPUtfY2FuZCkKZWUxIDwtIHRyYWluKFl+LixkYXRhPWRvbm5lZXMsbWV0aG9kPSJrbm4iLHRyQ29udHJvbD1jdHJsMSx0dW5lR3JpZD1LSykKZWUxCnBsb3QoZWUxKQpgYGAKCgo3LiBVdGlsaXNlciAqKmNhcmV0KiogcG91ciBzw6lsZWN0aW9ubmVyICRrJCBwYXIgdmFsaWRhdGlvbiBjcm9pc8OpZSBsZWF2ZS1vbmUtb3V0LgoKCgo4LiBGYWlyZSBkZSBtw6ptZSBwb3VyIGxhIHZhbGlkYXRpb24gY3JvaXPDqWUgMTAgYmxvY3MuCgoKCkxlcyB2YWxpZGF0aW9ucyBjcm9pc8OpcyAgcGV1dmVudCBzZSByw6l2w6lsZXIgY291dGV1c2VzIGVuIHRlbXBzIGRlIGNhbGN1bC4gT24gdXRsaXNlIHNvdXZlbnQgZGVzIHRlY2huaXF1ZXMgZGUgcGFyYWxsw6lsaXNhdGlvbiBwb3VyIGFtw6lsaW9yZXIgbGVzIHBlcmZvcm1hbmNlcyBjb21wdXRhdGlvbm5lbGxlcy4gQ2VzIHRlY2huaXF1ZXMgc29udCByZWxhdGl2ZW1lbnQgZmFjaWxlIMOgIG1ldHRyZSBlbiBvZXV2cmUgYXZlYyAqKmNhcmV0KiosIG9uIHBldXQgcGFyIGV4ZW1wbGUgdXRpbGlzZXIgbGEgbGlicmFpcmllICoqZG9QYXJhbGxlbCoqIDoKCgpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQpsaWJyYXJ5KGRvUGFyYWxsZWwpCmNsIDwtIG1ha2VQU09DS2NsdXN0ZXIoMSkKcmVnaXN0ZXJEb1BhcmFsbGVsKGNsKQpzeXN0ZW0udGltZShlZTMgPC0gdHJhaW4oWX4uLGRhdGE9ZG9ubmVlcyxtZXRob2Q9ImtubiIsdHJDb250cm9sPWN0cmwzLHR1bmVHcmlkPUtLKSkKc3RvcENsdXN0ZXIoY2wpCmNsIDwtIG1ha2VQU09DS2NsdXN0ZXIoNCkKcmVnaXN0ZXJEb1BhcmFsbGVsKGNsKQpzeXN0ZW0udGltZShlZTMgPC0gdHJhaW4oWX4uLGRhdGE9ZG9ubmVlcyxtZXRob2Q9ImtubiIsdHJDb250cm9sPWN0cmwzLHR1bmVHcmlkPUtLKSkKc3RvcENsdXN0ZXIoY2wpCgpgYGAKCg==