utils.R 5.41 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
84
  buf_len <- as.integer(1024L * 1024L)
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
  # Check for identical parameters
118
  if (length(intersect(names(params), names(dot_params))) > 0L) {
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) <= 0L) 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
148
  if (length(ret) == 0L) {
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
  ret <- charToRaw(as.character(x))
166
  ret <- c(ret, as.raw(0L))
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.obj <- function(params, obj) {
179

180
  # List known objectives in a vector
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
  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"
212
213
214
215
216
    , "rank_xendcg"
    , "xendcg"
    , "xe_ndcg"
    , "xe_ndcg_mart"
    , "xendcg_mart"
217
  )
218

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

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

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

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

Guolin Ke's avatar
Guolin Ke committed
233
    }
234

235
  } else if (!is.function(params$objective)) {
236

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

Guolin Ke's avatar
Guolin Ke committed
240
  }
241

242
243
  # Return parameters
  return(params)
244

Guolin Ke's avatar
Guolin Ke committed
245
246
247
}

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

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

254
255
256
  # If 'eval' is a list or character vector, store it in 'metric'
  if (is.character(eval) || is.list(eval)) {
    params$metric <- append(params$metric, eval)
257
  }
258

259
  return(params)
Guolin Ke's avatar
Guolin Ke committed
260
}