utils.R 10.2 KB
Newer Older
1
lgb.is.Booster <- function(x) {
2
  return(lgb.check.r6.class(object = x, name = "lgb.Booster"))
3
}
4

5
lgb.is.Dataset <- function(x) {
6
  return(lgb.check.r6.class(object = x, name = "lgb.Dataset"))
7
}
8

Guolin Ke's avatar
Guolin Ke committed
9
10
11
12
13
14
15
16
lgb.null.handle <- function() {
  if (.Machine$sizeof.pointer == 8L) {
    return(NA_real_)
  } else {
    return(NA_integer_)
  }
}

17
lgb.is.null.handle <- function(x) {
18
  return(is.null(x) || is.na(x))
19
}
Guolin Ke's avatar
Guolin Ke committed
20
21

lgb.encode.char <- function(arr, len) {
22
  if (!is.raw(arr)) {
23
    stop("lgb.encode.char: Can only encode from raw type")
Guolin Ke's avatar
Guolin Ke committed
24
  }
25
  return(rawToChar(arr[seq_len(len)]))
Guolin Ke's avatar
Guolin Ke committed
26
27
}

28
29
# [description] Raise an error. Before raising that error, check for any error message
#               stored in a buffer on the C++ side.
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
lgb.last_error <- function() {
  # Perform text error buffering
  buf_len <- 200L
  act_len <- 0L
  err_msg <- raw(buf_len)
  err_msg <- .Call(
    "LGBM_GetLastError_R"
    , buf_len
    , act_len
    , err_msg
    , PACKAGE = "lib_lightgbm"
  )

  # Check error buffer
  if (act_len > buf_len) {
    buf_len <- act_len
    err_msg <- raw(buf_len)
    err_msg <- .Call(
      "LGBM_GetLastError_R"
      , buf_len
      , act_len
      , err_msg
      , PACKAGE = "lib_lightgbm"
    )
  }

56
  stop("api error: ", lgb.encode.char(arr = err_msg, len = act_len))
57
58
59

  return(invisible(NULL))

60
61
}

Guolin Ke's avatar
Guolin Ke committed
62
lgb.call <- function(fun_name, ret, ...) {
63
  # Set call state to a zero value
64
  call_state <- 0L
65

66
  # Check for a ret call
Guolin Ke's avatar
Guolin Ke committed
67
  if (!is.null(ret)) {
68
69
70
71
72
73
74
    call_state <- .Call(
      fun_name
      , ...
      , ret
      , call_state
      , PACKAGE = "lib_lightgbm"
    )
Guolin Ke's avatar
Guolin Ke committed
75
  } else {
76
77
78
79
80
81
    call_state <- .Call(
      fun_name
      , ...
      , call_state
      , PACKAGE = "lib_lightgbm"
    )
Guolin Ke's avatar
Guolin Ke committed
82
  }
Guolin Ke's avatar
Guolin Ke committed
83

84
  return(ret)
85

Guolin Ke's avatar
Guolin Ke committed
86
87
88
}

lgb.call.return.str <- function(fun_name, ...) {
89

90
  # Create buffer
91
  buf_len <- as.integer(1024L * 1024L)
92
  act_len <- 0L
Guolin Ke's avatar
Guolin Ke committed
93
  buf <- raw(buf_len)
94

95
  # Call buffer
96
  buf <- lgb.call(fun_name = fun_name, ret = buf, ..., buf_len, act_len)
97

98
  # Check for buffer content
Guolin Ke's avatar
Guolin Ke committed
99
100
  if (act_len > buf_len) {
    buf_len <- act_len
101
    buf <- raw(buf_len)
102
    buf <- lgb.call(fun_name = fun_name, ret = buf, ..., buf_len, act_len)
Guolin Ke's avatar
Guolin Ke committed
103
  }
104

105
  return(lgb.encode.char(arr = buf, len = act_len))
106

Guolin Ke's avatar
Guolin Ke committed
107
108
109
}

