# Random Weighted Classifier in R

I am computing a random weighted classifier based on the rates at which 3 labels appear in a "train" set. I want to use this RWC as a baseline for other classifiers. I'm doing this over 1000 iterations and then computing the mean of F1, Precision and Recall of each class besides the overall kappa.

Can this code run faster/look nicer? Minimum example here:

library(caret)

random_weighted_classifier <- function(weightA, weightB, weightC){
random_number = sample(1:100,1) / 100

if(random_number <= weightA){
return("better")
}else if (random_number > weightA && random_number <= (weightA + weightB)){
return("worse")
}else if(random_number > (weightA + weightB) && random_number <= (weightA + weightB + weightC)){
return("no change")
}
}

test <- function(){

betters = rep(x = "better", 100)
worses = rep(x = "worse", 50)
no_changes = rep(x = "no_change", 10)
reference = sample(c(betters, worses, no_changes))

better = sum(reference == "better")
worse = sum(reference == "worse")
no_change = sum(reference == "no_change")
total = length(reference)

# rwc = random weighted classifer
prediction_rwc = vector("character", total)

iterations = 1000
f1_rwc = matrix(0., iterations, 3)
pres_rwc = matrix(0.,iterations, 3)
rec_rwc = matrix(0., iterations, 3)
kappa_rwc = vector("double", iterations)

for(i in seq(1:iterations)){

for(j in seq(1:total)){
prediction_rwc[[j]] = random_weighted_classifier(better/total, worse/total, no_change/total)
}
cm = (confusionMatrix(data = factor(prediction_rwc, levels = c("better","worse", "no_change")),
reference = factor(reference, levels = c("better","worse", "no_change")),
positive = c("better", "worse"),
mode = "everything"))

f1_rwc[i,1:3] <-  cm$byClass[,"F1"] pres_rwc[i,1:3] = cm$byClass[,"Precision"]
rec_rwc[i,1:3] = cm$byClass[,"Recall"] kappa_rwc[[i]] = round(cm$overall["Kappa"],2)
}

print(list("f1" = c(mean(f1_rwc[,1], na.rm = T),mean(f1_rwc[,2], na.rm = T),mean(f1_rwc[,3], na.rm = T)),
"precision" = c(mean(pres_rwc[,1], na.rm = T),mean(pres_rwc[,2], na.rm = T),mean(pres_rwc[,3], na.rm = T)),
"recall" = c(mean(rec_rwc[,1], na.rm = T),mean(rec_rwc[,2], na.rm = T),mean(rec_rwc[,3], na.rm = T)),
"kappa" = mean(kappa_rwc, na.rm = T)))

}

test()


Some improvements:

random_weighted_classifier2 <- function(n = 1, weightA, weightB, weightC){
x <- sample(1:100, n, replace = T) / 100
i1 <- x <= weightA
i2 <- x > weightA & x <= (weightA + weightB)
rez <- rep('no_change', n)
rez[i2] <- "worse"
rez[i1] <- "better"
rez
}

test <- function(){

betters <- rep("better", 100)
worses <- rep("worse", 50)
no_changes <- rep("no_change", 10)
reference <- sample(c(betters, worses, no_changes))

better <- sum(reference == "better")
worse <- sum(reference == "worse")
no_change <- sum(reference == "no_change")
total <- length(reference)

iterations <- 1000
f1_rwc <- pres_rwc <- rec_rwc <- matrix(0., iterations, 3)
kappa_rwc <- vector("double", iterations)

referenceF <- factor(reference, levels = c("better","worse", "no_change"))
for (i in seq(1:iterations)) {

prediction_rwc <- random_weighted_classifier2(total,
better/total,
worse/total,
no_change/total)
prediction_rwc <-
factor(prediction_rwc, levels = c("better","worse", "no_change"))
conTable <- table(prediction_rwc, referenceF)
cm <- confusionMatrix(conTable, positive = c("better", "worse"),
mode = "everything")

f1_rwc[i, 1:3] <-  cm$byClass[,"F1"] pres_rwc[i, 1:3] <- cm$byClass[,"Precision"]
rec_rwc[i, 1:3] <- cm$byClass[,"Recall"] kappa_rwc[[i]] <- round(cm$overall["Kappa"], 2)
}

print(list("f1" = colMeans(f1_rwc, na.rm = T),
"precision" = colMeans(pres_rwc, na.rm = T),
"recall" = colMeans(rec_rwc, na.rm = T),
"kappa" = mean(kappa_rwc, na.rm = T)))
}


