Commit | Line | Data |
---|---|---|
7733758e BA |
1 | #' standardCV_core |
2 | #' | |
3 | #' Cross-validation method, added here as an example. | |
4 | #' Parameters are described in ?agghoo and ?AgghooCV | |
5 | standardCV_core <- function(data, target, task, gmodel, params, loss, CV) { | |
6 | n <- nrow(data) | |
7 | shuffle_inds <- NULL | |
8 | if (CV$type == "vfold" && CV$shuffle) | |
9 | shuffle_inds <- sample(n, n) | |
10 | list_testinds <- list() | |
11 | for (v in seq_len(CV$V)) | |
12 | list_testinds[[v]] <- get_testIndices(n, CV, v, shuffle_inds) | |
13 | gmodel <- agghoo::Model$new(data, target, task, gmodel, params) | |
14 | best_error <- Inf | |
15 | best_p <- NULL | |
16 | for (p in seq_len(gmodel$nmodels)) { | |
17 | error <- Reduce('+', lapply(seq_len(CV$V), function(v) { | |
18 | testIdx <- list_testinds[[v]] | |
19 | d <- splitTrainTest(data, target, testIdx) | |
20 | model_pred <- gmodel$get(d$dataTrain, d$targetTrain, p) | |
21 | prediction <- model_pred(d$dataTest) | |
22 | loss(prediction, d$targetTest) | |
23 | }) ) | |
24 | if (error <= best_error) { | |
25 | if (error == best_error) | |
26 | best_p[[length(best_p)+1]] <- p | |
27 | else { | |
28 | best_p <- list(p) | |
29 | best_error <- error | |
30 | } | |
31 | } | |
32 | } | |
33 | chosenP <- best_p[[ sample(length(best_p), 1) ]] | |
34 | list(model=gmodel$get(data, target, chosenP), param=gmodel$getParam(chosenP)) | |
35 | } | |
36 | ||
a7ec4f8a BA |
37 | #' CVvoting_core |
38 | #' | |
39 | #' "voting" cross-validation method, added here as an example. | |
40 | #' Parameters are described in ?agghoo and ?AgghooCV | |
41 | CVvoting_core <- function(data, target, task, gmodel, params, loss, CV) { | |
42 | CV <- checkCV(CV) | |
43 | n <- nrow(data) | |
44 | shuffle_inds <- NULL | |
45 | if (CV$type == "vfold" && CV$shuffle) | |
46 | shuffle_inds <- sample(n, n) | |
a7ec4f8a | 47 | gmodel <- agghoo::Model$new(data, target, task, gmodel, params) |
7733758e | 48 | bestP <- rep(0, gmodel$nmodels) |
a7ec4f8a BA |
49 | for (v in seq_len(CV$V)) { |
50 | test_indices <- get_testIndices(n, CV, v, shuffle_inds) | |
51 | d <- splitTrainTest(data, target, test_indices) | |
52 | best_p <- NULL | |
53 | best_error <- Inf | |
54 | for (p in seq_len(gmodel$nmodels)) { | |
55 | model_pred <- gmodel$get(d$dataTrain, d$targetTrain, p) | |
56 | prediction <- model_pred(d$dataTest) | |
57 | error <- loss(prediction, d$targetTest) | |
58 | if (error <= best_error) { | |
59 | if (error == best_error) | |
60 | best_p[[length(best_p)+1]] <- p | |
61 | else { | |
62 | best_p <- list(p) | |
63 | best_error <- error | |
64 | } | |
65 | } | |
66 | } | |
67 | for (p in best_p) | |
68 | bestP[p] <- bestP[p] + 1 | |
69 | } | |
70 | # Choose a param at random in case of ex-aequos: | |
71 | maxP <- max(bestP) | |
72 | chosenP <- sample(which(bestP == maxP), 1) | |
73 | list(model=gmodel$get(data, target, chosenP), param=gmodel$getParam(chosenP)) | |
74 | } | |
75 | ||
17ea2f13 BA |
76 | #' standardCV_run |
77 | #' | |
78 | #' Run and eval the standard cross-validation procedure. | |
79 | #' Parameters are rather explicit except "floss", which corresponds to the | |
80 | #' "final" loss function, applied to compute the error on testing dataset. | |
81 | #' | |
82 | #' @export | |
43a6578d | 83 | standardCV_run <- function( |
17ea2f13 | 84 | dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ... |
43a6578d | 85 | ) { |
afa67660 BA |
86 | args <- list(...) |
87 | task <- checkTask(args$task, targetTrain) | |
88 | modPar <- checkModPar(args$gmodel, args$params) | |
89 | loss <- checkLoss(args$loss, task) | |
17ea2f13 | 90 | CV <- checkCV(args$CV) |
afa67660 BA |
91 | s <- standardCV_core( |
92 | dataTrain, targetTrain, task, modPar$gmodel, modPar$params, loss, CV) | |
43a6578d BA |
93 | if (verbose) |
94 | print(paste( "Parameter:", s$param )) | |
afa67660 BA |
95 | p <- s$model(dataTest) |
96 | err <- floss(p, targetTest) | |
43a6578d | 97 | if (verbose) |
afa67660 BA |
98 | print(paste("error CV:", err)) |
99 | invisible(err) | |
43a6578d BA |
100 | } |
101 | ||
7733758e BA |
102 | #' CVvoting_run |
103 | #' | |
104 | #' Run and eval the voting cross-validation procedure. | |
105 | #' Parameters are rather explicit except "floss", which corresponds to the | |
106 | #' "final" loss function, applied to compute the error on testing dataset. | |
107 | #' | |
108 | #' @export | |
109 | CVvoting_run <- function( | |
110 | dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ... | |
111 | ) { | |
112 | args <- list(...) | |
113 | task <- checkTask(args$task, targetTrain) | |
114 | modPar <- checkModPar(args$gmodel, args$params) | |
115 | loss <- checkLoss(args$loss, task) | |
116 | CV <- checkCV(args$CV) | |
117 | s <- CVvoting_core( | |
118 | dataTrain, targetTrain, task, modPar$gmodel, modPar$params, loss, CV) | |
119 | if (verbose) | |
120 | print(paste( "Parameter:", s$param )) | |
121 | p <- s$model(dataTest) | |
122 | err <- floss(p, targetTest) | |
123 | if (verbose) | |
124 | print(paste("error CV:", err)) | |
125 | invisible(err) | |
126 | } | |
127 | ||
17ea2f13 BA |
128 | #' agghoo_run |
129 | #' | |
130 | #' Run and eval the agghoo procedure. | |
131 | #' Parameters are rather explicit except "floss", which corresponds to the | |
132 | #' "final" loss function, applied to compute the error on testing dataset. | |
133 | #' | |
134 | #' @export | |
43a6578d | 135 | agghoo_run <- function( |
17ea2f13 | 136 | dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ... |
43a6578d | 137 | ) { |
17ea2f13 BA |
138 | args <- list(...) |
139 | CV <- checkCV(args$CV) | |
140 | # Must remove CV arg, or agghoo will complain "error: unused arg" | |
141 | args$CV <- NULL | |
142 | a <- do.call(agghoo, c(list(data=dataTrain, target=targetTrain), args)) | |
43a6578d BA |
143 | a$fit(CV) |
144 | if (verbose) { | |
145 | print("Parameters:") | |
146 | print(unlist(a$getParams())) | |
147 | } | |
148 | pa <- a$predict(dataTest) | |
149 | err <- floss(pa, targetTest) | |
150 | if (verbose) | |
151 | print(paste("error agghoo:", err)) | |
afa67660 | 152 | invisible(err) |
43a6578d BA |
153 | } |
154 | ||
17ea2f13 BA |
155 | #' compareTo |
156 | #' | |
157 | #' Compare a list of learning methods (or run only one), on data/target. | |
158 | #' | |
159 | #' @param data Data matrix or data.frame | |
160 | #' @param target Target vector (generally) | |
161 | #' @param method_s Either a single function, or a list | |
162 | #' (examples: agghoo_run, standardCV_run) | |
163 | #' @param rseed Seed of the random generator (-1 means "random seed") | |
164 | #' @param floss Loss function to compute the error on testing dataset. | |
165 | #' @param verbose TRUE to request methods to be verbose. | |
166 | #' @param ... arguments passed to method_s function(s) | |
167 | #' | |
168 | #' @export | |
43a6578d | 169 | compareTo <- function( |
afa67660 | 170 | data, target, method_s, rseed=-1, floss=NULL, verbose=TRUE, ... |
43a6578d BA |
171 | ) { |
172 | if (rseed >= 0) | |
173 | set.seed(rseed) | |
174 | n <- nrow(data) | |
175 | test_indices <- sample( n, round(n / ifelse(n >= 500, 10, 5)) ) | |
afa67660 | 176 | d <- splitTrainTest(data, target, test_indices) |
43a6578d BA |
177 | |
178 | # Set error function to be used on model outputs (not in core method) | |
afa67660 | 179 | task <- checkTask(list(...)$task, target) |
43a6578d BA |
180 | if (is.null(floss)) { |
181 | floss <- function(y1, y2) { | |
182 | ifelse(task == "classification", mean(y1 != y2), mean(abs(y1 - y2))) | |
183 | } | |
184 | } | |
185 | ||
186 | # Run (and compare) all methods: | |
187 | runOne <- function(o) { | |
17ea2f13 | 188 | o(d$dataTrain, d$dataTest, d$targetTrain, d$targetTest, floss, verbose, ...) |
43a6578d | 189 | } |
afa67660 | 190 | errors <- c() |
43a6578d BA |
191 | if (is.list(method_s)) |
192 | errors <- sapply(method_s, runOne) | |
193 | else if (is.function(method_s)) | |
194 | errors <- runOne(method_s) | |
43a6578d BA |
195 | invisible(errors) |
196 | } | |
197 | ||
17ea2f13 BA |
198 | #' compareMulti |
199 | #' | |
200 | #' Run compareTo N times in parallel. | |
201 | #' | |
202 | #' @inheritParams compareTo | |
203 | #' @param N Number of calls to method(s) | |
204 | #' @param nc Number of cores. Set to parallel::detectCores() if undefined. | |
205 | #' Set it to any value <=1 to say "no parallelism". | |
206 | #' @param verbose TRUE to print task numbers and "Errors:" in the end. | |
207 | #' | |
208 | #' @export | |
43a6578d | 209 | compareMulti <- function( |
17ea2f13 | 210 | data, target, method_s, N=100, nc=NA, floss=NULL, verbose=TRUE, ... |
43a6578d | 211 | ) { |
afa67660 | 212 | require(parallel) |
43a6578d BA |
213 | if (is.na(nc)) |
214 | nc <- parallel::detectCores() | |
afa67660 BA |
215 | |
216 | # "One" comparison for each method in method_s (list) | |
43a6578d | 217 | compareOne <- function(n) { |
17ea2f13 BA |
218 | if (verbose) |
219 | print(n) | |
afa67660 | 220 | compareTo(data, target, method_s, n, floss, verbose=FALSE, ...) |
43a6578d | 221 | } |
afa67660 | 222 | |
43a6578d | 223 | errors <- if (nc >= 2) { |
43a6578d BA |
224 | parallel::mclapply(1:N, compareOne, mc.cores = nc) |
225 | } else { | |
226 | lapply(1:N, compareOne) | |
227 | } | |
17ea2f13 BA |
228 | if (verbose) |
229 | print("Errors:") | |
43a6578d BA |
230 | Reduce('+', errors) / N |
231 | } | |
17ea2f13 BA |
232 | |
233 | #' compareRange | |
234 | #' | |
235 | #' Run compareMulti on several values of the parameter V. | |
236 | #' | |
237 | #' @inheritParams compareMulti | |
238 | #' @param V_range Values of V to be tested. | |
239 | #' | |
240 | #' @export | |
241 | compareRange <- function( | |
a78bd1c0 | 242 | data, target, method_s, N=100, nc=NA, floss=NULL, V_range=c(10,15,20), ... |
17ea2f13 BA |
243 | ) { |
244 | args <- list(...) | |
245 | # Avoid warnings if V is left unspecified: | |
246 | CV <- suppressWarnings( checkCV(args$CV) ) | |
247 | errors <- lapply(V_range, function(V) { | |
248 | args$CV$V <- V | |
249 | do.call(compareMulti, c(list(data=data, target=target, method_s=method_s, | |
250 | N=N, nc=nc, floss=floss, verbose=F), args)) | |
251 | }) | |
252 | print(paste(V_range, errors)) | |
253 | } |