lgb.params2str <- function(params, ...) {
110

111
  # Check for a list as input
112
  if (!identical(class(params), "list")) {
113
114
    stop("params must be a list")
  }
115

116
  # Split parameter names
Guolin Ke's avatar
Guolin Ke committed
117
  names(params) <- gsub("\\.", "_", names(params))
118

119
  # Merge parameters from the params and the dots-expansion
Guolin Ke's avatar
Guolin Ke committed
120
121
  dot_params <- list(...)
  names(dot_params) <- gsub("\\.", "_", names(dot_params))
122

123
  # Check for identical parameters
124
  if (length(intersect(names(params), names(dot_params))) > 0L) {
125
126
127
128
129
130
131
    stop(
      "Same parameters in "
      , sQuote("params")
      , " and in the call are not allowed. Please check your "
      , sQuote("params")
      , " list"
    )
132
  }
133

134
  # Merge parameters
Guolin Ke's avatar
Guolin Ke committed
135
  params <- c(params, dot_params)
136

137
138
  # Setup temporary variable
  ret <- list()
139

140
  # Perform key value join
Guolin Ke's avatar
Guolin Ke committed
141
  for (key in names(params)) {
142

143
144
145
146
147
148
149
150
151
152
153
    # If a parameter has multiple values, join those values together with commas.
    # trimws() is necessary because format() will pad to make strings the same width
    val <- paste0(
      trimws(
        format(
          x = params[[key]]
          , scientific = FALSE
        )
      )
      , collapse = ","
    )
154
    if (nchar(val) <= 0L) next # Skip join
155

156
    # Join key value
Guolin Ke's avatar
Guolin Ke committed
157
    pair <- paste0(c(key, val), collapse = "=")
158
    ret <- c(ret, pair)
159

Guolin Ke's avatar
Guolin Ke committed
160
  }
161

162
  # Check ret length
163
  if (length(ret) == 0L) {
164
    return(lgb.c_str(x = ""))
Guolin Ke's avatar
Guolin Ke committed
165
  }
166

167
  return(lgb.c_str(x = paste0(ret, collapse = " ")))
168

Guolin Ke's avatar
Guolin Ke committed
169
170
}

171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
lgb.check_interaction_constraints <- function(params, column_names) {

  # Convert interaction constraints to feature numbers
  string_constraints <- list()

  if (!is.null(params[["interaction_constraints"]])) {

    if (!methods::is(params[["interaction_constraints"]], "list")) {
        stop("interaction_constraints must be a list")
    }
    if (!all(sapply(params[["interaction_constraints"]], function(x) {is.character(x) || is.numeric(x)}))) {
        stop("every element in interaction_constraints must be a character vector or numeric vector")
    }

    for (constraint in params[["interaction_constraints"]]) {

      # Check for character name
      if (is.character(constraint)) {

          constraint_indices <- as.integer(match(constraint, column_names) - 1L)

          # Provided indices, but some indices are not existing?
          if (sum(is.na(constraint_indices)) > 0L) {
            stop(
              "supplied an unknown feature in interaction_constraints "
              , sQuote(constraint[is.na(constraint_indices)])
            )
          }

        } else {

          # Check that constraint indices are at most number of features
          if (max(constraint) > length(column_names)) {
            stop(
              "supplied a too large value in interaction_constraints: "
              , max(constraint)
              , " but only "
              , length(column_names)
              , " features"
            )
          }

          # Store indices as [0, n-1] indexed instead of [1, n] indexed
          constraint_indices <- as.integer(constraint - 1L)

        }

        # Convert constraint to string
        constraint_string <- paste0("[", paste0(constraint_indices, collapse = ","), "]")
        string_constraints <- append(string_constraints, constraint_string)
    }

  }

  return(string_constraints)

}

Guolin Ke's avatar
Guolin Ke committed
229
lgb.c_str <- function(x) {
230

Guolin Ke's avatar
Guolin Ke committed
231
  ret <- charToRaw(as.character(x))
232
  ret <- c(ret, as.raw(0L))
233
  return(ret)
234

Guolin Ke's avatar
Guolin Ke committed
235
236
237
}

lgb.check.r6.class <- function(object, name) {
238

239
  # Check for non-existence of R6 class or named class
240
  return(all(c("R6", name) %in% class(object)))
241

Guolin Ke's avatar
Guolin Ke committed
242
243
244
}

