高维数据移除高度相关变量：代码遗留问题及替代方案咨询

问题描述 #

我有一个包含200余个变量的大型数据框，目前通过cor()生成相关矩阵，调用caret::findCorrelation(x, cutoff = 0.8)识别高度相关变量。同时使用Boruta包的Boruta()进行特征重要性分析，计划按meanImp从低到高逐个移除高相关变量，直至数据中无此类变量。但自行编写的remove_highly_correlated函数执行后，数据仍存在高度相关变量，现需排查原因，并获取其他可行的高相关变量移除方法。

所用代码 #

remove_highly_correlated <- function(data, confirmed_sorted, cutoff = 0.80) {
  removed_vars <- character(0)
  
  while (TRUE) {
    removed_this_iteration <- FALSE  
    
    for (i in 1:nrow(confirmed_sorted)) {
      var <- as.character(confirmed_sorted$variables[i])
      
      if (var %in% colnames(data)) {
        cor_matrix <- cor(data)  
        hc <- findCorrelation(cor_matrix, cutoff = cutoff)
        
        if (length(hc) > 0 && var %in% rownames(cor_matrix)[hc]) {
          message(paste("Variable", var, "is highly correlated, removing..."))
          removed_vars <- c(removed_vars, var)  
          data <- data[, -which(colnames(data) == var)]  
          removed_this_iteration <- TRUE  
          break 
        }
      }
    }
    
    if (!removed_this_iteration) {
      break  
    }
  }
  
  return(list(data = data, removed_vars = removed_vars))
}

result <- remove_highly_correlated(data5, confirmed_sorted)

data5_filtered <- as.data.frame(result$data)
removed_variables <- as.data.frame(result$removed_vars)

cor_d5 = round(cor(data5_filtered), 4)
hc = findCorrelation(cor_d5, cutoff = 0.80, verbose = TRUE)

示例数据 #

blue <- c(0.57, 0.76, 0.78, 0.53, 0.26, 0.27, 0.32, 0.20, 0.63, 0.68, 0.69, 0.69, 0.35, 0.51, 0.39, 0.57, 0.67, 0.63, 0.66, 0.61, 0.54, 0.51, 0.56, 0.59, 0.52, 0.40, 0.39, 0.46, 0.82, 0.84, 0.83, 0.52, 0.59, 0.70, 0.61, 0.83)
red <- c(0.14, 0.11, 0.15, 0.17, 0.18, 0.17, 0.16, 0.07, 0.07, 0.11, 0.12, 0.10, 0.27, 0.19, 0.23, 0.19, 0.10, 0.11, 0.09, 0.10, 0.17, 0.23, 0.23, 0.22, 0.24, 1.00, 0.88, 0.64, 0.11, 0.12, 0.14, 0.56, 0.54, 0.36, 0.53, 0.13)
purple <- c(0.80, 0.84, 0.79, 0.76, 0.75, 0.76, 0.77, 0.59, 0.90, 0.84, 0.83, 0.86, 0.64, 0.73, 0.68, 0.73, 0.85, 0.83, 0.86, 0.85, 0.76, 0.69, 0.69, 0.71, 0.68, 0.00, 0.09, 0.28, 0.84, 0.83, 0.80, 0.35, 0.36, 0.55, 0.38, 0.81)
pink <- c(0.67, 0.73, 0.66, 0.62, 0.63, 0.63, 0.64, 0.49, 0.84, 0.74, 0.73, 0.78, 0.51, 0.58, 0.52, 0.59, 0.74, 0.72, 0.77, 0.75, 0.64, 0.54, 0.55, 0.57, 0.54, 0.00, 0.06, 0.18, 0.74, 0.73, 0.68, 0.25, 0.24, 0.41, 0.26, 0.69)
orange <- c(0.14, 0.11, 0.15, 0.17, 0.18, 0.17, 0.16, 0.07, 0.07, 0.11, 0.12, 0.10, 0.27, 0.19, 0.23, 0.19, 0.10, 0.11, 0.09, 0.10, 0.17, 0.23, 0.23, 0.22, 0.24, 1.00, 0.88, 0.64, 0.11, 0.12, 0.14, 0.56, 0.54, 0.36, 0.53, 0.13)
yellow <- c(0.20, 0.16, 0.21, 0.24, 0.25, 0.24, 0.23, 0.41, 0.10, 0.16, 0.17, 0.14, 0.36, 0.27, 0.32, 0.27, 0.15, 0.17, 0.14, 0.15, 0.24, 0.31, 0.31, 0.29, 0.32, 1.00, 0.91, 0.72, 0.16, 0.17, 0.20, 0.65, 0.64, 0.45, 0.62, 0.19)

data5 <- data.frame(blue, red, purple, pink, orange, yellow)

