R/R6_Model.R

   1 #' @title R6 class representing a (generic) model.
   2 #'
   3 #' @description
   4 #' "Model" class, containing a (generic) learning function, which from
   5 #' data + target [+ params] returns a prediction function X --> y.
   6 #' Parameters for cross-validation are either provided or estimated.
   7 #' Model family can be chosen among "rf", "tree", "ppr" and "knn" for now.
   8 #'
   9 #' @importFrom FNN knn.reg
  10 #' @importFrom class knn
  11 #' @importFrom stats ppr
  12 #' @importFrom randomForest randomForest
  13 #' @importFrom rpart rpart
  14 #' @importFrom caret var_seq
  15 #'
  16 #' @export
  17 Model <- R6::R6Class("Model",
  18   public = list(
  19     #' @field nmodels Number of parameters (= number of [predictive] models)
  20     nmodels = NA,
  21     #' @description Create a new generic model.
  22     #' @param data Matrix or data.frame
  23     #' @param target Vector of targets (generally numeric or factor)
  24     #' @param task "regression" or "classification"
  25     #' @param gmodel Generic model returning a predictive function; chosen
  26     #'               automatically given data and target nature if not provided.
  27     #' @param params List of parameters for cross-validation (each defining a model)
  28     initialize = function(data, target, task, gmodel = NULL, params = NULL) {
  29       if (is.null(gmodel)) {
  30         # (Generic) model not provided
  31         all_numeric <- is.numeric(as.matrix(data))
  32         if (!all_numeric)
  33           # At least one non-numeric column: use random forests or trees
  34           # TODO: 4 = arbitrary magic number...
  35           gmodel = ifelse(ncol(data) >= 4, "rf", "tree")
  36         else
  37           # Numerical data
  38           gmodel = ifelse(task == "regression", "ppr", "knn")
  39       }
  40       if (is.null(params))
  41         # Here, gmodel is a string (= its family),
  42         # because a custom model must be given with its parameters.
  43         params <- as.list(private$getParams(gmodel, data, target, task))
  44       private$params <- params
  45       if (is.character(gmodel))
  46         gmodel <- private$getGmodel(gmodel, task)
  47       private$gmodel <- gmodel
  48       self$nmodels <- length(private$params)
  49     },
  50     #' @description
  51     #' Returns the model at index "index", trained on dataHO/targetHO.
  52     #' @param dataHO Matrix or data.frame
  53     #' @param targetHO Vector of targets (generally numeric or factor)
  54     #' @param index Index of the model in 1...nmodels
  55     get = function(dataHO, targetHO, index) {
  56       private$gmodel(dataHO, targetHO, private$params[[index]])
  57     },
  58     #' @description
  59     #' Returns the parameter at index "index".
  60     #' @param index Index of the model in 1...nmodels
  61     getParam = function(index) {
  62       private$params[[index]]
  63     }
  64   ),
  65   private = list(
  66     # No need to expose model or parameters list
  67     gmodel = NULL,
  68     params = NULL,
  69     # Main function: given a family, return a generic model, which in turn
  70     # will output a predictive model from data + target + params.
  71     getGmodel = function(family, task) {
  72       if (family == "tree") {
  73         function(dataHO, targetHO, param) {
  74           require(rpart)
  75           method <- ifelse(task == "classification", "class", "anova")
  76           if (is.null(colnames(dataHO)))
  77             colnames(dataHO) <- paste0("V", 1:ncol(dataHO))
  78           df <- data.frame(cbind(dataHO, target=targetHO))
  79           model <- rpart::rpart(target ~ ., df, method=method, control=list(cp=param))
  80           if (task == "regression")
  81             type <- "vector"
  82           else {
  83             if (is.null(dim(targetHO)))
  84               type <- "class"
  85             else
  86               type <- "prob"
  87           }
  88           function(X) {
  89             if (is.null(colnames(X)))
  90               colnames(X) <- paste0("V", 1:ncol(X))
  91             predict(model, as.data.frame(X), type=type)
  92           }
  93         }
  94       }
  95       else if (family == "rf") {
  96         function(dataHO, targetHO, param) {
  97           require(randomForest)
  98           if (task == "classification" && !is.factor(targetHO))
  99             targetHO <- as.factor(targetHO)
 100           model <- randomForest::randomForest(dataHO, targetHO, mtry=param)
 101           function(X) predict(model, X)
 102         }
 103       }
 104       else if (family == "ppr") {
 105         function(dataHO, targetHO, param) {
 106           model <- stats::ppr(dataHO, targetHO, nterms=param)
 107           function(X) predict(model, X)
 108         }
 109       }
 110       else if (family == "knn") {
 111         if (task == "classification") {
 112           function(dataHO, targetHO, param) {
 113             require(class)
 114             function(X) class::knn(dataHO, X, cl=targetHO, k=param)
 115           }
 116         }
 117         else {
 118           function(dataHO, targetHO, param) {
 119             require(FNN)
 120             function(X) FNN::knn.reg(dataHO, X, y=targetHO, k=param)$pred
 121           }
 122         }
 123       }
 124     },
 125     # Return a default list of parameters, given a gmodel family
 126     getParams = function(family, data, target, task) {
 127       if (family == "tree") {
 128         # Run rpart once to obtain a CV grid for parameter cp
 129         require(rpart)
 130         df <- data.frame(cbind(data, target=target))
 131         ctrl <- list(
 132           cp = 0,
 133           minsplit = 2,
 134           minbucket = 1,
 135           xval = 0)
 136         method <- ifelse(task == "classification", "class", "anova")
 137         r <- rpart(target ~ ., df, method=method, control=ctrl)
 138         cps <- r$cptable[-1,1]
 139         if (length(cps) <= 1)
 140           stop("No cross-validation possible: select another model")
 141         if (length(cps) <= 11)
 142           return (cps)
 143         step <- (length(cps) - 1) / 10
 144         cps[unique(round(seq(1, length(cps), step)))]
 145       }
 146       else if (family == "rf") {
 147         p <- ncol(data)
 148         # Use caret package to obtain the CV grid of mtry values
 149         require(caret)
 150         caret::var_seq(p, classification = (task == "classification"),
 151                        len = min(10, p-1))
 152       }
 153       else if (family == "ppr")
 154         # This is nterms in ppr() function
 155         1:10
 156       else if (family == "knn") {
 157         n <- nrow(data)
 158         # Choose ~10 NN values
 159         K <- length(unique(target))
 160         if (n <= 10)
 161           return (1:(n-1))
 162         sqrt_n <- sqrt(n)
 163         step <- (2*sqrt_n - 1) / 10
 164         grid <- unique(round(seq(1, 2*sqrt_n, step)))
 165         if (K == 2) {
 166           # Common binary classification case: odd number of neighbors
 167           for (i in 2:11) {
 168             if (grid[i] %% 2 == 0)
 169               grid[i] <- grid[i] + 1 #arbitrary choice
 170           }
 171         }
 172         grid
 173       }
 174     }
 175   )
 176 )