lgb.cv.R 20.9 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
      for (x in self$boosters) {
        x[["booster"]]$reset_parameter(params = new_params)
17
      }
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
29
#' @param label Deprecated. See "Deprecated Arguments" section below.
#' @param weight Deprecated. See "Deprecated Arguments" section below.
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.
39
40
#' @param colnames Deprecated. See "Deprecated Arguments" section below.
#' @param categorical_feature Deprecated. See "Deprecated Arguments" section below.
41
42
43
#' @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
44
45
46
#' @param eval_train_metric \code{boolean}, whether to add the cross validation results on the
#'               training data. This parameter defaults to \code{FALSE}. Setting it to \code{TRUE}
#'               will increase run time.
47
#' @inheritSection lgb_shared_params Early Stopping
48
#' @return a trained model \code{lgb.CVBooster}.
49
#'
Guolin Ke's avatar
Guolin Ke committed
50
#' @examples
51
#' \donttest{
52
53
#' \dontshow{setLGBMthreads(2L)}
#' \dontshow{data.table::setDTthreads(1L)}
54
55
56
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
57
58
59
60
61
#' params <- list(
#'   objective = "regression"
#'   , metric = "l2"
#'   , min_data = 1L
#'   , learning_rate = 1.0
62
#'   , num_threads = 2L
63
#' )
64
65
66
#' model <- lgb.cv(
#'   params = params
#'   , data = dtrain
67
#'   , nrounds = 5L
68
#'   , nfold = 3L
69
#' )
70
#' }
71
72
73
74
75
76
77
#'
#' @section Deprecated Arguments:
#'
#' A future release of \code{lightgbm} will require passing an \code{lgb.Dataset}
#' to argument \code{'data'}. It will also remove support for passing arguments
#' \code{'categorical_feature'}, \code{'colnames'}, \code{'label'}, and \code{'weight'}.
#'
78
#' @importFrom data.table data.table setorderv
Guolin Ke's avatar
Guolin Ke committed
79
#' @export
80
81
lgb.cv <- function(params = list()
                   , data
82
                   , nrounds = 100L
83
84
85
86
87
88
89
90
                   , nfold = 3L
                   , label = NULL
                   , weight = NULL
                   , obj = NULL
                   , eval = NULL
                   , verbose = 1L
                   , record = TRUE
                   , eval_freq = 1L
91
                   , showsd = TRUE
92
93
94
95
96
97
98
99
                   , stratified = TRUE
                   , folds = NULL
                   , init_model = NULL
                   , colnames = NULL
                   , categorical_feature = NULL
                   , early_stopping_rounds = NULL
                   , callbacks = list()
                   , reset_data = FALSE
100
                   , serializable = TRUE
101
                   , eval_train_metric = FALSE
102
                   ) {
103

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

  # If 'data' is not an lgb.Dataset, try to construct one using 'label'
109
  if (!.is_Dataset(x = data)) {
110
111
112
113
    warning(paste0(
      "Passing anything other than an lgb.Dataset object to lgb.cv() is deprecated. "
      , "Either pass an lgb.Dataset object, or use lightgbm()."
    ))
114
115
116
    if (is.null(label)) {
      stop("'label' must be provided for lgb.cv if 'data' is not an 'lgb.Dataset'")
    }
117
    data <- lgb.Dataset(data = data, label = label)
118
119
  }

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
  # raise deprecation warnings if necessary
  # ref: https://github.com/microsoft/LightGBM/issues/6435
  args <- names(match.call())
  if ("categorical_feature" %in% args) {
    .emit_dataset_kwarg_warning("categorical_feature", "lgb.cv")
  }
  if ("colnames" %in% args) {
    .emit_dataset_kwarg_warning("colnames", "lgb.cv")
  }
  if ("label" %in% args) {
    .emit_dataset_kwarg_warning("label", "lgb.cv")
  }
  if ("weight" %in% args) {
    .emit_dataset_kwarg_warning("weight", "lgb.cv")
  }

136
137
138
139
  # 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
140
  params <- .check_wrapper_param(
141
142
143
144
    main_param_name = "verbosity"
    , params = params
    , alternative_kwarg_value = verbose
  )
145
  params <- .check_wrapper_param(
146
147
148
149
    main_param_name = "num_iterations"
    , params = params
    , alternative_kwarg_value = nrounds
  )
150
  params <- .check_wrapper_param(
151
152
153
154
    main_param_name = "metric"
    , params = params
    , alternative_kwarg_value = NULL
  )
155
  params <- .check_wrapper_param(
156
157
    main_param_name = "objective"
    , params = params
158
    , alternative_kwarg_value = obj
159
  )
160
  params <- .check_wrapper_param(
161
162
163
164
165
166
    main_param_name = "early_stopping_round"
    , params = params
    , alternative_kwarg_value = early_stopping_rounds
  )
  early_stopping_rounds <- params[["early_stopping_round"]]

167
168
  # extract any function objects passed for objective or metric
  fobj <- NULL
169
  if (is.function(params$objective)) {
Guolin Ke's avatar
Guolin Ke committed
170
    fobj <- params$objective
171
    params$objective <- "none"
Guolin Ke's avatar
Guolin Ke committed
172
  }
173

174
  # If eval is a single function, store it as a 1-element list
175
  # (for backwards compatibility). If it is a list of functions, store
176
177
  # all of them. This makes it possible to pass any mix of strings like "auc"
  # and custom functions to eval
178
  params <- .check_eval(params = params, eval = eval)
179
  eval_functions <- list(NULL)
180
  if (is.function(eval)) {
181
182
183
184
185
186
187
    eval_functions <- list(eval)
  }
  if (methods::is(eval, "list")) {
    eval_functions <- Filter(
      f = is.function
      , x = eval
    )
188
  }
189

190
  # Init predictor to empty
Guolin Ke's avatar
Guolin Ke committed
191
  predictor <- NULL
192

193
  # Check for boosting from a trained model
194
  if (is.character(init_model)) {
195
    predictor <- Predictor$new(modelfile = init_model)
196
  } else if (.is_Booster(x = init_model)) {
Guolin Ke's avatar
Guolin Ke committed
197
198
    predictor <- init_model$to_predictor()
  }
199

200
  # Set the iteration to start from / end to (and check for boosting from a trained model, again)
201
  begin_iteration <- 1L
202
  if (!is.null(predictor)) {
203
    begin_iteration <- predictor$current_iter() + 1L
Guolin Ke's avatar
Guolin Ke committed
204
  }
205
  end_iteration <- begin_iteration + params[["num_iterations"]] - 1L
206

207
208
209
210
211
  # 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

212
213
214
215
  # Construct datasets, if needed
  data$update_params(params = params)
  data$construct()

216
217
218
219
220
221
222
  # Check interaction constraints
  cnames <- NULL
  if (!is.null(colnames)) {
    cnames <- colnames
  } else if (!is.null(data$get_colnames())) {
    cnames <- data$get_colnames()
  }
223
  params[["interaction_constraints"]] <- .check_interaction_constraints(
224
225
226
    interaction_constraints = interaction_constraints
    , column_names = cnames
  )
227

228
  if (!is.null(weight)) {
229
    data$set_field(field_name = "weight", data = weight)
230
  }
231

232
  # Update parameters with parsed parameters
233
  data$update_params(params = params)
234

235
  # Create the predictor set
236
  data$.__enclos_env__$private$set_predictor(predictor = predictor)
237

238
239
  # Write column names
  if (!is.null(colnames)) {
240
    data$set_colnames(colnames = colnames)
241
  }
242

243
244
  # Write categorical features
  if (!is.null(categorical_feature)) {
245
    data$set_categorical_feature(categorical_feature = categorical_feature)
246
  }
247

248
  if (!is.null(folds)) {
249

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

Guolin Ke's avatar
Guolin Ke committed
255
  } else {
256

257
    if (nfold <= 1L) {
258
259
      stop(sQuote("nfold"), " must be > 1")
    }
260

261
    # Create folds
262
    folds <- .generate_cv_folds(
263
264
265
      nfold = nfold
      , nrows = nrow(data)
      , stratified = stratified
266
267
      , label = get_field(dataset = data, field_name = "label")
      , group = get_field(dataset = data, field_name = "group")
268
      , params = params
269
    )
270

Guolin Ke's avatar
Guolin Ke committed
271
  }
272

273
  # Add printing log callback
274
  if (params[["verbosity"]] > 0L && eval_freq > 0L) {
275
    callbacks <- .add_cb(cb_list = callbacks, cb = cb_print_evaluation(period = eval_freq))
Guolin Ke's avatar
Guolin Ke committed
276
  }
277

278
279
  # Add evaluation log callback
  if (record) {
280
    callbacks <- .add_cb(cb_list = callbacks, cb = cb_record_evaluation())
281
  }
282

283
  # Did user pass parameters that indicate they want to use early stopping?
284
  using_early_stopping <- !is.null(early_stopping_rounds) && early_stopping_rounds > 0L
285
286
287
288
289

  boosting_param_names <- .PARAMETER_ALIASES()[["boosting"]]
  using_dart <- any(
    sapply(
      X = boosting_param_names
290
291
      , FUN = function(param) {
        identical(params[[param]], "dart")
292
      }
293
294
295
296
    )
  )

  # Cannot use early stopping with 'dart' boosting
297
  if (using_dart) {
298
299
300
    if (using_early_stopping) {
      warning("Early stopping is not available in 'dart' mode.")
    }
301
    using_early_stopping <- FALSE
302

303
    # Remove the cb_early_stop() function if it was passed in to callbacks
304
    callbacks <- Filter(
305
      f = function(cb_func) {
306
        !identical(attr(cb_func, "name"), "cb_early_stop")
307
308
309
310
311
312
      }
      , x = callbacks
    )
  }

  # If user supplied early_stopping_rounds, add the early stopping callback
313
  if (using_early_stopping) {
314
    callbacks <- .add_cb(
315
      cb_list = callbacks
316
      , cb = cb_early_stop(
317
        stopping_rounds = early_stopping_rounds
318
        , first_metric_only = isTRUE(params[["first_metric_only"]])
319
        , verbose = params[["verbosity"]] > 0L
320
321
      )
    )
Guolin Ke's avatar
Guolin Ke committed
322
  }
323

324
  cb <- .categorize_callbacks(cb_list = callbacks)
325

326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
  # 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
343
344
        test_groups <- get_field(dataset = data, field_name = "group")[test_group_indices]
        train_groups <- get_field(dataset = data, field_name = "group")[-test_group_indices]
345
346
347
348
349
350
351
352
      } 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
