Using repeated sampling to detect mislabeled observations

In lecture we discussed confidence in predictions. You could use ensemble methods and assess how often a certain observation is allocated to each class - are the different models in your assemble in agreement?

We feel more confident in a prediction if there is agreement between models in the ensemble - but what if the ensemble is confident but wrong? That is, what if across your train-test splits the ensemble almost always agrees on a certain class but this is the wrong class? This could indicate that the observation is mislabeled.

By contrast, if the ensemble is uncertain - this is perhaps an observation close to the decision boundary.

library(conformal) # requires a lot of other packages, mainly caret for the model types
library(randomForest)

Loading required package: caret

Loading required package: ggplot2

Warning message:
"package 'ggplot2' was built under R version 4.4.3"
Loading required package: lattice

Loading required package: e1071

Warning message:
"package 'e1071' was built under R version 4.4.3"
Loading required package: grid

No methods found in package 'randomForest' for request: 'predict.randomForest' when loading 'conformal'

No methods found in package 'randomForest' for request: 'plot.randomForest' when loading 'conformal'

randomForest 4.7-1.1

Type rfNews() to see new features/changes/bug fixes.


Attaching package: 'randomForest'


The following object is masked from 'package:ggplot2':

    margin

Mislabeling

I train on a subset of 0s and 1s using 25 leading PC components and record the predictions and errors I make on the test set. I aggregate across the runs and assess confidence and percentage of errors.

library(ElemStatLearn)
library(nsprcomp)

data(zip.train)
set.seed(1000)
Numbers<-zip.train[sample(seq(1,7291),2000),] # a subset of the digits

ssn<-svd(Numbers[,-1])
plot(ssn$d,type="l",xlab="Number of components",ylab="Eigenvalues")
# most of variance explained by 50 components (of 256)
plot(ssn$u[,1:2],xlab="PC1",ylab="PC2",pch=16)   # Plotting PC1 vs PC2
#pp<-identify(ssn$u[,1:2]) # use this to mark some of the observations if use in R interactive mode
aa<-rev(sort.list(ssn$u[,1]))
bb<-rev(sort.list(ssn$u[,2]))
au<-c(sample(aa[1:10],2),sample(aa[990:1000],1))
bu<-c(sample(bb[1:10],2),sample(bb[990:1000],1)) # Here I just pick some digits at the extremes of pc1 and pc2
points(ssn$u[au,1:2],col=2,pch=16,cex=1.5)       # and highlight them in the scatter plot
points(ssn$u[bu,1:2],col=3,pch=16,cex=1.5)
#
par(mfrow=c(3,3))                                # Plotting the corresponding digits
for (bb in (1:length(au))) {
   image(t(matrix(as.numeric(Numbers[au[bb],-1]),16,16,byrow=T))[,16:1], col = gray.colors(33)) }
for (bb in (1:length(bu))) {
   image(t(matrix(as.numeric(Numbers[bu[bb],-1]),16,16,byrow=T))[,16:1], col = gray.colors(33)) }

data(zip.train)
set.seed(1000)
# repeat train-test split - keep record of predictions and errors

NN <- zip.train[zip.train[,1]<=1,] # only 0s and 1s
aa <- sample(seq(1,dim(NN)[1]),100)
NN[aa,1] <- abs(NN[aa,1]-1)        # mislabeling 100 observations on purpose
n <- dim(NN)[1]
B <- 500                           # how many runs?

PredMat  <- matrix(-1, n, length(unique(NN[,1])))     # which prediction
CountMat <- matrix(-1, n, 1)     # is the observations in the test set?              
ErrMat   <- matrix(-1, n, 1)     # how many incorrect predictions? 
#
for (bb in (1:B)) {
 it<-sample(seq(1,n),floor(n/2)) #train
 it2<-seq(1,n)[-it]              #test
 Data <- NN
 colnames(Data) <- c("class", paste0("X_", seq(1,dim(NN)[2]-1)))
 Tr.data  <- Data[it,-1]
 Tr.label <- Data[it,1]
 Test.data <- Data[it2,-1]
 Test.label <- Data[it2,1]
 trControl <- trainControl(method = "cv",  number=5, savePredictions=TRUE)
 set.seed(3)
 # number of trees - of course you can add to tune this in the inner loop as well!
 nb_trees <- 20
 model <- train(Tr.data, as.factor(Tr.label),  # using random forest, you can use other caret models as well
         method="rf",type="classification", 
         trControl=trControl,predict.all=TRUE,
         keep.forest=TRUE,norm.votes=TRUE,
         ntree=nb_trees)
 pp <- predict(model, Test.data)
 izz <- seq(1,n)[it2] 
 for (zz in 0:1) {
    izzp <- izz[pp==zz]
    PredMat[izzp,zz+1]  <- PredMat[izzp,zz+1] + 1 
 }
 CountMat[it2] <- CountMat[it2] + 1
 err <- rep(0,length(pp))
 err[pp!=Test.label] <- 1
 ErrMat[it2] <- ErrMat[it2]+err
    }
###

PP<-apply(PredMat,1,which.max)          # winning class across splits
PA<-apply(PredMat,1,max)/CountMat       # confidence (percentage of votes on winning class)

#
plot(PA,ErrMat/CountMat+rnorm(length(ErrMat),sd=.01),xlab="% majority votes",ylab="% misclassifications")
points(PA[aa], ErrMat[aa]/CountMat[aa]+rnorm(length(ErrMat[aa]),sd=.01),col=2)
# NOTICE - the red observations (the mislabeled ones) are all high confidence and always wrong!
#
plot(seq(1,length(ErrMat)),PA,type="s",xlab="index",ylab="percentage winning class votes") 
points(seq(1,length(ErrMat))[aa],PA[aa],col=2) # confident 
plot(seq(1,length(ErrMat)),ErrMat/CountMat,type="s")
points(seq(1,length(ErrMat))[aa],(ErrMat/CountMat)[aa],col=2,xlab="index",ylab="percentage wrong class votes")
# but wrong all the time!