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) {
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)
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)
24 if (error <= best_error) {
25 if (error == best_error)
26 best_p[[length(best_p)+1]] <- p
33 chosenP <- best_p[[ sample(length(best_p), 1) ]]
34 list(model=gmodel$get(data, target, chosenP), param=gmodel$getParam(chosenP))
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) {
45 if (CV$type == "vfold" && CV$shuffle)
46 shuffle_inds <- sample(n, n)
47 gmodel <- agghoo::Model$new(data, target, task, gmodel, params)
48 bestP <- rep(0, gmodel$nmodels)
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)
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
68 bestP[p] <- bestP[p] + 1
70 # Choose a param at random in case of ex-aequos:
72 chosenP <- sample(which(bestP == maxP), 1)
73 list(model=gmodel$get(data, target, chosenP), param=gmodel$getParam(chosenP))
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.
83 standardCV_run <- function(
84 dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ...
87 task <- checkTask(args$task, targetTrain)
88 modPar <- checkModPar(args$gmodel, args$params)
89 loss <- checkLoss(args$loss, task)
90 CV <- checkCV(args$CV)
92 dataTrain, targetTrain, task, modPar$gmodel, modPar$params, loss, CV)
94 print(paste( "Parameter:", s$param ))
95 p <- s$model(dataTest)
96 err <- floss(p, targetTest)
98 print(paste("error CV:", err))
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.
109 CVvoting_run <- function(
110 dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ...
113 task <- checkTask(args$task, targetTrain)
114 modPar <- checkModPar(args$gmodel, args$params)
115 loss <- checkLoss(args$loss, task)
116 CV <- checkCV(args$CV)
118 dataTrain, targetTrain, task, modPar$gmodel, modPar$params, loss, CV)
120 print(paste( "Parameter:", s$param ))
121 p <- s$model(dataTest)
122 err <- floss(p, targetTest)
124 print(paste("error CV:", err))
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.
135 agghoo_run <- function(
136 dataTrain, dataTest, targetTrain, targetTest, floss, verbose, ...
139 CV <- checkCV(args$CV)
140 # Must remove CV arg, or agghoo will complain "error: unused arg"
142 a <- do.call(agghoo, c(list(data=dataTrain, target=targetTrain), args))
146 print(unlist(a$getParams()))
148 pa <- a$predict(dataTest)
149 err <- floss(pa, targetTest)
151 print(paste("error agghoo:", err))
157 #' Compare a list of learning methods (or run only one), on data/target.
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)
169 compareTo <- function(
170 data, target, method_s, rseed=-1, floss=NULL, verbose=TRUE, ...
175 test_indices <- sample( n, round(n / ifelse(n >= 500, 10, 5)) )
176 d <- splitTrainTest(data, target, test_indices)
178 # Set error function to be used on model outputs (not in core method)
179 task <- checkTask(list(...)$task, target)
180 if (is.null(floss)) {
181 floss <- function(y1, y2) {
182 ifelse(task == "classification", mean(y1 != y2), mean(abs(y1 - y2)))
186 # Run (and compare) all methods:
187 runOne <- function(o) {
188 o(d$dataTrain, d$dataTest, d$targetTrain, d$targetTest, floss, verbose, ...)
191 if (is.list(method_s))
192 errors <- sapply(method_s, runOne)
193 else if (is.function(method_s))
194 errors <- runOne(method_s)
200 #' Run compareTo N times in parallel.
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.
209 compareMulti <- function(
210 data, target, method_s, N=100, nc=NA, floss=NULL, verbose=TRUE, ...
214 nc <- parallel::detectCores()
216 # "One" comparison for each method in method_s (list)
217 compareOne <- function(n) {
220 compareTo(data, target, method_s, n, floss, verbose=FALSE, ...)
223 errors <- if (nc >= 2) {
224 parallel::mclapply(1:N, compareOne, mc.cores = nc)
226 lapply(1:N, compareOne)
230 Reduce('+', errors) / N
235 #' Run compareMulti on several values of the parameter V.
237 #' @inheritParams compareMulti
238 #' @param V_range Values of V to be tested.
241 compareRange <- function(
242 data, target, method_s, N=100, nc=NA, floss=NULL, V_range=c(10,15,20), ...
245 # Avoid warnings if V is left unspecified:
246 CV <- suppressWarnings( checkCV(args$CV) )
247 errors <- lapply(V_range, function(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))
252 print(paste(V_range, errors))