lgb.cv.R 14.9 KB
Newer Older
Guolin Ke's avatar
Guolin Ke committed
1
CVBooster <- R6Class(
2
  classname = "lgb.CVBooster",
3
  cloneable = FALSE,
Guolin Ke's avatar
Guolin Ke committed
4
  public = list(
5
    best_iter = -1,
6
    best_score = -1,
Guolin Ke's avatar
Guolin Ke committed
7
    record_evals = list(),
8
9
    boosters = list(),
    initialize = function(x) {
Guolin Ke's avatar
Guolin Ke committed
10
      self$boosters <- x
11
    },
12
13
14
    reset_parameter = function(new_params) {
      for (x in boosters) { x$reset_parameter(new_params) }
      self
Guolin Ke's avatar
Guolin Ke committed
15
16
17
18
19
    }
  )
)

#' Main CV logic for LightGBM
20
#'
Guolin Ke's avatar
Guolin Ke committed
21
#' Main CV logic for LightGBM
22
#'
Guolin Ke's avatar
Guolin Ke committed
23
24
25
#' @param params List of parameters
#' @param data a \code{lgb.Dataset} object, used for CV
#' @param nrounds number of CV rounds
26
#' @param nfold the original dataset is randomly partitioned into \code{nfold} equal size subsamples.
Guolin Ke's avatar
Guolin Ke committed
27
#' @param label vector of response values. Should be provided only when data is an R-matrix.
28
#' @param weight vector of response values. If not NULL, will set to dataset
29
30
31
32
33
34
35
36
#' @param obj objective function, can be character or custom objective function. Examples include 
#'        \code{regression}, \code{regression_l1}, \code{huber},
#'        \code{binary}, \code{lambdarank}, \code{multiclass}, \code{multiclass}
#' @param boosting boosting type. \code{gbdt}, \code{dart}
#' @param num_leaves number of leaves in one tree. defaults to 127
#' @param max_depth Limit the max depth for tree model. This is used to deal with overfit when #data is small. 
#'        Tree still grow by leaf-wise.
#' @param num_threads Number of threads for LightGBM. For the best speed, set this to the number of real CPU cores, not the number of threads (most CPU using hyper-threading to generate 2 threads per CPU core).
Guolin Ke's avatar
Guolin Ke committed
37
#' @param eval evaluation function, can be (list of) character or custom eval function
38
39
40
#' @param verbose verbosity for output, if <= 0, also will disable the print of evalutaion during training
#' @param record Boolean, TRUE will record iteration message to \code{booster$record_evals} 
#' @param eval_freq evalutaion output frequence, only effect when verbose > 0
Guolin Ke's avatar
Guolin Ke committed
41
#' @param showsd \code{boolean}, whether to show standard deviation of cross validation
42
#' @param stratified a \code{boolean} indicating whether sampling of folds should be stratified
Guolin Ke's avatar
Guolin Ke committed
43
44
#'        by the values of outcome labels.
#' @param folds \code{list} provides a possibility to use a list of pre-defined CV folds
45
#'        (each element must be a vector of test fold's indices). When folds are supplied,
Guolin Ke's avatar
Guolin Ke committed
46
47
48
#'        the \code{nfold} and \code{stratified} parameters are ignored.
#' @param init_model path of model file of \code{lgb.Booster} object, will continue train from this model
#' @param colnames feature names, if not null, will use this to overwrite the names in dataset
49
50
51
#' @param categorical_feature list of str or int
#'        type int represents index,
#'        type str represents feature names
Guolin Ke's avatar
Guolin Ke committed
52
53
54
55
56
57
58
59
60
#' @param early_stopping_rounds int
#'        Activates early stopping.
#'        Requires at least one validation data and one metric
#'        If there's more than one, will check all of them
#'        Returns the model with (best_iter + early_stopping_rounds)
#'        If early stopping occurs, the model will have 'best_iter' field
#' @param callbacks list of callback functions
#'        List of callback functions that are applied at each iteration.
#' @param ... other parameters, see parameters.md for more informations
61
#' 
62
#' @return a trained model \code{lgb.CVBooster}.
63
#' 
Guolin Ke's avatar
Guolin Ke committed
64
#' @examples
65
#' \dontrun{
66
67
68
69
70
71
72
73
74
75
76
77
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' params <- list(objective = "regression", metric = "l2")
#' model <- lgb.cv(params,
#'                 dtrain,
#'                 10,
#'                 nfold = 5,
#'                 min_data = 1,
#'                 learning_rate = 1,
#'                 early_stopping_rounds = 10)
78
#' }
Guolin Ke's avatar
Guolin Ke committed
79
80
#' @rdname lgb.train
#' @export
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
lgb.cv <- function(params = list(),
                   data,
                   nrounds = 10, 
                   nfold = 3,
                   label = NULL,
                   weight = NULL,
                   obj = NULL,
                   eval = NULL,
                   verbose = 1,
                   record = TRUE,
                   eval_freq = 1L,
                   showsd = TRUE,
                   stratified = TRUE,
                   folds = NULL,
                   init_model = NULL,
                   colnames = NULL,
                   categorical_feature = NULL,
98
                   early_stopping_rounds = NULL,
99
100
101
102
                   callbacks = list(),
                   ...) {
  
  # Setup temporary variables
Guolin Ke's avatar
Guolin Ke committed
103
  addiction_params <- list(...)
104
105
106
107
108
109
110
111
  params <- append(params, addiction_params)
  params$verbose <- verbose
  params <- lgb.check.obj(params, obj)
  params <- lgb.check.eval(params, eval)
  fobj <- NULL
  feval <- NULL
  
  # Check for objective (function or not)
112
  if (is.function(params$objective)) {
Guolin Ke's avatar
Guolin Ke committed
113
114
115
    fobj <- params$objective
    params$objective <- "NONE"
  }
116
117
118
119
120
121
122
  
  # Check for loss (function or not)
  if (is.function(eval)) {
    feval <- eval
  }
  
  # Check for parameters
Guolin Ke's avatar
Guolin Ke committed
123
  lgb.check.params(params)
124
125
  
  # Init predictor to empty
Guolin Ke's avatar
Guolin Ke committed
126
  predictor <- NULL
127
128
  
  # Check for boosting from a trained model
129
  if (is.character(init_model)) {
Guolin Ke's avatar
Guolin Ke committed
130
    predictor <- Predictor$new(init_model)
131
  } else if (lgb.is.Booster(init_model)) {
Guolin Ke's avatar
Guolin Ke committed
132
133
    predictor <- init_model$to_predictor()
  }
134
135
  
  # Set the iteration to start from / end to (and check for boosting from a trained model, again)
Guolin Ke's avatar
Guolin Ke committed
136
  begin_iteration <- 1
137
  if (!is.null(predictor)) {
Guolin Ke's avatar
Guolin Ke committed
138
139
140
    begin_iteration <- predictor$current_iter() + 1
  }
  end_iteration <- begin_iteration + nrounds - 1
141
142
  
  # Check for training dataset type correctness
143
  if (!lgb.is.Dataset(data)) {
144
145
146
    if (is.null(label)) {
      stop("Labels must be provided for lgb.cv")
    }
147
    data <- lgb.Dataset(data, label = label)
Guolin Ke's avatar
Guolin Ke committed
148
149
  }

150
151
152
153
154
155
  # Check for weights
  if (!is.null(weight)) {
    data$set_info("weight", weight)
  }
  
  # Update parameters with parsed parameters
Guolin Ke's avatar
Guolin Ke committed
156
  data$update_params(params)
157
158
  
  # Create the predictor set
Guolin Ke's avatar
Guolin Ke committed
159
  data$.__enclos_env__$private$set_predictor(predictor)
160
161
162
163
164
165
166
167
168
169
170
171
  
  # Write column names
  if (!is.null(colnames)) {
    data$set_colnames(colnames)
  }
  
  # Write categorical features
  if (!is.null(categorical_feature)) {
    data$set_categorical_feature(categorical_feature)
  }
  
  # Construct datasets, if needed
Guolin Ke's avatar
Guolin Ke committed
172
  data$construct()
173
174
  
  # Check for folds
175
  if (!is.null(folds)) {
176
177
178
    
    # Check for list of folds or for single value
    if (!is.list(folds) | length(folds) < 2) {
179
      stop(sQuote("folds"), " must be a list with 2 or more elements that are vectors of indices for each CV-fold")
180
181
182
    }
    
    # Set number of folds
Guolin Ke's avatar
Guolin Ke committed
183
    nfold <- length(folds)
184
    
Guolin Ke's avatar
Guolin Ke committed
185
  } else {
186
187
188
189
190
191
192
193
194
195
196
    
    # Check fold value
    if (nfold <= 1) {
      stop(sQuote("nfold"), " must be > 1")
    }
    
    # Create folds
    folds <- generate.cv.folds(nfold,
                               nrow(data),
                               stratified,
                               getinfo(data, "label"),
197
                               getinfo(data, "group"),
198
199
                               params)
    
Guolin Ke's avatar
Guolin Ke committed
200
  }
201
202
  
  # Add printing log callback
203
  if (verbose > 0 & eval_freq > 0) {
Guolin Ke's avatar
Guolin Ke committed
204
205
    callbacks <- add.cb(callbacks, cb.print.evaluation(eval_freq))
  }
206
207
208
209
210
211
212
  
  # Add evaluation log callback
  if (record) {
    callbacks <- add.cb(callbacks, cb.record.evaluation())
  }
  
  # Add early stopping callback
Guolin Ke's avatar
Guolin Ke committed
213
  if (!is.null(early_stopping_rounds)) {
214
215
    if (early_stopping_rounds > 0) {
      callbacks <- add.cb(callbacks, cb.early.stop(early_stopping_rounds, verbose = verbose))
Guolin Ke's avatar
Guolin Ke committed
216
217
    }
  }
218
219
  
  # Categorize callbacks
Guolin Ke's avatar
Guolin Ke committed
220
  cb <- categorize.callbacks(callbacks)
221
  
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
  # Construct booster using a list apply, check if requires group or not
  if (!is.list(folds[[1]])) {
    bst_folds <- lapply(seq_along(folds), function(k) {
      dtest <- slice(data, folds[[k]])
      dtrain <- slice(data, unlist(folds[-k]))
      setinfo(dtrain, "weight", getinfo(data, "weight")[-folds[[k]]])
      setinfo(dtrain, "init_score", getinfo(data, "init_score")[-folds[[k]]])
      setinfo(dtest, "weight", getinfo(data, "weight")[folds[[k]]])
      setinfo(dtest, "init_score", getinfo(data, "init_score")[folds[[k]]])
      booster <- Booster$new(params, dtrain)
      booster$add_valid(dtest, "valid")
      list(booster = booster)
    })
  } else {
    bst_folds <- lapply(seq_along(folds), function(k) {
      dtest <- slice(data, folds[[k]]$fold)
      dtrain <- slice(data, (1:nrow(data))[-folds[[k]]$fold])
      setinfo(dtrain, "weight", getinfo(data, "weight")[-folds[[k]]$fold])
      setinfo(dtrain, "init_score", getinfo(data, "init_score")[-folds[[k]]$fold])
      setinfo(dtrain, "group", getinfo(data, "group")[-folds[[k]]$group])
      setinfo(dtest, "weight", getinfo(data, "weight")[folds[[k]]$fold])
      setinfo(dtest, "init_score", getinfo(data, "init_score")[folds[[k]]$fold])
      setinfo(dtest, "group", getinfo(data, "group")[folds[[k]]$group])
      booster <- Booster$new(params, dtrain)
      booster$add_valid(dtest, "valid")
      list(booster = booster)
    })
  }
  
251
252
  
  # Create new booster
Guolin Ke's avatar
Guolin Ke committed
253
  cv_booster <- CVBooster$new(bst_folds)
254
255
256
257
  
  # Callback env
  env <- CB_ENV$new()
  env$model <- cv_booster
Guolin Ke's avatar
Guolin Ke committed
258
  env$begin_iteration <- begin_iteration
259
260
261
  env$end_iteration <- end_iteration
  
  # Start training model using number of iterations to start and end with
262
  for (i in seq(from = begin_iteration, to = end_iteration)) {
263
264
    
    # Overwrite iteration in environment
Guolin Ke's avatar
Guolin Ke committed
265
266
    env$iteration <- i
    env$eval_list <- list()
267
268
269
270
271
272
273
    
    # Loop through "pre_iter" element
    for (f in cb$pre_iter) {
      f(env)
    }
    
    # Update one boosting iteration
Guolin Ke's avatar
Guolin Ke committed
274
    msg <- lapply(cv_booster$boosters, function(fd) {
275
276
      fd$booster$update(fobj = fobj)
      fd$booster$eval_valid(feval = feval)
Guolin Ke's avatar
Guolin Ke committed
277
    })
278
279
    
    # Prepare collection of evaluation results
Guolin Ke's avatar
Guolin Ke committed
280
    merged_msg <- lgb.merge.cv.result(msg)
281
282
    
    # Write evaluation result in environment
Guolin Ke's avatar
Guolin Ke committed
283
    env$eval_list <- merged_msg$eval_list
284
285
286
287
288
289
290
291
292
293
294
295
    
    # Check for standard deviation requirement
    if(showsd) {
      env$eval_err_list <- merged_msg$eval_err_list
    }
    
    # Loop through env
    for (f in cb$post_iter) {
      f(env)
    }
    
    # Check for early stopping and break if needed
296
    if (env$met_early_stop) break
297
    
Guolin Ke's avatar
Guolin Ke committed
298
  }
299
300
301
302
  
  # Return booster
  return(cv_booster)
  
Guolin Ke's avatar
Guolin Ke committed
303
304
305
}