353
354
        , weight = get_field(dataset = data, field_name = "weight")[test_indices]
        , init_score = get_field(dataset = data, field_name = "init_score")[test_indices]
355
      )
356
      data.table::setorderv(x = indexDT, cols = "indices", order = 1L)
357
      dtest <- lgb.slice.Dataset(data, indexDT$indices)
358
359
      set_field(dataset = dtest, field_name = "weight", data = indexDT$weight)
      set_field(dataset = dtest, field_name = "init_score", data = indexDT$init_score)
360
361
362
363

      # set up training set
      indexDT <- data.table::data.table(
        indices = train_indices
364
365
        , weight = get_field(dataset = data, field_name = "weight")[train_indices]
        , init_score = get_field(dataset = data, field_name = "init_score")[train_indices]
366
      )
367
      data.table::setorderv(x = indexDT, cols = "indices", order = 1L)
368
      dtrain <- lgb.slice.Dataset(data, indexDT$indices)
369
370
      set_field(dataset = dtrain, field_name = "weight", data = indexDT$weight)
      set_field(dataset = dtrain, field_name = "init_score", data = indexDT$init_score)
371
372

      if (folds_have_group) {
373
374
        set_field(dataset = dtest, field_name = "group", data = test_groups)
        set_field(dataset = dtrain, field_name = "group", data = train_groups)
375
376
      }

