lgb.cv.R 20.7 KB
Newer Older
James Lamb's avatar
James Lamb committed
1
2
#' @importFrom R6 R6Class
CVBooster <- R6::R6Class(
3
  classname = "lgb.CVBooster",
4
  cloneable = FALSE,
Guolin Ke's avatar
Guolin Ke committed
5
  public = list(
6
    best_iter = -1L,
7
    best_score = NA,
Guolin Ke's avatar
Guolin Ke committed
8
    record_evals = list(),
9
10
    boosters = list(),
    initialize = function(x) {
Guolin Ke's avatar
Guolin Ke committed
11
      self$boosters <- x
12
      return(invisible(NULL))
13
    },
14
    reset_parameter = function(new_params) {
15
16
17
      for (x in boosters) {
        x$reset_parameter(params = new_params)
      }
18
      return(invisible(self))
Guolin Ke's avatar
Guolin Ke committed
19
20
21
22
    }
  )
)

23
#' @name lgb.cv
James Lamb's avatar
James Lamb committed
24
#' @title Main CV logic for LightGBM
James Lamb's avatar
James Lamb committed
25
26
#' @description Cross validation logic used by LightGBM
#' @inheritParams lgb_shared_params
27
#' @param nfold the original dataset is randomly partitioned into \code{nfold} equal size subsamples.
28
#' @param label Vector of labels, used if \code{data} is not an \code{\link{lgb.Dataset}}
29
#' @param weight vector of response values. If not NULL, will set to dataset
30
#' @param record Boolean, TRUE will record iteration message to \code{booster$record_evals}
31
32
33
#' @param showsd \code{boolean}, whether to show standard deviation of cross validation.
#'               This parameter defaults to \code{TRUE}. Setting it to \code{FALSE} can lead to a
#'               slight speedup by avoiding unnecessary computation.
34
#' @param stratified a \code{boolean} indicating whether sampling of folds should be stratified
35
#'                   by the values of outcome labels.
Guolin Ke's avatar
Guolin Ke committed
36
#' @param folds \code{list} provides a possibility to use a list of pre-defined CV folds
37
38
#'              (each element must be a vector of test fold's indices). When folds are supplied,
#'              the \code{nfold} and \code{stratified} parameters are ignored.
Guolin Ke's avatar
Guolin Ke committed
39
#' @param colnames feature names, if not null, will use this to overwrite the names in dataset
40
41
42
#' @param categorical_feature categorical features. This can either be a character vector of feature
#'                            names or an integer vector with the indices of the features (e.g.
#'                            \code{c(1L, 10L)} to say "the first and tenth columns").
43
44
45
#' @param callbacks List of callback functions that are applied at each iteration.
#' @param reset_data Boolean, setting it to TRUE (not the default value) will transform the booster model
#'                   into a predictor model which frees up memory and the original datasets
James Lamb's avatar
James Lamb committed
46
47
#' @param ... other parameters, see Parameters.rst for more information. A few key parameters:
#'            \itemize{
48
49
50
#'                \item{\code{boosting}: Boosting type. \code{"gbdt"}, \code{"rf"}, \code{"dart"} or \code{"goss"}.}
#'                \item{\code{num_leaves}: Maximum number of leaves in one tree.}
#'                \item{\code{max_depth}: Limit the max depth for tree model. This is used to deal with
James Lamb's avatar
James Lamb committed
51
#'                                 overfit when #data is small. Tree still grow by leaf-wise.}
52
#'                \item{\code{num_threads}: Number of threads for LightGBM. For the best speed, set this to
53
54
55
#'                             the number of real CPU cores(\code{parallel::detectCores(logical = FALSE)}),
#'                             not the number of threads (most CPU using hyper-threading to generate 2 threads
#'                             per CPU core).}
James Lamb's avatar
James Lamb committed
56
#'            }
57
#'            NOTE: As of v3.3.0, use of \code{...} is deprecated. Add parameters to \code{params} directly.
58
#' @inheritSection lgb_shared_params Early Stopping
59
#' @return a trained model \code{lgb.CVBooster}.
60
#'
Guolin Ke's avatar
Guolin Ke committed
61
#' @examples
62
#' \donttest{
63
64
65
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
66
67
68
69
70
71
#' params <- list(
#'   objective = "regression"
#'   , metric = "l2"
#'   , min_data = 1L
#'   , learning_rate = 1.0
#' )
72
73
74
#' model <- lgb.cv(
#'   params = params
#'   , data = dtrain
75
#'   , nrounds = 5L
76
#'   , nfold = 3L
77
#' )
78
#' }
79
#' @importFrom data.table data.table setorderv
Guolin Ke's avatar
Guolin Ke committed
80
#' @export
81
82
lgb.cv <- function(params = list()
                   , data
83
                   , nrounds = 100L
84
85
86
87
88
89
90
91
                   , nfold = 3L
                   , label = NULL
                   , weight = NULL
                   , obj = NULL
                   , eval = NULL
                   , verbose = 1L
                   , record = TRUE
                   , eval_freq = 1L
92
                   , showsd = TRUE
93
94
95
96
97
98
99
100
                   , stratified = TRUE
                   , folds = NULL
                   , init_model = NULL
                   , colnames = NULL
                   , categorical_feature = NULL
                   , early_stopping_rounds = NULL
                   , callbacks = list()
                   , reset_data = FALSE
101
                   , serializable = TRUE
102
103
                   , ...
                   ) {
104

105
106
107
108
109
  if (nrounds <= 0L) {
    stop("nrounds should be greater than zero")
  }

  # If 'data' is not an lgb.Dataset, try to construct one using 'label'
110
  if (!lgb.is.Dataset(x = data)) {
111
112
113
    if (is.null(label)) {
      stop("'label' must be provided for lgb.cv if 'data' is not an 'lgb.Dataset'")
    }
114
    data <- lgb.Dataset(data = data, label = label)
115
116
  }

117
  # Setup temporary variables
118
119
  additional_params <- list(...)
  params <- append(params, additional_params)
120
  params$verbose <- verbose
121
122
  params <- lgb.check.obj(params = params, obj = obj)
  params <- lgb.check.eval(params = params, eval = eval)
123
  fobj <- NULL
124
  eval_functions <- list(NULL)
125

126
127
128
129
130
131
132
133
134
  if (length(additional_params) > 0L) {
    warning(paste0(
      "lgb.cv: Found the following passed through '...': "
      , paste(names(additional_params), collapse = ", ")
      , ". These will be used, but in future releases of lightgbm, this warning will become an error. "
      , "Add these to 'params' instead. See ?lgb.cv for documentation on how to call this function."
    ))
  }

135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
  # set some parameters, resolving the way they were passed in with other parameters
  # in `params`.
  # this ensures that the model stored with Booster$save() correctly represents
  # what was passed in
  params <- lgb.check.wrapper_param(
    main_param_name = "num_iterations"
    , params = params
    , alternative_kwarg_value = nrounds
  )
  params <- lgb.check.wrapper_param(
    main_param_name = "early_stopping_round"
    , params = params
    , alternative_kwarg_value = early_stopping_rounds
  )
  early_stopping_rounds <- params[["early_stopping_round"]]

151
  # Check for objective (function or not)
152
  if (is.function(params$objective)) {
Guolin Ke's avatar
Guolin Ke committed
153
154
155
    fobj <- params$objective
    params$objective <- "NONE"
  }
156

157
  # If eval is a single function, store it as a 1-element list
158
  # (for backwards compatibility). If it is a list of functions, store
159
160
  # all of them. This makes it possible to pass any mix of strings like "auc"
  # and custom functions to eval
161
  if (is.function(eval)) {
162
163
164
165
166
167
168
    eval_functions <- list(eval)
  }
  if (methods::is(eval, "list")) {
    eval_functions <- Filter(
      f = is.function
      , x = eval
    )
169
  }
170

171
  # Init predictor to empty
Guolin Ke's avatar
Guolin Ke committed
172
  predictor <- NULL
173

174
  # Check for boosting from a trained model
175
  if (is.character(init_model)) {
176
177
    predictor <- Predictor$new(modelfile = init_model)
  } else if (lgb.is.Booster(x = init_model)) {
Guolin Ke's avatar
Guolin Ke committed
178
179
    predictor <- init_model$to_predictor()
  }
180

181
  # Set the iteration to start from / end to (and check for boosting from a trained model, again)
182
  begin_iteration <- 1L
183
  if (!is.null(predictor)) {
184
    begin_iteration <- predictor$current_iter() + 1L
Guolin Ke's avatar
Guolin Ke committed
185
  }
186
  end_iteration <- begin_iteration + params[["num_iterations"]] - 1L
187

188
189
190
191
192
  # pop interaction_constraints off of params. It needs some preprocessing on the
  # R side before being passed into the Dataset object
  interaction_constraints <- params[["interaction_constraints"]]
  params["interaction_constraints"] <- NULL

193
194
195
196
  # Construct datasets, if needed
  data$update_params(params = params)
  data$construct()

197
198
199
200
201
202
203
  # Check interaction constraints
  cnames <- NULL
  if (!is.null(colnames)) {
    cnames <- colnames
  } else if (!is.null(data$get_colnames())) {
    cnames <- data$get_colnames()
  }
204
205
206
207
  params[["interaction_constraints"]] <- lgb.check_interaction_constraints(
    interaction_constraints = interaction_constraints
    , column_names = cnames
  )
208

209
  if (!is.null(weight)) {
210
    data$set_field(field_name = "weight", data = weight)
211
  }
212

213
  # Update parameters with parsed parameters
214
  data$update_params(params = params)
215

216
  # Create the predictor set
217
  data$.__enclos_env__$private$set_predictor(predictor = predictor)
218

219
220
  # Write column names
  if (!is.null(colnames)) {
221
    data$set_colnames(colnames = colnames)
222
  }
223

224
225
  # Write categorical features
  if (!is.null(categorical_feature)) {
226
    data$set_categorical_feature(categorical_feature = categorical_feature)
227
  }
228

229
  if (!is.null(folds)) {
230

231
    # Check for list of folds or for single value
232
    if (!identical(class(folds), "list") || length(folds) < 2L) {
233
      stop(sQuote("folds"), " must be a list with 2 or more elements that are vectors of indices for each CV-fold")
234
    }
235

Guolin Ke's avatar
Guolin Ke committed
236
    nfold <- length(folds)
237

Guolin Ke's avatar
Guolin Ke committed
238
  } else {
239

240
    if (nfold <= 1L) {
241
242
      stop(sQuote("nfold"), " must be > 1")
    }
243

244
    # Create folds
245
    folds <- generate.cv.folds(
246
247
248
      nfold = nfold
      , nrows = nrow(data)
      , stratified = stratified
249
250
      , label = get_field(dataset = data, field_name = "label")
      , group = get_field(dataset = data, field_name = "group")
251
      , params = params
252
    )
253

Guolin Ke's avatar
Guolin Ke committed
254
  }
255

256
  # Add printing log callback
257
  if (verbose > 0L && eval_freq > 0L) {
258
    callbacks <- add.cb(cb_list = callbacks, cb = cb.print.evaluation(period = eval_freq))
Guolin Ke's avatar
Guolin Ke committed
259
  }
260

261
262
  # Add evaluation log callback
  if (record) {
263
    callbacks <- add.cb(cb_list = callbacks, cb = cb.record.evaluation())
264
  }
265

266
  # Did user pass parameters that indicate they want to use early stopping?
267
  using_early_stopping <- !is.null(early_stopping_rounds) && early_stopping_rounds > 0L
268
269
270
271
272

  boosting_param_names <- .PARAMETER_ALIASES()[["boosting"]]
  using_dart <- any(
    sapply(
      X = boosting_param_names
273
274
      , FUN = function(param) {
        identical(params[[param]], "dart")
275
      }
276
277
278
279
    )
  )

  # Cannot use early stopping with 'dart' boosting
280
  if (using_dart) {
281
    warning("Early stopping is not available in 'dart' mode.")
282
    using_early_stopping <- FALSE
283
284
285

    # Remove the cb.early.stop() function if it was passed in to callbacks
    callbacks <- Filter(
286
      f = function(cb_func) {
287
288
289
290
291
292
293
        !identical(attr(cb_func, "name"), "cb.early.stop")
      }
      , x = callbacks
    )
  }

  # If user supplied early_stopping_rounds, add the early stopping callback
294
  if (using_early_stopping) {
295
    callbacks <- add.cb(
296
297
      cb_list = callbacks
      , cb = cb.early.stop(
298
        stopping_rounds = early_stopping_rounds
299
        , first_metric_only = isTRUE(params[["first_metric_only"]])
300
301
302
        , verbose = verbose
      )
    )
Guolin Ke's avatar
Guolin Ke committed
303
  }
304

305
  cb <- categorize.callbacks(cb_list = callbacks)
306

307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
  # Construct booster for each fold. The data.table() code below is used to
  # guarantee that indices are sorted while keeping init_score and weight together
  # with the correct indices. Note that it takes advantage of the fact that
  # someDT$some_column returns NULL is 'some_column' does not exist in the data.table
  bst_folds <- lapply(
    X = seq_along(folds)
    , FUN = function(k) {

      # For learning-to-rank, each fold is a named list with two elements:
      #   * `fold` = an integer vector of row indices
      #   * `group` = an integer vector describing which groups are in the fold
      # For classification or regression tasks, it will just be an integer
      # vector of row indices
      folds_have_group <- "group" %in% names(folds[[k]])
      if (folds_have_group) {
        test_indices <- folds[[k]]$fold
        test_group_indices <- folds[[k]]$group
324
325
        test_groups <- get_field(dataset = data, field_name = "group")[test_group_indices]
        train_groups <- get_field(dataset = data, field_name = "group")[-test_group_indices]
326
327
328
329
330
331
332
333
      } else {
        test_indices <- folds[[k]]
      }
      train_indices <- seq_len(nrow(data))[-test_indices]

      # set up test set
      indexDT <- data.table::data.table(
        indices = test_indices
334
335
        , weight = get_field(dataset = data, field_name = "weight")[test_indices]
        , init_score = get_field(dataset = data, field_name = "init_score")[test_indices]
336
      )
337
      data.table::setorderv(x = indexDT, cols = "indices", order = 1L)
338
      dtest <- slice(data, indexDT$indices)
339
340
      set_field(dataset = dtest, field_name = "weight", data = indexDT$weight)
      set_field(dataset = dtest, field_name = "init_score", data = indexDT$init_score)
341
342
343
344

      # set up training set
      indexDT <- data.table::data.table(
        indices = train_indices
345
346
        , weight = get_field(dataset = data, field_name = "weight")[train_indices]
        , init_score = get_field(dataset = data, field_name = "init_score")[train_indices]
347
      )
348
      data.table::setorderv(x = indexDT, cols = "indices", order = 1L)
349
      dtrain <- slice(data, indexDT$indices)
350
351
      set_field(dataset = dtrain, field_name = "weight", data = indexDT$weight)
      set_field(dataset = dtrain, field_name = "init_score", data = indexDT$init_score)
352
353

      if (folds_have_group) {
354
355
        set_field(dataset = dtest, field_name = "group", data = test_groups)
        set_field(dataset = dtrain, field_name = "group", data = train_groups)
356
357
      }

358
359
      booster <- Booster$new(params = params, train_set = dtrain)
      booster$add_valid(data = dtest, name = "valid")
360
361
362
363
364
      return(
        list(booster = booster)
      )
    }
  )
365

366
  # Create new booster
367
  cv_booster <- CVBooster$new(x = bst_folds)
368

369
370
371
  # Callback env
  env <- CB_ENV$new()
  env$model <- cv_booster
Guolin Ke's avatar
Guolin Ke committed
372
  env$begin_iteration <- begin_iteration
373
  env$end_iteration <- end_iteration
374

375
  # Start training model using number of iterations to start and end with
376
  for (i in seq.int(from = begin_iteration, to = end_iteration)) {
377

378
    # Overwrite iteration in environment
Guolin Ke's avatar
Guolin Ke committed
379
380
    env$iteration <- i
    env$eval_list <- list()
381

382
383
384
    for (f in cb$pre_iter) {
      f(env)
    }
385

386
    # Update one boosting iteration
Guolin Ke's avatar
Guolin Ke committed
387
    msg <- lapply(cv_booster$boosters, function(fd) {
388
      fd$booster$update(fobj = fobj)
389
390
391
392
393
      out <- list()
      for (eval_function in eval_functions) {
        out <- append(out, fd$booster$eval_valid(feval = eval_function))
      }
      return(out)
Guolin Ke's avatar
Guolin Ke committed
394
    })
395

396
    # Prepare collection of evaluation results
397
398
399
400
    merged_msg <- lgb.merge.cv.result(
      msg = msg
      , showsd = showsd
    )
401

402
    # Write evaluation result in environment
Guolin Ke's avatar
Guolin Ke committed
403
    env$eval_list <- merged_msg$eval_list
404

405
    # Check for standard deviation requirement
406
    if (showsd) {
407
408
      env$eval_err_list <- merged_msg$eval_err_list
    }
409

410
411
412
413
    # Loop through env
    for (f in cb$post_iter) {
      f(env)
    }
414

415
    # Check for early stopping and break if needed
416
    if (env$met_early_stop) break
417

Guolin Ke's avatar
Guolin Ke committed
418
  }
419

420
421
  # When early stopping is not activated, we compute the best iteration / score ourselves
  # based on the first first metric
422
  if (record && is.na(env$best_score)) {
423
424
425
426
427
428
429
    # when using a custom eval function, the metric name is returned from the
    # function, so figure it out from record_evals
    if (!is.null(eval_functions[1L])) {
      first_metric <- names(cv_booster$record_evals[["valid"]])[1L]
    } else {
      first_metric <- cv_booster$.__enclos_env__$private$eval_names[1L]
    }
430
431
432
    .find_best <- which.min
    if (isTRUE(env$eval_list[[1L]]$higher_better[1L])) {
      .find_best <- which.max
433
    }
434
435
436
437
438
439
440
441
    cv_booster$best_iter <- unname(
      .find_best(
        unlist(
          cv_booster$record_evals[["valid"]][[first_metric]][[.EVAL_KEY()]]
        )
      )
    )
    cv_booster$best_score <- cv_booster$record_evals[["valid"]][[first_metric]][[.EVAL_KEY()]][[cv_booster$best_iter]]
442
  }
443

444
445
446
  if (reset_data) {
    lapply(cv_booster$boosters, function(fd) {
      # Store temporarily model data elsewhere
447
448
      booster_old <- list(
        best_iter = fd$booster$best_iter
449
        , best_score = fd$booster$best_score
450
451
        , record_evals = fd$booster$record_evals
      )
452
453
454
455
456
457
458
      # Reload model
      fd$booster <- lgb.load(model_str = fd$booster$save_model_to_string())
      fd$booster$best_iter <- booster_old$best_iter
      fd$booster$best_score <- booster_old$best_score
      fd$booster$record_evals <- booster_old$record_evals
    })
  }
459

460
461
462
463
  if (serializable) {
    lapply(cv_booster$boosters, function(model) model$booster$save_raw())
  }

464
  return(cv_booster)
465

Guolin Ke's avatar
Guolin Ke committed
466
467
468
}