# Generates random (stratified if needed) CV folds
306
generate.cv.folds <- function(nfold, nrows, stratified, label, group, params) {
307
  
308
309
310
311
312
  # Check for group existence
  if (is.null(group)) {
    
    # Shuffle
    rnd_idx <- sample(seq_len(nrows))
313
    
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
    # Request stratified folds
    if (isTRUE(stratified) && length(label) == length(rnd_idx)) {
      
      y <- label[rnd_idx]
      y <- factor(y)
      folds <- lgb.stratified.folds(y, nfold)
      
    } else {
      
      # Make simple non-stratified folds
      folds <- list()
      
      # Loop through each fold
      for (i in 1:nfold) {
        kstep <- length(rnd_idx) %/% (nfold - i + 1)
        folds[[i]] <- rnd_idx[seq_len(kstep)]
        rnd_idx <- rnd_idx[-(seq_len(kstep))]
      }
      
    }
334
    
Guolin Ke's avatar
Guolin Ke committed
335
  } else {
336
    
337
338
339
340
341
342
343
344
345
346
347
    # When doing group, stratified is not possible (only random selection)
    if (nfold > length(group)) {
      stop("\n\tYou requested too many folds for the number of available groups.\n")
    }
    
    # Degroup the groups
    ungrouped <- inverse.rle(list(lengths = group, values = 1:length(group)))
    
    # Can't stratify, shuffle
    rnd_idx <- sample(seq_len(length(group)))
    
348
    # Make simple non-stratified folds
Guolin Ke's avatar
Guolin Ke committed
349
    folds <- list()
350
351
    
    # Loop through each fold
352
353
354
355
356
357
    for (i in 1:nfold) {
      kstep <- length(rnd_idx) %/% (nfold - i + 1)
      folds[[i]] <- list()
      folds[[i]][["fold"]] <- which(ungrouped %in% rnd_idx[1:kstep])
      folds[[i]][["group"]] <- rnd_idx[1:kstep]
      rnd_idx <- rnd_idx[-(1:kstep)]
Guolin Ke's avatar
Guolin Ke committed
358
    }
359
    
Guolin Ke's avatar
Guolin Ke committed
360
  }
361
362
363
364
  
  # Return folds
  return(folds)
  
Guolin Ke's avatar
Guolin Ke committed
365
366
367
368
369
}

