R语言循环处理大数据框性能优化求助

问题背景 #

现有R代码涉及两个矩阵列表（list1、list2）和一个大型DataFrame（行数约1000），需执行10000次循环计算损失值。代码可正常运行，但耗时远长于功能类似的VBA代码（VBA仅需数秒）。经排查，score_new的计算部分是性能瓶颈。

原始数据结构定义：

n <- 1000
dat <- data.frame(id=1:n, 
              category=sample(1:13, n, replace=TRUE),
               value1=rnorm(n),
                value2=rnorm(n),
            value3=sample(seq(0,1,0.1),n,replace=TRUE),
            value4=rnorm(n),
           value5=sample(4:20,n,replace=TRUE),
           value6=sample(2:18,n,replace=TRUE), 
          value7=sample(0:24,n,replace=TRUE))

list1<-lapply(1:13,function(x){matrix(rnorm(24*25),nrow=24,ncol=25)})
list2<-lapply(1:13,function(x){matrix(rnorm(24*20),nrow=24,ncol=20)})
names(list2)<-1:13
names(list1)<-1:13

核心计算逻辑（性能瓶颈在score_new的循环判断）：

loss_1<-vector(mode="numeric",length=10000)
loss_2<-vector(mode="numeric",length=10000)
for (i in 1:10000){
       for(k in 1:13){
        random_number_1[k]=rnorm(1,0,1)}
loss_1_i=0
loss_2_i=0
for (j in 1:n){ 
 category=as.numeric(dat[j,c("category")])
 value1=as.numeric(dat[j,c("value1")])
 value2=as.numeric(dat[j,c("value2")])
 value3=as.numeric(dat[j,c("value3")])
 value5=as.numeric(dat[j,c("value5")])
 value6=as.numeric(dat[j,c("value6")])
 value7=as.numeric(dat[j,c("value7")])
 random_number_2=rnorm(1,0,1)        
 my_col_name=as.numeric(names(list1[[category]]))
 my_col_name=sort(my_col_name,decreasing=TRUE) 
   test=random_number_2*sqrt(value3)+ random_number_1[category]*sqrt(1-value3)  
 score_new=24
  for(k in my_col_name){
      k=as.character(k)
       if (test>=list1[[category]][value7,c(k)]){
           score_new= as.numeric(k)
           k=as.numeric(k)
       }
}
 variable1=as.numeric(list2[[category]][score_new,value5])
 variable2=as.numeric(list2[[category]][value7,value6])
   if (score_new==24){
     loss_1_i=loss_1_i+value1*value2
     loss_2_i=loss_2_i+value1*value2
       }else{ 
        loss_2_i=loss_2_i+0.6*(variable1- variable2)*value1*value2}
   } 
 loss_1[i]=loss_1_i
 loss_2[i]=loss_2_i
}

优化方案 #

1. 预处理list1，消除重复排序与类型转换 #

score_new的计算需要反复对list1的列名降序排序，提前完成预处理：

# 预处理list1：按列名降序排列矩阵，并保存排序后的列名（数值型）
list1_processed <- lapply(list1, function(mat) {
  col_nums <- as.numeric(colnames(mat))
  # 按列名降序排列矩阵
  sorted_cols_order <- order(col_nums, decreasing = TRUE)
  mat_sorted <- mat[, sorted_cols_order]
  # 保存排序后的列名
  sorted_col_nums <- col_nums[sorted_cols_order]
  list(mat = mat_sorted, cols = sorted_col_nums)
})

2. 向量化替代score_new的循环判断 #

原代码用for循环逐个判断test与list1元素的大小，改用向量化操作快速定位第一个满足条件的列：

# 单个j的score_new计算优化示例
category <- category_vec[j]
value7 <- value7_vec[j]
test <- random_number_2_vec[j] * sqrt(value3_vec[j]) + random_number_1[category] * sqrt(1 - value3_vec[j])

# 提取预处理后的对应行
row_vals <- list1_processed[[category]]$mat[value7, ]
# 生成判断逻辑向量
cond <- test >= row_vals

# 快速定位score_new
if (any(cond)) {
  # which.max返回第一个TRUE的位置，对应降序列名中的最大符合值
  score_new <- list1_processed[[category]]$cols[which.max(cond)]
} else {
  score_new <- 24
}

3. 批量生成随机数，消除循环内的rnorm调用 #

原代码循环调用rnorm(1)生成随机数，改为批量生成：

# 外层循环i中，一次性生成13个random_number_1
random_number_1 <- rnorm(13, 0, 1)

