view release on metacpan or  search on metacpan

xgboost/R-package/R/utils.R  view on Meta::CPAN

    }
  }
  
  # for multiclass, expect num_class to be set
  if (typeof(params[['objective']]) == "character" &&
      substr(NVL(params[['objective']], 'x'), 1, 6) == 'multi:' &&
      as.numeric(NVL(params[['num_class']], 0)) < 2) {
        stop("'num_class' > 1 parameter must be set for multiclass classification")
  }
  
  # monotone_constraints parser
  
  if (!is.null(params[['monotone_constraints']]) &&
      typeof(params[['monotone_constraints']]) != "character") {
        vec2str = paste(params[['monotone_constraints']], collapse = ',')
        vec2str = paste0('(', vec2str, ')')
        params[['monotone_constraints']] = vec2str
  }
  
  return(params)
}


# Performs some checks related to custom objective function.
# WARNING: has side-effects and can modify 'params' and 'obj' in its calling frame
check.custom.obj <- function(env = parent.frame()) {
  if (!is.null(env$params[['objective']]) && !is.null(env$obj))
    stop("Setting objectives in 'params' and 'obj' at the same time is not allowed")
  
  if (!is.null(env$obj) && typeof(env$obj) != 'closure')
    stop("'obj' must be a function")
  
  # handle the case when custom objective function was provided through params
  if (!is.null(env$params[['objective']]) &&
      typeof(env$params$objective) == 'closure') {
    env$obj <- env$params$objective
    env$params$objective <- NULL
  }
}

# Performs some checks related to custom evaluation function.
# WARNING: has side-effects and can modify 'params' and 'feval' in its calling frame
check.custom.eval <- function(env = parent.frame()) {
  if (!is.null(env$params[['eval_metric']]) && !is.null(env$feval))
    stop("Setting evaluation metrics in 'params' and 'feval' at the same time is not allowed")
  
  if (!is.null(env$feval) && typeof(env$feval) != 'closure')
    stop("'feval' must be a function")
  
  # handle a situation when custom eval function was provided through params
  if (!is.null(env$params[['eval_metric']]) &&
      typeof(env$params$eval_metric) == 'closure') {
    env$feval <- env$params$eval_metric
    env$params$eval_metric <- NULL
  }
  
  # require maximize to be set when custom feval and early stopping are used together
  if (!is.null(env$feval) &&
      is.null(env$maximize) && (
        !is.null(env$early_stopping_rounds) || 
        has.callbacks(env$callbacks, 'cb.early.stop')))
    stop("Please set 'maximize' to indicate whether the evaluation metric needs to be maximized or not")
}


# Update a booster handle for an iteration with dtrain data
xgb.iter.update <- function(booster_handle, dtrain, iter, obj = NULL) {
  if (!identical(class(booster_handle), "xgb.Booster.handle")) {
    stop("booster_handle must be of xgb.Booster.handle class")
  }
  if (!inherits(dtrain, "xgb.DMatrix")) {
    stop("dtrain must be of xgb.DMatrix class")
  }

  if (is.null(obj)) {
    .Call(XGBoosterUpdateOneIter_R, booster_handle, as.integer(iter), dtrain)
  } else {
    pred <- predict(booster_handle, dtrain)
    gpair <- obj(pred, dtrain)
    .Call(XGBoosterBoostOneIter_R, booster_handle, dtrain, gpair$grad, gpair$hess)
  }
  return(TRUE)
}


# Evaluate one iteration.
# Returns a named vector of evaluation metrics 
# with the names in a 'datasetname-metricname' format.
xgb.iter.eval <- function(booster_handle, watchlist, iter, feval = NULL) {
  if (!identical(class(booster_handle), "xgb.Booster.handle"))
    stop("class of booster_handle must be xgb.Booster.handle")

  if (length(watchlist) == 0) 
    return(NULL)
  
  evnames <- names(watchlist)
  if (is.null(feval)) {
    msg <- .Call(XGBoosterEvalOneIter_R, booster_handle, as.integer(iter), watchlist, as.list(evnames))
    msg <- stri_split_regex(msg, '(\\s+|:|\\s+)')[[1]][-1]
    res <- as.numeric(msg[c(FALSE,TRUE)]) # even indices are the values
    names(res) <- msg[c(TRUE,FALSE)]      # odds are the names
  } else {
    res <- sapply(seq_along(watchlist), function(j) {
      w <- watchlist[[j]]
      preds <- predict(booster_handle, w) # predict using all trees
      eval_res <- feval(preds, w)
      out <- eval_res$value
      names(out) <- paste0(evnames[j], "-", eval_res$metric)
      out
    })
  }
  return(res)
}


#
# Helper functions for cross validation ---------------------------------------
#

# Generates random (stratified if needed) CV folds
generate.cv.folds <- function(nfold, nrows, stratified, label, params) {