05cb7d8dd4bd52cb261a4110b56103799a83c1f8
[agghoo.git] / 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 )