377
      booster <- Booster$new(params = params, train_set = dtrain)
378
379
380
      if (isTRUE(eval_train_metric)) {
        booster$add_valid(data = dtrain, name = "train")
      }
381
      booster$add_valid(data = dtest, name = "valid")
382
383
384
385
386
      return(
        list(booster = booster)
      )
    }
  )
387

388
  # Create new booster
389
  cv_booster <- CVBooster$new(x = bst_folds)
390

391
392
393
  # Callback env
  env <- CB_ENV$new()
  env$model <- cv_booster
Guolin Ke's avatar
Guolin Ke committed
394
  env$begin_iteration <- begin_iteration
395
  env$end_iteration <- end_iteration
396

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

400
    # Overwrite iteration in environment
Guolin Ke's avatar
Guolin Ke committed
401
402
    env$iteration <- i
    env$eval_list <- list()
403

404
405
406
    for (f in cb$pre_iter) {
      f(env)
    }
407

408
    # Update one boosting iteration
Guolin Ke's avatar
Guolin Ke committed
409
    msg <- lapply(cv_booster$boosters, function(fd) {
410
      fd$booster$update(fobj = fobj)
411
412
413
414
415
      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
416
    })
417

418
    # Prepare collection of evaluation results
419
    merged_msg <- .merge_cv_result(
420
421
422
      msg = msg
      , showsd = showsd
    )
