7
\$\begingroup\$

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()
\$\endgroup\$
4
\$\begingroup\$

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.

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.