utils.R 5.55 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
19
  rawToChar(arr[seq_len(len)]) # Return the conversion of raw type to character type
  
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
    call_state <- .Call(fun_name, ..., ret, call_state, PACKAGE = "lib_lightgbm") # Call with ret
Guolin Ke's avatar
Guolin Ke committed
29
  } else {
30
    call_state <- .Call(fun_name, ..., call_state, PACKAGE = "lib_lightgbm") # Call without ret
Guolin Ke's avatar
Guolin Ke committed
31
  }
Guolin Ke's avatar
Guolin Ke committed
32
  call_state <- as.integer(call_state)
33
  # Check for call state value post call
34
  if (call_state != 0L) {
Guolin Ke's avatar
Guolin Ke committed
35

36
    # Perform text error buffering
37
38
    buf_len <- 200L
    act_len <- 0L
Guolin Ke's avatar
Guolin Ke committed
39
    err_msg <- raw(buf_len)
40
    err_msg <- .Call("LGBM_GetLastError_R", buf_len, act_len, err_msg, PACKAGE = "lib_lightgbm")
41
42
    
    # Check error buffer
Guolin Ke's avatar
Guolin Ke committed
43
44
45
    if (act_len > buf_len) {
      buf_len <- act_len
      err_msg <- raw(buf_len)
46
47
48
49
      err_msg <- .Call("LGBM_GetLastError_R",
                        buf_len,
                        act_len,
                        err_msg,
50
                        PACKAGE = "lib_lightgbm")
Guolin Ke's avatar
Guolin Ke committed
51
    }
52
53
    
    # Return error
54
    stop("api error: ", lgb.encode.char(err_msg, act_len))
Guolin Ke's avatar
Guolin Ke committed
55

Guolin Ke's avatar
Guolin Ke committed
56
  }
Guolin Ke's avatar
Guolin Ke committed
57

58
59
  return(ret)
  
Guolin Ke's avatar
Guolin Ke committed
60
61
62
}

lgb.call.return.str <- function(fun_name, ...) {
63
64
  
  # Create buffer
Guolin Ke's avatar
Guolin Ke committed
65
  buf_len <- as.integer(1024 * 1024)
66
  act_len <- 0L
Guolin Ke's avatar
Guolin Ke committed
67
  buf <- raw(buf_len)
68
69
  
  # Call buffer
Guolin Ke's avatar
Guolin Ke committed
70
  buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
71
72
  
  # Check for buffer content
Guolin Ke's avatar
Guolin Ke committed
73
74
  if (act_len > buf_len) {
    buf_len <- act_len
75
76
    buf <- raw(buf_len)
    buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
Guolin Ke's avatar
Guolin Ke committed
77
  }
78
79
80
81
  
  # Return encoded character
  return(lgb.encode.char(buf, act_len))
  
Guolin Ke's avatar
Guolin Ke committed
82
83
84
}

