feat: add one standard error rule callback

NAMESPACE

@@ -45,6 +45,12 @@ import(mlr3)
 import(mlr3misc)
 import(paradox)
 importFrom(R6,R6Class)
+importFrom(bbotk,mlr_terminators)
+importFrom(bbotk,trm)
+importFrom(bbotk,trms)
+importFrom(mlr3misc,clbk)
+importFrom(mlr3misc,clbks)
+importFrom(mlr3misc,mlr_callbacks)
 importFrom(utils,bibentry)
 importFrom(utils,combn)
 importFrom(utils,head)

R/FSelectInstanceMultiCrit.R

@@ -104,6 +104,7 @@ FSelectInstanceMultiCrit = R6Class("FSelectInstanceMultiCrit",
       assert_data_table(ydt)
       assert_names(names(ydt), permutation.of = self$objective$codomain$ids())
       private$.result = cbind(xdt, ydt)
+      call_back("on_result", self$callbacks, private$.context)
     },
 
     #' @description

R/FSelectInstanceSingleCrit.R

@@ -134,6 +134,7 @@ FSelectInstanceSingleCrit = R6Class("FSelectInstanceSingleCrit",
       assert_number(y)
       assert_names(names(y), permutation.of = self$objective$codomain$ids())
       private$.result = cbind(xdt, t(y)) # t(y) so the name of y stays
+      call_back("on_result", self$callbacks, private$.context)
     },
 
     #' @description

R/mlr_callbacks.R

@@ -108,3 +108,51 @@ load_callback_svm_rfe = function() {
     }
   )
 }
+
+#' @title One Standard Error Rule Callback
+#'
+#' @include CallbackFSelect.R
+#' @name mlr3fselect.one_se_rule
+#'
+#' @description
+#' Selects the smallest feature set within one standard error of the best as the result.
+#'
+#' @examples
+#' clbk("mlr3fselect.one_se_rule")
+#'
+#' # Run feature selection on the pima data set with the callback
+#' instance = fselect(
+#'   fselector = fs("random_search"),
+#'   task = tsk("pima"),
+#'   learner = lrn("classif.rpart"),
+#'   resampling = rsmp ("cv", folds = 3),
+#'   measures = msr("classif.ce"),
+#'   term_evals = 10,
+#'   callbacks = clbk("mlr3fselect.one_se_rule"))
+#
+#' # Smallest feature set within one standard error of the best
+#' instance$result
+NULL
+
+load_callback_one_se_rule = function() {
+  callback = callback_fselect("mlr3fselect.one_se_rule",
+    label = "One Standard Error Rule Callback",
+    man = "mlr3fselect::mlr3fselect.one_se_rule",
+
+    on_result = function(callback, context) {
+      archive = context$instance$archive
+      data = as.data.table(archive)
+      data[, n_features := map(features, length)]
+
+      # standard error
+      y = data[[archive$cols_y]]
+      se = sd(y) / sqrt(length(y))
+
+      # select smallest future set within one standard error of the best
+      best_y = context$instance$result_y
+      data = data[y > best_y - se & y < best_y + se, ][which.min(n_features)]
+
+      context$instance$.__enclos_env__$private$.result = data[, names(context$instance$result), with = FALSE]
+    }
+  )
+}

R/zzz.R

@@ -24,6 +24,7 @@
   x = utils::getFromNamespace("mlr_callbacks", ns = "mlr3misc")
   x$add("mlr3fselect.backup", load_callback_backup)
   x$add("mlr3fselect.svm_rfe", load_callback_svm_rfe)
+  x$add("mlr3fselect.one_se_rule", load_callback_one_se_rule)
 
   assign("lg", lgr::get_logger("bbotk"), envir = parent.env(environment()))
   if (Sys.getenv("IN_PKGDOWN") == "true") {

tests/testthat/test_mlr_callbacks.R

@@ -33,5 +33,24 @@ test_that("svm_rfe callbacks works", {
 
   archive = as.data.table(instance$archive)
   expect_list(archive$importance, types = "numeric")
+})
+
+test_that("one_se_rule callback works", {
+
+  score_design = data.table(
+    score = c(0.1, 0.1, 0.58, 0.6),
+    features = list("x1", c("x1", "x2"), c("x1", "x2", "x3"), c("x1", "x2", "x3", "x4"))
+  )
+  measure = msr("dummy", score_design = score_design)
+
+  instance = fselect(
+    fselector = fs("exhaustive_search"),
+    task = TEST_MAKE_TSK(),
+    learner = lrn("regr.rpart"),
+    resampling = rsmp("cv", folds = 3),
+    measures = measure,
+    callbacks = clbk("mlr3fselect.one_se_rule")
+  )
 
+  expect_equal(instance$result_feature_set, c("x1", "x2", "x3"))
 })