423

424
    # Write evaluation result in environment
Guolin Ke's avatar
Guolin Ke committed
425
    env$eval_list <- merged_msg$eval_list
426

427
    # Check for standard deviation requirement
428
    if (showsd) {
429
430
      env$eval_err_list <- merged_msg$eval_err_list
    }
431

432
433
434
435
    # Loop through env
    for (f in cb$post_iter) {
      f(env)
    }
436

437
    # Check for early stopping and break if needed
438
    if (env$met_early_stop) break
439

Guolin Ke's avatar
Guolin Ke committed
440
  }
441

442
443
  # When early stopping is not activated, we compute the best iteration / score ourselves
  # based on the first first metric
444
  if (record && is.na(env$best_score)) {
445
446
447
448
449
450
451
    # 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]
    }
452
453
454
    .find_best <- which.min
    if (isTRUE(env$eval_list[[1L]]$higher_better[1L])) {
      .find_best <- which.max
455
    }
456
457
458
459
460
461
462
463
    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]]
464
  }
465
466
467
468
  # Propagate the best_iter attribute from the cv_booster to the individual boosters
  for (bst in cv_booster$boosters) {
    bst$booster$best_iter <- cv_booster$best_iter
  }
469

470
471
472
  if (reset_data) {
    lapply(cv_booster$boosters, function(fd) {
      # Store temporarily model data elsewhere
473
474
      booster_old <- list(
        best_iter = fd$booster$best_iter
475
        , best_score = fd$booster$best_score
476
477
        , record_evals = fd$booster$record_evals
      )
478
479
480
481
482
483
484
      # 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
    })
  }
485

486
487
488
489
  if (serializable) {
    lapply(cv_booster$boosters, function(model) model$booster$save_raw())
  }

490
  return(cv_booster)
491

Guolin Ke's avatar
Guolin Ke committed
492
493
494
}

# Generates random (stratified if needed) CV folds
495
.generate_cv_folds <- function(nfold, nrows, stratified, label, group, params) {
496

497
498
  # Check for group existence
  if (is.null(group)) {
499

500
    # Shuffle
501
    rnd_idx <- sample.int(nrows)
502

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

506
      y <- label[rnd_idx]
507
      y <- as.factor(y)
508
      folds <- .stratified_folds(y = y, k = nfold)
509

510
    } else {
511

512
513
      # Make simple non-stratified folds
      folds <- list()
514

515
      # Loop through each fold
516
      for (i in seq_len(nfold)) {
517
        kstep <- length(rnd_idx) %/% (nfold - i + 1L)
518
        folds[[i]] <- rnd_idx[seq_len(kstep)]
519
        rnd_idx <- rnd_idx[-seq_len(kstep)]
520
      }
521

522
    }
523

Guolin Ke's avatar
Guolin Ke committed
524
  } else {
525

526
527
    # When doing group, stratified is not possible (only random selection)
    if (nfold > length(group)) {
528
      stop("\nYou requested too many folds for the number of available groups.\n")
529
    }
530

531
    # Degroup the groups
532
    ungrouped <- inverse.rle(list(lengths = group, values = seq_along(group)))
533

534
    # Can't stratify, shuffle
535
    rnd_idx <- sample.int(length(group))
536

537
    # Make simple non-stratified folds
Guolin Ke's avatar
Guolin Ke committed
538
    folds <- list()
539

540
    # Loop through each fold
541
    for (i in seq_len(nfold)) {
542
      kstep <- length(rnd_idx) %/% (nfold - i + 1L)
543
544
545
546
      folds[[i]] <- list(
        fold = which(ungrouped %in% rnd_idx[seq_len(kstep)])
        , group = rnd_idx[seq_len(kstep)]
      )
547
      rnd_idx <- rnd_idx[-seq_len(kstep)]
Guolin Ke's avatar
Guolin Ke committed
548
    }
549

Guolin Ke's avatar
Guolin Ke committed
550
  }
551

