todo-files/BatchmarkToBMR.R

In berndbischl/mlr: Machine Learning in R

# Coerce a Registry as Used in UseCase_RandomForests to a BenchmarkResult(as in mlr)

RegistryToBMR = function(reg, learners, measures, imputeMissing = TRUE) {

  # Get list of resample results
  res = reduceResultsList(reg, ids = findDone(reg),
    fun = function(job, res) {
      tsk = res$resample.res$task.id
      lrn = res$resample.res$learner.id
      dat = res$resample.res
      lst = eval(parse(text = paste0("list(", tsk, "= list(", lrn, "= dat))")))
    }
  )

  allLrns = c()
  for (i in seq_along(learners)) {
    allLrns = c(allLrns, learners[[i]]$id)
  }
  nLrns = length(unique(allLrns))

  # Coerce to format list of tasks that contain ResampleResults of all learners for the task.
  r = list()
  for (i in seq_along(res)) {
    tnm = names(res[[i]])[1]
    lnm = names(res[[i]][[tnm]])[1]
    r[[tnm]][[lnm]] = res[[i]][[tnm]][[lnm]]
  }

  # Coerce to BMR
  newBMR = list(results = r, measures = measures, learners = learners)
  class(newBMR) = "BenchmarkResult"

  # If impute is FALSE delete all tasks where not every learner is present
  if (!imputeMissing) {
    # Create copy
    rClean = newBMR$results
    # Get Number of learners:
    for (i in seq_along(r)) {
      if (length(r[[i]]) < nLrns) {
        print(paste0("Deleting task: ", names(r)[i]))
        rClean[[names(r)[i]]] = NULL
      }
    }
    # write into newBMR
    newBMR$results = rClean
  }

  # If impute == TRUE then impute a predefined ResampleResult  (all meas = 1, all times = 3600)
  if (imputeMissing) {
    # Define functions needed
    imputeMissingResampRes = function(learner, task) {
      load("impute.RData")
      imp$learner.id = learner
      imp$task.id = task
      return(imp)
    }

    imputeBMR = function(bmr) {
      # Write imputed resample result
      for (i in seq_along(bmr$results)) {
        if (length(bmr$results[[i]]) < nLrns) {
          missing = setdiff(allLrns, names(bmr$results[[i]]))
          for (j in seq_along(missing)) {
            imp = imputeMissingResampRes(missing[[j]], names(bmr$results)[i])
            eval(parse(text = paste0("bmr$results[[", i, "]][['", missing[[j]], "']] = imp")))
          }
        }
      }
      return(bmr)
    }
    # Call function
    newBMR = imputeBMR(newBMR)
    # end if(impute == TRUE)
  }

  # Return BMR
  return(newBMR)
}

# Call:
# RegistryToBMR(reg, lrn, measures)


## Old Stuff for debugging.

if (FALSE) {
  #  Fehler sammeln!
  # Create BMR to see Structure
  tsk = list(iris.task, sonar.task)
  lrns = list(makeLearner("classif.rpart"),
    makeLearner("classif.nnet"))
  rdesc = makeResampleDesc("CV", iters = 10)
  meas = list(mmce, ber, timetrain, timepredict)
  bmr = benchmark(lrns, tsk, rdesc, meas)

  # Inspect structure
  str(bmr, max.level = 1)
  bmr$measures
  bmr$learners
  str(bmr$results, max.level = 1)
  str(bmr$results[[1]], max.level = 1)

  # test consitency
  res = reduceResultsList(reg, ids = findDone(reg))

  for (i in seq_along(res)) {
    z = c(z, res[[i]]$resample.res$task.id)
    t = c(t, res[[i]]$resample.res$learner.id)
  }
  length(unique(t))

  # get impute.RData
  if (FALSE) {
    impute = resample(learner = makeLearner("classif.rpart"), task = iris.task,
      resampling = makeResampleDesc("CV", iters = 10),
      measures = list(mmce, ber, timetrain, timepredict))
    impute$measures.test$mmce = 1L
    impute$measures.test$ber = 1L
    impute$measures.test$timetrain = 3600L
    impute$measures.test$timepredict = 3600L
    impute$aggr = c(1L, 1L, 3600L, 3600L)
    names(impute$aggr) = c("mmce.test.mean", "ber.test.mean", "timetrain.test.mean", "timepredict.test.mean")
    impute$pred = "imputed"
    impute$measures.train = data.frame(c("imputed"))
    impute$err.msgs = "imputed"
    impute$models = "imputed"
    impute$runtime = 3600 * 10
    imp = impute
    save(imp, file = "impute.RData")
  }



  resample(learner = makeLearner("classif.obliqueRF"),
    task = toMlr(getOMLTask(3627))$mlr.task,
    measures = mmce,
    resampling = makeResampleDesc("CV", iters = 10))
}