# Creates CV folds stratified by the values of y.
# It was borrowed from caret::lgb.stratified.folds and simplified
# by always returning an unnamed list of fold indices.
370
lgb.stratified.folds <- function(y, k = 10) {
371
372
373
374
375
376
377
378
379
  
  ## Group the numeric data based on their magnitudes
  ## and sample within those groups.
  ## When the number of samples is low, we may have
  ## issues further slicing the numeric data into
  ## groups. The number of groups will depend on the
  ## ratio of the number of folds to the sample size.
  ## At most, we will use quantiles. If the sample
  ## is too small, we just do regular unstratified CV
Guolin Ke's avatar
Guolin Ke committed
380
  if (is.numeric(y)) {
381
    
Guolin Ke's avatar
Guolin Ke committed
382
    cuts <- floor(length(y) / k)
383
384
    if (cuts < 2) { cuts <- 2 }
    if (cuts > 5) { cuts <- 5 }
Guolin Ke's avatar
Guolin Ke committed
385
    y <- cut(y,
386
387
388
             unique(stats::quantile(y, probs = seq(0, 1, length = cuts))),
             include.lowest = TRUE)
    
Guolin Ke's avatar
Guolin Ke committed
389
  }
390
  
Guolin Ke's avatar
Guolin Ke committed
391
  if (k < length(y)) {
392
    ## Reset levels so that the possible levels and
Guolin Ke's avatar
Guolin Ke committed
393
394
395
396
    ## the levels in the vector are the same
    y <- factor(as.character(y))
    numInClass <- table(y)
    foldVector <- vector(mode = "integer", length(y))
397
    
Guolin Ke's avatar
Guolin Ke committed
398
399
400
    ## For each class, balance the fold allocation as far
    ## as possible, then resample the remainder.
    ## The final assignment of folds is also randomized.
401
    
402
    for (i in seq_along(numInClass)) {
403
404
      
      ## Create a vector of integers from 1:k as many times as possible without
Guolin Ke's avatar
Guolin Ke committed
405
406
      ## going over the number of samples in the class. Note that if the number
      ## of samples in a class is less than k, nothing is producd here.
407
      seqVector <- rep(seq_len(k), numInClass[i] %/% k)
408
409
      
      ## Add enough random integers to get  length(seqVector) == numInClass[i]
410
411
412
      if (numInClass[i] %% k > 0) {
        seqVector <- c(seqVector, sample(seq_len(k), numInClass[i] %% k))
      }
413
414
      
      ## Shuffle the integers for fold assignment and assign to this classes's data
415
      foldVector[y == dimnames(numInClass)$y[i]] <- sample(seqVector)
416
      
Guolin Ke's avatar
Guolin Ke committed
417
    }
418
    
Guolin Ke's avatar
Guolin Ke committed
419
  } else {
420
    
Guolin Ke's avatar
Guolin Ke committed
421
    foldVector <- seq(along = y)
422
    
Guolin Ke's avatar
Guolin Ke committed
423
  }
424
425
  
  # Return data
Guolin Ke's avatar
Guolin Ke committed
426
  out <- split(seq(along = y), foldVector)
427
  `names<-`(out, NULL)
Guolin Ke's avatar
Guolin Ke committed
428
429
}

