utils.R 5.54 KB
Newer Older
1
2
3
lgb.is.Booster <- function(x) {
  lgb.check.r6.class(x, "lgb.Booster") # Checking if it is of class lgb.Booster or not
}
4

5
6
7
lgb.is.Dataset <- function(x) {
  lgb.check.r6.class(x, "lgb.Dataset") # Checking if it is of class lgb.Dataset or not
}
8

9
lgb.is.null.handle <- function(x) {
10
  is.null(x) || is.na(x)
11
}
Guolin Ke's avatar
Guolin Ke committed
12
13

lgb.encode.char <- function(arr, len) {
14

15
  if (!is.raw(arr)) {
16
    stop("lgb.encode.char: Can only encode from raw type") # Not an object of type raw
Guolin Ke's avatar
Guolin Ke committed
17
  }
18
  rawToChar(arr[seq_len(len)]) # Return the conversion of raw type to character type
19

Guolin Ke's avatar
Guolin Ke committed
20
21
22
}

lgb.call <- function(fun_name, ret, ...) {
23
  # Set call state to a zero value
24
  call_state <- 0L
25

26
  # Check for a ret call
Guolin Ke's avatar
Guolin Ke committed
27
  if (!is.null(ret)) {
28
29
30
31
32
33
34
    call_state <- .Call(
      fun_name
      , ...
      , ret
      , call_state
      , PACKAGE = "lib_lightgbm"
    )
Guolin Ke's avatar
Guolin Ke committed
35
  } else {
36
37
38
39
40
41
    call_state <- .Call(
      fun_name
      , ...
      , call_state
      , PACKAGE = "lib_lightgbm"
    )
Guolin Ke's avatar
Guolin Ke committed
42
  }
Guolin Ke's avatar
Guolin Ke committed
43
  call_state <- as.integer(call_state)
44
  # Check for call state value post call
45
  if (call_state != 0L) {
Guolin Ke's avatar
Guolin Ke committed
46

47
    # Perform text error buffering
48
49
    buf_len <- 200L
    act_len <- 0L
Guolin Ke's avatar
Guolin Ke committed
50
    err_msg <- raw(buf_len)
51
52
53
54
55
56
57
    err_msg <- .Call(
      "LGBM_GetLastError_R"
      , buf_len
      , act_len
      , err_msg
      , PACKAGE = "lib_lightgbm"
    )
58

59
    # Check error buffer
Guolin Ke's avatar
Guolin Ke committed
60
61
62
    if (act_len > buf_len) {
      buf_len <- act_len
      err_msg <- raw(buf_len)
63
64
65
66
67
68
69
      err_msg <- .Call(
        "LGBM_GetLastError_R"
        , buf_len
        , act_len
        , err_msg
        , PACKAGE = "lib_lightgbm"
      )
Guolin Ke's avatar
Guolin Ke committed
70
    }
71

72
    # Return error
73
    stop("api error: ", lgb.encode.char(err_msg, act_len))
Guolin Ke's avatar
Guolin Ke committed
74

Guolin Ke's avatar
Guolin Ke committed
75
  }
Guolin Ke's avatar
Guolin Ke committed
76

77
  return(ret)
78

Guolin Ke's avatar
Guolin Ke committed
79
80
81
}

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

83
  # Create buffer
Guolin Ke's avatar
Guolin Ke committed
84
  buf_len <- as.integer(1024 * 1024)
85
  act_len <- 0L
Guolin Ke's avatar
Guolin Ke committed
86
  buf <- raw(buf_len)
87

88
  # Call buffer
Guolin Ke's avatar
Guolin Ke committed
89
  buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
90

91
  # Check for buffer content
Guolin Ke's avatar
Guolin Ke committed
92
93
  if (act_len > buf_len) {
    buf_len <- act_len
94
95
    buf <- raw(buf_len)
    buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
Guolin Ke's avatar
Guolin Ke committed
96
  }
97

98
99
  # Return encoded character
  return(lgb.encode.char(buf, act_len))
100

Guolin Ke's avatar
Guolin Ke committed
101
102
103
}

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

105
106
107
108
  # Check for a list as input
  if (!is.list(params)) {
    stop("params must be a list")
  }
109

110
  # Split parameter names
Guolin Ke's avatar
Guolin Ke committed
111
  names(params) <- gsub("\\.", "_", names(params))