# Generates random (stratified if needed) CV folds
469
generate.cv.folds <- function(nfold, nrows, stratified, label, group, params) {
470

471
472
  # Check for group existence
  if (is.null(group)) {
473

474
    # Shuffle
475
    rnd_idx <- sample.int(nrows)
476

477
    # Request stratified folds
478
    if (isTRUE(stratified) && params$objective %in% c("binary", "multiclass") && length(label) == length(rnd_idx)) {
479

480
      y <- label[rnd_idx]
481
      y <- as.factor(y)
482
      folds <- lgb.stratified.folds(y = y, k = nfold)
483

484
    } else {
485

486
487
      # Make simple non-stratified folds
      folds <- list()
488

489
      # Loop through each fold
490
      for (i in seq_len(nfold)) {
491
        kstep <- length(rnd_idx) %/% (nfold - i + 1L)
492
        folds[[i]] <- rnd_idx[seq_len(kstep)]
493
        rnd_idx <- rnd_idx[-seq_len(kstep)]
494
      }
495

496
    }
497

Guolin Ke's avatar
Guolin Ke committed
498
  } else {
499

500
501
    # When doing group, stratified is not possible (only random selection)
    if (nfold > length(group)) {
502
      stop("\nYou requested too many folds for the number of available groups.\n")
503
    }
504

505
    # Degroup the groups
506
    ungrouped <- inverse.rle(list(lengths = group, values = seq_along(group)))
507

508
    # Can't stratify, shuffle
509
    rnd_idx <- sample.int(length(group))
510

511
    # Make simple non-stratified folds
Guolin Ke's avatar
Guolin Ke committed
512
    folds <- list()
513

514
    # Loop through each fold
515
    for (i in seq_len(nfold)) {
516
      kstep <- length(rnd_idx) %/% (nfold - i + 1L)
517
518
519
520
      folds[[i]] <- list(
        fold = which(ungrouped %in% rnd_idx[seq_len(kstep)])
        , group = rnd_idx[seq_len(kstep)]
      )
521
      rnd_idx <- rnd_idx[-seq_len(kstep)]
Guolin Ke's avatar
Guolin Ke committed
522
    }
523

Guolin Ke's avatar
Guolin Ke committed
524
  }
525

526
  return(folds)
527

Guolin Ke's avatar
Guolin Ke committed
528
529
530
}