430
431
432
433
434
435
436
437
lgb.merge.cv.result <- function(msg, showsd = TRUE) {
  
  # Get CV message length
  if (length(msg) == 0) {
    stop("lgb.cv: size of cv result error")
  }
  
  # Get evaluation message length
Guolin Ke's avatar
Guolin Ke committed
438
  eval_len <- length(msg[[1]])
439
440
441
442
443
444
445
  
  # Is evaluation message empty?
  if (eval_len == 0) {
    stop("lgb.cv: should provide at least one metric for CV")
  }
  
  # Get evaluation results using a list apply
446
  eval_result <- lapply(seq_len(eval_len), function(j) {
447
448
    as.numeric(lapply(seq_along(msg), function(i) {
      msg[[i]][[j]]$value }))
Guolin Ke's avatar
Guolin Ke committed
449
  })
450
451
  
  # Get evaluation
Guolin Ke's avatar
Guolin Ke committed
452
  ret_eval <- msg[[1]]
453
454
455
456
457
458
459
  
  # Go through evaluation length items
  for (j in seq_len(eval_len)) {
    ret_eval[[j]]$value <- mean(eval_result[[j]])
  }
  
  # Preinit evaluation error
Guolin Ke's avatar
Guolin Ke committed
460
  ret_eval_err <- NULL
461
462
  
  # Check for standard deviation
463
  if (showsd) {
464
465
    
    # Parse standard deviation
466
    for (j in seq_len(eval_len)) {
467
468
      ret_eval_err <- c(ret_eval_err,
                        sqrt(mean(eval_result[[j]] ^ 2) - mean(eval_result[[j]]) ^ 2))
Guolin Ke's avatar
Guolin Ke committed
469
    }
470
471
    
    # Convert to list
Guolin Ke's avatar
Guolin Ke committed
472
    ret_eval_err <- as.list(ret_eval_err)
473
    
Guolin Ke's avatar
Guolin Ke committed
474
  }
475
476
477
478
479
  
  # Return errors
  list(eval_list = ret_eval,
       eval_err_list = ret_eval_err)
  
480
}