R/R6_AgghooCV.R

   1 #' @title R6 class with agghoo functions fit() and predict().
   2 #'
   3 #' @description
   4 #' Class encapsulating the methods to run to obtain the best predictor
   5 #' from the list of models (see 'Model' class).
   6 #'
   7 #' @importFrom R6 R6Class
   8 #'
   9 #' @export
  10 AgghooCV <- R6::R6Class("AgghooCV",
  11   public = list(
  12     #' @description Create a new AgghooCV object.
  13     #' @param data Matrix or data.frame
  14     #' @param target Vector of targets (generally numeric or factor)
  15     #' @param task "regression" or "classification"
  16     #' @param gmodel Generic model returning a predictive function
  17     #' @param loss Function assessing the error of a prediction
  18     initialize = function(data, target, task, gmodel, loss = NULL) {
  19       private$data <- data
  20       private$target <- target
  21       private$task <- task
  22       private$gmodel <- gmodel
  23       if (is.null(loss))
  24         loss <- private$defaultLoss
  25       private$loss <- loss
  26     },
  27     #' @description Fit an agghoo model.
  28     #' @param CV List describing cross-validation to run. Slots:
  29     #'          - type: 'vfold' or 'MC' for Monte-Carlo (default: MC)
  30     #'          - V: number of runs (default: 10)
  31     #'          - test_size: percentage of data in the test dataset, for MC
  32     #'            (irrelevant for V-fold). Default: 0.2.
  33     #'          - shuffle: wether or not to shuffle data before V-fold.
  34     #'            Irrelevant for Monte-Carlo; default: TRUE
  35     fit = function(
  36       CV = list(type = "MC",
  37                 V = 10,
  38                 test_size = 0.2,
  39                 shuffle = TRUE)
  40     ) {
  41       if (!is.list(CV))
  42         stop("CV: list of type, V, [test_size], [shuffle]")
  43       n <- nrow(private$data)
  44       shuffle_inds <- NULL
  45       if (CV$type == "vfold" && CV$shuffle)
  46         shuffle_inds <- sample(n, n)
  47       # Result: list of V predictive models (+ parameters for info)
  48       private$pmodels <- list()
  49       for (v in seq_len(CV$V)) {
  50         # Prepare train / test data and target, from full dataset.
  51         # dataHO: "data Hold-Out" etc.
  52         test_indices <- private$get_testIndices(CV, v, n, shuffle_inds)
  53         dataHO <- private$data[-test_indices,]
  54         testX <- private$data[test_indices,]
  55         targetHO <- private$target[-test_indices]
  56         testY <- private$target[test_indices]
  57         # [HACK] R will cast 1-dim matrices into vectors:
  58         if (!is.matrix(dataHO) && !is.data.frame(dataHO))
  59           dataHO <- as.matrix(dataHO)
  60         if (!is.matrix(testX) && !is.data.frame(testX))
  61           testX <- as.matrix(testX)
  62         best_model <- NULL
  63         best_error <- Inf
  64         for (p in seq_len(private$gmodel$nmodels)) {
  65           model_pred <- private$gmodel$get(dataHO, targetHO, p)
  66           prediction <- model_pred(testX)
  67           error <- private$loss(prediction, testY)
  68           if (error <= best_error) {
  69             newModel <- list(model=model_pred, param=private$gmodel$getParam(p))
  70             if (error == best_error)
  71               best_model[[length(best_model)+1]] <- newModel
  72             else {
  73               best_model <- list(newModel)
  74               best_error <- error
  75             }
  76           }
  77         }
  78         # Choose a model at random in case of ex-aequos
  79         private$pmodels[[v]] <- best_model[[ sample(length(best_model),1) ]]
  80       }
  81     },
  82     #' @description Predict an agghoo model (after calling fit())
  83     #' @param X Matrix or data.frame to predict
  84     predict = function(X) {
  85       if (!is.matrix(X) && !is.data.frame(X))
  86         stop("X: matrix or data.frame")
  87       if (!is.list(private$pmodels)) {
  88         print("Please call $fit() method first")
  89         return (invisible(NULL))
  90       }
  91       V <- length(private$pmodels)
  92       if (length(private$pmodels[[1]]$model(X[1,])) >= 2)
  93         # Soft classification:
  94         return (Reduce("+", lapply(private$pmodels, function(m) m$model(X))) / V)
  95       n <- nrow(X)
  96       all_predictions <- as.data.frame(matrix(nrow=n, ncol=V))
  97       for (v in 1:V)
  98         all_predictions[,v] <- private$pmodels[[v]]$model(X)
  99       if (private$task == "regression")
 100         # Easy case: just average each row
 101         return (rowMeans(all_predictions))
 102       # "Hard" classification:
 103       apply(all_predictions, 1, function(row) {
 104         t <- table(row)
 105         # Next lines in case of ties (broken at random)
 106         tmax <- max(t)
 107         sample( names(t)[which(t == tmax)], 1 )
 108       })
 109     },
 110     #' @description Return the list of V best parameters (after calling fit())
 111     getParams = function() {
 112       lapply(private$pmodels, function(m) m$param)
 113     }
 114   ),
 115   private = list(
 116     data = NULL,
 117     target = NULL,
 118     task = NULL,
 119     gmodel = NULL,
 120     loss = NULL,
 121     pmodels = NULL,
 122     get_testIndices = function(CV, v, n, shuffle_inds) {
 123       if (CV$type == "vfold") {
 124         # Slice indices (optionnally shuffled)
 125         first_index = round((v-1) * n / CV$V) + 1
 126         last_index = round(v * n / CV$V)
 127         test_indices = first_index:last_index
 128         if (!is.null(shuffle_inds))
 129           test_indices <- shuffle_inds[test_indices]
 130       }
 131       else
 132         # Monte-Carlo cross-validation
 133         test_indices = sample(n, round(n * CV$test_size))
 134       test_indices
 135     },
 136     defaultLoss = function(y1, y2) {
 137       if (private$task == "classification") {
 138         if (is.null(dim(y1)))
 139           # Standard case: "hard" classification
 140           mean(y1 != y2)
 141         else {
 142           # "Soft" classification: predict() outputs a probability matrix
 143           # In this case "target" could be in matrix form.
 144           if (!is.null(dim(y2)))
 145             mean(rowSums(abs(y1 - y2)))
 146           else {
 147             # Or not: y2 is a "factor".
 148             y2 <- as.character(y2)
 149             # NOTE: the user should provide target in matrix form because
 150             # matching y2 with columns is rather inefficient!
 151             names <- colnames(y1)
 152             positions <- list()
 153             for (idx in seq_along(names))
 154               positions[[ names[idx] ]] <- idx
 155             mean(vapply(
 156               seq_along(y2),
 157               function(idx) sum(abs(y1[idx,] - positions[[ y2[idx] ]])),
 158               0))
 159           }
 160         }
 161       }
 162       else
 163         # Regression
 164         mean(abs(y1 - y2))
 165     }
 166   )
 167 )