Skip to content

GitLab

"vscode:/vscode.git/clone" did not exist on "3abff370bb353293e4a03e516111dd02785fbd97"
Commit b6c973af authored by Laurae's avatar Laurae Committed by Guolin Ke
Browse files

[R-package] Improvements, readability, and bug fixes (#378) 

* Define environment in examples (xgboost clash)

* Large R code changes
parent e9275fb9
Hide whitespace changes
Inline Side-by-side
Showing with 2726 additions and 973 deletions
R-package/NAMESPACE
View file @ b6c973af
......@@ -25,6 +25,7 @@ export(lgb.plot.importance)
export(lgb.plot.interpretation)
export(lgb.save)
export(lgb.train)
export(lgb.unloader)
export(lightgbm)
export(readRDS.lgb.Booster)
export(saveRDS.lgb.Booster)
......
R-package/R/callback.R
View file @ b6c973af
......@@ -2,220 +2,425 @@ CB_ENV <- R6Class(
"lgb.cb_env",
cloneable = FALSE,
public = list(
model = NULL,
iteration = NULL,
model = NULL,
iteration = NULL,
begin_iteration = NULL,
end_iteration = NULL,
eval_list = list(),
eval_err_list = list(),
best_iter = -1,
met_early_stop = FALSE
end_iteration = NULL,
eval_list = list(),
eval_err_list = list(),
best_iter = -1,
met_early_stop = FALSE
)
)
cb.reset.parameters <- function(new_params) {
if (!is.list(new_params)) { stop(sQuote("new_params"), " must be a list") }
# Check for parameter list
if (!is.list(new_params)) {
stop(sQuote("new_params"), " must be a list")
}
# Deparse parameter list
pnames <- gsub("\\.", "_", names(new_params))
nrounds <- NULL
# run some checks in the begining
# Run some checks in the beginning
init <- function(env) {
# Store boosting rounds
nrounds <<- env$end_iteration - env$begin_iteration + 1
# Check for model environment
if (is.null(env$model)) { stop("Env should have a ", sQuote("model")) }
# Some parameters are not allowed to be changed,
# since changing them would simply wreck some chaos
not_allowed <- c("num_class", "metric", "boosting_type")
if (any(pnames %in% not_allowed)) {
stop("Parameters ", paste0(pnames[pnames %in% not_allowed], collapse = ", "), " cannot be changed during boosting")
}
# Check parameter names
for (n in pnames) {
# Set name
p <- new_params[[n]]
# Check if function for parameter
if (is.function(p)) {
if (length(formals(p)) != 2)
# Check if requires at least two arguments
if (length(formals(p)) != 2) {
stop("Parameter ", sQuote(n), " is a function but not of two arguments")
}
# Check if numeric or character
} else if (is.numeric(p) || is.character(p)) {
if (length(p) != nrounds)
# Check if length is matching
if (length(p) != nrounds) {
stop("Length of ", sQuote(n), " has to be equal to length of ", sQuote("nrounds"))
}
} else {
stop("Parameter ", sQuote(n), " is not a function or a vector")
}
}
}
callback <- function(env) {
if (is.null(nrounds)) { init(env) }
# Check if rounds is null
if (is.null(nrounds)) {
init(env)
}
# Store iteration
i <- env$iteration - env$begin_iteration
# Apply list on parameters
pars <- lapply(new_params, function(p) {
if (is.function(p)) { return(p(i, nrounds)) }
if (is.function(p)) {
return(p(i, nrounds))
}
p[i]
})
# to-do check pars
if (!is.null(env$model)) { env$model$reset_parameter(pars) }
# To-do check pars
if (!is.null(env$model)) {
env$model$reset_parameter(pars)
}
}
attr(callback, 'call') <- match.call()
attr(callback, 'is_pre_iteration') <- TRUE
attr(callback, 'name') <- 'cb.reset.parameters'
attr(callback, "call") <- match.call()
attr(callback, "is_pre_iteration") <- TRUE
attr(callback, "name") <- "cb.reset.parameters"
callback
}
# Format the evaluation metric string
format.eval.string <- function(eval_res, eval_err = NULL) {
if (is.null(eval_res) || length(eval_res) == 0) { stop('no evaluation results') }
# Check for empty evaluation string
if (is.null(eval_res) || length(eval_res) == 0) {
stop("no evaluation results")
}
# Check for empty evaluation error
if (!is.null(eval_err)) {
sprintf('%s\'s %s:%g+%g', eval_res$data_name, eval_res$name, eval_res$value, eval_err)
sprintf("%s\'s %s:%g+%g", eval_res$data_name, eval_res$name, eval_res$value, eval_err)
} else {
sprintf('%s\'s %s:%g', eval_res$data_name, eval_res$name, eval_res$value)
sprintf("%s\'s %s:%g", eval_res$data_name, eval_res$name, eval_res$value)
}
}
merge.eval.string <- function(env) {
if (length(env$eval_list) <= 0) { return("") }
msg <- list(sprintf('[%d]:', env$iteration))
# Check length of evaluation list
if (length(env$eval_list) <= 0) {
return("")
}
# Get evaluation
msg <- list(sprintf("[%d]:", env$iteration))
# Set if evaluation error
is_eval_err <- FALSE
if (length(env$eval_err_list) > 0) { is_eval_err <- TRUE }
# Check evaluation error list length
if (length(env$eval_err_list) > 0) {
is_eval_err <- TRUE
}
# Loop through evaluation list
for (j in seq_along(env$eval_list)) {
# Store evaluation error
eval_err <- NULL
if (is_eval_err) { eval_err <- env$eval_err_list[[j]] }
if (is_eval_err) {
eval_err <- env$eval_err_list[[j]]
}
# Set error message
msg <- c(msg, format.eval.string(env$eval_list[[j]], eval_err))
}
paste0(msg, collapse='\t')
# Return tabulated separated message
paste0(msg, collapse = "\t")
}
cb.print.evaluation <- function(period = 1){
cb.print.evaluation <- function(period = 1) {
# Create callback
callback <- function(env) {
# Check if period is at least 1 or more
if (period > 0) {
# Store iteration
i <- env$iteration
if ( (i - 1) %% period == 0
| i == env$begin_iteration
| i == env$end_iteration ) {
# Check if iteration matches moduo
if ((i - 1) %% period == 0 | i == env$begin_iteration | i == env$end_iteration ) {
# Merge evaluation string
msg <- merge.eval.string(env)
if (nchar(msg) > 0) { cat(merge.eval.string(env), "\n") }
# Check if message is existing
if (nchar(msg) > 0) {
cat(merge.eval.string(env), "\n")
}
}
}
}
attr(callback, 'call') <- match.call()
attr(callback, 'name') <- 'cb.print.evaluation'
# Store attributes
attr(callback, "call") <- match.call()
attr(callback, "name") <- "cb.print.evaluation"
# Return callback
callback
}
cb.record.evaluation <- function() {
# Create callback
callback <- function(env) {
if (length(env$eval_list) <= 0) { return() }
# Return empty if empty evaluation list
if (length(env$eval_list) <= 0) {
return()
}
# Set if evaluation error
is_eval_err <- FALSE
if (length(env$eval_err_list) > 0) { is_eval_err <- TRUE }
# Check evaluation error list length
if (length(env$eval_err_list) > 0) {
is_eval_err <- TRUE
}
# Check length of recorded evaluation
if (length(env$model$record_evals) == 0) {
# Loop through each evaluation list element
for (j in seq_along(env$eval_list)) {
# Store names
data_name <- env$eval_list[[j]]$data_name
name <- env$eval_list[[j]]$name
name <- env$eval_list[[j]]$name
env$model$record_evals$start_iter <- env$begin_iteration
# Check if evaluation record exists
if (is.null(env$model$record_evals[[data_name]])) {
env$model$record_evals[[data_name]] <- list()
}
env$model$record_evals[[data_name]][[name]] <- list()
env$model$record_evals[[data_name]][[name]]$eval <- list()
# Create dummy lists
env$model$record_evals[[data_name]][[name]] <- list()
env$model$record_evals[[data_name]][[name]]$eval <- list()
env$model$record_evals[[data_name]][[name]]$eval_err <- list()
}
}
# Loop through each evaluation list element
for (j in seq_along(env$eval_list)) {
# Get evaluation data
eval_res <- env$eval_list[[j]]
eval_err <- NULL
if (is_eval_err) { eval_err <- env$eval_err_list[[j]] }
if (is_eval_err) {
eval_err <- env$eval_err_list[[j]]
}
# Store names
data_name <- eval_res$data_name
name <- eval_res$name
name <- eval_res$name
# Store evaluation data
env$model$record_evals[[data_name]][[name]]$eval <- c(env$model$record_evals[[data_name]][[name]]$eval, eval_res$value)
env$model$record_evals[[data_name]][[name]]$eval_err <- c(env$model$record_evals[[data_name]][[name]]$eval_err, eval_err)
}
}
attr(callback, 'call') <- match.call()
attr(callback, 'name') <- 'cb.record.evaluation'
# Store attributes
attr(callback, "call") <- match.call()
attr(callback, "name") <- "cb.record.evaluation"
# Return callback
callback
}
cb.early.stop <- function(stopping_rounds, verbose = TRUE) {
# state variables
# Initialize variables
factor_to_bigger_better <- NULL
best_iter <- NULL
best_score <- NULL
best_msg <- NULL
eval_len <- NULL
best_iter <- NULL
best_score <- NULL
best_msg <- NULL
eval_len <- NULL
# Initalization function
init <- function(env) {
# Store evaluation length
eval_len <<- length(env$eval_list)
# Early stopping cannot work without metrics
if (eval_len == 0) {
stop("For early stopping, valids must have at least one element")
}
# Check if verbose or not
if (isTRUE(verbose)) {
cat("Will train until there is no improvement in ", stopping_rounds, " rounds.\n\n", sep = '')
cat("Will train until there is no improvement in ", stopping_rounds, " rounds.\n\n", sep = "")
}
# Maximization or minimization task
factor_to_bigger_better <<- rep(1.0, eval_len)
best_iter <<- rep(-1, eval_len)
best_iter <<- rep(-1, eval_len)
best_score <<- rep(-Inf, eval_len)
best_msg <<- list()
best_msg <<- list()
# Loop through evaluation elements
for (i in seq_len(eval_len)) {
# Prepend message
best_msg <<- c(best_msg, "")
# Check if maximization or minimization
if (!env$eval_list[[i]]$higher_better) {
factor_to_bigger_better[i] <<- -1.0
}
}
}
# Create callback
callback <- function(env, finalize = FALSE) {
if (is.null(eval_len)) { init(env) }
# Check for empty evaluation
if (is.null(eval_len)) {
init(env)
}
# Store iteration
cur_iter <- env$iteration
# Loop through evaluation
for (i in seq_len(eval_len)) {
# Store score
score <- env$eval_list[[i]]$value * factor_to_bigger_better[i]
# Check if score is better
if (score > best_score[i]) {
# Store new scores
best_score[i] <<- score
best_iter[i] <<- cur_iter
best_iter[i] <<- cur_iter
# Prepare to print if verbose
if (verbose) {
best_msg[[i]] <<- as.character(merge.eval.string(env))
}
} else {
# Check if early stopping is required
if (cur_iter - best_iter[i] >= stopping_rounds) {
if (!is.null(env$model)) { env$model$best_iter <- best_iter[i] }
# Check if model is not null
if (!is.null(env$model)) {
env$model$best_iter <- best_iter[i]
}
# Print message if verbose
if (isTRUE(verbose)) {
cat("Early stopping, best iteration is:", "\n")
cat(best_msg[[i]], "\n")
}
env$best_iter <- best_iter[i]
# Store best iteration and stop
env$best_iter <- best_iter[i]
env$met_early_stop <- TRUE
}
}
}
}
attr(callback, 'call') <- match.call()
attr(callback, 'name') <- 'cb.early.stop'
# Set attributes
attr(callback, "call") <- match.call()
attr(callback, "name") <- "cb.early.stop"
# Return callback
callback
}
# Extract callback names from the list of callbacks
callback.names <- function(cb_list) { unlist(lapply(cb_list, attr, "name")) }
add.cb <- function(cb_list, cb) {
# Combine two elements
cb_list <- c(cb_list, cb)
# Set names of elements
names(cb_list) <- callback.names(cb_list)
if ('cb.early.stop' %in% names(cb_list)) {
cb_list <- c(cb_list, cb_list['cb.early.stop'])
# this removes only the first one
cb_list['cb.early.stop'] <- NULL
# Check for existence
if ("cb.early.stop" %in% names(cb_list)) {
# Concatenate existing elements
cb_list <- c(cb_list, cb_list["cb.early.stop"])
# Remove only the first one
cb_list["cb.early.stop"] <- NULL
}
# Return element
cb_list
}
categorize.callbacks <- function(cb_list) {
# Check for pre-iteration or post-iteration
list(
pre_iter = Filter(function(x) {
pre <- attr(x, 'is_pre_iteration')
pre <- attr(x, "is_pre_iteration")
!is.null(pre) && pre
}, cb_list),
post_iter = Filter(function(x) {
pre <- attr(x, 'is_pre_iteration')
pre <- attr(x, "is_pre_iteration")
is.null(pre) || !pre
}, cb_list)
)
}
R-package/R/lgb.Booster.R
View file @ b6c973af
Booster <- R6Class(
"lgb.Booster",
classname = "lgb.Booster",
cloneable = FALSE,
public = list(
best_iter = -1,
best_iter = -1,
record_evals = list(),
finalize = function() {
# Finalize will free up the handles
finalize = function() {
# Check the need for freeing handle
if (!lgb.is.null.handle(private$handle)) {
# Freeing up handle
lgb.call("LGBM_BoosterFree_R", ret = NULL, private$handle)
private$handle <- NULL
}
},
initialize = function(params = list(),
# Initialize will create a starter booster
initialize = function(params = list(),
train_set = NULL,
modelfile = NULL,
...) {
params <- append(params, list(...))
# Create parameters and handle
params <- append(params, list(...))
params_str <- lgb.params2str(params)
handle <- lgb.new.handle()
handle <- lgb.new.handle()
# Check if training dataset is not null
if (!is.null(train_set)) {
# Check if training dataset is lgb.Dataset or not
if (!lgb.check.r6.class(train_set, "lgb.Dataset")) {
stop("lgb.Booster: Can only use lgb.Dataset as training data")
}
handle <-
lgb.call("LGBM_BoosterCreate_R", ret = handle, train_set$.__enclos_env__$private$get_handle(), params_str)
private$train_set <- train_set
private$num_dataset <- 1
# Store booster handle
handle <- lgb.call("LGBM_BoosterCreate_R", ret = handle, train_set$.__enclos_env__$private$get_handle(), params_str)
# Create private booster information
private$train_set <- train_set
private$num_dataset <- 1
private$init_predictor <- train_set$.__enclos_env__$private$predictor
# Check if predictor is existing
if (!is.null(private$init_predictor)) {
lgb.call("LGBM_BoosterMerge_R", ret = NULL,
handle,
private$init_predictor$.__enclos_env__$private$handle)
# Merge booster
lgb.call("LGBM_BoosterMerge_R",
ret = NULL,
handle,
private$init_predictor$.__enclos_env__$private$handle)
}
# Check current iteration
private$is_predicted_cur_iter <- c(private$is_predicted_cur_iter, FALSE)
} else if (!is.null(modelfile)) {
# Do we have a model file as character?
if (!is.character(modelfile)) {
stop("lgb.Booster: Can only use a string as model file path")
}
handle <-
lgb.call("LGBM_BoosterCreateFromModelfile_R",
ret = handle,
lgb.c_str(modelfile))
# Create booster from model
handle <- lgb.call("LGBM_BoosterCreateFromModelfile_R",
ret = handle,
lgb.c_str(modelfile))
} else {
stop(
"lgb.Booster: Need at least either training dataset or model file to create booster instance"
)
# Booster non existent
stop("lgb.Booster: Need at least either training dataset or model file to create booster instance")
}
class(handle) <- "lgb.Booster.handle"
private$handle <- handle
# Create class
class(handle) <- "lgb.Booster.handle"
private$handle <- handle
private$num_class <- 1L
private$num_class <-
lgb.call("LGBM_BoosterGetNumClasses_R", ret = private$num_class, private$handle)
private$num_class <- lgb.call("LGBM_BoosterGetNumClasses_R",
ret = private$num_class,
private$handle)
},
# Set training data name
set_train_data_name = function(name) {
# Set name
private$name_train_set <- name
self
},
# Add validation data
add_valid = function(data, name) {
# Check if data is lgb.Dataset
if (!lgb.check.r6.class(data, "lgb.Dataset")) {
stop("lgb.Booster.add_valid: Can only use lgb.Dataset as validation data")
}
# Check if predictors are identical
if (!identical(data$.__enclos_env__$private$predictor, private$init_predictor)) {
stop(
"lgb.Booster.add_valid: Failed to add validation data; you should use the same predictor for these data"
)
stop("lgb.Booster.add_valid: Failed to add validation data; you should use the same predictor for these data")
}
# Check if names are character
if (!is.character(name)) {
stop("lgb.Booster.add_valid: Can only use characters as data name")
}
lgb.call("LGBM_BoosterAddValidData_R", ret = NULL, private$handle, data$.__enclos_env__$private$get_handle())
private$valid_sets <- c(private$valid_sets, data)
private$name_valid_sets <- c(private$name_valid_sets, name)
private$num_dataset <- private$num_dataset + 1
private$is_predicted_cur_iter <-
c(private$is_predicted_cur_iter, FALSE)
self
# Add validation data to booster
lgb.call("LGBM_BoosterAddValidData_R",
ret = NULL,
private$handle,
data$.__enclos_env__$private$get_handle())
# Store private information
private$valid_sets <- c(private$valid_sets, data)
private$name_valid_sets <- c(private$name_valid_sets, name)
private$num_dataset <- private$num_dataset + 1
private$is_predicted_cur_iter <- c(private$is_predicted_cur_iter, FALSE)
# Return self
return(self)
},
# Reset parameters of booster
reset_parameter = function(params, ...) {
params <- append(params, list(...))
# Append parameters
params <- append(params, list(...))
params_str <- algb.params2str(params)
lgb.call("LGBM_BoosterResetParameter_R", ret = NULL,
private$handle,
params_str)
self
# Reset parameters
lgb.call("LGBM_BoosterResetParameter_R",
ret = NULL,
private$handle,
params_str)
# Return self
return(self)
},
# Perform boosting update iteration
update = function(train_set = NULL, fobj = NULL) {
# Check if training set is not null
if (!is.null(train_set)) {
# Check if training set is lgb.Dataset
if (!lgb.check.r6.class(train_set, "lgb.Dataset")) {
stop("lgb.Booster.update: Only can use lgb.Dataset as training data")
}
# Check if predictors are identical
if (!identical(train_set$predictor, private$init_predictor)) {
stop(
"lgb.Booster.update: Change train_set failed, you should use the same predictor for these data"
)
stop("lgb.Booster.update: Change train_set failed, you should use the same predictor for these data")
}
lgb.call("LGBM_BoosterResetTrainingData_R", ret = NULL,
private$handle,
train_set$.__enclos_env__$private$get_handle())
# Reset training data on booster
lgb.call("LGBM_BoosterResetTrainingData_R",
ret = NULL,
private$handle,
train_set$.__enclos_env__$private$get_handle())
# Store private train set
private$train_set = train_set
}
# Check if objective is empty
if (is.null(fobj)) {
# Boost iteration from known objective
ret <- lgb.call("LGBM_BoosterUpdateOneIter_R", ret = NULL, private$handle)
} else {
if (!is.function(fobj)) { stop("lgb.Booster.update: fobj should be a function") }
# Check if objective is function
if (!is.function(fobj)) {
stop("lgb.Booster.update: fobj should be a function")
}
# Perform objective calculation
gpair <- fobj(private$inner_predict(1), private$train_set)
# Check for gradient and hessian as list
if(is.null(gpair$grad) | is.null(gpair$hess)){
stop("lgb.Booster.update: custom objective should
return a list with attributes (hess, grad)")
}
ret <- lgb.call(
"LGBM_BoosterUpdateOneIterCustom_R", ret = NULL,
private$handle,
gpair$grad,
gpair$hess,
length(gpair$grad)
)
# Return custom boosting gradient/hessian
ret <- lgb.call("LGBM_BoosterUpdateOneIterCustom_R",
ret = NULL,
private$handle,
gpair$grad,
gpair$hess,
length(gpair$grad))
}
# Loop through each iteration
for (i in seq_along(private$is_predicted_cur_iter)) {
private$is_predicted_cur_iter[[i]] <- FALSE
}
ret
# Return self
return(ret)
},
# Return one iteration behind
rollback_one_iter = function() {
lgb.call("LGBM_BoosterRollbackOneIter_R", ret = NULL, private$handle)
# Return one iteration behind
lgb.call("LGBM_BoosterRollbackOneIter_R",
ret = NULL,
private$handle)
# Loop through each iteration
for (i in seq_along(private$is_predicted_cur_iter)) {
private$is_predicted_cur_iter[[i]] <- FALSE
}
self
# Return self
return(self)
},
# Get current iteration
current_iter = function() {
cur_iter <- 0L
lgb.call("LGBM_BoosterGetCurrentIteration_R", ret = cur_iter, private$handle)
lgb.call("LGBM_BoosterGetCurrentIteration_R",
ret = cur_iter,
private$handle)
},
# Evaluate data on metrics
eval = function(data, name, feval = NULL) {
# Check if dataset is lgb.Dataset
if (!lgb.check.r6.class(data, "lgb.Dataset")) {
stop("lgb.Booster.eval: Can only use lgb.Dataset to eval")
}
# Check for identical data
data_idx <- 0
if (identical(data, private$train_set)) { data_idx <- 1 } else {
if (identical(data, private$train_set)) {
data_idx <- 1
} else {
# Check for validation data
if (length(private$valid_sets) > 0) {
# Loop through each validation set
for (i in seq_along(private$valid_sets)) {
# Check for identical validation data with training data
if (identical(data, private$valid_sets[[i]])) {
# Found identical data, skip
data_idx <- i + 1
break
}
}
}
}
# Check if evaluation was not done
if (data_idx == 0) {
# Add validation data by name
self$add_valid(data, name)
data_idx <- private$num_dataset
}
# Evaluate data
private$inner_eval(name, data_idx, feval)
},
# Evaluation training data
eval_train = function(feval = NULL) {
private$inner_eval(private$name_train_set, 1, feval)
},
# Evaluation validation data
eval_valid = function(feval = NULL) {
# Create ret list
ret = list()
if (length(private$valid_sets) <= 0) { return(ret) }
# Check if validation is empty
if (length(private$valid_sets) <= 0) {
return(ret)
}
# Loop through each validation set
for (i in seq_along(private$valid_sets)) {
ret <- append(ret, private$inner_eval(private$name_valid_sets[[i]], i + 1, feval))
}
ret
# Return ret
return(ret)
},
# Save model
save_model = function(filename, num_iteration = NULL) {
if (is.null(num_iteration)) { num_iteration <- self$best_iter }
lgb.call(
"LGBM_BoosterSaveModel_R",
ret = NULL,
private$handle,
as.integer(num_iteration),
lgb.c_str(filename)
)
self
# Check if number of iteration is non existent
if (is.null(num_iteration)) {
num_iteration <- self$best_iter
}
# Save booster model
lgb.call("LGBM_BoosterSaveModel_R",
ret = NULL,
private$handle,
as.integer(num_iteration),
lgb.c_str(filename))
# Return self
return(self)
},
# Dump model in memory
dump_model = function(num_iteration = NULL) {
if (is.null(num_iteration)) { num_iteration <- self$best_iter }
lgb.call.return.str(
"LGBM_BoosterDumpModel_R",
private$handle,
as.integer(num_iteration)
)
# Check if number of iteration is non existent
if (is.null(num_iteration)) {
num_iteration <- self$best_iter
}
# Return dumped model
lgb.call.return.str("LGBM_BoosterDumpModel_R",
private$handle,
as.integer(num_iteration))
},
# Predict on new data
predict = function(data,
num_iteration = NULL,
rawscore = FALSE,
predleaf = FALSE,
header = FALSE,
reshape = FALSE) {
if (is.null(num_iteration)) { num_iteration <- self$best_iter }
num_iteration = NULL,
rawscore = FALSE,
predleaf = FALSE,
header = FALSE,
reshape = FALSE) {
# Check if number of iteration is non existent
if (is.null(num_iteration)) {
num_iteration <- self$best_iter
}
# Predict on new data
predictor <- Predictor$new(private$handle)
predictor$predict(data, num_iteration, rawscore, predleaf, header, reshape)
},
# Transform into predictor
to_predictor = function() {
Predictor$new(private$handle)
},
to_predictor = function() { Predictor$new(private$handle) },
# Used for save
raw = NA,
# Save model to temporary file for in-memory saving
save = function() {
# Create temporary file
temp <- tempfile()
# Save model to file
lgb.save(self, temp)
# Overwrite model in object
self$raw <- readChar(temp, file.info(temp)$size)
# Remove temporary file
file.remove(temp)
}
),
private = list(
handle = NULL,
train_set = NULL,
name_train_set = "training",
valid_sets = list(),
name_valid_sets = list(),
predict_buffer = list(),
is_predicted_cur_iter = list(),
num_class = 1,
num_dataset = 0,
init_predictor = NULL,
eval_names = NULL,
handle = NULL,
train_set = NULL,
name_train_set = "training",
valid_sets = list(),
name_valid_sets = list(),
predict_buffer = list(),
is_predicted_cur_iter = list(),
num_class = 1,
num_dataset = 0,
init_predictor = NULL,
eval_names = NULL,
higher_better_inner_eval = NULL,
inner_predict = function(idx) {
# Predict data
inner_predict = function(idx) {
# Store data name
data_name <- private$name_train_set
if (idx > 1) { data_name <- private$name_valid_sets[[idx - 1]] }
# Check for id bigger than 1
if (idx > 1) {
data_name <- private$name_valid_sets[[idx - 1]]
}
# Check for unknown dataset (over the maximum provided range)
if (idx > private$num_dataset) {
stop("data_idx should not be greater than num_dataset")
}
# Check for prediction buffer
if (is.null(private$predict_buffer[[data_name]])) {
# Store predictions
npred <- 0L
npred <- lgb.call("LGBM_BoosterGetNumPredict_R",
ret = npred,
private$handle,
as.integer(idx - 1))
private$predict_buffer[[data_name]] <- rep(0.0, npred)
ret = npred,
private$handle,
as.integer(idx - 1))
private$predict_buffer[[data_name]] <- numeric(npred)
}
# Check if current iteration was already predicted
if (!private$is_predicted_cur_iter[[idx]]) {
private$predict_buffer[[data_name]] <- lgb.call(
"LGBM_BoosterGetPredict_R",
ret = private$predict_buffer[[data_name]],
private$handle,
as.integer(idx - 1)
)
# Use buffer
private$predict_buffer[[data_name]] <- lgb.call("LGBM_BoosterGetPredict_R",
ret = private$predict_buffer[[data_name]],
private$handle,
as.integer(idx - 1))
private$is_predicted_cur_iter[[idx]] <- TRUE
}
private$predict_buffer[[data_name]]
# Return prediction buffer
return(private$predict_buffer[[data_name]])
},
# Get evaluation information
get_eval_info = function() {
# Check for evaluation names emptiness
if (is.null(private$eval_names)) {
names <- lgb.call.return.str("LGBM_BoosterGetEvalNames_R", private$handle)
# Get evaluation names
names <- lgb.call.return.str("LGBM_BoosterGetEvalNames_R",
private$handle)
# Check names' length
if (nchar(names) > 0) {
# Parse and store privately names
names <- strsplit(names, "\t")[[1]]
private$eval_names <- names
private$higher_better_inner_eval <- rep(FALSE, length(names))
# Loop through each name to pick up evaluation (and parse ndcg manually)
for (i in seq_along(names)) {
if ((names[i] == "auc") | grepl("^ndcg", names[i])) {
private$higher_better_inner_eval[i] <- TRUE
}
}
}
}
private$eval_names
# Return evaluation names
return(private$eval_names)
},
# Perform inner evaluation
inner_eval = function(data_name, data_idx, feval = NULL) {
# Check for unknown dataset (over the maximum provided range)
if (data_idx > private$num_dataset) {
stop("data_idx should not be greater than num_dataset")
}
# Get evaluation information
private$get_eval_info()
# Prepare return
ret <- list()
# Check evaluation names existence
if (length(private$eval_names) > 0) {
tmp_vals <- rep(0.0, length(private$eval_names))
tmp_vals <- lgb.call("LGBM_BoosterGetEval_R", ret = tmp_vals,
private$handle,
as.integer(data_idx - 1))
# Create evaluation values
tmp_vals <- numeric(length(private$eval_names))
tmp_vals <- lgb.call("LGBM_BoosterGetEval_R",
ret = tmp_vals,
private$handle,
as.integer(data_idx - 1))
# Loop through all evaluation names
for (i in seq_along(private$eval_names)) {
res <- list()
res$data_name <- data_name
res$name <- private$eval_names[i]
res$value <- tmp_vals[i]
# Store evaluation and append to return
res <- list()
res$data_name <- data_name
res$name <- private$eval_names[i]
res$value <- tmp_vals[i]
res$higher_better <- private$higher_better_inner_eval[i]
ret <- append(ret, list(res))
ret <- append(ret, list(res))
}
}
# Check if there are evaluation metrics
if (!is.null(feval)) {
# Check if evaluation metric is a function
if (!is.function(feval)) {
stop("lgb.Booster.eval: feval should be a function")
}
# Prepare data
data <- private$train_set
if (data_idx > 1) { data <- private$valid_sets[[data_idx - 1]] }
# Check if data to assess is existing differently
if (data_idx > 1) {
data <- private$valid_sets[[data_idx - 1]]
}
# Perform function evaluation
res <- feval(private$inner_predict(data_idx), data)
if(is.null(res$name) | is.null(res$value) |
is.null(res$higher_better)) {
# Check for name correctness
if(is.null(res$name) | is.null(res$value) | is.null(res$higher_better)) {
stop("lgb.Booster.eval: custom eval function should return a
list with attribute (name, value, higher_better)");
}
# Append names and evaluation
res$data_name <- data_name
ret <- append(ret, list(res))
ret <- append(ret, list(res))
}
ret
# Return ret
return(ret)
}
)
)
......@@ -322,32 +598,49 @@ Booster <- R6Class(
#'
#' When \code{predleaf = TRUE}, the output is a matrix object with the
#' number of columns corresponding to the number of trees.
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' preds <- predict(model, test$data)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' preds <- predict(model, test$data)
#' }
#'
#' @rdname predict.lgb.Booster
#' @export
predict.lgb.Booster <- function(object, data,
num_iteration = NULL,
rawscore = FALSE,
predleaf = FALSE,
header = FALSE,
reshape = FALSE) {
rawscore = FALSE,
predleaf = FALSE,
header = FALSE,
reshape = FALSE) {
# Check booster existence
if (!lgb.is.Booster(object)) {
stop("predict.lgb.Booster: object should be an ", sQuote("lgb.Booster"))
}
object$predict(data, num_iteration, rawscore, predleaf, header, reshape)
# Return booster predictions
object$predict(data,
num_iteration,
rawscore,
predleaf,
header,
reshape)
}
#' Load LightGBM model
......@@ -357,26 +650,41 @@ predict.lgb.Booster <- function(object, data,
#' @param filename path of model file
#'
#' @return booster
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' lgb.save(model, "model.txt")
#' load_booster <- lgb.load("model.txt")
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' lgb.save(model, "model.txt")
#' load_booster <- lgb.load("model.txt")
#' }
#'
#' @rdname lgb.load
#' @export
lgb.load <- function(filename){
if (!is.character(filename)) { stop("lgb.load: filename should be character") }
# Check if file name is character or not
if (!is.character(filename)) {
stop("lgb.load: filename should be character")
}
# Return new booster
Booster$new(modelfile = filename)
}
#' Save LightGBM model
......@@ -388,26 +696,45 @@ lgb.load <- function(filename){
#' @param num_iteration number of iteration want to predict with, NULL or <= 0 means use best iteration
#'
#' @return booster
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' lgb.save(model, "model.txt")
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' lgb.save(model, "model.txt")
#' }
#'
#' @rdname lgb.save
#' @export
lgb.save <- function(booster, filename, num_iteration = NULL){
if (!lgb.is.Booster(booster)) { stop("lgb.save: booster should be an ", sQuote("lgb.Booster")) }
if (!is.character(filename)) { stop("lgb.save: filename should be a character") }
# Check if booster is booster
if (!lgb.is.Booster(booster)) {
stop("lgb.save: booster should be an ", sQuote("lgb.Booster"))
}
# Check if file name is character
if (!is.character(filename)) {
stop("lgb.save: filename should be a character")
}
# Store booster
booster$save_model(filename, num_iteration)
}
#' Dump LightGBM model to json
......@@ -418,25 +745,40 @@ lgb.save <- function(booster, filename, num_iteration = NULL){
#' @param num_iteration number of iteration want to predict with, NULL or <= 0 means use best iteration
#'
#' @return json format of model
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' json_model <- lgb.dump(model)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' json_model <- lgb.dump(model)
#' }
#'
#' @rdname lgb.dump
#' @export
lgb.dump <- function(booster, num_iteration = NULL){
if (!lgb.is.Booster(booster)) { stop("lgb.save: booster should be an ", sQuote("lgb.Booster")) }
# Check if booster is booster
if (!lgb.is.Booster(booster)) {
stop("lgb.save: booster should be an ", sQuote("lgb.Booster"))
}
# Return booster at requested iteration
booster$dump_model(num_iteration)
}
#' Get record evaluation result from booster
......@@ -447,31 +789,51 @@ lgb.dump <- function(booster, num_iteration = NULL){
#' @param eval_name name of evaluation
#' @param iters iterations, NULL will return all
#' @param is_err TRUE will return evaluation error instead
#'
#' @return vector of evaluation result
#'
#' @rdname lgb.get.eval.result
#' @export
lgb.get.eval.result <- function(booster, data_name, eval_name, iters = NULL, is_err = FALSE) {
# Check if booster is booster
if (!lgb.is.Booster(booster)) {
stop("lgb.get.eval.result: Can only use ", sQuote("lgb.Booster"), " to get eval result")
}
# Check if data and evaluation name are characters or not
if (!is.character(data_name) || !is.character(eval_name)) {
stop("lgb.get.eval.result: data_name and eval_name should be characters")
}
# Check if recorded evaluation is existing
if (is.null(booster$record_evals[[data_name]])) {
stop("lgb.get.eval.result: wrong data name")
}
# Check if evaluation result is existing
if (is.null(booster$record_evals[[data_name]][[eval_name]])) {
stop("lgb.get.eval.result: wrong eval name")
}
# Create result
result <- booster$record_evals[[data_name]][[eval_name]]$eval
# Check if error is requested
if (is_err) {
result <- booster$record_evals[[data_name]][[eval_name]]$eval_err
}
# Check if iteration is non existant
if (is.null(iters)) {
return(as.numeric(result))
}
# Parse iteration and booster delta
iters <- as.integer(iters)
delta <- booster$record_evals$start_iter - 1
iters <- iters - delta
# Return requested result
as.numeric(result[iters])
}
R-package/R/lgb.Dataset.R
View file @ b6c973af
Dataset <- R6Class(
"lgb.Dataset",
classname = "lgb.Dataset",
cloneable = FALSE,
public = list(
# Finalize will free up the handles
finalize = function() {
# Check the need for freeing handle
if (!lgb.is.null.handle(private$handle)) {
# Freeing up handle
lgb.call("LGBM_DatasetFree_R", ret = NULL, private$handle)
private$handle <- NULL
}
},
# Initialize will create a starter dataset
initialize = function(data,
params = list(),
reference = NULL,
colnames = NULL,
params = list(),
reference = NULL,
colnames = NULL,
categorical_feature = NULL,
predictor = NULL,
free_raw_data = TRUE,
used_indices = NULL,
info = list(),
predictor = NULL,
free_raw_data = TRUE,
used_indices = NULL,
info = list(),
...) {
# Check for additional parameters
additional_params <- list(...)
INFO_KEYS <- c('label', 'weight', 'init_score', 'group')
# Create known attributes list
INFO_KEYS <- c("label", "weight", "init_score", "group")
# Check if attribute key is in the known attribute list
for (key in names(additional_params)) {
# Key existing
if (key %in% INFO_KEYS) {
# Store as info
info[[key]] <- additional_params[[key]]
} else {
# Store as param
params[[key]] <- additional_params[[key]]
}
}
# Check for dataset reference
if (!is.null(reference)) {
if (!lgb.check.r6.class(reference, "lgb.Dataset")) {
stop("lgb.Dataset: Can only use ", sQuote("lgb.Dataset"), " as reference")
}
}
# Check for predictor reference
if (!is.null(predictor)) {
if (!lgb.check.r6.class(predictor, "lgb.Predictor")) {
stop("lgb.Dataset: Only can use ", sQuote("lgb.Predictor"), " as predictor")
}
}
private$raw_data <- data
private$params <- params
# Setup private attributes
private$raw_data <- data
private$params <- params
private$reference <- reference
private$colnames <- colnames
private$colnames <- colnames
private$categorical_feature <- categorical_feature
private$predictor <- predictor
private$free_raw_data <- free_raw_data
private$used_indices <- used_indices
private$info <- info
private$predictor <- predictor
private$free_raw_data <- free_raw_data
private$used_indices <- used_indices
private$info <- info
},
create_valid = function(data, info = list(), ...) {
ret <- Dataset$new(
data,
private$params,
self,
private$colnames,
private$categorical_feature,
private$predictor,
private$free_raw_data,
NULL,
info,
...
)
ret
create_valid = function(data,
info = list(),
...) {
# Create new dataset
ret <- Dataset$new(data,
private$params,
self,
private$colnames,
private$categorical_feature,
private$predictor,
private$free_raw_data,
NULL,
info,
...)
# Return ret
return(ret)
},
# Dataset constructor
construct = function() {
# Check for handle null
if (!lgb.is.null.handle(private$handle)) {
return(self)
}
# Get feature names
cnames <- NULL
if (is.matrix(private$raw_data) || is(private$raw_data, "dgCMatrix")) {
cnames <- colnames(private$raw_data)
}
# set feature names if not exist
if (is.null(private$colnames) && !is.null(cnames)) {
private$colnames <- as.character(cnames)
}
# Get categorical feature index
if (!is.null(private$categorical_feature)) {
# Check for character name
if (typeof(private$categorical_feature) == "character") {
cate_indices <- as.list(match(private$categorical_feature, private$colnames) - 1)
# Provided indices, but some indices are not existing?
if (sum(is.na(cate_indices)) > 0) {
stop("lgb.self.get.handle: supplied an unknown feature in categorical_feature: ", sQuote(private$categorical_feature[is.na(cate_indices)]))
}
} else {
# Check if more categorical features were output over the feature space
if (max(private$categorical_feature) > length(private$colnames)) {
stop("lgb.self.get.handle: supplied a too large value in categorical_feature: ", max(private$categorical_feature), " but only ", length(private$colnames), " features")
}
# Store indices as [0, n-1] indexed instead of [1, n] indexed
cate_indices <- as.list(private$categorical_feature - 1)
}
# Store indices for categorical features
private$params$categorical_feature <- cate_indices
}
# Check has header or not
has_header <- FALSE
if (!is.null(private$params$has_header) ||
!is.null(private$params$header)) {
if (tolower(as.character(private$params$has_header)) == "true"
||
tolower(as.character(private$params$header)) == "true") {
if (!is.null(private$params$has_header) || !is.null(private$params$header)) {
if (tolower(as.character(private$params$has_header)) == "true" || tolower(as.character(private$params$header)) == "true") {
has_header <- TRUE
}
}
# Generate parameter str
params_str <- lgb.params2str(private$params)
# get handle of reference dataset
# Get handle of reference dataset
ref_handle <- NULL
if (!is.null(private$reference)) {
ref_handle <- private$reference$.__enclos_env__$private$get_handle()
}
handle <- lgb.new.handle()
# not subset
# Not subsetting
if (is.null(private$used_indices)) {
# Are we using a data file?
if (is.character(private$raw_data)) {
handle <- lgb.call(
"LGBM_DatasetCreateFromFile_R",
ret = handle,
lgb.c_str(private$raw_data),
params_str,
ref_handle
)
handle <- lgb.call("LGBM_DatasetCreateFromFile_R",
ret = handle,
lgb.c_str(private$raw_data),
params_str,
ref_handle)
} else if (is.matrix(private$raw_data)) {
handle <- lgb.call(
"LGBM_DatasetCreateFromMat_R",
ret = handle,
private$raw_data,
nrow(private$raw_data),
ncol(private$raw_data),
params_str,
ref_handle
)
# Are we using a matrix?
handle <- lgb.call("LGBM_DatasetCreateFromMat_R",
ret = handle,
private$raw_data,
nrow(private$raw_data),
ncol(private$raw_data),
params_str,
ref_handle)
} else if (is(private$raw_data, "dgCMatrix")) {
handle <- lgb.call(
"LGBM_DatasetCreateFromCSC_R",
ret = handle,
private$raw_data@p,
private$raw_data@i,
private$raw_data@x,
length(private$raw_data@p),
length(private$raw_data@x),
nrow(private$raw_data),
params_str,
ref_handle
)
# Are we using a dgCMatrix (sparsed matrix column compressed)
handle <- lgb.call("LGBM_DatasetCreateFromCSC_R",
ret = handle,
private$raw_data@p,
private$raw_data@i,
private$raw_data@x,
length(private$raw_data@p),
length(private$raw_data@x),
nrow(private$raw_data),
params_str,
ref_handle)
} else {
stop(
"lgb.Dataset.construct: does not support constructing from ", sQuote(class(private$raw_data))
)
# Unknown data type
stop("lgb.Dataset.construct: does not support constructing from ", sQuote(class(private$raw_data)))
}
} else {
# construct subset
# Reference is empty
if (is.null(private$reference)) {
stop("lgb.Dataset.construct: reference cannot be NULL for constructing data subset")
}
handle <- lgb.call(
"LGBM_DatasetGetSubset_R",
ret = handle,
ref_handle,
private$used_indices,
length(private$used_indices),
params_str
)
# Construct subset
handle <- lgb.call("LGBM_DatasetGetSubset_R",
ret = handle,
ref_handle,
private$used_indices,
length(private$used_indices),
params_str)
}
# Setup class and private type
class(handle) <- "lgb.Dataset.handle"
private$handle <- handle
# set feature names
if (!is.null(private$colnames)) { self$set_colnames(private$colnames) }
# Set feature names
if (!is.null(private$colnames)) {
self$set_colnames(private$colnames)
}
# load init score
if (!is.null(private$predictor) &&
is.null(private$used_indices)) {
# Load init score if requested
if (!is.null(private$predictor) && is.null(private$used_indices)) {
# Setup initial scores
init_score <- private$predictor$predict(private$raw_data, rawscore = TRUE, reshape = TRUE)
# do not need to transpose, for is col_marjor
# Not needed to transpose, for is col_marjor
init_score <- as.vector(init_score)
private$info$init_score <- init_score
}
# Should we free raw data?
if (isTRUE(private$free_raw_data)) {
private$raw_data <- NULL
}
if (isTRUE(private$free_raw_data)) { private$raw_data <- NULL }
# Get private information
if (length(private$info) > 0) {
# set infos
# Set infos
for (i in seq_along(private$info)) {
p <- private$info[i]
self$setinfo(names(p), p[[1]])
}
}
# Get label information existence
if (is.null(self$getinfo("label"))) {
stop("lgb.Dataset.construct: label should be set")
}
self
# Return oneself
return(self)
},
# Dimension function
dim = function() {
# Check for handle
if (!lgb.is.null.handle(private$handle)) {
num_row <- 0L
num_col <- 0L
c(
lgb.call("LGBM_DatasetGetNumData_R", ret = num_row, private$handle),
lgb.call("LGBM_DatasetGetNumFeature_R", ret = num_col, private$handle)
)
# Get numeric data and numeric features
c(lgb.call("LGBM_DatasetGetNumData_R", ret = num_row, private$handle),
lgb.call("LGBM_DatasetGetNumFeature_R", ret = num_col, private$handle))
} else if (is.matrix(private$raw_data) || is(private$raw_data, "dgCMatrix")) {
# Check if dgCMatrix (sparse matrix column compressed)
dim(private$raw_data)
} else {
stop(
"dim: cannot get dimensions before dataset has been constructed, please call lgb.Dataset.construct explicitly"
)
# Trying to work with unknown dimensions is not possible
stop("dim: cannot get dimensions before dataset has been constructed, please call lgb.Dataset.construct explicitly")
}
},
# Get column names
get_colnames = function() {
# Check for handle
if (!lgb.is.null.handle(private$handle)) {
# Get feature names and write them
cnames <- lgb.call.return.str("LGBM_DatasetGetFeatureNames_R", private$handle)
private$colnames <- as.character(base::strsplit(cnames, "\t")[[1]])
private$colnames
} else if (is.matrix(private$raw_data) || is(private$raw_data, "dgCMatrix")) {
# Check if dgCMatrix (sparse matrix column compressed)
colnames(private$raw_data)
} else {
stop(
"dim: cannot get dimensions before dataset has been constructed, please call lgb.Dataset.construct explicitly"
)
# Trying to work with unknown dimensions is not possible
stop("dim: cannot get dimensions before dataset has been constructed, please call lgb.Dataset.construct explicitly")
}
},
# Set column names
set_colnames = function(colnames) {
if (is.null(colnames)) { return(self) }
# Check column names non-existence
if (is.null(colnames)) {
return(self)
}
# Check empty column names
colnames <- as.character(colnames)
if (length(colnames) == 0) { return(self) }
if (length(colnames) == 0) {
return(self)
}
# Write column names
private$colnames <- colnames
if (!lgb.is.null.handle(private$handle)) {
# Merge names with tab separation
merged_name <- paste0(as.list(private$colnames), collapse = "\t")
lgb.call("LGBM_DatasetSetFeatureNames_R",
ret = NULL,
private$handle,
lgb.c_str(merged_name))
}
self
# Return self
return(self)
},
# Get information
getinfo = function(name) {
# Create known attributes list
INFONAMES <- c("label", "weight", "init_score", "group")
if (!is.character(name) ||
length(name) != 1 ||
!name %in% INFONAMES) {
stop(
"getinfo: name must one of the following: ", paste0(sQuote(INFONAMES), collapse = ", ")
)
# Check if attribute key is in the known attribute list
if (!is.character(name) || length(name) != 1 || !name %in% INFONAMES) {
stop("getinfo: name must one of the following: ", paste0(sQuote(INFONAMES), collapse = ", "))
}
# Check for info name and handle
if (is.null(private$info[[name]]) && !lgb.is.null.handle(private$handle)) {
# Get field size of info
info_len <- 0L
info_len <- lgb.call("LGBM_DatasetGetFieldSize_R",
ret = info_len,
private$handle,
lgb.c_str(name))
# Check if info is not empty
if (info_len > 0) {
# Get back fields
ret <- NULL
ret <- if (name == "group") { integer(info_len) } else { rep(0.0, info_len) }
ret <- if (name == "group") {
integer(info_len) # Integer
} else {
numeric(info_len) # Numeric
}
ret <- lgb.call("LGBM_DatasetGetField_R",
ret = ret,
private$handle,
lgb.c_str(name))
private$info[[name]] <- ret
}
}
private$info[[name]]
},
# Set information
setinfo = function(name, info) {
# Create known attributes list
INFONAMES <- c("label", "weight", "init_score", "group")
if (!is.character(name) ||
length(name) != 1 ||
!name %in% INFONAMES) {
stop(
"setinfo: name must one of the following: ", paste0(sQuote(INFONAMES), collapse = ", ")
)
}
info <- if (name == "group") { as.integer(info) } else { as.numeric(info) }
# Check if attribute key is in the known attribute list
if (!is.character(name) || length(name) != 1 || !name %in% INFONAMES) {
stop("setinfo: name must one of the following: ", paste0(sQuote(INFONAMES), collapse = ", "))
}
# Check for type of information
info <- if (name == "group") {
as.integer(info) # Integer
} else {
as.numeric(info) # Numeric
}
# Store information privately
private$info[[name]] <- info
if (!lgb.is.null.handle(private$handle) && !is.null(info)) {
if (length(info) > 0) {
lgb.call(
"LGBM_DatasetSetField_R",
ret = NULL,
private$handle,
lgb.c_str(name),
info,
length(info)
)
lgb.call("LGBM_DatasetSetField_R",
ret = NULL,
private$handle,
lgb.c_str(name),
info,
length(info))
}
}
self
# Return self
return(self)
},
# Slice dataset
slice = function(idxset, ...) {
Dataset$new(
NULL,
private$params,
self,
private$colnames,
private$categorical_feature,
private$predictor,
private$free_raw_data,
idxset,
NULL,
...
)
# Perform slicing
Dataset$new(NULL,
private$params,
self,
private$colnames,
private$categorical_feature,
private$predictor,
private$free_raw_data,
idxset,
NULL,
...)
},
# Update parameters
update_params = function(params) {
# Parameter updating
private$params <- modifyList(private$params, params)
self
},
# Set categorical feature parameter
set_categorical_feature = function(categorical_feature) {
if (identical(private$categorical_feature, categorical_feature)) { return(self) }
# Check for identical input
if (identical(private$categorical_feature, categorical_feature)) {
return(self)
}
# Check for empty data
if (is.null(private$raw_data)) {
stop(
"set_categorical_feature: cannot set categorical feature after freeing raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset"
)
stop("set_categorical_feature: cannot set categorical feature after freeing raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset")
}
# Overwrite categorical features
private$categorical_feature <- categorical_feature
# Finalize and return self
self$finalize()
self
return(self)
},
# Set reference
set_reference = function(reference) {
# Set known references
self$set_categorical_feature(reference$.__enclos_env__$private$categorical_feature)
self$set_colnames(reference$get_colnames())
private$set_predictor(reference$.__enclos_env__$private$predictor)
if (identical(private$reference, reference)) { return(self) }
# Check for identical references
if (identical(private$reference, reference)) {
return(self)
}
# Check for empty data
if (is.null(private$raw_data)) {
stop(
"set_reference: cannot set reference after freeing raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset"
)
stop("set_reference: cannot set reference after freeing raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset")
}
# Check for non-existing reference
if (!is.null(reference)) {
# Reference is unknown
if (!lgb.check.r6.class(reference, "lgb.Dataset")) {
stop("set_reference: Can only use lgb.Dataset as a reference")
}
}
# Store reference
private$reference <- reference
# Finalize and return self
self$finalize()
self
return(self)
},
# Save binary model
save_binary = function(fname) {
# Store binary data
self$construct()
lgb.call("LGBM_DatasetSaveBinary_R",
ret = NULL,
private$handle,
lgb.c_str(fname))
self
return(self)
}
),
private = list(
handle = NULL,
raw_data = NULL,
params = list(),
reference = NULL,
colnames = NULL,
handle = NULL,
raw_data = NULL,
params = list(),
reference = NULL,
colnames = NULL,
categorical_feature = NULL,
predictor = NULL,
free_raw_data = TRUE,
used_indices = NULL,
info = NULL,
get_handle = function() {
if (lgb.is.null.handle(private$handle)) { self$construct() }
predictor = NULL,
free_raw_data = TRUE,
used_indices = NULL,
info = NULL,
# Get handle
get_handle = function() {
# Get handle and construct if needed
if (lgb.is.null.handle(private$handle)) {
self$construct()
}
private$handle
},
# Set predictor
set_predictor = function(predictor) {
if (identical(private$predictor, predictor)) { return(self) }
# Return self is identical predictor
if (identical(private$predictor, predictor)) {
return(self)
}
# Check for empty data
if (is.null(private$raw_data)) {
stop(
"set_predictor: cannot set predictor after free raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset"
)
stop("set_predictor: cannot set predictor after free raw data,
please set ", sQuote("free_raw_data = FALSE"), " when you construct lgb.Dataset")
}
# Check for empty predictor
if (!is.null(predictor)) {
# Predictor is unknown
if (!lgb.check.r6.class(predictor, "lgb.Predictor")) {
stop("set_predictor: Can only use lgb.Predictor as predictor")
}
}
# Store predictor
private$predictor <- predictor
# Finalize and return self
self$finalize()
self
return(self)
}
)
)
......@@ -390,112 +624,141 @@ Dataset <- R6Class(
#' @param free_raw_data TRUE for need to free raw data after construct
#' @param info a list of information of the lgb.Dataset object
#' @param ... other information to pass to \code{info} or parameters pass to \code{params}
#'
#' @return constructed dataset
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.save(dtrain, 'lgb.Dataset.data')
#' dtrain <- lgb.Dataset('lgb.Dataset.data')
#' lgb.Dataset.construct(dtrain)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.save(dtrain, "lgb.Dataset.data")
#' dtrain <- lgb.Dataset("lgb.Dataset.data")
#' lgb.Dataset.construct(dtrain)
#' }
#'
#' @export
lgb.Dataset <- function(data,
params = list(),
reference = NULL,
colnames = NULL,
params = list(),
reference = NULL,
colnames = NULL,
categorical_feature = NULL,
free_raw_data = TRUE,
info = list(),
free_raw_data = TRUE,
info = list(),
...) {
Dataset$new(
data,
params,
reference,
colnames,
categorical_feature,
NULL,
free_raw_data,
NULL,
info,
...
)
# Create new dataset
Dataset$new(data,
params,
reference,
colnames,
categorical_feature,
NULL,
free_raw_data,
NULL,
info,
...)
}
#' Construct validation data
#'
#'
#' Construct validation data according to training data
#'
#'
#' @param dataset \code{lgb.Dataset} object, training data
#' @param data a \code{matrix} object, a \code{dgCMatrix} object or a character representing a filename
#' @param info a list of information of the lgb.Dataset object
#' @param ... other information to pass to \code{info}.
#'
#' @return constructed dataset
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' }
#'
#' @export
lgb.Dataset.create.valid <- function(dataset, data, info = list(), ...) {
lgb.Dataset.create.valid <- function(dataset, data, info = list(), ...) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("lgb.Dataset.create.valid: input data should be an lgb.Dataset object")
}
# Create validation dataset
dataset$create_valid(data, info, ...)
}
#' Construct Dataset explicitly
#'
#'
#' @param dataset Object of class \code{lgb.Dataset}
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.construct(dtrain)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.construct(dtrain)
#' }
#'
#' @export
lgb.Dataset.construct <- function(dataset) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("lgb.Dataset.construct: input data should be an lgb.Dataset object")
}
# Construct the dataset
dataset$construct()
}
#' Dimensions of an lgb.Dataset
#'
#'
#' Returns a vector of numbers of rows and of columns in an \code{lgb.Dataset}.
#' @param x Object of class \code{lgb.Dataset}
#' @param ... other parameters
#'
#' @return a vector of numbers of rows and of columns
#'
#'
#' @details
#' Note: since \code{nrow} and \code{ncol} internally use \code{dim}, they can also
#' be directly used with an \code{lgb.Dataset} object.
#'
#'
#' @examples
#' dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#'
#' stopifnot(nrow(dtrain) == nrow(train$data))
#' stopifnot(ncol(dtrain) == ncol(train$data))
#' stopifnot(all(dim(dtrain) == dim(train$data)))
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#'
#' stopifnot(nrow(dtrain) == nrow(train$data))
#' stopifnot(ncol(dtrain) == ncol(train$data))
#' stopifnot(all(dim(dtrain) == dim(train$data)))
#' }
#'
#' @rdname dim
#' @export
dim.lgb.Dataset <- function(x, ...) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(x)) {
stop("dim.lgb.Dataset: input data should be an lgb.Dataset object")
}
# Return dimensions
x$dim()
}
#' Handling of column names of \code{lgb.Dataset}
......@@ -512,227 +775,305 @@ dim.lgb.Dataset <- function(x, ...) {
#' Since row names are irrelevant, it is recommended to use \code{colnames} directly.
#'
#' @examples
#' dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.construct(dtrain)
#' dimnames(dtrain)
#' colnames(dtrain)
#' colnames(dtrain) <- make.names(1:ncol(train$data))
#' print(dtrain, verbose=TRUE)
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.construct(dtrain)
#' dimnames(dtrain)
#' colnames(dtrain)
#' colnames(dtrain) <- make.names(1:ncol(train$data))
#' print(dtrain, verbose = TRUE)
#' }
#'
#' @rdname dimnames.lgb.Dataset
#' @export
dimnames.lgb.Dataset <- function(x) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(x)) {
stop("dimnames.lgb.Dataset: input data should be an lgb.Dataset object")
}
# Return dimension names
list(NULL, x$get_colnames())
}
#' @rdname dimnames.lgb.Dataset
#' @export
`dimnames<-.lgb.Dataset` <- function(x, value) {
if (!is.list(value) || length(value) != 2L)
# Check if invalid element list
if (!is.list(value) || length(value) != 2L) {
stop("invalid ", sQuote("value"), " given: must be a list of two elements")
if (!is.null(value[[1L]])) { stop("lgb.Dataset does not have rownames") }
}
# Check for unknown row names
if (!is.null(value[[1L]])) {
stop("lgb.Dataset does not have rownames")
}
# Check for second value missing
if (is.null(value[[2]])) {
# No column names
x$set_colnames(NULL)
return(x)
}
# Check for unmatching column size
if (ncol(x) != length(value[[2]])) {
stop("can't assign ", sQuote(length(value[[2]])), " colnames to an lgb.Dataset with ", sQuote(ncol(x)), " columns")
}
if (ncol(x) != length(value[[2]]))
stop("can't assign ",
sQuote(length(value[[2]])),
" colnames to an lgb.Dataset with ",
sQuote(ncol(x)), " columns")
# Set column names properly, and return
x$set_colnames(value[[2]])
x
}
#' Slice a dataset
#'
#'
#' Get a new \code{lgb.Dataset} containing the specified rows of
#' orginal lgb.Dataset object
#'
#'
#' @param dataset Object of class "lgb.Dataset"
#' @param idxset a integer vector of indices of rows needed
#' @param ... other parameters (currently not used)
#' @return constructed sub dataset
#'
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#'
#' dsub <- slice(dtrain, 1:42)
#' labels1 <- getinfo(dsub, 'label')
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#'
#' dsub <- lightgbm::slice(dtrain, 1:42)
#' labels <- lightgbm::getinfo(dsub, "label")
#' }
#'
#' @export
slice <- function(dataset, ...) { UseMethod("slice") }
slice <- function(dataset, ...) {
UseMethod("slice")
}
#' @rdname slice
#' @export
slice.lgb.Dataset <- function(dataset, idxset, ...) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("slice.lgb.Dataset: input dataset should be an lgb.Dataset object")
}
# Return sliced set
dataset$slice(idxset, ...)
}
#' Get information of an lgb.Dataset object
#'
#'
#' @param dataset Object of class \code{lgb.Dataset}
#' @param name the name of the information field to get (see details)
#' @param ... other parameters
#' @return info data
#'
#'
#' @details
#' The \code{name} field can be one of the following:
#'
#'
#' \itemize{
#' \item \code{label}: label lightgbm learn from ;
#' \item \code{weight}: to do a weight rescale ;
#' \item \code{group}: group size
#' \item \code{init_score}: initial score is the base prediction lightgbm will boost from ;
#' }
#'
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.construct(dtrain)
#' labels <- getinfo(dtrain, 'label')
#' setinfo(dtrain, 'label', 1-labels)
#'
#' labels2 <- getinfo(dtrain, 'label')
#' stopifnot(all(labels2 == 1-labels))
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.construct(dtrain)
#'
#' labels <- lightgbm::getinfo(dtrain, "label")
#' lightgbm::setinfo(dtrain, "label", 1 - labels)
#'
#' labels2 <- lightgbm::getinfo(dtrain, "label")
#' stopifnot(all(labels2 == 1 - labels))
#' }
#'
#' @export
getinfo <- function(dataset, ...) { UseMethod("getinfo") }
getinfo <- function(dataset, ...) {
UseMethod("getinfo")
}
#' @rdname getinfo
#' @export
getinfo.lgb.Dataset <- function(dataset, name, ...) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("getinfo.lgb.Dataset: input dataset should be an lgb.Dataset object")
}
# Return information
dataset$getinfo(name)
}
#' Set information of an lgb.Dataset object
#'
#'
#' @param dataset Object of class "lgb.Dataset"
#' @param name the name of the field to get
#' @param info the specific field of information to set
#' @param ... other parameters
#' @return passed object
#'
#'
#' @details
#' The \code{name} field can be one of the following:
#'
#'
#' \itemize{
#' \item \code{label}: label lightgbm learn from ;
#' \item \code{weight}: to do a weight rescale ;
#' \item \code{init_score}: initial score is the base prediction lightgbm will boost from ;
#' \item \code{group}.
#' }
#'
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.construct(dtrain)
#' labels <- getinfo(dtrain, 'label')
#' setinfo(dtrain, 'label', 1-labels)
#' labels2 <- getinfo(dtrain, 'label')
#' stopifnot(all.equal(labels2, 1-labels))
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.construct(dtrain)
#'
#' labels <- lightgbm::getinfo(dtrain, "label")
#' lightgbm::setinfo(dtrain, "label", 1 - labels)
#'
#' labels2 <- lightgbm::getinfo(dtrain, "label")
#' stopifnot(all.equal(labels2, 1 - labels))
#' }
#'
#' @export
setinfo <- function(dataset, ...) { UseMethod("setinfo") }
setinfo <- function(dataset, ...) {
UseMethod("setinfo")
}
#' @rdname setinfo
#' @export
setinfo.lgb.Dataset <- function(dataset, name, info, ...) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("setinfo.lgb.Dataset: input dataset should be an lgb.Dataset object")
}
# Set information
dataset$setinfo(name, info)
}
#' Set categorical feature of \code{lgb.Dataset}
#'
#'
#' @param dataset object of class \code{lgb.Dataset}
#' @param categorical_feature categorical features
#'
#' @return passed dataset
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.save(dtrain, 'lgb.Dataset.data')
#' dtrain <- lgb.Dataset('lgb.Dataset.data')
#' lgb.Dataset.set.categorical(dtrain, 1:2)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.save(dtrain, "lgb.Dataset.data")
#' dtrain <- lgb.Dataset("lgb.Dataset.data")
#' lgb.Dataset.set.categorical(dtrain, 1:2)
#' }
#'
#' @rdname lgb.Dataset.set.categorical
#' @export
lgb.Dataset.set.categorical <- function(dataset, categorical_feature) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("lgb.Dataset.set.categorical: input dataset should be an lgb.Dataset object")
}
# Set categoricals
dataset$set_categorical_feature(categorical_feature)
}
#' Set reference of \code{lgb.Dataset}
#'
#'
#' If you want to use validation data, you should set reference to training data
#'
#'
#' @param dataset object of class \code{lgb.Dataset}
#' @param reference object of class \code{lgb.Dataset}
#'
#' @return passed dataset
#'
#' @examples
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset(test$data, test=train$label)
#' lgb.Dataset.set.reference(dtest, dtrain)
#' library(lightgbm)
#' data(agaricus.train, package ="lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset(test$data, test = train$label)
#' lgb.Dataset.set.reference(dtest, dtrain)
#' }
#'
#' @rdname lgb.Dataset.set.reference
#' @export
lgb.Dataset.set.reference <- function(dataset, reference) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("lgb.Dataset.set.reference: input dataset should be an lgb.Dataset object")
}
# Set reference
dataset$set_reference(reference)
}
#' Save \code{lgb.Dataset} to a binary file
#'
#'
#' @param dataset object of class \code{lgb.Dataset}
#' @param fname object filename of output file
#'
#' @return passed dataset
#'
#' @examples
#'
#' \dontrun{
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' lgb.Dataset.save(dtrain, "data.bin")
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' lgb.Dataset.save(dtrain, "data.bin")
#' }
#'
#' @rdname lgb.Dataset.save
#' @export
lgb.Dataset.save <- function(dataset, fname) {
# Check if dataset is not a dataset
if (!lgb.is.Dataset(dataset)) {
stop("lgb.Dataset.set: input dataset should be an lgb.Dataset object")
}
# File-type is not matching
if (!is.character(fname)) {
stop("lgb.Dataset.set: fname should be a character or a file connection")
}
# Store binary
dataset$save_binary(fname)
}
R-package/R/lgb.Predictor.R
View file @ b6c973af
Predictor <- R6Class(
"lgb.Predictor",
classname = "lgb.Predictor",
cloneable = FALSE,
public = list(
# Finalize will free up the handles
finalize = function() {
# Check the need for freeing handle
if (private$need_free_handle && !lgb.is.null.handle(private$handle)) {
cat("free booster handle\n")
# Freeing up handle
lgb.call("LGBM_BoosterFree_R", ret = NULL, private$handle)
private$handle <- NULL
}
},
# Initialize will create a starter model
initialize = function(modelfile) {
# Create new lgb handle
handle <- lgb.new.handle()
# Check if handle is a character
if (is.character(modelfile)) {
# Create handle on it
handle <- lgb.call("LGBM_BoosterCreateFromModelfile_R", ret = handle, lgb.c_str(modelfile))
private$need_free_handle <- TRUE
} else if (is(modelfile, "lgb.Booster.handle")) {
# Check if model file is a booster handle already
handle <- modelfile
private$need_free_handle <- FALSE
} else {
# Model file is unknown
stop("lgb.Predictor: modelfile must be either a character filename or an lgb.Booster.handle")
}
# Override class and store it
class(handle) <- "lgb.Booster.handle"
private$handle <- handle
},
# Get current iteration
current_iter = function() {
cur_iter <- 0L
lgb.call("LGBM_BoosterGetCurrentIteration_R", ret = cur_iter, private$handle)
},
predict = function(data, num_iteration = NULL, rawscore = FALSE,
predleaf = FALSE, header = FALSE, reshape = FALSE) {
if (is.null(num_iteration)) { num_iteration <- -1 }
# Predict from data
predict = function(data,
num_iteration = NULL,
rawscore = FALSE,
predleaf = FALSE,
header = FALSE,
reshape = FALSE) {
# Check if number of iterations is existing - if not, then set it to -1 (use all)
if (is.null(num_iteration)) {
num_iteration <- -1
}
# Set temporary variable
num_row <- 0L
# Check if data is a file name
if (is.character(data)) {
# Data is a filename, create a temporary file with a "lightgbm_" pattern in it
tmp_filename <- tempfile(pattern = "lightgbm_")
on.exit(unlink(tmp_filename), add = TRUE)
# Predict from temporary file
lgb.call("LGBM_BoosterPredictForFile_R", ret = NULL, private$handle, data,
as.integer(header),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration),
lgb.c_str(tmp_filename))
preds <- read.delim(tmp_filename, header = FALSE, seq = "\t")
# Get predictions from file
preds <- read.delim(tmp_filename, header = FALSE, seq = "\t")
num_row <- nrow(preds)
preds <- as.vector(t(preds))
preds <- as.vector(t(preds))
} else {
# Not a file, we need to predict from R object
num_row <- nrow(data)
npred <- 0L
npred <- lgb.call("LGBM_BoosterCalcNumPredict_R", ret = npred,
private$handle,
as.integer(num_row),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
# allocte space for prediction
preds <- rep(0.0, npred)
npred <- 0L
# Check number of predictions to do
npred <- lgb.call("LGBM_BoosterCalcNumPredict_R",
ret = npred,
private$handle,
as.integer(num_row),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
# Pre-allocate empty vector
preds <- numeric(npred)
# Check if data is a matrix
if (is.matrix(data)) {
preds <- lgb.call("LGBM_BoosterPredictForMat_R", ret = preds,
private$handle,
data,
as.integer(nrow(data)),
as.integer(ncol(data)),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
preds <- lgb.call("LGBM_BoosterPredictForMat_R",
ret = preds,
private$handle,
data,
as.integer(nrow(data)),
as.integer(ncol(data)),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
} else if (is(data, "dgCMatrix")) {
preds <- lgb.call("LGBM_BoosterPredictForCSC_R", ret = preds,
private$handle,
data@p,
data@i,
data@x,
length(data@p),
length(data@x),
nrow(data),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
# Check if data is a dgCMatrix (sparse matrix, column compressed format)
preds <- lgb.call("LGBM_BoosterPredictForCSC_R",
ret = preds,
private$handle,
data@p,
data@i,
data@x,
length(data@p),
length(data@x),
nrow(data),
as.integer(rawscore),
as.integer(predleaf),
as.integer(num_iteration))
} else {
# Cannot predict on unknown class
# to-do: predict from lgb.Dataset
stop("predict: cannot predict on data of class ", sQuote(class(data)))
}
}
# Check if number of rows is strange (not a multiple of the dataset rows)
if (length(preds) %% num_row != 0) {
stop("predict: prediction length ", sQuote(length(preds))," is not a multiple of nrows(data): ", sQuote(num_row))
}
# Get number of cases per row
npred_per_case <- length(preds) / num_row
# Data reshaping
if (predleaf) {
# Predict leaves only, reshaping is mandatory
preds <- matrix(preds, ncol = npred_per_case, byrow = TRUE)
} else if (reshape && npred_per_case > 1) {
# Predict with data reshaping
preds <- matrix(preds, ncol = npred_per_case, byrow = TRUE)
}
preds
# Return predictions
return(preds)
}
),
private = list( handle = NULL, need_free_handle = FALSE )
private = list(handle = NULL,
need_free_handle = FALSE)
)
R-package/R/lgb.cv.R
View file @ b6c973af
CVBooster <- R6Class(
"lgb.CVBooster",
classname = "lgb.CVBooster",
cloneable = FALSE,
public = list(
best_iter = -1,
best_iter = -1,
record_evals = list(),
boosters = list(),
initialize = function(x) {
boosters = list(),
initialize = function(x) {
self$boosters <- x
},
reset_parameter = function(new_params) {
......@@ -15,7 +15,6 @@ CVBooster <- R6Class(
)
)
#' Main CV logic for LightGBM
#'
#' Main CV logic for LightGBM
......@@ -58,233 +57,377 @@ CVBooster <- R6Class(
#' @param callbacks list of callback functions
#' List of callback functions that are applied at each iteration.
#' @param ... other parameters, see parameters.md for more informations
#'
#' @return a trained model \code{lgb.CVBooster}.
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' params <- list(objective="regression", metric="l2")
#' model <- lgb.cv(params, dtrain, 10, nfold=5, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' params <- list(objective = "regression", metric = "l2")
#' model <- lgb.cv(params,
#' dtrain,
#' 10,
#' nfold = 5,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' }
#' @rdname lgb.train
#' @export
lgb.cv <- function(params=list(), data, nrounds = 10,
nfold = 3,
label = NULL,
weight = NULL,
obj = NULL,
eval = NULL,
verbose = 1,
record = TRUE,
eval_freq = 1L,
showsd = TRUE,
stratified = TRUE,
folds = NULL,
init_model = NULL,
colnames = NULL,
categorical_feature = NULL,
lgb.cv <- function(params = list(),
data,
nrounds = 10,
nfold = 3,
label = NULL,
weight = NULL,
obj = NULL,
eval = NULL,
verbose = 1,
record = TRUE,
eval_freq = 1L,
showsd = TRUE,
stratified = TRUE,
folds = NULL,
init_model = NULL,
colnames = NULL,
categorical_feature = NULL,
early_stopping_rounds = NULL,
callbacks = list(), ...) {
callbacks = list(),
...) {
# Setup temporary variables
addiction_params <- list(...)
params <- append(params, addiction_params)
params$verbose <- verbose
params <- lgb.check.obj(params, obj)
params <- lgb.check.eval(params, eval)
fobj <- NULL
feval <- NULL
params <- append(params, addiction_params)
params$verbose <- verbose
params <- lgb.check.obj(params, obj)
params <- lgb.check.eval(params, eval)
fobj <- NULL
feval <- NULL
# Check for objective (function or not)
if (is.function(params$objective)) {
fobj <- params$objective
params$objective <- "NONE"
}
if (is.function(eval)) { feval <- eval }
# Check for loss (function or not)
if (is.function(eval)) {
feval <- eval
}
# Check for parameters
lgb.check.params(params)
# Init predictor to empty
predictor <- NULL
# Check for boosting from a trained model
if (is.character(init_model)) {
predictor <- Predictor$new(init_model)
} else if (lgb.is.Booster(init_model)) {
predictor <- init_model$to_predictor()
}
# Set the iteration to start from / end to (and check for boosting from a trained model, again)
begin_iteration <- 1
if (!is.null(predictor)) {
begin_iteration <- predictor$current_iter() + 1
}
end_iteration <- begin_iteration + nrounds - 1
# Check for training dataset type correctness
if (!lgb.is.Dataset(data)) {
if (is.null(label)) { stop("Labels must be provided for lgb.cv") }
if (is.null(label)) {
stop("Labels must be provided for lgb.cv")
}
data <- lgb.Dataset(data, label = label)
}
if (!is.null(weight)) { data$set_info("weight", weight) }
# Check for weights
if (!is.null(weight)) {
data$set_info("weight", weight)
}
# Update parameters with parsed parameters
data$update_params(params)
# Create the predictor set
data$.__enclos_env__$private$set_predictor(predictor)
if (!is.null(colnames)) { data$set_colnames(colnames) }
if (!is.null(categorical_feature)) { data$set_categorical_feature(categorical_feature) }
# Write column names
if (!is.null(colnames)) {
data$set_colnames(colnames)
}
# Write categorical features
if (!is.null(categorical_feature)) {
data$set_categorical_feature(categorical_feature)
}
# Construct datasets, if needed
data$construct()
# Check for folds
if (!is.null(folds)) {
if (!is.list(folds) | length(folds) < 2)
# Check for list of folds or for single value
if (!is.list(folds) | length(folds) < 2) {
stop(sQuote("folds"), " must be a list with 2 or more elements that are vectors of indices for each CV-fold")
}
# Set number of folds
nfold <- length(folds)
} else {
if (nfold <= 1) { stop(sQuote("nfold"), " must be > 1") }
folds <- generate.cv.folds(nfold, nrow(data), stratified, getinfo(data, 'label'), params)
# Check fold value
if (nfold <= 1) {
stop(sQuote("nfold"), " must be > 1")
}
# Create folds
folds <- generate.cv.folds(nfold,
nrow(data),
stratified,
getinfo(data, "label"),
params)
}
# Add printing log callback
if (verbose > 0 & eval_freq > 0) {
callbacks <- add.cb(callbacks, cb.print.evaluation(eval_freq))
}
if (record) { callbacks <- add.cb(callbacks, cb.record.evaluation()) }
# Add evaluation log callback
if (record) {
callbacks <- add.cb(callbacks, cb.record.evaluation())
}
# Add early stopping callback
if (!is.null(early_stopping_rounds)) {
if (early_stopping_rounds > 0) {
callbacks <- add.cb(callbacks, cb.early.stop(early_stopping_rounds, verbose = verbose))
}
}
# Categorize callbacks
cb <- categorize.callbacks(callbacks)
# construct booster
# Construct booster using a list apply
bst_folds <- lapply(seq_along(folds), function(k) {
dtest <- slice(data, folds[[k]])
dtrain <- slice(data, unlist(folds[-k]))
dtest <- slice(data, folds[[k]])
dtrain <- slice(data, unlist(folds[-k]))
booster <- Booster$new(params, dtrain)
booster$add_valid(dtest, "valid")
list(booster = booster)
})
# Create new booster
cv_booster <- CVBooster$new(bst_folds)
# callback env
env <- CB_ENV$new()
env$model <- cv_booster
# Callback env
env <- CB_ENV$new()
env$model <- cv_booster
env$begin_iteration <- begin_iteration
env$end_iteration <- end_iteration
#start training
env$end_iteration <- end_iteration
# Start training model using number of iterations to start and end with
for (i in seq(from = begin_iteration, to = end_iteration)) {
# Overwrite iteration in environment
env$iteration <- i
env$eval_list <- list()
for (f in cb$pre_iter) { f(env) }
# update one iter
# Loop through "pre_iter" element
for (f in cb$pre_iter) {
f(env)
}
# Update one boosting iteration
msg <- lapply(cv_booster$boosters, function(fd) {
fd$booster$update(fobj = fobj)
fd$booster$eval_valid(feval = feval)
})
# Prepare collection of evaluation results
merged_msg <- lgb.merge.cv.result(msg)
# Write evaluation result in environment
env$eval_list <- merged_msg$eval_list
if(showsd) { env$eval_err_list <- merged_msg$eval_err_list }
for (f in cb$post_iter) { f(env) }
# met early stopping
# Check for standard deviation requirement
if(showsd) {
env$eval_err_list <- merged_msg$eval_err_list
}
# Loop through env
for (f in cb$post_iter) {
f(env)
}
# Check for early stopping and break if needed
if (env$met_early_stop) break
}
cv_booster
# Return booster
return(cv_booster)
}
# Generates random (stratified if needed) CV folds
generate.cv.folds <- function(nfold, nrows, stratified, label, params) {
# cannot do it for rank
if (exists('objective', where = params) &&
is.character(params$objective) &&
params$objective == 'lambdarank') {
stop("\n\tAutomatic generation of CV-folds is not implemented for lambdarank!\n",
"\tConsider providing pre-computed CV-folds through the 'folds=' parameter.\n")
# Cannot do it for rank
if (exists('objective', where = params) && is.character(params$objective) && params$objective == "lambdarank") {
stop("\n\tAutomatic generation of CV-folds is not implemented for lambdarank!\n", "\tConsider providing pre-computed CV-folds through the 'folds=' parameter.\n")
}
# shuffle
# Shuffle
rnd_idx <- sample(seq_len(nrows))
if (isTRUE(stratified) &&
length(label) == length(rnd_idx)) {
y <- label[rnd_idx]
y <- factor(y)
# Request stratified folds
if (isTRUE(stratified) && length(label) == length(rnd_idx)) {
y <- label[rnd_idx]
y <- factor(y)
folds <- lgb.stratified.folds(y, nfold)
} else {
# make simple non-stratified folds
# Make simple non-stratified folds
kstep <- length(rnd_idx) %/% nfold
folds <- list()
# Loop through each fold
for (i in seq_len(nfold - 1)) {
folds[[i]] <- rnd_idx[seq_len(kstep)]
rnd_idx <- rnd_idx[-(seq_len(kstep))]
rnd_idx <- rnd_idx[-(seq_len(kstep))]
}
folds[[nfold]] <- rnd_idx
}
folds
# Return folds
return(folds)
}
# Creates CV folds stratified by the values of y.
# It was borrowed from caret::lgb.stratified.folds and simplified
# by always returning an unnamed list of fold indices.
lgb.stratified.folds <- function(y, k = 10) {
## 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
if (is.numeric(y)) {
## 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
cuts <- floor(length(y) / k)
if (cuts < 2) { cuts <- 2 }
if (cuts > 5) { cuts <- 5 }
y <- cut(y,
unique(stats::quantile(y, probs = seq(0, 1, length = cuts))),
include.lowest = TRUE)
unique(stats::quantile(y, probs = seq(0, 1, length = cuts))),
include.lowest = TRUE)
}
if (k < length(y)) {
## reset levels so that the possible levels and
## Reset levels so that the possible levels and
## the levels in the vector are the same
y <- factor(as.character(y))
numInClass <- table(y)
foldVector <- vector(mode = "integer", length(y))
## For each class, balance the fold allocation as far
## as possible, then resample the remainder.
## The final assignment of folds is also randomized.
for (i in seq_along(numInClass)) {
## create a vector of integers from 1:k as many times as possible without
## 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 producd here.
seqVector <- rep(seq_len(k), numInClass[i] %/% k)
## add enough random integers to get length(seqVector) == numInClass[i]
## Add enough random integers to get length(seqVector) == numInClass[i]
if (numInClass[i] %% k > 0) {
seqVector <- c(seqVector, sample(seq_len(k), numInClass[i] %% k))
}
## shuffle the integers for fold assignment and assign to this classes's data
## Shuffle the integers for fold assignment and assign to this classes's data
foldVector[y == dimnames(numInClass)$y[i]] <- sample(seqVector)
}
} else {
foldVector <- seq(along = y)
}
# Return data
out <- split(seq(along = y), foldVector)
`names<-`(out, NULL)
}
lgb.merge.cv.result <- function(msg, showsd = TRUE){
if (length(msg) == 0) { stop("lgb.cv: size of cv result error") }
lgb.merge.cv.result <- function(msg, showsd = TRUE) {
# Get CV message length
if (length(msg) == 0) {
stop("lgb.cv: size of cv result error")
}
# Get evaluation message length
eval_len <- length(msg[[1]])
if (eval_len == 0) { stop("lgb.cv: should provide at least one metric for CV") }
# Is evaluation message empty?
if (eval_len == 0) {
stop("lgb.cv: should provide at least one metric for CV")
}
# Get evaluation results using a list apply
eval_result <- lapply(seq_len(eval_len), function(j) {
as.numeric(lapply(seq_along(msg), function(i) { msg[[i]][[j]]$value }))
as.numeric(lapply(seq_along(msg), function(i) {
msg[[i]][[j]]$value }))
})
# Get evaluation
ret_eval <- msg[[1]]
for (j in seq_len(eval_len)) { ret_eval[[j]]$value <- mean(eval_result[[j]]) }
# Go through evaluation length items
for (j in seq_len(eval_len)) {
ret_eval[[j]]$value <- mean(eval_result[[j]])
}
# Preinit evaluation error
ret_eval_err <- NULL
# Check for standard deviation
if (showsd) {
# Parse standard deviation
for (j in seq_len(eval_len)) {
ret_eval_err <- c( ret_eval_err, sqrt( mean(eval_result[[j]]^2) - mean(eval_result[[j]])^2 ))
ret_eval_err <- c(ret_eval_err,
sqrt(mean(eval_result[[j]] ^ 2) - mean(eval_result[[j]]) ^ 2))
}
# Convert to list
ret_eval_err <- as.list(ret_eval_err)
}
list(eval_list = ret_eval, eval_err_list = ret_eval_err)
# Return errors
list(eval_list = ret_eval,
eval_err_list = ret_eval_err)
}
R-package/R/lgb.importance.R
View file @ b6c973af
#' Compute feature importance in a model
#'
#'
#' Creates a \code{data.table} of feature importances in a model.
#'
#'
#' @param model object of class \code{lgb.Booster}.
#' @param percentage whether to show importance in relative percentage.
#'
#'
#' @return
#'
#'
#' For a tree model, a \code{data.table} with the following columns:
#' \itemize{
#' \item \code{Feature} Feature names in the model.
......@@ -14,10 +14,11 @@
#' \item \code{Cover} The number of observation related to this feature.
#' \item \code{Frequency} The number of times a feature splited in trees.
#' }
#'
#'
#' @examples
#'
#' data(agaricus.train, package = 'lightgbm')
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#'
......@@ -29,16 +30,22 @@
#'
#' tree_imp1 <- lgb.importance(model, percentage = TRUE)
#' tree_imp2 <- lgb.importance(model, percentage = FALSE)
#'
#' }
#'
#' @importFrom magrittr %>% %T>%
#' @importFrom data.table :=
#' @export
lgb.importance <- function(model, percentage = TRUE) {
# Check if model is a lightgbm model
if (!any(class(model) == "lgb.Booster")) {
stop("'model' has to be an object of class lgb.Booster")
}
# Setup importance
tree_dt <- lgb.model.dt.tree(model)
# Extract elements
tree_imp <- tree_dt %>%
magrittr::extract(.,
i = is.na(split_index) == FALSE,
......@@ -46,10 +53,15 @@ lgb.importance <- function(model, percentage = TRUE) {
by = "split_feature") %T>%
data.table::setnames(., old = "split_feature", new = "Feature") %>%
magrittr::extract(., i = order(Gain, decreasing = TRUE))
# Check if relative values are requested
if (percentage) {
tree_imp[, ":="(Gain = Gain / sum(Gain),
Cover = Cover / sum(Cover),
Frequency = Frequency / sum(Frequency))]
}
# Return importance table
return(tree_imp)
}
R-package/R/lgb.interprete.R
View file @ b6c973af
#' Compute feature contribution of prediction
#'
#'
#' Computes feature contribution components of rawscore prediction.
#'
#'
#' @param model object of class \code{lgb.Booster}.
#' @param data a matrix object or a dgCMatrix object.
#' @param idxset a integer vector of indices of rows needed.
#' @param num_iteration number of iteration want to predict with, NULL or <= 0 means use best iteration.
#'
#'
#' @return
#'
#'
#' For regression, binary classification and lambdarank model, a \code{list} of \code{data.table} with the following columns:
#' \itemize{
#' \item \code{Feature} Feature names in the model.
#' \item \code{Contribution} The total contribution of this feature's splits.
#' }
#' For multiclass classification, a \code{list} of \code{data.table} with the Feature column and Contribution columns to each class.
#'
#'
#' @examples
#'
#' \dontrun{
#' library(lightgbm)
#' Sigmoid <- function(x) 1 / (1 + exp(-x))
#' Logit <- function(x) log(x / (1 - x))
#' data(agaricus.train, package = 'lightgbm')
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' setinfo(dtrain, "init_score", rep(Logit(mean(train$label)), length(train$label)))
#' data(agaricus.test, package = 'lightgbm')
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#'
#' params = list(objective = "binary",
......@@ -34,47 +35,94 @@
#' model <- lgb.train(params, dtrain, 20)
#'
#' tree_interpretation <- lgb.interprete(model, test$data, 1:5)
#'
#' }
#'
#' @importFrom magrittr %>% %T>%
#' @export
lgb.interprete <- function(model, data, idxset, num_iteration = NULL) {
lgb.interprete <- function(model,
data,
idxset,
num_iteration = NULL) {
# Get tree model
tree_dt <- lgb.model.dt.tree(model, num_iteration)
# Check number of classes
num_class <- model$.__enclos_env__$private$num_class
# Get vector list
tree_interpretation_dt_list <- vector(mode = "list", length = length(idxset))
# Get parsed predictions of data
leaf_index_mat_list <- model$predict(data[idxset, , drop = FALSE],
num_iteration = num_iteration,
predleaf = TRUE) %>%
t(.) %>%
data.table::as.data.table(.) %>%
lapply(., FUN = function(x) matrix(x, ncol = num_class, byrow = TRUE))
# Get list of trees
tree_index_mat_list <- lapply(leaf_index_mat_list,
FUN = function(x) matrix(seq_len(length(x)) - 1, ncol = num_class, byrow = TRUE))
# Sequence over idxset
for (i in seq_along(idxset)) {
tree_interpretation_dt_list[[i]] <- single.row.interprete(tree_dt, num_class, tree_index_mat_list[[i]], leaf_index_mat_list[[i]])
}
# Return interpretation list
return(tree_interpretation_dt_list)
}
single.tree.interprete <- function(tree_dt, tree_id, leaf_id) {
single.tree.interprete <- function(tree_dt,
tree_id,
leaf_id) {
# Match tree id
single_tree_dt <- tree_dt[tree_index == tree_id, ]
# Get leaves
leaf_dt <- single_tree_dt[leaf_index == leaf_id, .(leaf_index, leaf_parent, leaf_value)]
# Get nodes
node_dt <- single_tree_dt[!is.na(split_index), .(split_index, split_feature, node_parent, internal_value)]
# Prepare sequences
feature_seq <- character(0)
value_seq <- numeric(0)
# Get to root from leaf
leaf_to_root <- function(parent_id, current_value) {
# Store value
value_seq <<- c(current_value, value_seq)
# Check for null parent id
if (!is.na(parent_id)) {
# Not null means existing node
this_node <- node_dt[split_index == parent_id, ]
feature_seq <<- c(this_node[["split_feature"]], feature_seq)
leaf_to_root(this_node[["node_parent"]], this_node[["internal_value"]])
}
}
# Perform leaf to root conversion
leaf_to_root(leaf_dt[["leaf_parent"]], leaf_dt[["leaf_value"]])
# Return formatted data.table
data.table::data.table(Feature = feature_seq, Contribution = diff.default(value_seq))
}
multiple.tree.interprete <- function(tree_dt, tree_index, leaf_index) {
multiple.tree.interprete <- function(tree_dt,
tree_index,
leaf_index) {
# Apply each trees
mapply(single.tree.interprete,
tree_id = tree_index, leaf_id = leaf_index,
MoreArgs = list(tree_dt = tree_dt),
......@@ -82,29 +130,51 @@ multiple.tree.interprete <- function(tree_dt, tree_index, leaf_index) {
data.table::rbindlist(., use.names = TRUE) %>%
magrittr::extract(., j = .(Contribution = sum(Contribution)), by = "Feature") %>%
magrittr::extract(., i = order(abs(Contribution), decreasing = TRUE))
}
single.row.interprete <- function(tree_dt, num_class, tree_index_mat, leaf_index_mat) {
# Prepare vector list
tree_interpretation <- vector(mode = "list", length = num_class)
# Loop throughout each class
for (i in seq_len(num_class)) {
tree_interpretation[[i]] <- multiple.tree.interprete(tree_dt, tree_index_mat[,i], leaf_index_mat[,i]) %T>%
{
tree_interpretation[[i]] <- multiple.tree.interprete(tree_dt, tree_index_mat[,i], leaf_index_mat[,i]) %T>% {
# Number of classes larger than 1 requires adjustment
if (num_class > 1) {
data.table::setnames(., old = "Contribution", new = paste("Class", i - 1))
}
}
}
# Check for numbe rof classes larger than 1
if (num_class == 1) {
# First interpretation element
tree_interpretation_dt <- tree_interpretation[[1]]
} else {
# Full interpretation elements
tree_interpretation_dt <- Reduce(f = function(x, y) merge(x, y, by = "Feature", all = TRUE),
x = tree_interpretation)
# Loop throughout each tree
for (j in 2:ncol(tree_interpretation_dt)) {
data.table::set(tree_interpretation_dt,
i = which(is.na(tree_interpretation_dt[[j]])),
j = j,
value = 0)
}
}
# Return interpretation tree
return(tree_interpretation_dt)
}
R-package/R/lgb.model.dt.tree.R
View file @ b6c973af
#' Parse a LightGBM model json dump
#'
#'
#' Parse a LightGBM model json dump into a \code{data.table} structure.
#'
#'
#' @param model object of class \code{lgb.Booster}
#'
#'
#' @return
#' A \code{data.table} with detailed information about model trees' nodes and leafs.
#'
#'
#' The columns of the \code{data.table} are:
#'
#'
#' \itemize{
#' \item \code{tree_index}: ID of a tree in a model (integer)
#' \item \code{split_index}: ID of a node in a tree (integer)
#' \item \code{split_feature}: for a node, it's a feature name (character);
#' for a leaf, it simply labels it as \code{'NA'}
#' for a leaf, it simply labels it as \code{"NA"}
#' \item \code{node_parent}: ID of the parent node for current node (integer)
#' \item \code{leaf_index}: ID of a leaf in a tree (integer)
#' \item \code{leaf_parent}: ID of the parent node for current leaf (integer)
......@@ -25,10 +25,12 @@
#' \item \code{leaf_value}: Leaf value
#' \item \code{leaf_count}: The number of observation collected by a leaf
#' }
#'
#'
#' @examples
#'
#' data(agaricus.train, package = 'lightgbm')
#' \dontrun{
#' library(lightgbm)
#'
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#'
......@@ -39,57 +41,112 @@
#' model <- lgb.train(params, dtrain, 20)
#'
#' tree_dt <- lgb.model.dt.tree(model)
#'
#' }
#'
#' @importFrom magrittr %>%
#' @importFrom data.table :=
#' @export
lgb.model.dt.tree <- function(model, num_iteration = NULL) {
# Dump json model first
json_model <- lgb.dump(model, num_iteration = num_iteration)
# Parse json model second
parsed_json_model <- jsonlite::fromJSON(json_model,
simplifyVector = TRUE,
simplifyDataFrame = FALSE,
simplifyMatrix = FALSE,
flatten = FALSE)
# Parse tree model third
tree_list <- lapply(parsed_json_model$tree_info, single.tree.parse)
# Combine into single data.table fourth
tree_dt <- data.table::rbindlist(tree_list, use.names = TRUE)
# Lookup sequence
tree_dt[, split_feature := Lookup(split_feature,
seq(0, parsed_json_model$max_feature_idx, by = 1),
parsed_json_model$feature_names)]
# Return tree
return(tree_dt)
}
single.tree.parse <- function(lgb_tree) {
# Setup initial default data.table with default types
single_tree_dt <- data.table::data.table(tree_index = integer(0),
split_index = integer(0), split_feature = integer(0), node_parent = integer(0),
leaf_index = integer(0), leaf_parent = integer(0),
split_gain = numeric(0), threshold = numeric(0), decision_type = character(0),
internal_value = integer(0), internal_count = integer(0),
leaf_value = integer(0), leaf_count = integer(0))
split_index = integer(0),
split_feature = integer(0),
node_parent = integer(0),
leaf_index = integer(0),
leaf_parent = integer(0),
split_gain = numeric(0),
threshold = numeric(0),
decision_type = character(0),
internal_value = integer(0),
internal_count = integer(0),
leaf_value = integer(0),
leaf_count = integer(0))
# Traverse tree function
pre_order_traversal <- function(tree_node_leaf, parent_index = NA) {
# Check if split index is not null in leaf
if (!is.null(tree_node_leaf$split_index)) {
# Overwrite data.table - this should be switched to an envir in the future
single_tree_dt <<- data.table::rbindlist(l = list(single_tree_dt,
c(tree_node_leaf[c("split_index", "split_feature",
"split_gain", "threshold", "decision_type",
"internal_value", "internal_count")],
c(tree_node_leaf[c("split_index",
"split_feature",
"split_gain",
"threshold",
"decision_type",
"internal_value",
"internal_count")],
"node_parent" = parent_index)),
use.names = TRUE, fill = TRUE)
pre_order_traversal(tree_node_leaf$left_child, parent_index = tree_node_leaf$split_index)
pre_order_traversal(tree_node_leaf$right_child, parent_index = tree_node_leaf$split_index)
use.names = TRUE,
fill = TRUE)
# Traverse tree again both left and right
pre_order_traversal(tree_node_leaf$left_child,
parent_index = tree_node_leaf$split_index)
pre_order_traversal(tree_node_leaf$right_child,
parent_index = tree_node_leaf$split_index)
} else if (!is.null(tree_node_leaf$leaf_index)) {
# Overwrite data.table - this should be switched to an envir in the future
single_tree_dt <<- data.table::rbindlist(l = list(single_tree_dt,
tree_node_leaf[c("leaf_index", "leaf_parent",
"leaf_value", "leaf_count")]),
use.names = TRUE, fill = TRUE)
tree_node_leaf[c("leaf_index",
"leaf_parent",
"leaf_value",
"leaf_count")]),
use.names = TRUE,
fill = TRUE)
}
}
# Traverse structure
pre_order_traversal(lgb_tree$tree_structure)
# Store index
single_tree_dt[, tree_index := lgb_tree$tree_index]
# Return tree
return(single_tree_dt)
}
Lookup <- function(key, key_lookup, value_lookup, missing = NA) {
# Match key by looked up key
match(key, key_lookup) %>%
magrittr::extract(value_lookup, .) %>%
magrittr::inset(. , is.na(.), missing)
}
R-package/R/lgb.plot.importance.R
View file @ b6c973af
#' Plot feature importance as a bar graph
#'
#'
#' Plot previously calculated feature importance: Gain, Cover and Frequency, as a bar graph.
#'
#'
#' @param tree_imp a \code{data.table} returned by \code{\link{lgb.importance}}.
#' @param top_n maximal number of top features to include into the plot.
#' @param measure the name of importance measure to plot, can be "Gain", "Cover" or "Frequency".
#' @param left_margin (base R barplot) allows to adjust the left margin size to fit feature names.
#' @param cex (base R barplot) passed as \code{cex.names} parameter to \code{barplot}.
#'
#'
#' @details
#' The graph represents each feature as a horizontal bar of length proportional to the defined importance of a feature.
#' Features are shown ranked in a decreasing importance order.
#'
#'
#' @return
#' The \code{lgb.plot.importance} function creates a \code{barplot}
#' and silently returns a processed data.table with \code{top_n} features sorted by defined importance.
#'
#'
#' @examples
#'
#' data(agaricus.train, package = 'lightgbm')
#' \dontrun{
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#'
......@@ -30,21 +30,48 @@
#'
#' tree_imp <- lgb.importance(model, percentage = TRUE)
#' lgb.plot.importance(tree_imp, top_n = 10, measure = "Gain")
#'
#' }
#'
#' @export
lgb.plot.importance <- function(tree_imp, top_n = 10, measure = "Gain", left_margin = 10, cex = NULL) {
lgb.plot.importance <- function(tree_imp,
top_n = 10,
measure = "Gain",
left_margin = 10,
cex = NULL) {
# Check for measurement (column names) correctness
measure <- match.arg(measure, choices = c("Gain", "Cover", "Frequency"), several.ok = FALSE)
# Get top N importance (defaults to 10)
top_n <- min(top_n, nrow(tree_imp))
# Parse importance
tree_imp <- tree_imp[order(abs(get(measure)), decreasing = TRUE),][1:top_n,]
# Attempt to setup a correct cex
if (is.null(cex)) {
cex <- 2.5 / log2(1 + top_n)
}
# Refresh plot
op <- par(no.readonly = TRUE)
on.exit(par(op))
# Do some magic plotting
par(mar = op$mar %>% magrittr::inset(., 2, left_margin))
# Do plot
tree_imp[.N:1,
barplot(height = get(measure), names.arg = Feature, horiz = TRUE, border = NA,
main = "Feature Importance", xlab = measure, cex.names = cex, las = 1)]
barplot(height = get(measure),
names.arg = Feature,
horiz = TRUE,
border = NA,
main = "Feature Importance",
xlab = measure,
cex.names = cex,
las = 1)]
# Return invisibly
invisible(tree_imp)
}
R-package/R/lgb.plot.interpretation.R
View file @ b6c973af
#' Plot feature contribution as a bar graph
#'
#'
#' Plot previously calculated feature contribution as a bar graph.
#'
#'
#' @param tree_interpretation_dt a \code{data.table} returned by \code{\link{lgb.interprete}}.
#' @param top_n maximal number of top features to include into the plot.
#' @param cols the column numbers of layout, will be used only for multiclass classification feature contribution.
#' @param left_margin (base R barplot) allows to adjust the left margin size to fit feature names.
#' @param cex (base R barplot) passed as \code{cex.names} parameter to \code{barplot}.
#'
#'
#' @details
#' The graph represents each feature as a horizontal bar of length proportional to the defined contribution of a feature.
#' Features are shown ranked in a decreasing contribution order.
#'
#'
#' @return
#' The \code{lgb.plot.interpretation} function creates a \code{barplot}
#'
#' The \code{lgb.plot.interpretation} function creates a \code{barplot}.
#'
#' @examples
#'
#' Sigmoid <- function(x) 1 / (1 + exp(-x))
#' Logit <- function(x) log(x / (1 - x))
#' data(agaricus.train, package = 'lightgbm')
#' \dontrun{
#' library(lightgbm)
#' Sigmoid <- function(x) {1 / (1 + exp(-x))}
#' Logit <- function(x) {log(x / (1 - x))}
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' setinfo(dtrain, "init_score", rep(Logit(mean(train$label)), length(train$label)))
#' data(agaricus.test, package = 'lightgbm')
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#'
#'
#' params = list(objective = "binary",
#' learning_rate = 0.01, num_leaves = 63, max_depth = -1,
#' min_data_in_leaf = 1, min_sum_hessian_in_leaf = 1)
#' model <- lgb.train(params, dtrain, 20)
#' model <- lgb.train(params, dtrain, 20)
#'
#'
#' tree_interpretation <- lgb.interprete(model, test$data, 1:5)
#' lgb.plot.interpretation(tree_interpretation[[1]], top_n = 10)
#'
#' }
#'
#' @export
lgb.plot.interpretation <- function(tree_interpretation_dt, top_n = 10, cols = 1, left_margin = 10, cex = NULL) {
lgb.plot.interpretation <- function(tree_interpretation_dt,
top_n = 10,
cols = 1,
left_margin = 10,
cex = NULL) {
# Get number of columns
num_class <- ncol(tree_interpretation_dt) - 1
# Refresh plot
op <- par(no.readonly = TRUE)
on.exit(par(op))
# Do some magic plotting
par(mar = op$mar %>% magrittr::inset(., 1:3, c(3, left_margin, 2)))
# Check for number of classes
if (num_class == 1) {
multiple.tree.plot.interpretation(tree_interpretation_dt, top_n = top_n, title = NULL, cex = cex)
# Only one class, plot straight away
multiple.tree.plot.interpretation(tree_interpretation_dt,
top_n = top_n,
title = NULL,
cex = cex)
} else {
# More than one class, shape data first
layout_mat <- matrix(seq(1, cols * ceiling(num_class / cols)),
ncol = cols, nrow = ceiling(num_class / cols))
# Shape output
par(mfcol = c(nrow(layout_mat), ncol(layout_mat)))
# Loop throughout all classes
for (i in seq_len(num_class)) {
# Prepare interpretation, perform T, get the names, and plot straight away
tree_interpretation_dt[, c(1, i + 1), with = FALSE] %T>%
data.table::setnames(., old = names(.), new = c("Feature", "Contribution")) %>%
multiple.tree.plot.interpretation(., top_n = top_n, title = paste("Class", i - 1), cex = cex)
multiple.tree.plot.interpretation(., # Self
top_n = top_n,
title = paste("Class", i - 1),
cex = cex)
}
}
}
multiple.tree.plot.interpretation <- function(tree_interpretation, top_n, title, cex) {
multiple.tree.plot.interpretation <- function(tree_interpretation,
top_n,
title,
cex) {
# Parse tree
tree_interpretation <- tree_interpretation[order(abs(Contribution), decreasing = TRUE),][1:min(top_n, .N),]
# Attempt to setup a correct cex
if (is.null(cex)) {
cex <- 2.5 / log2(1 + top_n)
}
# Do plot
tree_interpretation[.N:1,
barplot(height = Contribution, names.arg = Feature, horiz = TRUE,
barplot(height = Contribution,
names.arg = Feature,
horiz = TRUE,
col = ifelse(Contribution > 0, "firebrick", "steelblue"),
border = NA, main = title, cex.names = cex, las = 1)]
border = NA,
main = title,
cex.names = cex,
las = 1)]
# Return invisibly
invisible(NULL)
}
R-package/R/lgb.train.R
View file @ b6c973af
#' Main training logic for LightGBM
#'
#'
#' @param params List of parameters
#' @param data a \code{lgb.Dataset} object, used for training
#' @param nrounds number of training rounds
......@@ -30,146 +30,236 @@
#' @param callbacks list of callback functions
#' List of callback functions that are applied at each iteration.
#' @param ... other parameters, see parameters.md for more informations
#'
#' @return a trained booster model \code{lgb.Booster}.
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' }
#'
#' @rdname lgb.train
#'
#' @export
lgb.train <- function(params = list(), data, nrounds = 10,
valids = list(),
obj = NULL,
eval = NULL,
verbose = 1,
record = TRUE,
eval_freq = 1L,
init_model = NULL,
colnames = NULL,
categorical_feature = NULL,
lgb.train <- function(params = list(),
data,
nrounds = 10,
valids = list(),
obj = NULL,
eval = NULL,
verbose = 1,
record = TRUE,
eval_freq = 1L,
init_model = NULL,
colnames = NULL,
categorical_feature = NULL,
early_stopping_rounds = NULL,
callbacks = list(), ...) {
callbacks = list(),
...) {
# Setup temporary variables
additional_params <- list(...)
params <- append(params, additional_params)
params <- append(params, additional_params)
params$verbose <- verbose
params <- lgb.check.obj(params, obj)
params <- lgb.check.eval(params, eval)
fobj <- NULL
feval <- NULL
params <- lgb.check.obj(params, obj)
params <- lgb.check.eval(params, eval)
fobj <- NULL
feval <- NULL
# Check for objective (function or not)
if (is.function(params$objective)) {
fobj <- params$objective
fobj <- params$objective
params$objective <- "NONE"
}
if (is.function(eval)) { feval <- eval }
# Check for loss (function or not)
if (is.function(eval)) {
feval <- eval
}
# Check for parameters
lgb.check.params(params)
# Init predictor to empty
predictor <- NULL
# Check for boosting from a trained model
if (is.character(init_model)) {
predictor <- Predictor$new(init_model)
} else if (lgb.is.Booster(init_model)) {
predictor <- init_model$to_predictor()
}
# Set the iteration to start from / end to (and check for boosting from a trained model, again)
begin_iteration <- 1
if (!is.null(predictor)) {
begin_iteration <- predictor$current_iter() + 1
}
end_iteration <- begin_iteration + nrounds - 1
# check dataset
# Check for training dataset type correctness
if (!lgb.is.Dataset(data)) {
stop("lgb.train: data only accepts lgb.Dataset object")
}
# Check for validation dataset type correctness
if (length(valids) > 0) {
# One or more validation dataset
# Check for list as input and type correctness by object
if (!is.list(valids) || !all(sapply(valids, lgb.is.Dataset))) {
stop("lgb.train: valids must be a list of lgb.Dataset elements")
}
# Attempt to get names
evnames <- names(valids)
# Check for names existance
if (is.null(evnames) || !all(nzchar(evnames))) {
stop("lgb.train: each element of the valids must have a name tag")
}
}
# Update parameters with parsed parameters
data$update_params(params)
# Create the predictor set
data$.__enclos_env__$private$set_predictor(predictor)
if (!is.null(colnames)) { data$set_colnames(colnames) }
if (!is.null(categorical_feature)) { data$set_categorical_feature(categorical_feature) }
# Write column names
if (!is.null(colnames)) {
data$set_colnames(colnames)
}
# Write categorical features
if (!is.null(categorical_feature)) {
data$set_categorical_feature(categorical_feature)
}
# Construct datasets, if needed
data$construct()
vaild_contain_train <- FALSE
train_data_name <- "train"
reduced_valid_sets <- list()
train_data_name <- "train"
reduced_valid_sets <- list()
# Parse validation datasets
if (length(valids) > 0) {
# Loop through all validation datasets using name
for (key in names(valids)) {
# Use names to get validation datasets
valid_data <- valids[[key]]
# Check for duplicate train/validation dataset
if (identical(data, valid_data)) {
vaild_contain_train <- TRUE
train_data_name <- key
train_data_name <- key
next
}
# Update parameters, data
valid_data$update_params(params)
valid_data$set_reference(data)
reduced_valid_sets[[key]] <- valid_data
}
}
# process callbacks
# Add printing log callback
if (verbose > 0 & eval_freq > 0) {
callbacks <- add.cb(callbacks, cb.print.evaluation(eval_freq))
}
# Add evaluation log callback
if (record & length(valids) > 0) {
callbacks <- add.cb(callbacks, cb.record.evaluation())
}
# Early stopping callback
# Add early stopping callback
if (!is.null(early_stopping_rounds)) {
if (early_stopping_rounds > 0) {
callbacks <- add.cb(callbacks, cb.early.stop(early_stopping_rounds, verbose = verbose))
}
}
# "Categorize" callbacks
cb <- categorize.callbacks(callbacks)
# construct booster
# Construct booster with datasets
booster <- Booster$new(params = params, train_set = data)
if (vaild_contain_train) { booster$set_train_data_name(train_data_name) }
for (key in names(reduced_valid_sets)) {
booster$add_valid(reduced_valid_sets[[key]], key)
}
# callback env
env <- CB_ENV$new()
env$model <- booster
# Callback env
env <- CB_ENV$new()
env$model <- booster
env$begin_iteration <- begin_iteration
env$end_iteration <- end_iteration
env$end_iteration <- end_iteration
#start training
# Start training model using number of iterations to start and end with
for (i in seq(from = begin_iteration, to = end_iteration)) {
# Overwrite iteration in environment
env$iteration <- i
env$eval_list <- list()
for (f in cb$pre_iter) { f(env) }
# update one iter
# Loop through "pre_iter" element
for (f in cb$pre_iter) {
f(env)
}
# Update one boosting iteration
booster$update(fobj = fobj)
# collect eval result
# Prepare collection of evaluation results
eval_list <- list()
# Collection: Has validation dataset?
if (length(valids) > 0) {
# Validation has training dataset?
if (vaild_contain_train) {
eval_list <- append(eval_list, booster$eval_train(feval = feval))
}
# Has no validation dataset
eval_list <- append(eval_list, booster$eval_valid(feval = feval))
}
# Write evaluation result in environment
env$eval_list <- eval_list
for (f in cb$post_iter) { f(env) }
# met early stopping
# Loop through env
for (f in cb$post_iter) {
f(env)
}
# Check for early stopping and break if needed
if (env$met_early_stop) break
}
booster
# Return booster
return(booster)
}
R-package/R/lgb.unloader.R 0 → 100644
View file @ b6c973af
#' LightGBM unloading error fix
#'
#' Attempts to unload LightGBM packages so you can remove objects cleanly without having to restart R. This is useful for instance if an object becomes stuck for no apparent reason and you do not want to restart R to fix the lost object.
#'
#' @param restart Whether to reload \code{LightGBM} immediately after detaching from R. Defaults to \code{TRUE} which means automatically reload \code{LightGBM} once unloading is performed.
#' @param wipe Whether to wipe all \code{lgb.Dataset} and \code{lgb.Booster} from the global environment. Defaults to \code{FALSE} which means to not remove them.
#' @param envir The environment to perform wiping on if \code{wipe == TRUE}. Defaults to \code{.GlobalEnv} which is the global environment.
#'
#' @return NULL invisibly.
#'
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' lgb.unloader(restore = FALSE, wipe = FALSE, envir = .GlobalEnv)
#' rm(model, dtrain, dtest) # Not needed if wipe = TRUE
#' gc() # Not needed if wipe = TRUE
#'
#' library(lightgbm)
#' # Do whatever you want again with LightGBM without object clashing
#' }
#'
#' @export
lgb.unloader <- function(restore = TRUE, wipe = FALSE, envir = .GlobalEnv) {
# Unload package
try(detach("package:lightgbm", unload = TRUE), silent = TRUE)
# Should we wipe variables? (lgb.Booster, lgb.Dataset)
if (wipe) {
rm(list = ls(envir = envir)[which(sapply(ls(.GlobalEnv), function(x) {"lgb.Booster" %in% class(get(x, envir = envir))}))], envir = envir)
rm(list = ls(envir = envir)[which(sapply(ls(.GlobalEnv), function(x) {"lgb.Dataset" %in% class(get(x, envir = envir))}))], envir = envir)
gc(verbose = FALSE)
}
# Load package back?
if (restore) {
library(lightgbm)
}
invisible()
}
R-package/R/lightgbm.R
View file @ b6c973af
......@@ -3,25 +3,43 @@
#'
#' @rdname lgb.train
#' @export
lightgbm <- function(data, label = NULL, weight = NULL,
params = list(), nrounds = 10,
verbose = 1, eval_freq = 1L,
early_stopping_rounds = NULL,
save_name = "lightgbm.model",
init_model = NULL, callbacks = list(), ...) {
lightgbm <- function(data,
label = NULL,
weight = NULL,
params = list(),
nrounds = 10,
verbose = 1,
eval_freq = 1L,
early_stopping_rounds = NULL,
save_name = "lightgbm.model",
init_model = NULL,
callbacks = list(),
...) {
# Set data to a temporary variable
dtrain <- data
# Check whether data is lgb.Dataset, if not then create lgb.Dataset manually
if (!lgb.is.Dataset(dtrain)) {
dtrain <- lgb.Dataset(data, label = label, weight = weight)
}
# Set validation as oneself
valids <- list()
if (verbose > 0) { valids$train = dtrain }
if (verbose > 0) {
valids$train = dtrain
}
# Train a model using the regular way
bst <- lgb.train(params, dtrain, nrounds, valids, verbose = verbose, eval_freq = eval_freq,
early_stopping_rounds = early_stopping_rounds,
init_model = init_model, callbacks = callbacks, ...)
# Store model under a specific name
bst$save_model(save_name)
bst
# Return booster
return(bst)
}
#' Training part from Mushroom Data Set
......
R-package/R/readRDS.lgb.Booster.R
View file @ b6c973af
......@@ -10,33 +10,52 @@
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' saveRDS.lgb.Booster(model, "model.rds")
#' new_model <- readRDS.lgb.Booster("model.rds")
#' }
#'
#' @export
readRDS.lgb.Booster <- function(file = "", refhook = NULL) {
# Read RDS file
object <- readRDS(file = file, refhook = refhook)
# Check if object has the model stored
if (!is.na(object$raw)) {
# Create temporary file for the model loading
temp <- tempfile()
write(object$raw, temp)
object2 <- lgb.load(temp)
file.remove(temp)
# Restore best iteration and recorded evaluations
object2$best_iter <- object$best_iter
object2$record_evals <- object$record_evals
# Return newly loaded object
return(object2)
} else {
# Return RDS loaded object
return(object)
}
}
R-package/R/saveRDS.lgb.Booster.R
View file @ b6c973af
......@@ -15,27 +15,60 @@
#' @examples
#' \dontrun{
#' library(lightgbm)
#' data(agaricus.train, package='lightgbm')
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label=train$label)
#' data(agaricus.test, package='lightgbm')
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label=test$label)
#' params <- list(objective="regression", metric="l2")
#' valids <- list(test=dtest)
#' model <- lgb.train(params, dtrain, 100, valids, min_data=1, learning_rate=1, early_stopping_rounds=10)
#' dtest <- lgb.Dataset.create.valid(dtrain, test$data, label = test$label)
#' params <- list(objective = "regression", metric = "l2")
#' valids <- list(test = dtest)
#' model <- lgb.train(params,
#' dtrain,
#' 100,
#' valids,
#' min_data = 1,
#' learning_rate = 1,
#' early_stopping_rounds = 10)
#' saveRDS.lgb.Booster(model, "model.rds")
#' }
#'
#' @export
saveRDS.lgb.Booster <- function(object, file = "", ascii = FALSE, version = NULL, compress = TRUE, refhook = NULL, raw = TRUE) {
saveRDS.lgb.Booster <- function(object,
file = "",
ascii = FALSE,
version = NULL,
compress = TRUE,
refhook = NULL,
raw = TRUE) {
# Check if object has a raw value (and if the user wants to store the raw)
if (is.na(object$raw) & (raw)) {
# Save model
object$save()
saveRDS(object, file = file, ascii = ascii, version = version, compress = compress, refhook = refhook)
# Save RDS
saveRDS(object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook)
# Free model from memory
object$raw <- NA
} else {
saveRDS(object, file = file, ascii = ascii, version = version, compress = compress, refhook = refhook)
# Save as usual
saveRDS(object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook)
}
}
R-package/R/utils.R
View file @ b6c973af
lgb.is.Booster <- function(x) { lgb.check.r6.class(x, "lgb.Booster") }
lgb.is.Booster <- function(x) {
lgb.check.r6.class(x, "lgb.Booster") # Checking if it is of class lgb.Booster or not
}
lgb.is.Dataset <- function(x) { lgb.check.r6.class(x, "lgb.Dataset") }
lgb.is.Dataset <- function(x) {
lgb.check.r6.class(x, "lgb.Dataset") # Checking if it is of class lgb.Dataset or not
}
# use 64bit data to store address
lgb.new.handle <- function() { 0.0 }
lgb.new.handle <- function() {
0.0 # Return numeric type in R
}
lgb.is.null.handle <- function(x) { is.null(x) || x == 0 }
lgb.is.null.handle <- function(x) {
is.null(x) || x == 0 # Is it null or zero?
}
lgb.encode.char <- function(arr, len) {
if (!is.raw(arr)) {
stop("lgb.encode.char: Can only encode from raw type")
stop("lgb.encode.char: Can only encode from raw type") # Not an object of type raw
}
rawToChar(arr[seq_len(len)])
rawToChar(arr[seq_len(len)]) # Return the conversion of raw type to character type
}
lgb.call <- function(fun_name, ret, ...) {
# Set call state to a zero value
call_state <- 0L
# Check for a ret call
if (!is.null(ret)) {
call_state <- .Call(fun_name, ..., ret, call_state, PACKAGE = "lightgbm")
call_state <- .Call(fun_name, ..., ret, call_state, PACKAGE = "lightgbm") # Call with ret
} else {
call_state <- .Call(fun_name, ..., call_state, PACKAGE = "lightgbm")
call_state <- .Call(fun_name, ..., call_state, PACKAGE = "lightgbm") # Call without ret
}
# Check for call state value post call
if (call_state != 0L) {
# 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 = "lightgbm")
# Check error buffer
if (act_len > buf_len) {
buf_len <- act_len
err_msg <- raw(buf_len)
......@@ -35,107 +55,200 @@ lgb.call <- function(fun_name, ret, ...) {
err_msg,
PACKAGE = "lightgbm")
}
# Return error
stop(paste0("api error: ", lgb.encode.char(err_msg, act_len)))
}
ret
return(ret)
}
lgb.call.return.str <- function(fun_name, ...) {
# Create buffer
buf_len <- as.integer(1024 * 1024)
act_len <- 0L
buf <- raw(buf_len)
# Call buffer
buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
# Check for buffer content
if (act_len > buf_len) {
buf_len <- act_len
buf <- raw(buf_len)
buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
buf <- raw(buf_len)
buf <- lgb.call(fun_name, ret = buf, ..., buf_len, act_len)
}
lgb.encode.char(buf, act_len)
# Return encoded character
return(lgb.encode.char(buf, act_len))
}
lgb.params2str <- function(params, ...) {
if (!is.list(params)) { stop("params must be a list") }
# Check for a list as input
if (!is.list(params)) {
stop("params must be a list")
}
# Split parameter names
names(params) <- gsub("\\.", "_", names(params))
# merge parameters from the params and the dots-expansion
# Merge parameters from the params and the dots-expansion
dot_params <- list(...)
names(dot_params) <- gsub("\\.", "_", names(dot_params))
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"
)
# 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
params <- c(params, dot_params)
ret <- list()
# Setup temporary variable
ret <- list()
# Perform key value join
for (key in names(params)) {
# join multi value first
# Join multi value first
val <- paste0(params[[key]], collapse = ",")
if (nchar(val) <= 0) next
# join key value
if (nchar(val) <= 0) next # Skip join
# Join key value
pair <- paste0(c(key, val), collapse = "=")
ret <- c(ret, pair)
ret <- c(ret, pair)
}
# Check ret length
if (length(ret) == 0) {
# Return empty string
lgb.c_str("")
} else {
# Return string separated by a space per element
lgb.c_str(paste0(ret, collapse = " "))
}
}
lgb.c_str <- function(x) {
# Perform character to raw conversion
ret <- charToRaw(as.character(x))
ret <- c(ret, as.raw(0))
ret
}
lgb.check.r6.class <- function(object, name) {
# Check for non-existence of R6 class
if (!("R6" %in% class(object))) {
return(FALSE)
}
# Check for non-existance of a named class
if (!(name %in% class(object))) {
return(FALSE)
}
TRUE
# Return default value
return(TRUE)
}
lgb.check.params <- function(params) {
# To-do
params
params # Currently return params because this is not finalized
}
lgb.check.obj <- function(params, obj) {
OBJECTIVES <- c("regression", "binary", "multiclass", "lambdarank")
# List known objectives in a vector
OBJECTIVES <- c("regression", "regression_l1", "regression_l2", "huber", "fair", "poisson", "binary", "lambdarank", "multiclass")
# Check whether the objective is empty or not, and take it from params if needed
if (!is.null(obj)) { params$objective <- obj }
# Check whether the objective is a character
if (is.character(params$objective)) {
# If the objective is a character, check if it is a known objective
if (!(params$objective %in% OBJECTIVES)) {
# Interrupt on unknown objective name
stop("lgb.check.obj: objective name error should be one of (", paste0(OBJECTIVES, collapse = ", "), ")")
}
} else if (!is.function(params$objective)) {
# If objective is not a character nor a function, then stop
stop("lgb.check.obj: objective should be a character or a function")
}
params
# Return parameters
return(params)
}
lgb.check.eval <- function(params, eval) {
if (is.null(params$metric)) { params$metric <- list() }
# 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
if (!is.null(eval)) {
# append metric
# Append metric if character or list
if (is.character(eval) || is.list(eval)) {
# Append metrics
params$metric <- append(params$metric, eval)
}
}
# Check if evaluation metric is not a function
if (!is.function(eval)) {
# Check if there is no parameter
if (length(params$metric) == 0) {
# add default metric
# Add default metric
params$metric <- switch(
params$objective,
regression = "l2",
binary = "binary_logloss",
multiclass = "multi_logloss",
lambdarank = "ndcg",
stop("lgb.check.eval: No default metric available for objective ", sQuote(params$objective))
regression = "l2", # MSE
regression_l1 = "l1", # MAE
regression_l2 = "l2", # MSE
huber = "l1", # Proxy for MAE
fair = "l1", # Proxy for MAE
poisson = "poisson", # Poisson
binary = "binary_logloss", # Logloss
multiclass = "multi_logloss", # Multiclass logloss
lambdarank = "ndcg", # Normalized discounted cumulative gain
stop("lgb.check.eval: No default metric available for objective ", sQuote(params$objective)) # Unknown objective parameter
)
}
}
params
# Return parameters
return(params)
}
R-package/demo/basic_walkthrough.R
View file @ b6c973af
require(lightgbm)
require(methods)
# we load in the agaricus dataset
# We load in the agaricus dataset
# In this example, we are aiming to predict whether a mushroom is edible
data(agaricus.train, package='lightgbm')
data(agaricus.test, package='lightgbm')
data(agaricus.train, package = "lightgbm")
data(agaricus.test, package = "lightgbm")
train <- agaricus.train
test <- agaricus.test
# the loaded data is stored in sparseMatrix, and label is a numeric vector in {0,1}
# The loaded data is stored in sparseMatrix, and label is a numeric vector in {0,1}
class(train$label)
class(train$data)
#-------------Basic Training using lightgbm-----------------
# this is the basic usage of lightgbm you can put matrix in data field
# note: we are putting in sparse matrix here, lightgbm naturally handles sparse input
# use sparse matrix when your feature is sparse(e.g. when you are using one-hot encoding vector)
#--------------------Basic Training using lightgbm----------------
# This is the basic usage of lightgbm you can put matrix in data field
# Note: we are putting in sparse matrix here, lightgbm naturally handles sparse input
# Use sparse matrix when your feature is sparse (e.g. when you are using one-hot encoding vector)
print("Training lightgbm with sparseMatrix")
bst <- lightgbm(data = train$data, label = train$label, num_leaves = 4, learning_rate = 1, nrounds = 2,
bst <- lightgbm(data = train$data,
label = train$label,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
objective = "binary")
# alternatively, you can put in dense matrix, i.e. basic R-matrix
# Alternatively, you can put in dense matrix, i.e. basic R-matrix
print("Training lightgbm with Matrix")
bst <- lightgbm(data = as.matrix(train$data), label = train$label, num_leaves = 4, learning_rate = 1, nrounds = 2,
bst <- lightgbm(data = as.matrix(train$data),
label = train$label,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
objective = "binary")
# you can also put in lgb.Dataset object, which stores label, data and other meta datas needed for advanced features
# You can also put in lgb.Dataset object, which stores label, data and other meta datas needed for advanced features
print("Training lightgbm with lgb.Dataset")
dtrain <- lgb.Dataset(data = train$data, label = train$label)
bst <- lightgbm(data = dtrain, num_leaves = 4, learning_rate = 1, nrounds = 2,
objective = "binary")
dtrain <- lgb.Dataset(data = train$data,
label = train$label)
bst <- lightgbm(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
objective = "binary")
# Verbose = 0,1,2
print("Train lightgbm with verbose 0, no message")
bst <- lightgbm(data = dtrain, num_leaves = 4, learning_rate = 1, nrounds = 2,
objective = "binary", verbose = 0)
bst <- lightgbm(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
objective = "binary",
verbose = 0)
print("Train lightgbm with verbose 1, print evaluation metric")
bst <- lightgbm(data = dtrain, num_leaves = 4, learning_rate = 1, nrounds = 2,
nthread = 2, objective = "binary", verbose = 1)
bst <- lightgbm(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
nthread = 2,
objective = "binary",
verbose = 1)
print("Train lightgbm with verbose 2, also print information about tree")
bst <- lightgbm(data = dtrain, num_leaves = 4, learning_rate = 1, nrounds = 2,
nthread = 2, objective = "binary", verbose = 2)
bst <- lightgbm(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
nthread = 2,
objective = "binary",
verbose = 2)
# you can also specify data as file path to a LibSVM/TCV/CSV format input
# since we do not have this file with us, the following line is just for illustration
# bst <- lightgbm(data = 'agaricus.train.svm', num_leaves = 4, learning_rate = 1, nrounds = 2,objective = "binary")
# You can also specify data as file path to a LibSVM/TCV/CSV format input
# Since we do not have this file with us, the following line is just for illustration
# bst <- lightgbm(data = "agaricus.train.svm", num_leaves = 4, learning_rate = 1, nrounds = 2,objective = "binary")
#--------------------basic prediction using lightgbm--------------
# you can do prediction using the following line
# you can put in Matrix, sparseMatrix, or lgb.Dataset
#--------------------Basic prediction using lightgbm--------------
# You can do prediction using the following line
# You can put in Matrix, sparseMatrix, or lgb.Dataset
pred <- predict(bst, test$data)
err <- mean(as.numeric(pred > 0.5) != test$label)
print(paste("test-error=", err))
#-------------------save and load models-------------------------
# save model to binary local file
#--------------------Save and load models-------------------------
# Save model to binary local file
lgb.save(bst, "lightgbm.model")
# load binary model to R
# Load binary model to R
bst2 <- lgb.load("lightgbm.model")
pred2 <- predict(bst2, test$data)
# pred2 should be identical to pred
print(paste("sum(abs(pred2-pred))=", sum(abs(pred2-pred))))
print(paste("sum(abs(pred2-pred))=", sum(abs(pred2 - pred))))
#--------------------Advanced features ---------------------------
# To use advanced features, we need to put data in lgb.Dataset
dtrain <- lgb.Dataset(data = train$data, label = train$label, free_raw_data = FALSE)
dtest <- lgb.Dataset(data = test$data, label = test$label, free_raw_data = FALSE)
#----------------Advanced features --------------
# to use advanced features, we need to put data in lgb.Dataset
dtrain <- lgb.Dataset(data = train$data, label=train$label, free_raw_data=FALSE)
dtest <- lgb.Dataset(data = test$data, label=test$label, free_raw_data=FALSE)
#---------------Using valids----------------
#--------------------Using validation set-------------------------
# valids is a list of lgb.Dataset, each of them is tagged with name
valids <- list(train=dtrain, test=dtest)
# to train with valids, use lgb.train, which contains more advanced features
valids <- list(train = dtrain, test = dtest)
# To train with valids, use lgb.train, which contains more advanced features
# valids allows us to monitor the evaluation result on all data in the list
print("Train lightgbm using lgb.train with valids")
bst <- lgb.train(data=dtrain, num_leaves=4, learning_rate=1, nrounds=2, valids=valids,
nthread = 2, objective = "binary")
# we can change evaluation metrics, or use multiple evaluation metrics
print("train lightgbm using lgb.train with valids, watch logloss and error")
bst <- lgb.train(data=dtrain, num_leaves=4, learning_rate=1, nrounds=2, valids=valids,
eval = c("binary_error","binary_logloss"),
nthread = 2, objective = "binary")
bst <- lgb.train(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
valids = valids,
nthread = 2,
objective = "binary")
# We can change evaluation metrics, or use multiple evaluation metrics
print("Train lightgbm using lgb.train with valids, watch logloss and error")
bst <- lgb.train(data = dtrain,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
valids = valids,
eval = c("binary_error", "binary_logloss"),
nthread = 2,
objective = "binary")
# lgb.Dataset can also be saved using lgb.Dataset.save
lgb.Dataset.save(dtrain, "dtrain.buffer")
# to load it in, simply call lgb.Dataset
# To load it in, simply call lgb.Dataset
dtrain2 <- lgb.Dataset("dtrain.buffer")
bst <- lgb.train(data=dtrain2, num_leaves=4, learning_rate=1, nrounds=2, valids=valids,
nthread = 2, objective = "binary")
bst <- lgb.train(data = dtrain2,
num_leaves = 4,
learning_rate = 1,
nrounds = 2,
valids = valids,
nthread = 2,
objective = "binary")
# information can be extracted from lgb.Dataset using getinfo
label = getinfo(dtest, "label")
pred <- predict(bst, test$data)
err <- as.numeric(sum(as.integer(pred > 0.5) != label))/length(label)
err <- as.numeric(sum(as.integer(pred > 0.5) != label)) / length(label)
print(paste("test-error=", err))
R-package/demo/boost_from_prediction.R
View file @ b6c973af
require(lightgbm)
require(methods)
# load in the agaricus dataset
data(agaricus.train, package='lightgbm')
data(agaricus.test, package='lightgbm')
# Load in the agaricus dataset
data(agaricus.train, package = "lightgbm")
data(agaricus.test, package = "lightgbm")
dtrain <- lgb.Dataset(agaricus.train$data, label = agaricus.train$label)
dtest <- lgb.Dataset(agaricus.test$data, label = agaricus.test$label)
valids <- list(eval = dtest, train = dtrain)
###
#--------------------Advanced features ---------------------------
# advanced: start from a initial base prediction
#
print('start running example to start from a initial prediction')
# train lightgbm for 1 round
param <- list(num_leaves=4, learning_rate=1, nthread = 2, silent=1, objective='binary')
bst <- lgb.train(param, dtrain, 1, valids=valids)
print("Start running example to start from a initial prediction")
# Train lightgbm for 1 round
param <- list(num_leaves = 4,
learning_rate = 1,
nthread = 2,
silent = 1,
objective = "binary")
bst <- lgb.train(param, dtrain, 1, valids = valids)
# Note: we need the margin value instead of transformed prediction in set_init_score
ptrain <- predict(bst, agaricus.train$data, rawscore = TRUE)
ptest <- predict(bst, agaricus.test$data, rawscore = TRUE)
ptrain <- predict(bst, agaricus.train$data, rawscore=TRUE)
ptest <- predict(bst, agaricus.test$data, rawscore=TRUE)
# set the init_score property of dtrain and dtest
# base margin is the base prediction we will boost from
setinfo(dtrain, "init_score", ptrain)
setinfo(dtest, "init_score", ptest)
print('this is result of boost from initial prediction')
bst <- lgb.train(params = param, data = dtrain, nrounds = 5, valids = valids)
print("This is result of boost from initial prediction")
bst <- lgb.train(params = param,
data = dtrain,
nrounds = 5,
valids = valids)
R-package/demo/cross_validation.R
View file @ b6c973af
require(lightgbm)
# load in the agaricus dataset
data(agaricus.train, package='lightgbm')
data(agaricus.test, package='lightgbm')
data(agaricus.train, package = "lightgbm")
data(agaricus.test, package = "lightgbm")
dtrain <- lgb.Dataset(agaricus.train$data, label = agaricus.train$label)
dtest <- lgb.Dataset(agaricus.test$data, label = agaricus.test$label)
nround <- 2
param <- list(num_leaves=4, learning_rate=1, objective='binary')
nrounds <- 2
param <- list(num_leaves = 4,
learning_rate = 1,
objective = "binary")
cat('running cross validation\n')
# do cross validation, this will print result out as
print("Running cross validation")
# Do cross validation, this will print result out as
# [iteration] metric_name:mean_value+std_value
# std_value is standard deviation of the metric
lgb.cv(param, dtrain, nround, nfold=5, eval={'binary_error'})
lgb.cv(param,
dtrain,
nrounds,
nfold = 5,
eval = "binary_error")
cat('running cross validation, disable standard deviation display\n')
print("Running cross validation, disable standard deviation display")
# do cross validation, this will print result out as
# [iteration] metric_name:mean_value+std_value
# std_value is standard deviation of the metric
lgb.cv(param, dtrain, nround, nfold=5,
eval='binary_error', showsd = FALSE)
lgb.cv(param,
dtrain,
nrounds,
nfold = 5,
eval = "binary_error",
showsd = FALSE)
###
# you can also do cross validation with cutomized loss function
# Tou can also do cross validation with cutomized loss function
# See custom_objective.R
##
print ('running cross validation, with cutomsized loss function')
print("Running cross validation, with cutomsized loss function")
logregobj <- function(preds, dtrain) {
labels <- getinfo(dtrain, "label")
preds <- 1/(1 + exp(-preds))
preds <- 1 / (1 + exp(-preds))
grad <- preds - labels
hess <- preds * (1 - preds)
return(list(grad = grad, hess = hess))
}
evalerror <- function(preds, dtrain) {
labels <- getinfo(dtrain, "label")
err <- as.numeric(sum(labels != (preds > 0)))/length(labels)
return(list(name = "error", value = err, higher_better=FALSE))
err <- as.numeric(sum(labels != (preds > 0))) / length(labels)
return(list(name = "error", value = err, higher_better = FALSE))
}
# train with customized objective
lgb.cv(params = param, data = dtrain, nrounds = nround, obj=logregobj, eval=evalerror, nfold = 5)
lgb.cv(params = param,
data = dtrain,
nrounds = nrounds,
obj = logregobj,
eval = evalerror,
nfold = 5)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment