[R-package] enable saving Booster with saveRDS() and loading it with readRDS() (fixes #4296)

R-package/NAMESPACE

@@ -19,20 +19,21 @@ export(lgb.Dataset.set.categorical)
 export(lgb.Dataset.set.reference)
 export(lgb.convert_with_rules)
 export(lgb.cv)
+export(lgb.drop_serialized)
 export(lgb.dump)
 export(lgb.get.eval.result)
 export(lgb.importance)
 export(lgb.interprete)
 export(lgb.load)
+export(lgb.make_serializable)
 export(lgb.model.dt.tree)
 export(lgb.plot.importance)
 export(lgb.plot.interpretation)
+export(lgb.restore_handle)
 export(lgb.save)
 export(lgb.train)
 export(lgb.unloader)
 export(lightgbm)
-export(readRDS.lgb.Booster)
-export(saveRDS.lgb.Booster)
 export(set_field)
 export(setinfo)
 export(slice)

R-package/R/lgb.Booster.R

@@ -84,9 +84,12 @@ Booster <- R6::R6Class(
 
         } else if (!is.null(model_str)) {
 
-          # Do we have a model_str as character?
-          if (!is.character(model_str)) {
-            stop("lgb.Booster: Can only use a string as model_str")
+          # Do we have a model_str as character/raw?
+          if (is.character(model_str)) {
+            model_str <- charToRaw(model_str)
+          }
+          if (!is.raw(model_str)) {
+            stop("lgb.Booster: Can only use a character/raw vector as model_str")
           }
 
           # Create booster from model
@@ -194,6 +197,8 @@ Booster <- R6::R6Class(
       params <- utils::modifyList(params, additional_params)
       params_str <- lgb.params2str(params = params)
 
+      self$restore_handle()
+
       .Call(
         LGBM_BoosterResetParameter_R
         , private$handle
@@ -287,6 +292,8 @@ Booster <- R6::R6Class(
     # Return one iteration behind
     rollback_one_iter = function() {
 
+      self$restore_handle()
+
       .Call(
         LGBM_BoosterRollbackOneIter_R
         , private$handle
@@ -304,6 +311,8 @@ Booster <- R6::R6Class(
     # Get current iteration
     current_iter = function() {
 
+      self$restore_handle()
+
       cur_iter <- 0L
       .Call(
         LGBM_BoosterGetCurrentIteration_R
@@ -317,6 +326,8 @@ Booster <- R6::R6Class(
     # Get upper bound
     upper_bound = function() {
 
+      self$restore_handle()
+
       upper_bound <- 0.0
       .Call(
         LGBM_BoosterGetUpperBoundValue_R
@@ -330,6 +341,8 @@ Booster <- R6::R6Class(
     # Get lower bound
     lower_bound = function() {
 
+      self$restore_handle()
+
       lower_bound <- 0.0
       .Call(
         LGBM_BoosterGetLowerBoundValue_R
@@ -421,6 +434,8 @@ Booster <- R6::R6Class(
     # Save model
     save_model = function(filename, num_iteration = NULL, feature_importance_type = 0L) {
 
+      self$restore_handle()
+
       if (is.null(num_iteration)) {
         num_iteration <- self$best_iter
       }
@@ -436,7 +451,9 @@ Booster <- R6::R6Class(
       return(invisible(self))
     },
 
-    save_model_to_string = function(num_iteration = NULL, feature_importance_type = 0L) {
+    save_model_to_string = function(num_iteration = NULL, feature_importance_type = 0L, as_char = TRUE) {
+
+      self$restore_handle()
 
       if (is.null(num_iteration)) {
         num_iteration <- self$best_iter
@@ -449,6 +466,10 @@ Booster <- R6::R6Class(
           , as.integer(feature_importance_type)
       )
 
+      if (as_char) {
+        model_str <- rawToChar(model_str)
+      }
+
       return(model_str)
 
     },
@@ -527,17 +548,39 @@ Booster <- R6::R6Class(
       return(Predictor$new(modelfile = private$handle))
     },
 
-    # Used for save
-    raw = NA,
+    # Used for serialization
+    raw = NULL,
 
-    # Save model to temporary file for in-memory saving
-    save = function() {
+    # Store serialized raw bytes in model object
+    save_raw = function() {
+      if (is.null(self$raw)) {
+        self$raw <- self$save_model_to_string(NULL, as_char = FALSE)
+      }
+      return(invisible(NULL))
 
-      # Overwrite model in object
-      self$raw <- self$save_model_to_string(NULL)
+    },
 
+    drop_raw = function() {
+      self$raw <- NULL
       return(invisible(NULL))
+    },
+
+    check_null_handle = function() {
+      return(lgb.is.null.handle(private$handle))
+    },
 
+    restore_handle = function() {
+      if (self$check_null_handle()) {
+        if (is.null(self$raw)) {
+          .Call(LGBM_NullHandleError_R)
+        }
+        private$handle <- .Call(LGBM_BoosterLoadModelFromString_R, self$raw)
+      }
+      return(invisible(NULL))
+    },
+
+    get_handle = function() {
+      return(private$handle)
     }
 
   ),
@@ -636,6 +679,8 @@ Booster <- R6::R6Class(
         stop("data_idx should not be greater than num_dataset")
       }
 
+      self$restore_handle()
+
       private$get_eval_info()
 
       ret <- list()
@@ -784,6 +829,7 @@ predict.lgb.Booster <- function(object,
   if (!lgb.is.Booster(x = object)) {
     stop("predict.lgb.Booster: object should be an ", sQuote("lgb.Booster"))
   }
+  object$restore_handle()
 
   additional_params <- list(...)
   if (length(additional_params) > 0L) {
@@ -815,7 +861,7 @@ predict.lgb.Booster <- function(object,
 #' @description Load LightGBM takes in either a file path or model string.
 #'              If both are provided, Load will default to loading from file
 #' @param filename path of model file
-#' @param model_str a str containing the model
+#' @param model_str a str containing the model (as a `character` or `raw` vector)
 #'
 #' @return lgb.Booster
 #'
@@ -863,9 +909,12 @@ lgb.load <- function(filename = NULL, model_str = NULL) {
     return(invisible(Booster$new(modelfile = filename)))
   }
 
+  if (is.character(model_str)) {
+    model_str <- charToRaw(model_str)
+  }
   if (model_str_provided) {
-    if (!is.character(model_str)) {
-      stop("lgb.load: model_str should be character")
+    if (!is.raw(model_str)) {
+      stop("lgb.load: model_str should be a character/raw vector")
     }
     return(invisible(Booster$new(model_str = model_str)))
   }

R-package/R/lgb.Predictor.R

@@ -39,12 +39,17 @@ Predictor <- R6::R6Class(
         )
         private$need_free_handle <- TRUE
 
-      } else if (methods::is(modelfile, "lgb.Booster.handle")) {
+      } else if (methods::is(modelfile, "lgb.Booster.handle") || inherits(modelfile, "externalptr")) {
 
         # Check if model file is a booster handle already
         handle <- modelfile
         private$need_free_handle <- FALSE
 
+      } else if (lgb.is.Booster(modelfile)) {
+
+        handle <- modelfile$get_handle()
+        private$need_free_handle <- FALSE
+
       } else {
 
         stop("lgb.Predictor: modelfile must be either a character filename or an lgb.Booster.handle")

R-package/R/lgb.cv.R

@@ -97,6 +97,7 @@ lgb.cv <- function(params = list()
                    , categorical_feature = NULL
                    , early_stopping_rounds = NULL
                    , callbacks = list()
+                   , serializable = TRUE
                    , reset_data = FALSE
                    , ...
                    ) {
@@ -456,6 +457,10 @@ lgb.cv <- function(params = list()
     })
   }
 
+  if (serializable) {
+    lapply(cv_booster$boosters, function(model) model$booster$save_raw())
+  }
+
   return(cv_booster)
 
 }

R-package/R/lgb.drop_serialized.R

@@ -0,0 +1,16 @@
+#' @name lgb.drop_serialized
+#' @title Drop serialized raw bytes in a LightGBM model object
+#' @description If a LightGBM model object was produced with argument `serializable=TRUE`, the R object will keep
+#' a copy of the underlying C++ object as raw bytes, which can be used to reconstruct such object after getting
+#' serialized and de-serialized, but at the cost of extra memory usage. If these raw bytes are not needed anymore,
+#' they can be dropped through this function in order to save memory. Note that the object will be modified in-place.
+#' @param model \code{lgb.Booster} object which was produced with `serializable=TRUE`.
+#'
+#' @return \code{lgb.Booster} (the same `model` object that was passed as input, as invisible).
+#' @seealso \link{lgb.restore_handle}, \link{lgb.make_serializable}.
+#' @export
+lgb.drop_serialized <- function(model) {
+  stopifnot(lgb.is.Booster(model))
+  model$drop_raw()
+  return(invisible(model))
+}

R-package/R/lgb.importance.R

@@ -41,6 +41,7 @@ lgb.importance <- function(model, percentage = TRUE) {
   if (!lgb.is.Booster(x = model)) {
     stop("'model' has to be an object of class lgb.Booster")
   }
+  model$restore_handle()
 
   # Setup importance
   tree_dt <- lgb.model.dt.tree(model = model)

R-package/R/lgb.make_serializable.R

@@ -0,0 +1,16 @@
+#' @name lgb.make_serializable
+#' @title Make a LightGBM object serializable by keeping raw bytes
+#' @description If a LightGBM model object was produced with argument `serializable=FALSE`, the R object will not
+#' be serializable (e.g. cannot save and load with \code{saveRDS} and \code{readRDS}) as it will lack the raw bytes
+#' needed to reconstruct its underlying C++ object. This function can be used to forcibly produce those serialized
+#' raw bytes and make the object serializable. Note that the object will be modified in-place.
+#' @param model \code{lgb.Booster} object which was produced with `serializable=FALSE`.
+#'
+#' @return \code{lgb.Booster} (the same `model` object that was passed as input, as invisible).
+#' @seealso \link{lgb.restore_handle}, \link{lgb.drop_serialized}.
+#' @export
+lgb.make_serializable <- function(model) {
+  stopifnot(lgb.is.Booster(model))
+  model$save_raw()
+  return(invisible(model))
+}

R-package/R/lgb.restore_handle.R

@@ -0,0 +1,33 @@
+#' @name lgb.restore_handle
+#' @title Restore the C++ component of a deserialized LGB model
+#' @description After a LightGBM model object is de-serialized through functions such as \code{save} or
+#' \code{saveRDS}, its underlying C++ object will be blank and needs to be restored to able to use it. Such
+#' object is restored automatically when calling functions such as \code{predict}, but this function can be
+#' used to forcibly restore it beforehand. Note that the object will be modified in-place.
+#' @param model \code{lgb.Booster} object which was de-serialized and whose underlying C++ object and R handle
+#' need to be restored.
+#'
+#' @return \code{lgb.Booster} (the same `model` object that was passed as input, as invisible).
+#' @seealso \link{lgb.make_serializable}, \link{lgb.drop_serialized}.
+#' @examples
+#' library(lightgbm)
+#' data("agaricus.train")
+#' model <- lightgbm(
+#'   agaricus.train$data
+#'   , agaricus.train$label
+#'   , params = list(objective = "binary", nthreads = 1L)
+#'   , nrounds = 5L
+#'   , verbose = 0)
+#' fname <- tempfile(fileext="rds")
+#' saveRDS(model, fname)
+#'
+#' model_new <- readRDS(fname)
+#' model_new$check_null_handle()
+#' lgb.restore_handle(model_new)
+#' model_new$check_null_handle()
+#' @export
+lgb.restore_handle <- function(model) {
+  stopifnot(lgb.is.Booster(model))
+  model$restore_handle()
+  return(invisible(model))
+}

R-package/R/lgb.train.R

@@ -67,6 +67,7 @@ lgb.train <- function(params = list(),
                       early_stopping_rounds = NULL,
                       callbacks = list(),
                       reset_data = FALSE,
+                      serializable = TRUE,
                       ...) {
 
   # validate inputs early to avoid unnecessary computation
@@ -395,6 +396,9 @@ lgb.train <- function(params = list(),
 
   }
 
+  if (serializable)
+    booster$save_raw()
+
   return(booster)
 
 }

R-package/R/lightgbm.R

@@ -52,6 +52,8 @@
 #' @param params a list of parameters. See \href{https://lightgbm.readthedocs.io/en/latest/Parameters.html}{
 #'               the "Parameters" section of the documentation} for a list of parameters and valid values.
 #' @param verbose verbosity for output, if <= 0, also will disable the print of evaluation during training
+#' @param serializable whether to make the resulting objects serializable through functions such as
+#' \code{save} or \code{saveRDS} (see section "Model serialization").
 #' @section Early Stopping:
 #'
 #'          "early stopping" refers to stopping the training process if the model's performance on a given
@@ -66,6 +68,21 @@
 #'          in \code{params}, that metric will be considered the "first" one. If you omit \code{metric},
 #'          a default metric will be used based on your choice for the parameter \code{obj} (keyword argument)
 #'          or \code{objective} (passed into \code{params}).
+#' @section Model serialization:
+#'
+#'          LightGBM models objects can be serialized and de-serialized through functions such as \code{save}
+#'          or \code{saveRDS}, but similarly to libraries such as 'xgboost', serialization works a bit differently
+#'          from typical R objects. In order to make models serializable in R, a copy of the underlying C++ object
+#'          as serialized raw bytes is produced and stored in the R model object, and when this R object is
+#'          de-serialized, the underlying C++ model object gets reconstructed from these raw bytes, but will only
+#'          do so once some function that uses it is called, such as \code{predict}. In order to forcibly
+#'          reconstruct the C++ object after deserialization (e.g. after calling \code{readRDS} or similar), one
+#'          can use the function \link{lgb.restore_handle} (for example, if one makes predictions in parallel or in
+#'          forked processes, it will be faster to restore the handle beforehand).
+#'
+#'          Producing and keeping these raw bytes however uses extra memory, and if they are not required,
+#'          it is possible to avoid producing them by passing `serializable=FALSE`. In such cases, these raw
+#'          bytes can be added to the model on demand through function \link{lgb.make_serializable}.
 #' @keywords internal
 NULL
 
@@ -113,6 +130,7 @@ lightgbm <- function(data,
                      save_name = "lightgbm.model",
                      init_model = NULL,
                      callbacks = list(),
+                     serializable = TRUE,
                      ...) {
 
   # validate inputs early to avoid unnecessary computation
@@ -137,6 +155,7 @@ lightgbm <- function(data,
     , "early_stopping_rounds" = early_stopping_rounds
     , "init_model" = init_model
     , "callbacks" = callbacks
+    , "serializable" = serializable
   )
   train_args <- append(train_args, list(...))