lgb.params2str <- function(params, ...) {
85
86
87
88
89
90
91
  
  # Check for a list as input
  if (!is.list(params)) {
    stop("params must be a list")
  }
  
  # Split parameter names
Guolin Ke's avatar
Guolin Ke committed
92
  names(params) <- gsub("\\.", "_", names(params))
93
94
  
  # Merge parameters from the params and the dots-expansion
Guolin Ke's avatar
Guolin Ke committed
95
96
  dot_params <- list(...)
  names(dot_params) <- gsub("\\.", "_", names(dot_params))
97
98
99
100
101
102
103
  
  # Check for identical parameters
  if (length(intersect(names(params), names(dot_params))) > 0) {
    stop("Same parameters in ", sQuote("params"), " and in the call are not allowed. Please check your ", sQuote("params"), " list")
  }
  
  # Merge parameters
Guolin Ke's avatar
Guolin Ke committed
104
  params <- c(params, dot_params)
105
106
107
108
109
  
  # Setup temporary variable
  ret <- list()
  
  # Perform key value join
Guolin Ke's avatar
Guolin Ke committed
110
  for (key in names(params)) {
111
112
    
    # Join multi value first
113
    val <- paste0(format(params[[key]], scientific = FALSE), collapse = ",")
114
115
116
    if (nchar(val) <= 0) next # Skip join
    
    # Join key value
Guolin Ke's avatar
Guolin Ke committed
117
    pair <- paste0(c(key, val), collapse = "=")
118
119
    ret <- c(ret, pair)
    
Guolin Ke's avatar
Guolin Ke committed
120
  }
121
122
  
  # Check ret length
Guolin Ke's avatar
Guolin Ke committed
123
  if (length(ret) == 0) {
124
125
    
    # Return empty string
126
    lgb.c_str("")
127
    
128
  } else {
129
130
    
    # Return string separated by a space per element
131
    lgb.c_str(paste0(ret, collapse = " "))
132
    
Guolin Ke's avatar
Guolin Ke committed
133
  }
134
  
Guolin Ke's avatar
Guolin Ke committed
135
136
137
}

lgb.c_str <- function(x) {
138
139
  
  # Perform character to raw conversion
Guolin Ke's avatar
Guolin Ke committed
140
141
  ret <- charToRaw(as.character(x))
  ret <- c(ret, as.raw(0))
142
  ret
143
  
Guolin Ke's avatar
Guolin Ke committed
144
145
146
}

lgb.check.r6.class <- function(object, name) {
147
  
148
149
  # Check for non-existence of R6 class or named class
  all(c("R6", name) %in% class(object))
150
  
Guolin Ke's avatar
Guolin Ke committed
151
152
}

153
lgb.check.params <- function(params) {
154
  
Guolin Ke's avatar
Guolin Ke committed
155
  # To-do
156
157
  params # Currently return params because this is not finalized
  
Guolin Ke's avatar
Guolin Ke committed
158
159
160
}

lgb.check.obj <- function(params, obj) {
161
162
  
  # List known objectives in a vector
Guolin Ke's avatar
Guolin Ke committed
163
164
165
166
167
168
  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")
169
170
  
  # Check whether the objective is empty or not, and take it from params if needed
171
  if (!is.null(obj)) { params$objective <- obj }
172
173
  
  # Check whether the objective is a character
174
  if (is.character(params$objective)) {
175
176
    
    # If the objective is a character, check if it is a known objective
177
    if (!(params$objective %in% OBJECTIVES)) {
178
179
      
      # Interrupt on unknown objective name
180
      stop("lgb.check.obj: objective name error should be one of (", paste0(OBJECTIVES, collapse = ", "), ")")
181
      
Guolin Ke's avatar
Guolin Ke committed
182
    }
183
    
184
  } else if (!is.function(params$objective)) {
185
186
    
    # If objective is not a character nor a function, then stop
187
    stop("lgb.check.obj: objective should be a character or a function")
188
    
Guolin Ke's avatar
Guolin Ke committed
189
  }
190
191
192
193
  
  # Return parameters
  return(params)
  
Guolin Ke's avatar
Guolin Ke committed
194
195
196
}

lgb.check.eval <- function(params, eval) {
197
198
199
200
201
202
203
  
  # Check if metric is null, if yes put a list instead
  if (is.null(params$metric)) {
    params$metric <- list()
  }
  
  # Check if evaluation metric is null, if not then append it
204
  if (!is.null(eval)) {
205
206
    
    # Append metric if character or list
207
    if (is.character(eval) || is.list(eval)) {
208
209
      
      # Append metrics
Guolin Ke's avatar
Guolin Ke committed
210
      params$metric <- append(params$metric, eval)
211
      
Guolin Ke's avatar
Guolin Ke committed
212
    }
213
    
214
  } 
215
216
  # Return parameters
  return(params)
Guolin Ke's avatar
Guolin Ke committed
217
}