112

113
  # Merge parameters from the params and the dots-expansion
Guolin Ke's avatar
Guolin Ke committed
114
115
  dot_params <- list(...)
  names(dot_params) <- gsub("\\.", "_", names(dot_params))
116

117
118
  # Check for identical parameters
  if (length(intersect(names(params), names(dot_params))) > 0) {
119
120
121
122
123
124
125
    stop(
      "Same parameters in "
      , sQuote("params")
      , " and in the call are not allowed. Please check your "
      , sQuote("params")
      , " list"
    )
126
  }
127

128
  # Merge parameters
Guolin Ke's avatar
Guolin Ke committed
129
  params <- c(params, dot_params)
130

131
132
  # Setup temporary variable
  ret <- list()
133

134
  # Perform key value join
Guolin Ke's avatar
Guolin Ke committed
135
  for (key in names(params)) {
136

137
    # Join multi value first
138
    val <- paste0(format(params[[key]], scientific = FALSE), collapse = ",")
139
    if (nchar(val) <= 0) next # Skip join
140

141
    # Join key value
Guolin Ke's avatar
Guolin Ke committed
142
    pair <- paste0(c(key, val), collapse = "=")
143
    ret <- c(ret, pair)
144

Guolin Ke's avatar
Guolin Ke committed
145
  }
146

147
  # Check ret length
Guolin Ke's avatar
Guolin Ke committed
148
  if (length(ret) == 0) {
149

150
    # Return empty string
151
    lgb.c_str("")
152

153
  } else {
154

155
    # Return string separated by a space per element
156
    lgb.c_str(paste0(ret, collapse = " "))
157

Guolin Ke's avatar
Guolin Ke committed
158
  }
159

Guolin Ke's avatar
Guolin Ke committed
160
161
162
}

lgb.c_str <- function(x) {
163

164
  # Perform character to raw conversion
Guolin Ke's avatar
Guolin Ke committed
165
166
  ret <- charToRaw(as.character(x))
  ret <- c(ret, as.raw(0))
167
  ret
168

Guolin Ke's avatar
Guolin Ke committed
169
170
171
}

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

173
174
  # Check for non-existence of R6 class or named class
  all(c("R6", name) %in% class(object))
175

Guolin Ke's avatar
Guolin Ke committed
176
177
}

178
lgb.check.params <- function(params) {
179

Guolin Ke's avatar
Guolin Ke committed
180
  # To-do
181
  params # Currently return params because this is not finalized
182

Guolin Ke's avatar
Guolin Ke committed
183
184
185
}

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

187
  # List known objectives in a vector
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
  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"
  )
220

221
  # Check whether the objective is empty or not, and take it from params if needed
222
223
224
  if (!is.null(obj)) {
    params$objective <- obj
  }
225

226
  # Check whether the objective is a character
227
  if (is.character(params$objective)) {
228

229
    # If the objective is a character, check if it is a known objective
230
    if (!(params$objective %in% OBJECTIVES)) {
231

232
      # Interrupt on unknown objective name
233
      stop("lgb.check.obj: objective name error should be one of (", paste0(OBJECTIVES, collapse = ", "), ")")
234

Guolin Ke's avatar
Guolin Ke committed
235
    }
236

237
  } else if (!is.function(params$objective)) {
238

239
    # If objective is not a character nor a function, then stop
240
    stop("lgb.check.obj: objective should be a character or a function")
241

Guolin Ke's avatar
Guolin Ke committed
242
  }
243

244
245
  # Return parameters
  return(params)
246

Guolin Ke's avatar
Guolin Ke committed
247
248
249
}

lgb.check.eval <- function(params, eval) {
250

251
252
253
254
  # Check if metric is null, if yes put a list instead
  if (is.null(params$metric)) {
    params$metric <- list()
  }
255

256
  # Check if evaluation metric is null, if not then append it
257
  if (!is.null(eval)) {
258

259
    # Append metric if character or list
260
    if (is.character(eval) || is.list(eval)) {
261

262
      # Append metrics
Guolin Ke's avatar
Guolin Ke committed
263
      params$metric <- append(params$metric, eval)
264

Guolin Ke's avatar
Guolin Ke committed
265
    }
266
267

  }
268
269
  # Return parameters
  return(params)
Guolin Ke's avatar
Guolin Ke committed
270
}