如何优化R语言分类模型集成预测函数的内层循环？

The Problem: Slow Inner Loop #

Your original predict.risemble function hits a major bottleneck in the inner for loop that iterates over each prediction to update the voting dataframe. Row-by-row modifications to data frames are notoriously inefficient in R—especially with large datasets—since each tweak triggers a full reallocation of the data structure under the hood.

Here's the slow implementation you started with:

predict.risemble <- function(.models, .dataset) {
  all_levels <- unique(unlist(lapply(.models, function(x) x$levels)))
  voting_df <- data.frame(matrix(0, ncol = length(all_levels), nrow = nrow(.dataset)))
  colnames(voting_df) <- all_levels
  voting_df <- as_tibble(voting_df)
  for (model in .models) {
    cat(sprintf("Making predictions for model %s\n", model$method))
    predictions <- predict(model, .dataset)
    cat("Voting ...\n")
    for (i in 1:length(predictions)) {
      prediction <- as.character(predictions[i])
      voting_df[i, prediction] <- voting_df[i, prediction] + model$results$Kappa
      if (mod(i, 1000) == 0) {
        cat(sprintf("%f%%\n", i / length(predictions) * 100))
      }
    }
  }
  return (as.factor(colnames(voting_df)[apply(voting_df, 1, which.max)]))
}

The Optimized Solution #

We can completely eliminate the slow inner loop by leaning into R's strength: vectorized operations. Using dplyr and tidyr, we'll generate a full voting matrix for each model in one go, then accumulate votes via fast matrix addition.

Here's the refined function:

predict.risemble <- function(.models, .dataset) {
  all_levels <- unique(unlist(lapply(.models, function(x) x$levels)))
  voting_df <- data.frame(matrix(0, ncol = length(all_levels), nrow = nrow(.dataset)))
  colnames(voting_df) <- all_levels
  voting_df <- as_tibble(voting_df)
  voting_df <- voting_df %>% select(noquote(order(colnames(voting_df))))
  
  for (model in .models) {
    predictions <- as.character(predict(model, .dataset))
    # Create a full vote matrix for this model in one vectorized step
    votes <- tibble(prediction = predictions) %>%
      mutate(prediction_id = row_number(), value = model$results$Kappa) %>%
      spread(prediction, value) %>%
      select(-one_of("prediction_id"))
    
    # Align columns with all_levels and fill missing categories with 0
    votes[, all_levels[!all_levels %in% names(votes)]] <- NA
    votes <- votes %>% select(noquote(order(colnames(votes))))
    votes[is.na(votes)] <- 0
    
    # Accumulate votes via fast matrix addition
    voting_df <- voting_df + votes
  }
  
  # Determine final predictions by weighted majority vote
  return (as.factor(colnames(voting_df)[apply(voting_df, 1, which.max)]))
}

Key Optimizations Breakdown #

• Replace inner loop with spread: Instead of updating each cell individually, we convert the predictions vector into a structured tibble, then use spread to build a matrix where each row has the model's Kappa value in the column matching its prediction (and NA elsewhere). This is a single, optimized operation that runs far faster than any R-level loop.
• Column alignment: We ensure every model's vote matrix matches voting_df's columns (and order), filling missing categories with 0. This lets us use direct matrix addition (voting_df + votes)—a C-level operation that’s way more efficient than row-by-row edits.
• No more incremental updates: By generating full vote matrices and adding them together, we cut out all the overhead of modifying the voting dataframe one row at a time.

Example Walkthrough #

For a predictions vector c("a", "a", "a", "b", "c") and a Kappa value of 1, the votes tibble would look like this after processing:

# A tibble: 5 x 3
      a     b     c
  <dbl> <dbl> <dbl>
1     1     0     0
2     1     0     0
3     1     0     0
4     0     1     0
5     0     0     1

This matrix gets added directly to voting_df with zero loops required.

内容的提问来源于stack exchange，提问作者RIscRIpt