It should be around 50 % faster (16.80 vs 11.02 sec for 1k iterations).

You, possibly, could speed it up even more by removing the confusionMatrix function and calculation of all of the necessary parameters by yourself.

## Update

Based on confusionMatrix I managed to extract relevant parts of code and wrap into a function:

statistics <- function(data, beta = 1) {
stat <- sapply(rownames(data), function(relevant) {

if (nrow(data) > 2) {
m <- matrix(NA, 2, 2)
colnames(m) <- rownames(m) <- c("rel", "irrel")
irrelCol <- which(!(colnames(data) %in% relevant))
relCol <- which(colnames(data) %in% relevant)
m[1, 1] <- sum(data[relCol, relCol])
m[1, 2] <- sum(data[relCol, irrelCol])
m[2, 1] <- sum(data[irrelCol, relCol])
m[2, 2] <- sum(data[irrelCol, irrelCol])
m <- as.table(m)
relevant <- "rel"
}
numer <- m[relevant, relevant]
denom <- sum(m[relevant, ])
prec <- ifelse(denom > 0, numer/denom, NA) # Precision

denom <- sum(m[, relevant])
rec <- ifelse(denom > 0, numer / denom, NA) # Recall

F1 <- (1 + beta^2)*prec*rec/((beta^2 * prec) + rec) # F1
c('Precision' = prec, 'Recall' = rec, 'F1' = F1)
})

k <- unlist(e1071::classAgreement(data))["kappa"]
list(stat, kappa = k)
}


and then test3 looks like:

test3 <- function(iterations = 100){

vals <- c("better","worse", "no_change")
betters <- rep("better", 100)
worses <- rep("worse", 50)
no_changes <- rep("no_change", 10)
reference <- sample(c(betters, worses, no_changes))

better <- sum(reference == "better")
worse <- sum(reference == "worse")
no_change <- sum(reference == "no_change")
n <- length(reference)

f1_rwc <- pres_rwc <- rec_rwc <- matrix(0., iterations, 3)
kappa_rwc <- vector("double", iterations)
referenceF <- factor(reference, levels = vals)

for (i in seq(1:iterations)) {

prediction_rwc <-
random_weighted_classifier2(n, better/n, worse/n, no_change/n)
prediction_rwc <-  factor(prediction_rwc, levels = vals)
conTable <- table(prediction_rwc, referenceF)
cm2 <- statistics(conTable)
f1_rwc[i, 1:3] <-  cm2[][3, ]
pres_rwc[i, 1:3] <- cm2[][1, ]
rec_rwc[i, 1:3] <- cm2[][2, ]
kappa_rwc[[i]] <- round(cm2[], 2)
}

list("f1" = colMeans(f1_rwc, na.rm = T),
"precision" = colMeans(pres_rwc, na.rm = T),
"recall" = colMeans(rec_rwc, na.rm = T),
"kappa" = mean(kappa_rwc, na.rm = T))
}


This should run under 1sec for 1k iterations.

p.s. kappa can be calculated with this:

  n <- sum(data)
ni <- rowSums(data)
nj <- colSums(data)
p0 <- sum(diag(data, names = F))/n
pc <- sum((ni/n) * (nj/n))
k <- (p0 - pc)/(1 - pc)


p.s.s. when reducing to those formulas, I stripped the code which was used for testing, so if you change your data format, bugs may appear. I assumed that the setting doesn't change.

• Thanks a lot! It is a huge improvement (and I didn't realise there was a small bug in the rwc method) – Julio Sep 4 '18 at 13:48