lgb.check.obj <- function(params, obj) {
245

246
  # List known objectives in a vector
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
  OBJECTIVES <- c(
    "regression"
    , "regression_l1"
    , "regression_l2"
    , "mean_squared_error"
    , "mse"
    , "l2_root"
    , "root_mean_squared_error"
    , "rmse"
    , "mean_absolute_error"
    , "mae"
    , "quantile"
    , "huber"
    , "fair"
    , "poisson"
    , "binary"
    , "lambdarank"
    , "multiclass"
    , "softmax"
    , "multiclassova"
    , "multiclass_ova"
    , "ova"
    , "ovr"
    , "xentropy"
    , "cross_entropy"
    , "xentlambda"
    , "cross_entropy_lambda"
    , "mean_absolute_percentage_error"
    , "mape"
    , "gamma"
    , "tweedie"
278
279
280
281
282
    , "rank_xendcg"
    , "xendcg"
    , "xe_ndcg"
    , "xe_ndcg_mart"
    , "xendcg_mart"
283
  )
284

285
  # Check whether the objective is empty or not, and take it from params if needed
286
287
288
  if (!is.null(obj)) {
    params$objective <- obj
  }
289

290
  # Check whether the objective is a character
291
  if (is.character(params$objective)) {
292

293
    # If the objective is a character, check if it is a known objective
294
    if (!(params$objective %in% OBJECTIVES)) {
295

296
      stop("lgb.check.obj: objective name error should be one of (", paste0(OBJECTIVES, collapse = ", "), ")")
297

Guolin Ke's avatar
Guolin Ke committed
298
    }
299

300
  } else if (!is.function(params$objective)) {
301

302
    stop("lgb.check.obj: objective should be a character or a function")
303

Guolin Ke's avatar
Guolin Ke committed
304
  }
305

306
  return(params)
307

Guolin Ke's avatar
Guolin Ke committed
308
309
}

310
# [description]
311
312
313
314
#     Take any character values from eval and store them in params$metric.
#     This has to account for the fact that `eval` could be a character vector,
#     a function, a list of functions, or a list with a mix of strings and
#     functions
Guolin Ke's avatar
Guolin Ke committed
315
lgb.check.eval <- function(params, eval) {
316

317
318
  if (is.null(params$metric)) {
    params$metric <- list()
319
320
  } else if (is.character(params$metric)) {
    params$metric <- as.list(params$metric)
321
  }
322

323
324
325
326
327
328
329
330
331
  # if 'eval' is a character vector or list, find the character
  # elements and add them to 'metric'
  if (!is.function(eval)) {
    for (i in seq_along(eval)) {
      element <- eval[[i]]
      if (is.character(element)) {
        params$metric <- append(params$metric, element)
      }
    }
332
  }
333

334
335
336
337
338
339
340
341
342
  # If more than one character metric was given, then "None" should
  # not be included
  if (length(params$metric) > 1L) {
    params$metric <- Filter(
        f = function(metric) {
          !(metric %in% .NO_METRIC_STRINGS())
        }
        , x = params$metric
    )
343
344
  }

345
346
347
  # duplicate metrics should be filtered out
  params$metric <- as.list(unique(unlist(params$metric)))

348
  return(params)
Guolin Ke's avatar
Guolin Ke committed
349
}
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408


# [description]
#
#     Resolve differences between passed-in keyword arguments, parameters,
#     and parameter aliases. This function exists because some functions in the
#     package take in parameters through their own keyword arguments other than
#     the `params` list.
#
#     If the same underlying parameter is provided multiple
#     ways, the first item in this list is used:
#
#         1. the main (non-alias) parameter found in `params`
#         2. the first alias of that parameter found in `params`
#         3. the keyword argument passed in
#
#     For example, "num_iterations" can also be provided to lgb.train()
#     via keyword "nrounds". lgb.train() will choose one value for this parameter
#     based on the first match in this list:
#
#         1. params[["num_iterations]]
#         2. the first alias of "num_iterations" found in params
#         3. the nrounds keyword argument
#
#     If multiple aliases are found in `params` for the same parameter, they are
#     all removed before returning `params`.
#
# [return]
#     params with num_iterations set to the chosen value, and other aliases
#     of num_iterations removed
lgb.check.wrapper_param <- function(main_param_name, params, alternative_kwarg_value) {

  aliases <- .PARAMETER_ALIASES()[[main_param_name]]
  aliases_provided <- names(params)[names(params) %in% aliases]
  aliases_provided <- aliases_provided[aliases_provided != main_param_name]

  # prefer the main parameter
  if (!is.null(params[[main_param_name]])) {
    for (param in aliases_provided) {
      params[[param]] <- NULL
    }
    return(params)
  }

  # if the main parameter wasn't proovided, prefer the first alias
  if (length(aliases_provided) > 0L) {
    first_param <- aliases_provided[1L]
    params[[main_param_name]] <- params[[first_param]]
    for (param in aliases_provided) {
      params[[param]] <- NULL
    }
    return(params)
  }

  # if not provided in params at all, use the alternative value provided
  # through a keyword argument from lgb.train(), lgb.cv(), etc.
  params[[main_param_name]] <- alternative_kwarg_value
  return(params)
}