# Creates CV folds stratified by the values of y.
531
# It was borrowed from caret::createFolds and simplified
Guolin Ke's avatar
Guolin Ke committed
532
# by always returning an unnamed list of fold indices.
533
#' @importFrom stats quantile
534
lgb.stratified.folds <- function(y, k) {
535

536
537
538
539
540
541
542
543
  ## 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
544
  if (is.numeric(y)) {
545

546
    cuts <- length(y) %/% k
547
548
    if (cuts < 2L) {
      cuts <- 2L
549
    }
550
551
    if (cuts > 5L) {
      cuts <- 5L
552
553
554
    }
    y <- cut(
      y
555
      , unique(stats::quantile(y, probs = seq.int(0.0, 1.0, length.out = cuts)))
556
557
      , include.lowest = TRUE
    )
558

Guolin Ke's avatar
Guolin Ke committed
559
  }
560

Guolin Ke's avatar
Guolin Ke committed
561
  if (k < length(y)) {
562

563
    ## Reset levels so that the possible levels and
Guolin Ke's avatar
Guolin Ke committed
564
    ## the levels in the vector are the same
565
    y <- as.factor(as.character(y))
Guolin Ke's avatar
Guolin Ke committed
566
567
    numInClass <- table(y)
    foldVector <- vector(mode = "integer", length(y))
568

Guolin Ke's avatar
Guolin Ke committed
569
570
571
    ## For each class, balance the fold allocation as far
    ## as possible, then resample the remainder.
    ## The final assignment of folds is also randomized.
572

573
    for (i in seq_along(numInClass)) {
574

575
      ## Create a vector of integers from 1:k as many times as possible without
Guolin Ke's avatar
Guolin Ke committed
576
577
      ## 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.
578
      seqVector <- rep(seq_len(k), numInClass[i] %/% k)
579

580
      ## Add enough random integers to get length(seqVector) == numInClass[i]
581
      if (numInClass[i] %% k > 0L) {
582
        seqVector <- c(seqVector, sample.int(k, numInClass[i] %% k))
583
      }
584

585
      ## Shuffle the integers for fold assignment and assign to this classes's data
586
      foldVector[y == dimnames(numInClass)$y[i]] <- sample(seqVector)
587

Guolin Ke's avatar
Guolin Ke committed
588
    }
589

Guolin Ke's avatar
Guolin Ke committed
590
  } else {
591

Guolin Ke's avatar
Guolin Ke committed
592
    foldVector <- seq(along = y)
593

Guolin Ke's avatar
Guolin Ke committed
594
  }
595

Guolin Ke's avatar
Guolin Ke committed
596
  out <- split(seq(along = y), foldVector)
597
  names(out) <- NULL
598
  return(out)
Guolin Ke's avatar
Guolin Ke committed
599
600
}

