More functionality for model attributes

R-package/NAMESPACE

@@ -10,13 +10,16 @@ S3method(predict,xgb.Booster.handle)
 S3method(setinfo,xgb.DMatrix)
 S3method(slice,xgb.DMatrix)
 export("xgb.attr<-")
+export("xgb.attributes<-")
+export("xgb.parameters<-")
 export(getinfo)
 export(print.xgb.DMatrix)
 export(setinfo)
 export(slice)
 export(xgb.DMatrix)
 export(xgb.DMatrix.save)
 export(xgb.attr)
+export(xgb.attributes)
 export(xgb.create.features)
 export(xgb.cv)
 export(xgb.dump)

R-package/R/xgb.Booster.R

@@ -2,31 +2,28 @@
 # internal utility function
 xgb.Booster <- function(params = list(), cachelist = list(), modelfile = NULL) {
   if (typeof(cachelist) != "list") {
-    stop("xgb.Booster: only accepts list of DMatrix as cachelist")
+    stop("xgb.Booster only accepts list of DMatrix as cachelist")
   }
   for (dm in cachelist) {
     if (class(dm) != "xgb.DMatrix") {
-      stop("xgb.Booster: only accepts list of DMatrix as cachelist")
+      stop("xgb.Booster only accepts list of DMatrix as cachelist")
     }
   }
   handle <- .Call("XGBoosterCreate_R", cachelist, PACKAGE = "xgboost")
-  if (length(params) != 0) {
-    for (i in 1:length(params)) {
-      p <- params[i]
-      .Call("XGBoosterSetParam_R", handle, gsub("\\.", "_", names(p)), as.character(p),
-            PACKAGE = "xgboost")
-    }
-  }
   if (!is.null(modelfile)) {
     if (typeof(modelfile) == "character") {
       .Call("XGBoosterLoadModel_R", handle, modelfile, PACKAGE = "xgboost")
     } else if (typeof(modelfile) == "raw") {
       .Call("XGBoosterLoadModelFromRaw_R", handle, modelfile, PACKAGE = "xgboost")
     } else {
-      stop("xgb.Booster: modelfile must be character or raw vector")
+      stop("modelfile must be character or raw vector")
     }
   }
-  return(structure(handle, class = "xgb.Booster.handle"))
+  class(handle) <- "xgb.Booster.handle"
+  if (length(params) > 0) {
+    xgb.parameters(handle) <- params
+  }
+  return(handle)
 }
 
 # Convert xgb.Booster.handle to xgb.Booster
@@ -38,6 +35,20 @@ xgb.handleToBooster <- function(handle, raw = NULL)
   return(bst)
 }
 
+# Return a verified to be valid handle out of either xgb.Booster.handle or xgb.Booster
+# internal utility function
+xgb.get.handle <- function(object) {
+  handle <- switch(class(object)[1],
+    xgb.Booster = object$handle,
+    xgb.Booster.handle = object,
+    stop("argument must be of either xgb.Booster or xgb.Booster.handle class")
+  )
+  if (is.null(handle) | .Call("XGCheckNullPtr_R", handle, PACKAGE="xgboost")) {
+    stop("invalid xgb.Booster.handle")
+  }
+  handle
+}
+
 # Check whether an xgb.Booster object is complete
 # internal utility function
 xgb.Booster.check <- function(bst, saveraw = TRUE)
