R语言SIS包变量筛选代码并行化优化求助

我用R的SIS包，通过不同调参（tune）和惩罚项（penalty）做变量筛选。大数据集下嵌套for循环运行太慢，尝试并行化后出现错误，求解决方法。

原串行实现代码 #

# 加载依赖包
library(parallel)
library(doParallel)
library(foreach)
library(SIS)
library(dplyr)

# 加载示例数据
data('leukemia.train', package = 'SIS')
y.train = leukemia.train[,dim(leukemia.train)[2]]
x.train = as.matrix(leukemia.train[,-dim(leukemia.train)[2]])
x.train = standardize(x.train)

# 定义惩罚项列表
penalty <- c("lasso", "SCAD", "MCP")

# 结果存储容器
RESULT <- NULL 
alldat <- NULL

# 嵌套循环执行变量筛选
for(pen in penalty){
  tune  <- c("aic", "bic", "ebic", "cv")
  OUT <- NULL
  dat <- NULL
  
  for(tun in tune){
    # 拟合SIS筛选模型
    mod=SIS(x = x.train, y = y.train, family = 'binomial',
            penalty = pen, tune = tun, varISIS = 'aggr', seed = 21)  
    out <- mod$ix
    coff <- mod$coef.est
    
    x <- x.train %>% as.data.frame()
    dat0 <- x[c(out)]
    
    # 修正系数名称
    if(dim(dat0)[2] >= 1) attr(coff, "names")[-1] <- c(colnames(dat0))
    
    df1 <- coff %>% as.data.frame()
    OUT[[tun]] <- cbind(CpG = rownames(df1), data.frame(coef = df1[, 1], row.names = NULL))
    names(OUT[tun]) <- paste(tun)
    
    dat[[tun]] <- dat0
    names(dat[tun]) <- paste(tun)
  }
  
  RESULT[[pen]] <- OUT
  alldat[[pen]] <- dat
  names(RESULT[pen]) <- paste(pen)
  names(alldat[pen]) <- paste(pen)
}

尝试的并行代码（存在错误） #

# 生成调参+惩罚项的所有组合
pentune.df <- expand.grid(
  tune  = c("aic", "bic", "ebic", "cv"),
  penalty = c("lasso", "SCAD", "MCP")
)

# 创建并注册并行集群
n.cores <- parallel::detectCores() - 2
my.cluster <- parallel::makeCluster(n.cores)
doParallel::registerDoParallel(cl = my.cluster)

# 并行执行循环
foreach(
  tun = pentune.df$tun,
  pena = pentune.df$pena,
  .combine = 'list', 
  .packages = "SIS"
) %dopar% {
  
  # 拟合模型
  mod <- SIS(x = x.train, y = y.train, family = 'binomial',
          penalty = pena, tune = tun, varISIS = 'aggr', seed = 21)
  out <- mod$ix
  coff <- mod$coef.est
  x <- as.data.frame(x.train)
  dat0 <- x[c(out)]
  
  if(dim(dat0)[2] >= 1) attr(coff, "names")[-1] <- c(colnames(dat0))
  df1 <- as.data.frame(coff)
  OUT <- return(cbind(CpG = rownames(df1), data.frame(coef = df1[, 1], row.names = NULL)))
}

# 停止集群
parallel::stopCluster(cl = my.cluster)

错误原因与修正方案 #

核心问题 #

1. 全局变量无法传递：集群节点无法直接读取全局环境中的x.train、y.train，需显式导出
2. 包依赖不全：代码用到dplyr但未在.packages中声明
3. return用法错误：foreach循环内无需用return()赋值，直接输出结果即可
4. 结果结构不匹配原需求：原代码返回嵌套列表，当前并行代码返回扁平列表，需后续整理

修正后的并行代码 #

library(parallel)
library(doParallel)
library(foreach)
library(SIS)
library(dplyr)
library(tibble)

# 数据准备（和原代码一致）
data('leukemia.train', package = 'SIS')
y.train = leukemia.train[,dim(leukemia.train)[2]]
x.train = as.matrix(leukemia.train[,-dim(leukemia.train)[2]])
x.train = standardize(x.train)

# 生成参数组合，禁用因子类型避免后续问题
pentune.df <- expand.grid(
  tune = c("aic", "bic", "ebic", "cv"),
  penalty = c("lasso", "SCAD", "MCP"),
  stringsAsFactors = FALSE
)

# 初始化并行集群
n.cores <- parallel::detectCores() - 2
my.cluster <- parallel::makeCluster(n.cores)
doParallel::registerDoParallel(cl = my.cluster)

# 并行执行变量筛选
parallel_results <- foreach(
  i = 1:nrow(pentune.df),
  .combine = "rbind",
  .packages = c("SIS", "dplyr", "tibble"),
  .export = c("x.train", "y.train")
) %dopar% {
  tun <- pentune.df$tune[i]
  pena <- pentune.df$penalty[i]
  
  # 拟合模型
  mod <- SIS(x = x.train, y = y.train, family = 'binomial',
             penalty = pena, tune = tun, varISIS = 'aggr', seed = 21)
  out <- mod$ix
  coff <- mod$coef.est
  
  x_df <- as.data.frame(x.train)
  dat0 <- x_df[out]
  
  # 修正系数名称
  if(ncol(dat0) >= 1) names(coff)[-1] <- colnames(dat0)
  
  # 整理结果格式
  df1 <- as.data.frame(coff) %>%
    rownames_to_column("CpG") %>%
    rename(coef = 2) %>%
    mutate(penalty = pena, tune = tun)
  
  df1
}

# 停止集群
parallel::stopCluster(cl = my.cluster)

# 将结果整理为原串行代码的嵌套列表结构
RESULT_parallel <- split(parallel_results, parallel_results$penalty) %>%
  lapply(function(pen_df) {
    split(pen_df, pen_df$tune) %>%
      lapply(function(tune_df) {
        tune_df %>% select(-penalty, -tune)
      })
  })

# 可选：整理筛选后的数据集（对应原alldat）
alldat_parallel <- foreach(
  i = 1:nrow(pentune.df),
  .combine = "list",
  .packages = "dplyr",
  .export = c("x.train", "y.train")
) %dopar% {
  tun <- pentune.df$tune[i]
  pena <- pentune.df$penalty[i]
  
  mod <- SIS(x = x.train, y = y.train, family = 'binomial',
             penalty = pena, tune = tun, varISIS = 'aggr', seed = 21)
  out <- mod$ix
  x_df <- as.data.frame(x.train)
  dat0 <- x_df[out]
  
  list(penalty = pena, tune = tun, data = dat0)
} %>%
  split(.$penalty) %>%
  lapply(function(pen_list) {
    lapply(pen_list, function(tune_item) {
      tune_item$data
    }) %>% setNames(sapply(pen_list, function(x) x$tune))
  })

关键改进点 #

• 用.export显式传递全局变量到集群节点
• 在.packages中包含所有用到的依赖包
• 去掉循环内错误的return()赋值逻辑
• 先合并为结构化数据框，再拆分回原嵌套列表结构，便于后续分析
• 用rownames_to_column简化行名处理逻辑

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