601
lgb.merge.cv.result <- function(msg, showsd) {
602

603
  if (length(msg) == 0L) {
604
605
    stop("lgb.cv: size of cv result error")
  }
606

607
  eval_len <- length(msg[[1L]])
608

609
  if (eval_len == 0L) {
610
611
    stop("lgb.cv: should provide at least one metric for CV")
  }
612

613
  # Get evaluation results using a list apply
614
  eval_result <- lapply(seq_len(eval_len), function(j) {
615
616
    as.numeric(lapply(seq_along(msg), function(i) {
      msg[[i]][[j]]$value }))
Guolin Ke's avatar
Guolin Ke committed
617
  })
618

619
  # Get evaluation. Just taking the first element here to
620
  # get structure (name, higher_better, data_name)
621
  ret_eval <- msg[[1L]]
622

623
624
625
  for (j in seq_len(eval_len)) {
    ret_eval[[j]]$value <- mean(eval_result[[j]])
  }
626

Guolin Ke's avatar
Guolin Ke committed
627
  ret_eval_err <- NULL
628

629
  # Check for standard deviation
630
  if (showsd) {
631

632
    # Parse standard deviation
633
    for (j in seq_len(eval_len)) {
634
635
      ret_eval_err <- c(
        ret_eval_err
636
        , sqrt(mean(eval_result[[j]] ^ 2L) - mean(eval_result[[j]]) ^ 2L)
637
      )
Guolin Ke's avatar
Guolin Ke committed
638
    }
639

Guolin Ke's avatar
Guolin Ke committed
640
    ret_eval_err <- as.list(ret_eval_err)
641

Guolin Ke's avatar
Guolin Ke committed
642
  }
643

644
645
646
647
648
  return(
    list(
      eval_list = ret_eval
      , eval_err_list = ret_eval_err
    )
649
  )
650

651
}