Random Weighted Classifier in R

Question

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()

Answer 1

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[[1]][3, ]
    pres_rwc[i, 1:3] <- cm2[[1]][1, ]
    rec_rwc[i, 1:3] <- cm2[[1]][2, ]
    kappa_rwc[[i]] <- round(cm2[[2]], 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.