@@ -146,28 +157,43 @@ predict.xgb.Booster.handle <- function(object, ...) {
 
 #' Accessors for serializable attributes of a model.
 #'
-#' These methods allow to manipulate key-value attribute strings of an xgboost model.
+#' These methods allow to manipulate the key-value attribute strings of an xgboost model.
 #'
-#' @param object Object of class \code{xgb.Booster} or  \code{xgb.Booster.handle}.
-#' @param which a non-empty character string specifying which attribute is to be accessed.
-#' @param value a value of an attribute. Non-character values are converted to character.
-#'        When length of a \code{value} vector is more than one, only the first element is used.
+#' @param object Object of class \code{xgb.Booster} or \code{xgb.Booster.handle}.
+#' @param name a non-empty character string specifying which attribute is to be accessed.
+#' @param value a value of an attribute for \code{xgb.attr<-}; for \code{xgb.attributes<-} 
+#'        it's a list (or an object coercible to a list) with the names of attributes to set 
+#'        and the elements corresponding to attribute values. 
+#'        Non-character values are converted to character.
+#'        When attribute value is not a scalar, only the first index is used.
+#'        Use \code{NULL} to remove an attribute.
 #'
 #' @details
-#' Note that the xgboost model attributes are a separate concept from the attributes in R.
-#' Specifically, they refer to key-value strings that can be attached to an xgboost model
-#' and stored within the model's binary representation.
+#' The primary purpose of xgboost model attributes is to store some meta-data about the model.
+#' Note that they are a separate concept from the object attributes in R.
+#' Specifically, they refer to key-value strings that can be attached to an xgboost model,
+#' stored together with the model's binary representation, and accessed later 
+#' (from R or any other interface).
 #' In contrast, any R-attribute assigned to an R-object of \code{xgb.Booster} class
-#' would not be saved by \code{xgb.save}, since xgboost model is an external memory object
+#' would not be saved by \code{xgb.save} because an xgboost model is an external memory object
 #' and its serialization is handled extrnally.
+#' Also, setting an attribute that has the same name as one of xgboost's parameters wouldn't 
+#' change the value of that parameter for a model. 
+#' Use \code{\link{`xgb.parameters<-`}} to set or change model parameters.
 #' 
-#' Also note that the attribute setter would usually work more efficiently for \code{xgb.Booster.handle}
-#' than for \code{xgb.Booster}, since only just a handle would need to be copied.
+#' The attribute setters would usually work more efficiently for \code{xgb.Booster.handle}
+#' than for \code{xgb.Booster}, since only just a handle (pointer) would need to be copied.
+#' 
+#' The \code{xgb.attributes<-} setter either updates the existing or adds one or several attributes, 
+#' but doesn't delete the existing attributes which don't have their names in \code{names(attributes)}.
 #' 
 #' @return
 #' \code{xgb.attr} returns either a string value of an attribute 
 #' or \code{NULL} if an attribute wasn't stored in a model.
 #' 
+#' \code{xgb.attributes} returns a list of all attribute stored in a model 
+#' or \code{NULL} if a model has no stored attributes.
+#' 
 #' @examples
 #' data(agaricus.train, package='xgboost')
 #' train <- agaricus.train
@@ -177,42 +203,117 @@ predict.xgb.Booster.handle <- function(object, ...) {
 #'
 #' xgb.attr(bst, "my_attribute") <- "my attribute value"
 #' print(xgb.attr(bst, "my_attribute"))
+#' xgb.attributes(bst) <- list(a = 123, b = "abc")
 #'
 #' xgb.save(bst, 'xgb.model')
 #' bst1 <- xgb.load('xgb.model')
 #' print(xgb.attr(bst1, "my_attribute"))
-#'
+#' print(xgb.attributes(bst1))
+#' 
+#' # deletion:
+#' xgb.attr(bst1, "my_attribute") <- NULL
+#' print(xgb.attributes(bst1))
+#' xgb.attributes(bst1) <- list(a = NULL, b = NULL)
+#' print(xgb.attributes(bst1))
+#' 
 #' @rdname xgb.attr
 #' @export
-xgb.attr <- function(object, which) {
-  if (is.null(which) | nchar(as.character(which)[1]) == 0) stop("invalid attribute name")
-  handle = xgb.get.handle(object, "xgb.attr")
-  .Call("XGBoosterGetAttr_R", handle, as.character(which)[1], PACKAGE="xgboost")
+xgb.attr <- function(object, name) {
+  if (is.null(name) || nchar(as.character(name[1])) == 0) stop("invalid attribute name")
+  handle <- xgb.get.handle(object)
+  .Call("XGBoosterGetAttr_R", handle, as.character(name[1]), PACKAGE="xgboost")
 }
 
 #' @rdname xgb.attr
 #' @export
-`xgb.attr<-` <- function(object, which, value) {
-  if (is.null(which) | nchar(as.character(which)[1]) == 0) stop("invalid attribute name")
-  handle = xgb.get.handle(object, "xgb.attr")
-  # TODO: setting NULL value to remove an attribute
-  .Call("XGBoosterSetAttr_R", handle, as.character(which)[1], as.character(value)[1], PACKAGE="xgboost")
+`xgb.attr<-` <- function(object, name, value) {
+  if (is.null(name) || nchar(as.character(name[1])) == 0) stop("invalid attribute name")
+  handle <- xgb.get.handle(object)
+  if (!is.null(value)) {
+    # Coerce the elements to be scalar strings.
+    # Q: should we warn user about non-scalar elements?
+    value <- as.character(value[1])
+  }
+  .Call("XGBoosterSetAttr_R", handle, as.character(name[1]), value, PACKAGE="xgboost")
   if (is(object, 'xgb.Booster') && !is.null(object$raw)) {
-      object$raw <- xgb.save.raw(object$handle)
+    object$raw <- xgb.save.raw(object$handle)
   }
   object
 }
 
-# Return a valid handle out of either xgb.Booster.handle or xgb.Booster
-# internal utility function
-xgb.get.handle <- function(object, caller="") {
-  handle = switch(class(object),
-    xgb.Booster = object$handle,
-    xgb.Booster.handle = object,
-    stop(caller, ": argument must be either xgb.Booster or xgb.Booster.handle")
-  )
-  if (is.null(handle) | .Call("XGCheckNullPtr_R", handle, PACKAGE="xgboost")) {
-    stop(caller, ": invalid xgb.Booster.handle")
+#' @rdname xgb.attr
+#' @export
+xgb.attributes <- function(object) {
+  handle <- xgb.get.handle(object)
+  attr_names <- .Call("XGBoosterGetAttrNames_R", handle, PACKAGE="xgboost")
+  if (is.null(attr_names)) return(NULL)
+  res <- lapply(attr_names, function(x) {
+    .Call("XGBoosterGetAttr_R", handle, x, PACKAGE="xgboost")
+  })
+  names(res) <- attr_names
+  res
+}
+
+#' @rdname xgb.attr
+#' @export
+`xgb.attributes<-` <- function(object, value) {
+  a <- as.list(value)
+  if (is.null(names(a)) || any(nchar(names(a)) == 0)) {
+    stop("attribute names cannot be empty strings")
   }
-  handle
+  # Coerce the elements to be scalar strings.
+  # Q: should we warn a user about non-scalar elements?
+  a <- lapply(a, function(x) {
+    if (is.null(x)) return(NULL)
+    as.character(x[1])
+  })
+  handle <- xgb.get.handle(object)
+  for (i in seq_along(a)) {
+    .Call("XGBoosterSetAttr_R", handle, names(a[i]), a[[i]], PACKAGE="xgboost")
+  }
+  if (is(object, 'xgb.Booster') && !is.null(object$raw)) {
+    object$raw <- xgb.save.raw(object$handle)
+  }
+  object
+}
+
+#' Accessors for model parameters.
+#'
+#' Only the setter for xgboost parameters is currently implemented.
+#'
+#' @param object Object of class \code{xgb.Booster} or \code{xgb.Booster.handle}.
+#' @param value a list (or an object coercible to a list) with the names of parameters to set
+#'        and the elements corresponding to parameter values.
+#'
+#' @details
+#' Note that the setter would usually work more efficiently for \code{xgb.Booster.handle}
+#' than for \code{xgb.Booster}, since only just a handle would need to be copied.
+#' 
+#' @examples
+#' data(agaricus.train, package='xgboost')
+#' train <- agaricus.train
+#'
+#' bst <- xgboost(data = train$data, label = train$label, max.depth = 2,
+#'                eta = 1, nthread = 2, nround = 2, objective = "binary:logistic")
+#'
+#' xgb.parameters(bst) <- list(eta = 0.1)
+#' 
+#' @rdname xgb.parameters
+#' @export
+`xgb.parameters<-` <- function(object, value) {
+  if (length(value) == 0) return(object)
+  p <- as.list(value)
+  if (is.null(names(p)) || any(nchar(names(p)) == 0)) {
+    stop("parameter names cannot be empty strings")
+  }
+  names(p) <- gsub("\\.", "_", names(p))
+  p <- lapply(p, function(x) as.character(x)[1])
+  handle <- xgb.get.handle(object)
+  for (i in seq_along(p)) {
+    .Call("XGBoosterSetParam_R", handle, names(p[i]), p[[i]], PACKAGE = "xgboost")
+  }
+  if (is(object, 'xgb.Booster') && !is.null(object$raw)) {
+    object$raw <- xgb.save.raw(object$handle)
+  }
+  object
 }