1090 lines
35 KiB
R
1090 lines
35 KiB
R
prescreen.parameters <- function(params) {
|
|
if (!NROW(params)) {
|
|
return(list())
|
|
}
|
|
if (!is.list(params)) {
|
|
stop("'params' must be a list or NULL.")
|
|
}
|
|
|
|
params <- params[!is.null(params)]
|
|
|
|
if ("num_class" %in% names(params)) {
|
|
stop("'num_class' cannot be manually specified for 'xgboost()'. Pass a factor 'y' instead.")
|
|
}
|
|
if ("process_type" %in% names(params)) {
|
|
if (params$process_type != "default") {
|
|
stop("Non-default 'process_type' is not supported for 'xgboost()'. Try 'xgb.train()'.")
|
|
}
|
|
}
|
|
|
|
return(params)
|
|
}
|
|
|
|
prescreen.objective <- function(objective) {
|
|
if (!is.null(objective)) {
|
|
if (objective %in% .OBJECTIVES_NON_DEFAULT_MODE()) {
|
|
stop(
|
|
"Objectives with non-default prediction mode (",
|
|
paste(.OBJECTIVES_NON_DEFAULT_MODE(), collapse = ", "),
|
|
") are not supported in 'xgboost()'. Try 'xgb.train()'."
|
|
)
|
|
}
|
|
|
|
if (!is.character(objective) || length(objective) != 1L || is.na(objective)) {
|
|
stop("'objective' must be a single character/string variable.")
|
|
}
|
|
}
|
|
}
|
|
|
|
process.base.margin <- function(base_margin, nrows, ncols) {
|
|
if (!NROW(base_margin)) {
|
|
return(NULL)
|
|
}
|
|
if (is.array(base_margin) && length(dim(base_margin)) > 2) {
|
|
stop(
|
|
"'base_margin' should not have more than 2 dimensions for any objective (got: ",
|
|
length(dim(base_margin)),
|
|
" dimensions)."
|
|
)
|
|
}
|
|
if (inherits(base_margin, c("sparseMatrix", "sparseVector"))) {
|
|
warning(
|
|
"Got a sparse matrix type (class: ",
|
|
paste(class(base_margin), collapse = ", "),
|
|
") for 'base_margin'. Will convert to dense matrix."
|
|
)
|
|
base_margin <- as.matrix(base_margin)
|
|
}
|
|
if (NROW(base_margin) != nrows) {
|
|
stop(
|
|
"'base_margin' has incorrect number of rows. Expected: ",
|
|
nrows,
|
|
". Got: ",
|
|
NROW(base_margin)
|
|
)
|
|
}
|
|
|
|
if (ncols == 1L) {
|
|
if (inherits(base_margin, c("matrix", "data.frame"))) {
|
|
if (ncol(base_margin) != 1L) {
|
|
stop("'base_margin' should be a 1-d vector for the given objective and data.")
|
|
}
|
|
if (is.data.frame(base_margin)) {
|
|
base_margin <- base_margin[[1L]]
|
|
} else {
|
|
base_margin <- base_margin[, 1L]
|
|
}
|
|
}
|
|
if (!is.numeric(base_margin)) {
|
|
base_margin <- as.numeric(base_margin)
|
|
}
|
|
} else {
|
|
supported_multicol <- c("matrix", "data.frame")
|
|
if (!inherits(base_margin, supported_multicol)) {
|
|
stop(
|
|
"'base_margin' should be a matrix with ",
|
|
ncols,
|
|
" columns for the given objective and data. Got class: ",
|
|
paste(class(base_margin), collapse = ", ")
|
|
)
|
|
}
|
|
if (ncol(base_margin) != ncols) {
|
|
stop(
|
|
"'base_margin' has incorrect number of columns. Expected: ",
|
|
ncols,
|
|
". Got: ",
|
|
ncol(base_margin)
|
|
)
|
|
}
|
|
if (!is.matrix(base_margin)) {
|
|
base_margin <- as.matrix(base_margin)
|
|
}
|
|
}
|
|
|
|
return(base_margin)
|
|
}
|
|
|
|
process.y.margin.and.objective <- function(
|
|
y,
|
|
base_margin,
|
|
objective,
|
|
params
|
|
) {
|
|
|
|
if (!NROW(y)) {
|
|
stop("Passed empty 'y'.")
|
|
}
|
|
|
|
if (is.array(y) && length(dim(y)) > 2) {
|
|
stop(
|
|
"'y' should not have more than 2 dimensions for any objective (got: ",
|
|
length(dim(y)),
|
|
")."
|
|
)
|
|
}
|
|
|
|
if (inherits(y, c("sparseMatrix", "sparseVector"))) {
|
|
warning(
|
|
"Got a sparse matrix type (class: ",
|
|
paste(class(y), collapse = ", "),
|
|
") for 'y'. Will convert to dense matrix."
|
|
)
|
|
y <- as.matrix(y)
|
|
}
|
|
|
|
if (is.character(y)) {
|
|
if (!is.vector(y)) {
|
|
if (NCOL(y) > 1L) {
|
|
stop("Multi-column categorical 'y' is not supported.")
|
|
}
|
|
y <- as.vector(y)
|
|
}
|
|
y <- factor(y)
|
|
}
|
|
|
|
if (is.logical(y)) {
|
|
if (!is.vector(y)) {
|
|
if (NCOL(y) > 1L) {
|
|
stop("Multi-column logical/boolean 'y' is not supported.")
|
|
}
|
|
y <- as.vector(y)
|
|
}
|
|
y <- factor(y, c(FALSE, TRUE))
|
|
}
|
|
|
|
if (is.factor(y)) {
|
|
|
|
y_levels <- levels(y)
|
|
if (length(y_levels) < 2) {
|
|
stop("Factor 'y' has less than 2 levels.")
|
|
}
|
|
if (length(y_levels) == 2) {
|
|
if (is.null(objective)) {
|
|
objective <- "binary:logistic"
|
|
} else {
|
|
if (!(objective %in% .BINARY_CLASSIF_OBJECTIVES())) {
|
|
stop(
|
|
"Got binary 'y' - supported objectives for this data are: ",
|
|
paste(.BINARY_CLASSIF_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
}
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, length(y), 1)
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective
|
|
),
|
|
metadata = list(
|
|
y_levels = y_levels,
|
|
n_targets = 1
|
|
)
|
|
)
|
|
} else { # length(levels) > 2
|
|
if (is.null(objective)) {
|
|
objective <- "multi:softprob"
|
|
} else {
|
|
if (!(objective %in% .MULTICLASS_CLASSIF_OBJECTIVES())) {
|
|
stop(
|
|
"Got non-binary factor 'y' - supported objectives for this data are: ",
|
|
paste(.MULTICLASS_CLASSIF_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
}
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, length(y), length(y_levels))
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective,
|
|
num_class = length(y_levels)
|
|
),
|
|
metadata = list(
|
|
y_levels = y_levels,
|
|
n_targets = length(y_levels)
|
|
)
|
|
)
|
|
}
|
|
|
|
out$dmatrix_args <- list(
|
|
label = as.numeric(y) - 1,
|
|
base_margin = base_margin
|
|
)
|
|
|
|
} else if (inherits(y, "Surv")) {
|
|
|
|
y_attr <- attributes(y)
|
|
supported_surv_types <- c("left", "right", "interval")
|
|
if (!(y_attr$type %in% supported_surv_types)) {
|
|
stop(
|
|
"Survival objectives are only supported for types: ",
|
|
paste(supported_surv_types, collapse = ", "),
|
|
". Was passed: ",
|
|
y_attr$type
|
|
)
|
|
}
|
|
|
|
if (is.null(objective)) {
|
|
objective <- "survival:aft"
|
|
} else {
|
|
if (y_attr$type == "right") {
|
|
if (!(objective %in% .SURVIVAL_RIGHT_CENSORING_OBJECTIVES())) {
|
|
stop(
|
|
"Got right-censored 'y' variable - supported objectives for this data are: ",
|
|
paste(.SURVIVAL_RIGHT_CENSORING_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
} else {
|
|
if (!(objective %in% .SURVIVAL_ALL_CENSORING_OBJECTIVES())) {
|
|
stop(
|
|
"Got ", y_attr$type, "-censored 'y' variable - supported objectives for this data are:",
|
|
paste(.SURVIVAL_ALL_CENSORING_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
}
|
|
}
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, nrow(y), 1)
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective
|
|
),
|
|
metadata = list(
|
|
n_targets = 1
|
|
)
|
|
)
|
|
|
|
# Note: the 'Surv' object class that is passed as 'y' might have either 2 or 3 columns
|
|
# depending on the type of censoring, and the last column in both cases is the one that
|
|
# indicates the observation type (e.g. censored / uncensored).
|
|
# In the case of interval censoring, the second column will not always have values with
|
|
# infinites filled in. For more information, see the code behind the 'print.Surv' method.
|
|
|
|
if (objective == "survival:cox") {
|
|
# Can only get here when using right censoring
|
|
if (y_attr$type != "right") {
|
|
stop("Internal error.")
|
|
}
|
|
|
|
out$dmatrix_args <- list(
|
|
label = y[, 1L] * (2 * (y[, 2L] - 0.5))
|
|
)
|
|
|
|
} else {
|
|
if (y_attr$type == "left") {
|
|
lb <- ifelse(
|
|
y[, 2L] == 0,
|
|
0,
|
|
y[, 1L]
|
|
)
|
|
ub <- y[, 1L]
|
|
out$dmatrix_args <- list(
|
|
label_lower_bound = lb,
|
|
label_upper_bound = ub
|
|
)
|
|
} else if (y_attr$type == "right") {
|
|
lb <- y[, 1L]
|
|
ub <- ifelse(
|
|
y[, 2L] == 0,
|
|
Inf,
|
|
y[, 1L]
|
|
)
|
|
out$dmatrix_args <- list(
|
|
label_lower_bound = lb,
|
|
label_upper_bound = ub
|
|
)
|
|
} else if (y_attr$type == "interval") {
|
|
out$dmatrix_args <- list(
|
|
label_lower_bound = ifelse(y[, 3L] == 2, 0, y[, 1L]),
|
|
label_upper_bound = ifelse(
|
|
y[, 3L] == 0, Inf,
|
|
ifelse(y[, 3L] == 3, y[, 2L], y[, 1L])
|
|
)
|
|
)
|
|
}
|
|
|
|
if (min(out$dmatrix_args$label_lower_bound) < 0) {
|
|
stop("Survival objectives are only defined for non-negative 'y'.")
|
|
}
|
|
}
|
|
|
|
out$dmatrix_args$base_margin <- base_margin
|
|
|
|
} else if (is.vector(y)) {
|
|
|
|
if (is.null(objective)) {
|
|
objective <- "reg:squarederror"
|
|
} else if (!(objective %in% .REGRESSION_OBJECTIVES())) {
|
|
stop(
|
|
"Got numeric 'y' - supported objectives for this data are: ",
|
|
paste(.REGRESSION_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
|
|
n_targets <- 1L
|
|
if (objective == "reg:quantileerror" && NROW(params$quantile_alpha) > 1) {
|
|
n_targets <- NROW(params$quantile_alpha)
|
|
}
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, length(y), n_targets)
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective
|
|
),
|
|
metadata = list(
|
|
n_targets = n_targets
|
|
),
|
|
dmatrix_args = list(
|
|
label = as.numeric(y),
|
|
base_margin = base_margin
|
|
)
|
|
)
|
|
|
|
} else if (is.data.frame(y)) {
|
|
if (ncol(y) == 1L) {
|
|
return(process.y.margin.and.objective(y[[1L]], base_margin, objective, params))
|
|
}
|
|
|
|
if (is.null(objective)) {
|
|
objective <- "reg:squarederror"
|
|
} else if (!(objective %in% .MULTI_TARGET_OBJECTIVES())) {
|
|
stop(
|
|
"Got multi-column 'y' - supported objectives for this data are: ",
|
|
paste(.MULTI_TARGET_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
|
|
y_names <- names(y)
|
|
y <- lapply(y, function(x) {
|
|
if (!inherits(x, c("numeric", "integer"))) {
|
|
stop(
|
|
"Multi-target 'y' only supports 'numeric' and 'integer' types. Got: ",
|
|
paste(class(x), collapse = ", ")
|
|
)
|
|
}
|
|
return(as.numeric(x))
|
|
})
|
|
y <- as.data.frame(y) |> as.matrix()
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, length(y), ncol(y))
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective
|
|
),
|
|
dmatrix_args = list(
|
|
label = y,
|
|
base_margin = base_margin
|
|
),
|
|
metadata = list(
|
|
y_names = y_names,
|
|
n_targets = ncol(y)
|
|
)
|
|
)
|
|
|
|
} else if (is.matrix(y)) {
|
|
if (ncol(y) == 1L) {
|
|
return(process.y.margin.and.objective(as.vector(y), base_margin, objective, params))
|
|
}
|
|
|
|
if (!is.null(objective) && !(objective %in% .MULTI_TARGET_OBJECTIVES())) {
|
|
stop(
|
|
"Got multi-column 'y' - supported objectives for this data are: ",
|
|
paste(.MULTI_TARGET_OBJECTIVES(), collapse = ", "),
|
|
". Was passed: ",
|
|
objective
|
|
)
|
|
}
|
|
if (is.null(objective)) {
|
|
objective <- "reg:squarederror"
|
|
}
|
|
|
|
y_names <- colnames(y)
|
|
if (storage.mode(y) != "double") {
|
|
storage.mode(y) <- "double"
|
|
}
|
|
|
|
if (!is.null(base_margin)) {
|
|
base_margin <- process.base.margin(base_margin, nrow(y), ncol(y))
|
|
}
|
|
|
|
out <- list(
|
|
params = list(
|
|
objective = objective
|
|
),
|
|
dmatrix_args = list(
|
|
label = y,
|
|
base_margin = base_margin
|
|
),
|
|
metadata = list(
|
|
n_targets = ncol(y)
|
|
)
|
|
)
|
|
|
|
if (NROW(y_names) == ncol(y)) {
|
|
out$metadata$y_names <- y_names
|
|
}
|
|
|
|
} else {
|
|
stop("Passed 'y' object with unsupported class: ", paste(class(y), collapse = ", "))
|
|
}
|
|
|
|
return(out)
|
|
}
|
|
|
|
process.row.weights <- function(w, lst_args) {
|
|
if (!is.null(w)) {
|
|
if ("label" %in% names(lst_args$dmatrix_args)) {
|
|
nrow_y <- NROW(lst_args$dmatrix_args$label)
|
|
} else if ("label_lower_bound" %in% names(lst_args$dmatrix_args)) {
|
|
nrow_y <- length(lst_args$dmatrix_args$label_lower_bound)
|
|
} else {
|
|
stop("Internal error.")
|
|
}
|
|
if (!is.numeric(w)) {
|
|
w <- as.numeric(w)
|
|
}
|
|
if (length(w) != nrow_y) {
|
|
stop(
|
|
"'weights' must be a 1-d vector with the same length as 'y' (",
|
|
length(w), " vs. ", nrow_y, ")."
|
|
)
|
|
}
|
|
lst_args$dmatrix_args$weight <- w
|
|
}
|
|
return(lst_args)
|
|
}
|
|
|
|
check.nthreads <- function(nthreads) {
|
|
if (is.null(nthreads)) {
|
|
return(1L)
|
|
}
|
|
if (!inherits(nthreads, c("numeric", "integer")) || !NROW(nthreads)) {
|
|
stop("'nthreads' must be a positive scalar value.")
|
|
}
|
|
if (length(nthreads) > 1L) {
|
|
nthreads <- utils::head(nthreads, 1L)
|
|
}
|
|
if (is.na(nthreads) || nthreads < 0) {
|
|
stop("Passed invalid 'nthreads': ", nthreads)
|
|
}
|
|
if (is.numeric(nthreads)) {
|
|
if (floor(nthreads) != nthreads) {
|
|
stop("'nthreads' must be an integer.")
|
|
}
|
|
}
|
|
return(as.integer(nthreads))
|
|
}
|
|
|
|
check.can.use.qdm <- function(x, params) {
|
|
if ("booster" %in% names(params)) {
|
|
if (params$booster == "gblinear") {
|
|
return(FALSE)
|
|
}
|
|
}
|
|
if ("tree_method" %in% names(params)) {
|
|
if (params$tree_method %in% c("exact", "approx")) {
|
|
return(FALSE)
|
|
}
|
|
}
|
|
return(TRUE)
|
|
}
|
|
|
|
process.x.and.col.args <- function(
|
|
x,
|
|
monotone_constraints,
|
|
interaction_constraints,
|
|
feature_weights,
|
|
lst_args,
|
|
use_qdm
|
|
) {
|
|
if (is.null(x)) {
|
|
stop("'x' cannot be NULL.")
|
|
}
|
|
if (inherits(x, "xgb.DMatrix")) {
|
|
stop("Cannot pass 'xgb.DMatrix' as 'x' to 'xgboost()'. Try 'xgb.train()' instead.")
|
|
}
|
|
supported_x_types <- c("data.frame", "matrix", "dgTMatrix", "dgCMatrix", "dgRMatrix")
|
|
if (!inherits(x, supported_x_types)) {
|
|
stop(
|
|
"'x' must be one of the following classes: ",
|
|
paste(supported_x_types, collapse = ", "),
|
|
". Got: ",
|
|
paste(class(x), collapse = ", ")
|
|
)
|
|
}
|
|
if (use_qdm && inherits(x, "sparseMatrix") && !inherits(x, "dgRMatrix")) {
|
|
x <- methods::as(x, "RsparseMatrix")
|
|
if (!inherits(x, "RsparseMatrix")) {
|
|
stop("Internal error: casting sparse matrix did not yield 'dgRMatrix'.")
|
|
}
|
|
}
|
|
|
|
if (NROW(feature_weights)) {
|
|
if (is.list(feature_weights)) {
|
|
feature_weights <- unlist(feature_weights)
|
|
}
|
|
if (!inherits(feature_weights, c("numeric", "integer"))) {
|
|
stop("'feature_weights' must be a numeric vector or named list matching to columns of 'x'.")
|
|
}
|
|
if (NROW(names(feature_weights)) && NROW(colnames(x))) {
|
|
matched <- match(colnames(x), names(feature_weights))
|
|
matched <- matched[!is.na(matched)]
|
|
matched <- matched[!duplicated(matched)]
|
|
if (length(matched) > 0 && length(matched) < length(feature_weights)) {
|
|
stop(
|
|
"'feature_weights' names do not contain all columns of 'x'. Missing: ",
|
|
utils::head(setdiff(colnames(x), names(feature_weights)))
|
|
)
|
|
}
|
|
if (length(matched)) {
|
|
feature_weights <- feature_weights[matched]
|
|
} else {
|
|
warning("Names of 'feature_weights' do not match with 'x'. Names will be ignored.")
|
|
}
|
|
}
|
|
|
|
lst_args$dmatrix_args$feature_weights <- unname(feature_weights)
|
|
}
|
|
|
|
if (NROW(monotone_constraints)) {
|
|
|
|
if (NROW(monotone_constraints) > ncol(x)) {
|
|
stop(
|
|
"'monotone_constraints' contains more entries than there are columns in 'x' (",
|
|
NROW(monotone_constraints), " vs. ", ncol(x), ")."
|
|
)
|
|
}
|
|
|
|
if (is.list(monotone_constraints)) {
|
|
|
|
if (!NROW(names(monotone_constraints))) {
|
|
stop(
|
|
"If passing 'monotone_constraints' as a named list,",
|
|
" must have names matching to columns of 'x'."
|
|
)
|
|
}
|
|
if (!NROW(colnames(x))) {
|
|
stop("If passing 'monotone_constraints' as a named list, 'x' must have column names.")
|
|
}
|
|
if (anyDuplicated(names(monotone_constraints))) {
|
|
stop(
|
|
"'monotone_constraints' contains duplicated names: ",
|
|
paste(
|
|
names(monotone_constraints)[duplicated(names(monotone_constraints))] |> utils::head(),
|
|
collapse = ", "
|
|
)
|
|
)
|
|
}
|
|
if (NROW(setdiff(names(monotone_constraints), colnames(x)))) {
|
|
stop(
|
|
"'monotone_constraints' contains column names not present in 'x': ",
|
|
paste(utils::head(names(monotone_constraints)), collapse = ", ")
|
|
)
|
|
}
|
|
|
|
vec_monotone_constr <- rep(0, ncol(x))
|
|
matched <- match(names(monotone_constraints), colnames(x))
|
|
vec_monotone_constr[matched] <- unlist(monotone_constraints)
|
|
lst_args$params$monotone_constraints <- unname(vec_monotone_constr)
|
|
|
|
} else if (inherits(monotone_constraints, c("numeric", "integer"))) {
|
|
|
|
if (NROW(names(monotone_constraints)) && NROW(colnames(x))) {
|
|
if (length(monotone_constraints) < ncol(x)) {
|
|
return(
|
|
process.x.and.col.args(
|
|
x,
|
|
as.list(monotone_constraints),
|
|
interaction_constraints,
|
|
feature_weights,
|
|
lst_args,
|
|
use_qdm
|
|
)
|
|
)
|
|
} else {
|
|
matched <- match(names(monotone_constraints), colnames(x))
|
|
matched <- matched[!is.na(matched)]
|
|
matched <- matched[!duplicated(matched)]
|
|
if (length(matched)) {
|
|
monotone_constraints <- monotone_constraints[matched]
|
|
} else {
|
|
warning("Names of 'monotone_constraints' do not match with 'x'. Names will be ignored.")
|
|
}
|
|
}
|
|
} else {
|
|
if (length(monotone_constraints) != ncol(x)) {
|
|
stop(
|
|
"If passing 'monotone_constraints' as unnamed vector or not using column names,",
|
|
" must have length matching to number of columns in 'x'. Got: ",
|
|
length(monotone_constraints), " (vs. ", ncol(x), ")"
|
|
)
|
|
}
|
|
}
|
|
|
|
lst_args$params$monotone_constraints <- unname(monotone_constraints)
|
|
|
|
} else if (is.character(monotone_constraints)) {
|
|
lst_args$params$monotone_constraints <- monotone_constraints
|
|
} else {
|
|
stop(
|
|
"Passed unsupported type for 'monotone_constraints': ",
|
|
paste(class(monotone_constraints), collapse = ", ")
|
|
)
|
|
}
|
|
}
|
|
|
|
if (NROW(interaction_constraints)) {
|
|
if (!is.list(interaction_constraints)) {
|
|
stop("'interaction_constraints' must be a list of vectors.")
|
|
}
|
|
cnames <- colnames(x)
|
|
lst_args$params$interaction_constraints <- lapply(interaction_constraints, function(idx) {
|
|
if (!NROW(idx)) {
|
|
stop("Elements in 'interaction_constraints' cannot be empty.")
|
|
}
|
|
|
|
if (is.character(idx)) {
|
|
if (!NROW(cnames)) {
|
|
stop(
|
|
"Passed a character vector for 'interaction_constraints', but 'x' ",
|
|
"has no column names to match them against."
|
|
)
|
|
}
|
|
out <- match(idx, cnames) - 1L
|
|
if (anyNA(out)) {
|
|
stop(
|
|
"'interaction_constraints' contains column names not present in 'x': ",
|
|
paste(utils::head(idx[which(is.na(out))]), collapse = ", ")
|
|
)
|
|
}
|
|
return(out)
|
|
} else if (inherits(idx, c("numeric", "integer"))) {
|
|
if (anyNA(idx)) {
|
|
stop("'interaction_constraints' cannot contain NA values.")
|
|
}
|
|
if (min(idx) < 1) {
|
|
stop("Column indices for 'interaction_constraints' must follow base-1 indexing.")
|
|
}
|
|
if (max(idx) > ncol(x)) {
|
|
stop("'interaction_constraints' contains invalid column indices.")
|
|
}
|
|
if (is.numeric(idx)) {
|
|
if (any(idx != floor(idx))) {
|
|
stop(
|
|
"'interaction_constraints' must contain only integer indices. Got non-integer: ",
|
|
paste(utils::head(idx[which(idx != floor(idx))]), collapse = ", ")
|
|
)
|
|
}
|
|
}
|
|
return(idx - 1L)
|
|
} else {
|
|
stop(
|
|
"Elements in 'interaction_constraints' must be vectors of types ",
|
|
"'integer', 'numeric', or 'character'. Got: ",
|
|
paste(class(idx), collapse = ", ")
|
|
)
|
|
}
|
|
})
|
|
}
|
|
|
|
lst_args$dmatrix_args$data <- x
|
|
return(lst_args)
|
|
}
|
|
|
|
#' @noMd
|
|
#' @export
|
|
#' @title Fit XGBoost Model
|
|
#' @description Fits an XGBoost model (boosted decision tree ensemble) to given x/y data.
|
|
#'
|
|
#' See the tutorial \href{https://xgboost.readthedocs.io/en/stable/tutorials/model.html}{
|
|
#' Introduction to Boosted Trees} for a longer explanation of what XGBoost does.
|
|
#'
|
|
#' This function is intended to provide a more user-friendly interface for XGBoost that follows
|
|
#' R's conventions for model fitting and predictions, but which doesn't expose all of the
|
|
#' possible functionalities of the core XGBoost library.
|
|
#'
|
|
#' See \link{xgb.train} for a more flexible low-level alternative which is similar across different
|
|
#' language bindings of XGBoost and which exposes the full library's functionalities.
|
|
#' @details For package authors using `xgboost` as a dependency, it is highly recommended to use
|
|
#' \link{xgb.train} in package code instead of `xgboost()`, since it has a more stable interface
|
|
#' and performs fewer data conversions and copies along the way.
|
|
#' @references \itemize{
|
|
#' \item Chen, Tianqi, and Carlos Guestrin. "Xgboost: A scalable tree boosting system."
|
|
#' Proceedings of the 22nd acm sigkdd international conference on knowledge discovery and
|
|
#' data mining. 2016.
|
|
#' \item \url{https://xgboost.readthedocs.io/en/stable/}
|
|
#' }
|
|
#' @param x The features / covariates. Can be passed as:\itemize{
|
|
#' \item A numeric or integer `matrix`.
|
|
#' \item A `data.frame`, in which all columns are one of the following types:\itemize{
|
|
#' \item `numeric`
|
|
#' \item `integer`
|
|
#' \item `logical`
|
|
#' \item `factor`
|
|
#' }
|
|
#'
|
|
#' Columns of `factor` type will be assumed to be categorical, while other column types will
|
|
#' be assumed to be numeric.
|
|
#' \item A sparse matrix from the `Matrix` package, either as `dgCMatrix` or `dgRMatrix` class.
|
|
#' }
|
|
#'
|
|
#' Note that categorical features are only supported for `data.frame` inputs, and are automatically
|
|
#' determined based on their types. See \link{xgb.train} with \link{xgb.DMatrix} for more flexible
|
|
#' variants that would allow something like categorical features on sparse matrices.
|
|
#' @param y The response variable. Allowed values are:\itemize{
|
|
#' \item A numeric or integer vector (for regression tasks).
|
|
#' \item A factor or character vector (for binary and multi-class classification tasks).
|
|
#' \item A logical (boolean) vector (for binary classification tasks).
|
|
#' \item A numeric or integer matrix or `data.frame` with numeric/integer columns
|
|
#' (for multi-task regression tasks).
|
|
#' \item A `Surv` object from the `survival` package (for survival tasks).
|
|
#' }
|
|
#'
|
|
#' If `objective` is `NULL`, the right task will be determined automatically based on
|
|
#' the class of `y`.
|
|
#'
|
|
#' If `objective` is not `NULL`, it must match with the type of `y` - e.g. `factor` types of `y`
|
|
#' can only be used with classification objectives and vice-versa.
|
|
#'
|
|
#' For binary classification, the last factor level of `y` will be used as the "positive"
|
|
#' class - that is, the numbers from `predict` will reflect the probabilities of belonging to this
|
|
#' class instead of to the first factor level. If `y` is a `logical` vector, then `TRUE` will be
|
|
#' set as the last level.
|
|
#' @param objective Optimization objective to minimize based on the supplied data, to be passed
|
|
#' by name as a string / character (e.g. `reg:absoluteerror`). See the
|
|
#' \href{https://xgboost.readthedocs.io/en/stable/parameter.html#learning-task-parameters}{
|
|
#' Learning Task Parameters} page for more detailed information on allowed values.
|
|
#'
|
|
#' If `NULL` (the default), will be automatically determined from `y` according to the following
|
|
#' logic:\itemize{
|
|
#' \item If `y` is a factor with 2 levels, will use `binary:logistic`.
|
|
#' \item If `y` is a factor with more than 2 levels, will use `multi:softprob` (number of classes
|
|
#' will be determined automatically, should not be passed under `params`).
|
|
#' \item If `y` is a `Surv` object from the `survival` package, will use `survival:aft` (note that
|
|
#' the only types supported are left / right / interval censored).
|
|
#' \item Otherwise, will use `reg:squarederror`.
|
|
#' }
|
|
#'
|
|
#' If `objective` is not `NULL`, it must match with the type of `y` - e.g. `factor` types of `y`
|
|
#' can only be used with classification objectives and vice-versa.
|
|
#'
|
|
#' Note that not all possible `objective` values supported by the core XGBoost library are allowed
|
|
#' here - for example, objectives which are a variation of another but with a different default
|
|
#' prediction type (e.g. `multi:softmax` vs. `multi:softprob`) are not allowed, and neither are
|
|
#' ranking objectives, nor custom objectives at the moment.
|
|
#' @param nrounds Number of boosting iterations / rounds.
|
|
#'
|
|
#' Note that the number of default boosting rounds here is not automatically tuned, and different
|
|
#' problems will have vastly different optimal numbers of boosting rounds.
|
|
#' @param weights Sample weights for each row in `x` and `y`. If `NULL` (the default), each row
|
|
#' will have the same weight.
|
|
#'
|
|
#' If not `NULL`, should be passed as a numeric vector with length matching to the number of
|
|
#' rows in `x`.
|
|
#' @param verbosity Verbosity of printing messages. Valid values of 0 (silent), 1 (warning),
|
|
#' 2 (info), and 3 (debug).
|
|
#' @param nthreads Number of parallel threads to use. If passing zero, will use all CPU threads.
|
|
#' @param seed Seed to use for random number generation. If passing `NULL`, will draw a random
|
|
#' number using R's PRNG system to use as seed.
|
|
#' @param monotone_constraints Optional monotonicity constraints for features.
|
|
#'
|
|
#' Can be passed either as a named list (when `x` has column names), or as a vector. If passed
|
|
#' as a vector and `x` has column names, will try to match the elements by name.
|
|
#'
|
|
#' A value of `+1` for a given feature makes the model predictions / scores constrained to be
|
|
#' a monotonically increasing function of that feature (that is, as the value of the feature
|
|
#' increases, the model prediction cannot decrease), while a value of `-1` makes it a monotonically
|
|
#' decreasing function. A value of zero imposes no constraint.
|
|
#'
|
|
#' The input for `monotone_constraints` can be a subset of the columns of `x` if named, in which
|
|
#' case the columns that are not referred to in `monotone_constraints` will be assumed to have
|
|
#' a value of zero (no constraint imposed on the model for those features).
|
|
#'
|
|
#' See the tutorial \href{https://xgboost.readthedocs.io/en/stable/tutorials/monotonic.html}{
|
|
#' Monotonic Constraints} for a more detailed explanation.
|
|
#' @param interaction_constraints Constraints for interaction representing permitted interactions.
|
|
#' The constraints must be specified in the form of a list of vectors referencing columns in the
|
|
#' data, e.g. `list(c(1, 2), c(3, 4, 5))` (with these numbers being column indices, numeration
|
|
#' starting at 1 - i.e. the first sublist references the first and second columns) or
|
|
#' `list(c("Sepal.Length", "Sepal.Width"), c("Petal.Length", "Petal.Width"))` (references
|
|
#' columns by names), where each vector is a group of indices of features that are allowed to
|
|
#' interact with each other.
|
|
#'
|
|
#' See the tutorial
|
|
#' \href{https://xgboost.readthedocs.io/en/stable/tutorials/feature_interaction_constraint.html}{
|
|
#' Feature Interaction Constraints} for more information.
|
|
#' @param feature_weights Feature weights for column sampling.
|
|
#'
|
|
#' Can be passed either as a vector with length matching to columns of `x`, or as a named
|
|
#' list (only if `x` has column names) with names matching to columns of 'x'. If it is a
|
|
#' named vector, will try to match the entries to column names of `x` by name.
|
|
#'
|
|
#' If `NULL` (the default), all columns will have the same weight.
|
|
#' @param base_margin Base margin used for boosting from existing model.
|
|
#'
|
|
#' If passing it, will start the gradient boosting procedure from the scores that are provided
|
|
#' here - for example, one can pass the raw scores from a previous model, or some per-observation
|
|
#' offset, or similar.
|
|
#'
|
|
#' Should be either a numeric vector or numeric matrix (for multi-class and multi-target objectives)
|
|
#' with the same number of rows as `x` and number of columns corresponding to number of optimization
|
|
#' targets, and should be in the untransformed scale (for example, for objective `binary:logistic`,
|
|
#' it should have log-odds, not probabilities; and for objective `multi:softprob`, should have
|
|
#' number of columns matching to number of classes in the data).
|
|
#'
|
|
#' Note that, if it contains more than one column, then columns will not be matched by name to
|
|
#' the corresponding `y` - `base_margin` should have the same column order that the model will use
|
|
#' (for example, for objective `multi:softprob`, columns of `base_margin` will be matched against
|
|
#' `levels(y)` by their position, regardless of what `colnames(base_margin)` returns).
|
|
#'
|
|
#' If `NULL`, will start from zero, but note that for most objectives, an intercept is usually
|
|
#' added (controllable through parameter `base_score` instead) when `base_margin` is not passed.
|
|
#' @param ... Other training parameters. See the online documentation
|
|
#' \href{https://xgboost.readthedocs.io/en/stable/parameter.html}{XGBoost Parameters} for
|
|
#' details about possible values and what they do.
|
|
#'
|
|
#' Note that not all possible values from the core XGBoost library are allowed as `params` for
|
|
#' 'xgboost()' - in particular, values which require an already-fitted booster object (such as
|
|
#' `process_type`) are not accepted here.
|
|
#' @return A model object, inheriting from both `xgboost` and `xgb.Booster`. Compared to the regular
|
|
#' `xgb.Booster` model class produced by \link{xgb.train}, this `xgboost` class will have an
|
|
#' additional attribute `metadata` containing information which is used for formatting prediction
|
|
#' outputs, such as class names for classification problems.
|
|
#' @examples
|
|
#' library(xgboost)
|
|
#' data(mtcars)
|
|
#'
|
|
#' # Fit a small regression model on the mtcars data
|
|
#' model_regression <- xgboost(mtcars[, -1], mtcars$mpg, nthreads = 1, nrounds = 3)
|
|
#' predict(model_regression, mtcars, validate_features = TRUE)
|
|
#'
|
|
#' # Task objective is determined automatically according to the type of 'y'
|
|
#' data(iris)
|
|
#' model_classif <- xgboost(iris[, -5], iris$Species, nthreads = 1, nrounds = 5)
|
|
#' predict(model_classif, iris, validate_features = TRUE)
|
|
xgboost <- function(
|
|
x,
|
|
y,
|
|
objective = NULL,
|
|
nrounds = 100L,
|
|
weights = NULL,
|
|
verbosity = 0L,
|
|
nthreads = parallel::detectCores(),
|
|
seed = 0L,
|
|
monotone_constraints = NULL,
|
|
interaction_constraints = NULL,
|
|
feature_weights = NULL,
|
|
base_margin = NULL,
|
|
...
|
|
) {
|
|
# Note: '...' is a workaround, to be removed later by making all parameters be arguments
|
|
params <- list(...)
|
|
params <- prescreen.parameters(params)
|
|
prescreen.objective(objective)
|
|
use_qdm <- check.can.use.qdm(x, params)
|
|
lst_args <- process.y.margin.and.objective(y, base_margin, objective, params)
|
|
lst_args <- process.row.weights(weights, lst_args)
|
|
lst_args <- process.x.and.col.args(
|
|
x,
|
|
monotone_constraints,
|
|
interaction_constraints,
|
|
feature_weights,
|
|
lst_args,
|
|
use_qdm
|
|
)
|
|
|
|
if (use_qdm && "max_bin" %in% names(params)) {
|
|
lst_args$dmatrix_args$max_bin <- params$max_bin
|
|
}
|
|
|
|
nthreads <- check.nthreads(nthreads)
|
|
lst_args$dmatrix_args$nthread <- nthreads
|
|
lst_args$params$nthread <- nthreads
|
|
lst_args$params$seed <- seed
|
|
|
|
params <- c(lst_args$params, params)
|
|
|
|
fn_dm <- if (use_qdm) xgb.QuantileDMatrix else xgb.DMatrix
|
|
dm <- do.call(fn_dm, lst_args$dmatrix_args)
|
|
model <- xgb.train(
|
|
params = params,
|
|
data = dm,
|
|
nrounds = nrounds,
|
|
verbose = verbosity
|
|
)
|
|
attributes(model)$metadata <- lst_args$metadata
|
|
attributes(model)$call <- match.call()
|
|
class(model) <- c("xgboost", class(model))
|
|
return(model)
|
|
}
|
|
|
|
#' @method print xgboost
|
|
#' @export
|
|
print.xgboost <- function(x, ...) {
|
|
cat("XGBoost model object\n")
|
|
cat("Call:\n ")
|
|
print(attributes(x)$call)
|
|
cat("Objective: ", attributes(x)$params$objective, "\n", sep = "")
|
|
cat("Number of iterations: ", xgb.get.num.boosted.rounds(x), "\n", sep = "")
|
|
cat("Number of features: ", xgb.num_feature(x), "\n", sep = "")
|
|
|
|
printable_head <- function(v) {
|
|
v_sub <- utils::head(v, 5L)
|
|
return(
|
|
sprintf(
|
|
"%s%s",
|
|
paste(v_sub, collapse = ", "),
|
|
ifelse(length(v_sub) < length(v), ", ...", "")
|
|
)
|
|
)
|
|
}
|
|
|
|
if (NROW(attributes(x)$metadata$y_levels)) {
|
|
cat(
|
|
"Classes: ",
|
|
printable_head(attributes(x)$metadata$y_levels),
|
|
"\n",
|
|
sep = ""
|
|
)
|
|
} else if (NROW(attributes(x)$params$quantile_alpha)) {
|
|
cat(
|
|
"Prediction quantile",
|
|
ifelse(length(attributes(x)$params$quantile_alpha) > 1L, "s", ""),
|
|
": ",
|
|
printable_head(attributes(x)$params$quantile_alpha),
|
|
"\n",
|
|
sep = ""
|
|
)
|
|
} else if (NROW(attributes(x)$metadata$y_names)) {
|
|
cat(
|
|
"Prediction targets: ",
|
|
printable_head(attributes(x)$metadata$y_names),
|
|
"\n",
|
|
sep = ""
|
|
)
|
|
} else if (attributes(x)$metadata$n_targets > 1L) {
|
|
cat(
|
|
"Number of predition targets: ",
|
|
attributes(x)$metadata$n_targets,
|
|
"\n",
|
|
sep = ""
|
|
)
|
|
}
|
|
|
|
return(x)
|
|
}
|
|
|
|
|
|
#' Training part from Mushroom Data Set
|
|
#'
|
|
#' This data set is originally from the Mushroom data set,
|
|
#' UCI Machine Learning Repository.
|
|
#'
|
|
#' This data set includes the following fields:
|
|
#'
|
|
#' \itemize{
|
|
#' \item \code{label} the label for each record
|
|
#' \item \code{data} a sparse Matrix of \code{dgCMatrix} class, with 126 columns.
|
|
#' }
|
|
#'
|
|
#' @references
|
|
#' <https://archive.ics.uci.edu/ml/datasets/Mushroom>
|
|
#'
|
|
#' Bache, K. & Lichman, M. (2013). UCI Machine Learning Repository
|
|
#' <http://archive.ics.uci.edu/ml>. Irvine, CA: University of California,
|
|
#' School of Information and Computer Science.
|
|
#'
|
|
#' @docType data
|
|
#' @keywords datasets
|
|
#' @name agaricus.train
|
|
#' @usage data(agaricus.train)
|
|
#' @format A list containing a label vector, and a dgCMatrix object with 6513
|
|
#' rows and 127 variables
|
|
NULL
|
|
|
|
#' Test part from Mushroom Data Set
|
|
#'
|
|
#' This data set is originally from the Mushroom data set,
|
|
#' UCI Machine Learning Repository.
|
|
#'
|
|
#' This data set includes the following fields:
|
|
#'
|
|
#' \itemize{
|
|
#' \item \code{label} the label for each record
|
|
#' \item \code{data} a sparse Matrix of \code{dgCMatrix} class, with 126 columns.
|
|
#' }
|
|
#'
|
|
#' @references
|
|
#' <https://archive.ics.uci.edu/ml/datasets/Mushroom>
|
|
#'
|
|
#' Bache, K. & Lichman, M. (2013). UCI Machine Learning Repository
|
|
#' <http://archive.ics.uci.edu/ml>. Irvine, CA: University of California,
|
|
#' School of Information and Computer Science.
|
|
#'
|
|
#' @docType data
|
|
#' @keywords datasets
|
|
#' @name agaricus.test
|
|
#' @usage data(agaricus.test)
|
|
#' @format A list containing a label vector, and a dgCMatrix object with 1611
|
|
#' rows and 126 variables
|
|
NULL
|
|
|
|
# Various imports
|
|
#' @importClassesFrom Matrix dgCMatrix dgRMatrix CsparseMatrix
|
|
#' @importFrom Matrix sparse.model.matrix
|
|
#' @importFrom data.table data.table
|
|
#' @importFrom data.table is.data.table
|
|
#' @importFrom data.table as.data.table
|
|
#' @importFrom data.table :=
|
|
#' @importFrom data.table rbindlist
|
|
#' @importFrom data.table setkey
|
|
#' @importFrom data.table setkeyv
|
|
#' @importFrom data.table setnames
|
|
#' @importFrom jsonlite fromJSON
|
|
#' @importFrom jsonlite toJSON
|
|
#' @importFrom methods new
|
|
#' @importFrom utils object.size str tail
|
|
#' @importFrom stats coef
|
|
#' @importFrom stats predict
|
|
#' @importFrom stats median
|
|
#' @importFrom stats sd
|
|
#' @importFrom stats variable.names
|
|
#' @importFrom utils head
|
|
#' @importFrom graphics barplot
|
|
#' @importFrom graphics lines
|
|
#' @importFrom graphics points
|
|
#' @importFrom graphics grid
|
|
#' @importFrom graphics par
|
|
#' @importFrom graphics title
|
|
#' @importFrom grDevices rgb
|
|
#'
|
|
#' @import methods
|
|
#' @useDynLib xgboost, .registration = TRUE
|
|
NULL
|