# 外层循环i中，一次性生成n个random_number_2
random_number_2_vec <- rnorm(n, 0, 1)

4. 提前提取DataFrame列向量，减少重复索引与类型转换 #

将dat的列提前转为向量，避免循环内反复提取和类型转换：

# 提前提取所有需要的列向量
category_vec <- as.numeric(dat$category)
value1_vec <- as.numeric(dat$value1)
value2_vec <- as.numeric(dat$value2)
value3_vec <- as.numeric(dat$value3)
value5_vec <- as.numeric(dat$value5)
value6_vec <- as.numeric(dat$value6)
value7_vec <- as.numeric(dat$value7)

5. 用向量化求和替代循环累加 #

将每个j的损失贡献值先存入向量，再一次性求和，替代逐个累加：

# 外层循环i中，预分配贡献向量
loss1_contrib <- numeric(n)
loss2_contrib <- numeric(n)

for (j in 1:n) {
  # ... 计算score_new、variable1、variable2的逻辑 ...
  
  if (score_new == 24) {
    contrib <- value1_vec[j] * value2_vec[j]
    loss1_contrib[j] <- contrib
    loss2_contrib[j] <- contrib
  } else {
    loss2_contrib[j] <- 0.6 * (variable1 - variable2) * value1_vec[j] * value2_vec[j]
  }
}

# 一次性求和得到损失值
loss_1_i <- sum(loss1_contrib)
loss_2_i <- sum(loss2_contrib)

6. 进阶优化：用Rcpp实现核心计算逻辑 #

如果上述优化仍未达到预期速度，可将score_new计算与损失计算的核心逻辑用Rcpp实现，直接编译为机器码执行，速度可接近VBA：

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
List computeLosses(NumericVector category_vec, NumericVector value1_vec, 
                   NumericVector value2_vec, NumericVector value3_vec,
                   NumericVector value5_vec, NumericVector value6_vec,
                   NumericVector value7_vec, List list1_processed, 
                   List list2, NumericVector random_number_1,
                   NumericVector random_number_2_vec) {
  int n = category_vec.size();
  NumericVector loss1_contrib(n, 0.0);
  NumericVector loss2_contrib(n, 0.0);
  
  for (int j = 0; j < n; j++) {
    int category = category_vec[j] - 1; // R的列表索引从1开始，C++从0开始
    int value7 = value7_vec[j];
    double test = random_number_2_vec[j] * sqrt(value3_vec[j]) + 
                  random_number_1[category] * sqrt(1 - value3_vec[j]);
    
    // 获取预处理后的list1矩阵和列名
    List mat_list = list1_processed[category];
    NumericMatrix mat = mat_list["mat"];
    NumericVector cols = mat_list["cols"];
    NumericVector row_vals = mat(value7 - 1, _); // 矩阵行索引从0开始
    
    // 寻找score_new
    int score_new = 24;
    for (int k = 0; k < row_vals.size(); k++) {
      if (test >= row_vals[k]) {
        score_new = cols[k];
        break; // 降序排列，找到第一个满足条件的即可
      }
    }
    
    // 获取list2的变量
    NumericMatrix mat2 = list2[category];
    double variable1 = mat2(score_new - 1, value5_vec[j] - 1);
    double variable2 = mat2(value7 - 1, value6_vec[j] - 1);
    
    // 计算贡献值
    double val1_val2 = value1_vec[j] * value2_vec[j];
    if (score_new == 24) {
      loss1_contrib[j] = val1_val2;
      loss2_contrib[j] = val1_val2;
    } else {
      loss2_contrib[j] = 0.6 * (variable1 - variable2) * val1_val2;
    }
  }
  
  return List::create(Named("loss1") = sum(loss1_contrib),
                      Named("loss2") = sum(loss2_contrib));
}

在R中调用该Rcpp函数：

# 编译Rcpp代码（需先安装Rcpp包）
library(Rcpp)
sourceCpp("compute_losses.cpp")

# 外层循环i中调用
for (i in 1:10000) {
  random_number_1 <- rnorm(13, 0, 1)
  random_number_2_vec <- rnorm(n, 0, 1)
  
  loss_result <- computeLosses(category_vec, value1_vec, value2_vec, value3_vec,
                               value5_vec, value6_vec, value7_vec, list1_processed,
                               list2, random_number_1, random_number_2_vec)
  
  loss_1[i] <- loss_result$loss1
  loss_2[i] <- loss_result$loss2
}

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