variables <- c("yellow", "purple", "blue", "green", "pink", "orange", "red")
meanImp <- c(10.07, 9.40, 9.31, 7.51, 7.49, 6.82, 6.65)

confirmed_sorted<- data.frame(variables, meanImp)

原因排查 #

原函数存在以下逻辑缺陷：

1. 循环终止过早：每次遍历到第一个符合条件的变量就break，仅移除单个变量后重新进入循环，但findCorrelation返回的是一组高相关变量，导致同轮次中其他高相关变量被遗漏。
2. 冗余计算：遍历每个变量时都重新计算全量相关矩阵，效率低下且无必要。
3. 优先级冲突：强行按confirmed_sorted顺序移除变量，可能与findCorrelation内置的“移除对模型贡献较小变量”的逻辑冲突，导致不该移除的变量被移除，而该移除的被保留。

改进后的函数 #

修正逻辑，确保按特征重要性从低到高移除高相关变量，同时避免冗余计算：

remove_highly_correlated <- function(data, confirmed_sorted, cutoff = 0.80) {
  # 按meanImp升序排序，确保移除优先级是从低到高
  confirmed_sorted <- confirmed_sorted[order(confirmed_sorted$meanImp), ]
  removed_vars <- character(0)
  
  while (TRUE) {
    # 仅计算当前数据的相关矩阵，处理缺失值
    cor_matrix <- cor(data, use = "complete.obs")
    hc <- findCorrelation(cor_matrix, cutoff = cutoff)
    
    if (length(hc) == 0) break  # 无高相关变量，退出循环
    
    # 获取所有高相关变量名
    high_cor_vars <- rownames(cor_matrix)[hc]
    # 按优先级找到第一个需要移除的变量
    to_remove <- confirmed_sorted$variables[confirmed_sorted$variables %in% high_cor_vars][1]
    
    if (!is.na(to_remove)) {
      message(paste("移除高度相关变量:", to_remove))
      removed_vars <- c(removed_vars, to_remove)
      data <- data[, !colnames(data) %in% to_remove, drop = FALSE]
    } else {
      # 若高相关变量不在优先级列表中，移除findCorrelation推荐的第一个
      to_remove <- high_cor_vars[1]
      message(paste("移除高度相关变量（未在优先级列表中）:", to_remove))
      removed_vars <- c(removed_vars, to_remove)
      data <- data[, !colnames(data) %in% to_remove, drop = FALSE]
    }
  }
  
  return(list(data = data, removed_vars = removed_vars))
}

其他可行的高相关变量移除方法 #

1. 直接使用findCorrelation批量移除 #

适合无需结合特征重要性的场景，findCorrelation会直接返回需移除的变量索引：

cor_matrix <- cor(data5)
hc <- findCorrelation(cor_matrix, cutoff = 0.8)
data_filtered <- data5[, -hc]

2. 基于方差膨胀因子（VIF）移除 #

VIF衡量多重共线性程度，一般以VIF>10作为严重共线性的阈值：

library(car)
# 替换y为你的目标变量列名
vif_values <- vif(lm(y ~ ., data = data5))
high_vif_vars <- names(vif_values[vif_values > 10])
data_filtered <- data5[, !colnames(data5) %in% high_vif_vars]

3. 聚类法保留高重要性变量 #

将变量按相关性聚类，每类仅保留特征重要性最高的变量：

library(Hmisc)
library(cluster)

# 转换相关矩阵为距离矩阵
cor_matrix <- cor(data5)
dist_matrix <- as.dist(1 - abs(cor_matrix))

# 聚类并划分组（h=0.2对应相关性阈值0.8）
hc_cluster <- hclust(dist_matrix, method = "ward.D2")
clusters <- cutree(hc_cluster, h = 0.2)

# 按meanImp保留每类中最重要的变量
cluster_vars <- split(names(clusters), clusters)
selected_vars <- sapply(cluster_vars, function(vars) {
  vars_in_imp <- vars[vars %in% confirmed_sorted$variables]
  if (length(vars_in_imp) == 0) return(vars[1])
  confirmed_sorted[confirmed_sorted$variables %in% vars_in_imp, ] %>%
    arrange(desc(meanImp)) %>%
    slice(1) %>%
    pull(variables)
})

data_filtered <- data5[, selected_vars]

4. 使用recipes包自动化预处理 #

结合相关性移除与特征重要性筛选，构建标准化预处理流程：

library(recipes)

# 替换y为你的目标变量列名
rec <- recipe(y ~ ., data = data5) %>%
  step_corr(all_predictors(), threshold = 0.8) %>%  # 移除高相关变量
  step_select(all_predictors(), top_p = 100, importance = "impurity")  # 按特征重要性筛选

prepped_rec <- prep(rec, training = data5)
data_filtered <- bake(prepped_rec, new_data = data5)

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