552
  return(folds)
553

Guolin Ke's avatar
Guolin Ke committed
554
555
556
}

# Creates CV folds stratified by the values of y.
557
# It was borrowed from caret::createFolds and simplified
Guolin Ke's avatar
Guolin Ke committed
558
# by always returning an unnamed list of fold indices.
559
#' @importFrom stats quantile
560
.stratified_folds <- function(y, k) {
561

562
563
564
565
566
567
568
569
  # 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
570
  if (is.numeric(y)) {
571

572
    cuts <- length(y) %/% k
573
574
    if (cuts < 2L) {
      cuts <- 2L
575
    }
576
577
    if (cuts > 5L) {
      cuts <- 5L
578
579
580
    }
    y <- cut(
      y
581
      , unique(stats::quantile(y, probs = seq.int(0.0, 1.0, length.out = cuts)))
582
583
      , include.lowest = TRUE
    )
584

Guolin Ke's avatar
Guolin Ke committed
585
  }
586

Guolin Ke's avatar
Guolin Ke committed
587
  if (k < length(y)) {
588

589
590
    # Reset levels so that the possible levels and
    # the levels in the vector are the same
591
    y <- as.factor(as.character(y))
Guolin Ke's avatar
Guolin Ke committed
592
593
    numInClass <- table(y)
    foldVector <- vector(mode = "integer", length(y))
594

595
596
597
    # For each class, balance the fold allocation as far
    # as possible, then resample the remainder.
    # The final assignment of folds is also randomized.
598
    for (i in seq_along(numInClass)) {
599

600
601
602
      # Create a vector of integers from 1:k as many times as possible without
      # 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 produced here.
603
      seqVector <- rep(seq_len(k), numInClass[i] %/% k)
604

605
      # Add enough random integers to get length(seqVector) == numInClass[i]
606
      if (numInClass[i] %% k > 0L) {
607
        seqVector <- c(seqVector, sample.int(k, numInClass[i] %% k))
608
      }
609

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

Guolin Ke's avatar
Guolin Ke committed
613
    }
614

Guolin Ke's avatar
Guolin Ke committed
615
  } else {
616

Guolin Ke's avatar
Guolin Ke committed
617
    foldVector <- seq(along = y)
618

Guolin Ke's avatar
Guolin Ke committed
619
  }
620

Guolin Ke's avatar
Guolin Ke committed
621
  out <- split(seq(along = y), foldVector)
622
  names(out) <- NULL
623
  return(out)
Guolin Ke's avatar
Guolin Ke committed
624
625
}

626
.merge_cv_result <- function(msg, showsd) {
627

628
  if (length(msg) == 0L) {
629
630
    stop("lgb.cv: size of cv result error")
  }
631

632
  eval_len <- length(msg[[1L]])
633

634
  if (eval_len == 0L) {
635
636
    stop("lgb.cv: should provide at least one metric for CV")
  }
637

638
  # Get evaluation results using a list apply
639
  eval_result <- lapply(seq_len(eval_len), function(j) {
640
641
    as.numeric(lapply(seq_along(msg), function(i) {
      msg[[i]][[j]]$value }))
Guolin Ke's avatar
Guolin Ke committed
642
  })
643

644
  # Get evaluation. Just taking the first element here to
645
  # get structure (name, higher_better, data_name)
646
  ret_eval <- msg[[1L]]
647

648
649
650
  for (j in seq_len(eval_len)) {
    ret_eval[[j]]$value <- mean(eval_result[[j]])
  }
651

Guolin Ke's avatar
Guolin Ke committed
652
  ret_eval_err <- NULL
653

654
  # Check for standard deviation
655
  if (showsd) {
656

657
    # Parse standard deviation
658
    for (j in seq_len(eval_len)) {
659
660
      ret_eval_err <- c(
        ret_eval_err
661
        , sqrt(mean(eval_result[[j]] ^ 2L) - mean(eval_result[[j]]) ^ 2L)
662
      )
Guolin Ke's avatar
Guolin Ke committed
663
    }
664

Guolin Ke's avatar
Guolin Ke committed
665
    ret_eval_err <- as.list(ret_eval_err)
666

Guolin Ke's avatar
Guolin Ke committed
667
  }
668

669
670
671
672
673
  return(
    list(
      eval_list = ret_eval
      , eval_err_list = ret_eval_err
    )
674
  )
675

676
}