Default Ensemble-Weight Method for an Outcome Type
Source:R/default_methods.R
default_determine_weights.RdReturns the determine_super_learner_weights function that
super_learner() and crossfit_super_learner()
use when the user does not supply one.
Usage
default_determine_weights(
outcome_type = c("continuous", "binary", "density", "multiclass")
)Examples
# the weight-determination function super_learner() uses when
# determine_super_learner_weights is not supplied:
default_determine_weights("continuous") # non-negative least squares
#> function(data, y_variable, obs_weights = NULL) {
#> # use nonlinear least squares to produce a weighting scheme
#> index_of_y_variable <- which(colnames(data) == y_variable)[[1]]
#> A <- as.matrix(data[, -index_of_y_variable])
#> b <- data[[y_variable]]
#>
#> # Provide better error messages when all learners fail
#> if (ncol(A) == 0) {
#> stop(
#> "determine_super_learner_weights_nnls() received no columns of learner ",
#> "predictions (after removing the y_variable column), so there is ",
#> "nothing to determine weights over. This usually means that no ",
#> "learners successfully produced held-out predictions."
#> )
#> }
#>
#>
#> if (!is.null(obs_weights) && length(obs_weights) != nrow(data)) {
#> stop("The vector of observation weights must be equal in length to ",
#> "the data being passed to nadir::super_learner().")
#> }
#>
#> # if there are weights to use, we use the weights by multiplying A and b by
#> # the square root of the weight vector
#> if (!missing(obs_weights) &&
#> !is.null(obs_weights) &&
#> is.numeric(obs_weights) && length(obs_weights) == nrow(A)) {
#>
#> A <- A * sqrt(obs_weights)
#> b <- b * sqrt(obs_weights)
#> }
#>
#> nnls_output <- nnls::nnls(
#> A = A,
#> b = b
#> )
#>
#> model_weights <- nnls_output$x
#> if (sum(model_weights) <= 0) {
#> warning(
#> "Non-negative least squares assigned zero weight to every learner ",
#> "(their held-out predictions are non-positively correlated with the ",
#> "outcome). Falling back to equal weights across learners; consider ",
#> "including an intercept-like learner such as lnr_mean in the library."
#> )
#> model_weights <- rep(1, ncol(A))
#> }
#> model_weights <- model_weights / sum(model_weights)
#> return(model_weights)
#> }
#> <environment: namespace:nadir>
default_determine_weights("density") # negative-log-loss simplex
#> function(data, y_variable, obs_weights = NULL,
#> bound_eps = 1e-3) {
#> # in density estimation, the estimates have already "looked at" the
#> # y-variable by the time they've predicted a density estimate.
#> if (y_variable %in% colnames(data)) {
#> data[[y_variable]] <- NULL
#> }
#>
#> # With a single learner, the ensemble weight is trivially 1
#> # Running optim() here is (a) a constant objective, since softmax of a length-1
#> # parameter is always 1, and (b) triggers Nelder-Mead's 1-D unreliability
#> # warning.
#> if (ncol(data) == 1) {
#> return(1)
#> }
#>
#> # Provide better error messages when all learners fail
#> if (ncol(data) == 0) {
#> stop(
#> "determine_weights_using_neg_log_loss() received no columns of learner ",
#> "predictions (after removing the y_variable column), so there is ",
#> "nothing to determine weights over. This usually means that no ",
#> "learners successfully produced held-out predictions."
#> )
#> }
#>
#> weights_after_softmax <- rep(1 / ncol(data), ncol(data))
#> weights_before_softmax <- log(weights_after_softmax)
#>
#> data <- as.matrix(data)
#>
#> if (!is.null(obs_weights) && length(obs_weights) != nrow(data)) {
#> stop("The vector of observation weights must be equal in length to ",
#> "the data being passed to nadir::super_learner().")
#> }
#>
#> loss_fn <- function(presoftmax_weights) {
#> weights <- softmax(presoftmax_weights)
#>
#> # apply the weights to each column
#> weights_applied <- vapply(seq_len(ncol(data)), function(j) {
#> weights[j] * data[, j]
#> }, numeric(nrow(data)))
#> # sum up each row of predicted densities across learners
#> # this is now like a weighted average, and crucially the weights sum to 1
#> # so it's still a conditional density.
#> predicted_densities <- rowSums(weights_applied)
#>
#> # bound densities away from 0 before taking logs so a single
#> # zero-density prediction cannot make the loss Inf/NaN and abort optim()
#> # with "function cannot be evaluated at initial parameters".
#> #' @srrstats {G3.0} here argument \code{bound_eps} is used to establish when
#> #' densities are essentially zero.
#> predicted_densities <- pmax(predicted_densities, bound_eps)
#>
#> # now take our loss function and return it, to optimize against it
#> negative_log_predicted_densities <- -log(predicted_densities)
#>
#> if (!is.null(obs_weights)) {
#> negative_log_predicted_densities <- negative_log_predicted_densities * obs_weights
#> }
#> return(sum(negative_log_predicted_densities))
#> }
#>
#> weights_optim <- stats::optim(
#> par = weights_before_softmax,
#> fn = loss_fn,
#> method = "Nelder-Mead"
#> )
#>
#> weights <- softmax(weights_optim$par)
#>
#> return(weights)
#> }
#> <bytecode: 0x32de30ba0>
#> <environment: namespace:nadir>