getResamplingIndices(): Translate inner resampling indices to outer indices (#2413)

* update getResamplingIndices()

* add explicit return statement

* add test checking translation of inner indices

* move purrr from suggests to imports and remove explicit importing notation

* no pipes

* remove duplicate fields

* fix description

* fix typo in tests

* set_names() needs to be one level higher

* update NEWS.md

Author: pat-s

DESCRIPTION

@@ -39,7 +39,7 @@ Authors@R:
              email = "masonagallo@gmail.com"),
       person(given = "Patrick",
              family = "Schratz",
-             role = c("aut"),
+             role = "aut",
              email = "patrick.schratz@gmail.com",
              comment = c(ORCID = "0000-0003-0748-6624")),
       person(given = "Jakob",
@@ -147,6 +147,7 @@ Imports:
     ggplot2,
     methods,
     parallelMap (>= 1.3),
+    purrr,
     stats,
     stringi,
     survival,
@@ -223,7 +224,6 @@ Suggests:
     penalized (>= 0.9-47),
     pls,
     PMCMR (>= 4.1),
-    purrr,
     randomForest,
     randomForestSRC (>= 2.7.0),
     ranger (>= 0.8.0),

NEWS.md

@@ -3,6 +3,9 @@
 ## general
 * add option to use fully predefined indices in resampling (`makeResampleDesc(fixed = TRUE)`)
 
+## functions - general
+* getResamplingIndices(inner = TRUE) now correctly returns the inner indices (before inner indices referred to the subset of the respective outer level train set)
+
 ## learners - new
 * classif.liquidSVM
 * regr.liquidSVM

R/createSpatialResamplingPlots.R

@@ -2,6 +2,7 @@
 #'
 #' @description Visualize partitioning of resample objects with spatial information.
 #' @import ggplot2
+#' @importFrom purrr map_int flatten imap
 #' @family plot
 #' @author Patrick Schratz
 #' @param task [Task] \cr
@@ -152,9 +153,9 @@ createSpatialResamplingPlots = function(task = NULL, resample = NULL, crs = NULL
   }
 
   # create plot list with length = folds
-  nfolds = purrr::map_int(resample, ~ .x$pred$instance$desc$folds)[1]
+  nfolds = map_int(resample, ~ .x$pred$instance$desc$folds)[1]
 
-  plot.list.out.all = purrr::map(resample, function(.r) {
+  plot.list.out.all = map(resample, function(.r) {
 
     # bind coordinates to data
     data = cbind(task$env$data, task$coordinates)
@@ -163,9 +164,9 @@ createSpatialResamplingPlots = function(task = NULL, resample = NULL, crs = NULL
     data = sf::st_as_sf(data, coords = names(task$coordinates), crs = crs)
 
     # create plot list with length = folds
-    plot.list = purrr::map(1:(nfolds * repetitions), ~ data)
+    plot.list = map(1:(nfolds * repetitions), ~ data)
 
-    plot.list.out = purrr::imap(plot.list, ~ ggplot(.x) +
+    plot.list.out = imap(plot.list, ~ ggplot(.x) +
       geom_sf(data = subset(.x, as.integer(rownames(.x)) %in%
                        .r$pred$instance[["train.inds"]][[.y]]),
         color = color.train, size = point.size, ) +
@@ -183,7 +184,7 @@ createSpatialResamplingPlots = function(task = NULL, resample = NULL, crs = NULL
     return(plot.list.out)
   })
 
-  plot.list = purrr::flatten(plot.list.out.all)
+  plot.list = flatten(plot.list.out.all)
 
   # more than 1 repetition?
   if (repetitions > 1) {

R/getResamplingIndices.R

@@ -5,6 +5,7 @@
 #' with `resample(..., extract = getTuneResult)` or `resample(..., extract = getFeatSelResult)` this helper returns a `list` with
 #' the resampling indices used for the respective method.
 #'
+#' @importFrom purrr map flatten set_names
 #' @param object ([ResampleResult]) \cr
 #'   The result of resampling of a tuning or feature selection wrapper.
 #' @param inner ([logical]) \cr
@@ -38,7 +39,32 @@ getResamplingIndices = function(object, inner = FALSE) {
       stopf("No object of class 'TuneResult' or 'FeatuSelResult' found in slot 'extract'.
              Did you run 'resample()' with 'extract = getTuneResult' or 'extract = getFeatSelResult'?")
     }
-    lapply(object$extract, function(x) x$resampling[c("train.inds", "test.inds")])
+    inner_inds = lapply(object$extract, function(x) x$resampling[c("train.inds", "test.inds")])
+
+    outer_inds = object$pred$instance[c("train.inds", "test.inds")]
+
+    # now translate the inner inds back to the outer inds so we have the correct indices https://github.com/mlr-org/mlr/issues/2409
+
+    inner_inds_translated = map(1:length(inner_inds), function(z) # map over number of outer folds
+
+      set_names(
+        map(c("train.inds", "test.inds"), function(u) # map over train/test level
+
+          # list() -> create list for "train.inds" and "test.inds"
+          # flatten() -> reduce by one level
+          # set_names(c("train.inds", "test.inds")) -> now set list names
+          flatten(
+            map(inner_inds[[z]][[u]], ~ # map over number of inner folds
+                  list(outer_inds[["train.inds"]][[z]][.x]) # the inner test.inds are a subset of the outer train.inds! That's why "train.inds" is hardcoded here
+            )
+          )
+        ),
+        c("train.inds", "test.inds")
+      )
+    )
+
+    return(inner_inds_translated)
+
   } else {
     object$pred$instance[c("train.inds", "test.inds")]
   }

tests/testthat/test_base_resample_getResamplingIndices.R

@@ -45,3 +45,28 @@ test_that("getResamplingIndices works with getFeatSelResult", {
   # check if inner test.inds are retrieved correctly
   expect_length(unique(unlist(getResamplingIndices(r, inner = TRUE)[[1]]$test.inds)), 25)
 })
+
+test_that("getResamplingIndices(inner = TRUE) correctly translates the inner inds to indices of the task", {
+
+  # this test is from "test_base_fixed_indices_cv.R"
+  df = multiclass.df
+  fixed = as.factor(rep(1:5, rep(30, 5)))
+  ct = makeClassifTask(target = multiclass.target, data = df, blocking = fixed)
+  lrn = makeLearner("classif.lda")
+  ctrl = makeTuneControlRandom(maxit = 2)
+  ps = makeParamSet(makeNumericParam("nu", lower = 2, upper = 20))
+  inner = makeResampleDesc("CV", iters = 4, fixed = TRUE)
+  outer = makeResampleDesc("CV", iters = 5, fixed = TRUE)
+  tune_wrapper = makeTuneWrapper(lrn, resampling = inner, par.set = ps,
+    control = ctrl, show.info = FALSE)
+  p = resample(tune_wrapper, ct, outer, show.info = FALSE,
+    extract = getTuneResult)
+
+  inner_inds = getResamplingIndices(p, inner = TRUE)
+
+  # to test we expect that any inner fold contains indices that exceed $obs - (obs / nfolds)$ = 150 - 30 = 120
+  # 120 is the max index number that is used in the inner resampling (in the case of 150 obs and 5 folds) because we have one fold less than in the outer level
+  inds = sort(inner_inds[[2]][["test.inds"]][[1]])
+
+  expect_equal(length(inds[inds > 120]), 30)
+})