如何获取Tidymodels构建的神经网络的特征重要性？

问题背景 #

我用Tidymodels构建监督分类模型，目标是用498个变量预测二分类结果（目标变量broadGroup）。试了多种算法，大部分能通过VIP包获取特征重要性，但神经网络模型不行。而这个神经网络是目前AUROC表现最优的模型，我需要获取它的特征重要性。

模型构建代码如下：

# 创建预处理配方
ap_recipe <- recipe(broadGroup ~ ., data = ap_train) %>%
  step_normalize(all_numeric()) %>% 
  step_dummy(all_nominal_predictors())

# 设置bootstrap验证集
ap_boot <- bootstraps(ap_train, times= 3, strata = broadGroup)

# 定义神经网络模型
nnet_model <- mlp(hidden_units = tune(), 
                  penalty = tune(),
                  epochs = tune(),
                  activation = "relu") %>% 
  set_mode("classification") %>%
  set_engine("keras", verbose = FALSE)

# 构建工作流
nnet_wflow <- workflow() %>% 
  add_recipe(ap_recipe) %>%
  add_model(nnet_model)

# 创建调参网格
nnet_grid <- grid_regular(
  hidden_units(range = c(1,10)),
  penalty(range = c(10e-10,0)),
  epochs(range = c(500, 1000)),
  levels = 5)

# 模型调优与评估
nnet_res <- 
  nnet_wflow %>% 
  tune_grid(
    resamples = ap_boot,
    grid = nnet_grid,
    control = control_grid(save_pred = TRUE),
    metrics = metric_set(kap, recall, precision, f_meas, accuracy, roc_auc),
    )

# 选择最优参数
nnet_best <- 
  nnet_res %>% 
  select_best("roc_auc")

# 收集预测结果
nnet_predict <- nnet_res %>%
  collect_predictions(parameters = nnet_best)

# 保存模型结果
save(nnet_predict,nnet_res,nnet_best, file = "./data/model/apnnet.RData")

# 生成混淆矩阵
nnet_predict %>% conf_mat(broadGroup, .pred_class) 

我原本想通过循环：分别用单个特征、移除单个特征的数据集训练模型，比较AUROC变化，但498个特征太耗时，而且每次都要重新训练模型，不确定是否合理。请问有没有其他可行方法？

可行方法推荐 #

方法1：置换特征重要性（Permutation Importance） #

这是神经网络特征重要性评估的标准方法之一，不需要重新训练模型。核心逻辑是：打乱某个特征的取值，用已训练好的模型预测，观察性能（比如AUROC）的下降幅度——下降越多，说明该特征越重要。

# 首先基于最优参数拟合最终模型
final_nnet_wflow <- nnet_wflow %>%
  finalize_workflow(nnet_best) %>%
  fit(data = ap_train)

# 提取预处理后的训练数据（匹配配方的标准化和哑变量处理）
processed_data <- bake(prep(ap_recipe), new_data = ap_train)
X <- processed_data %>% select(-broadGroup)
y <- processed_data$broadGroup

# 定义置换重要性计算函数
calculate_perm_importance <- function(model, X, y, metric = roc_auc_vec) {
  # 获取原始模型性能
  original_pred <- predict(model, X, type = "prob")$.pred_1
  original_metric <- metric(y, original_pred)
  
  # 遍历每个特征计算置换后的性能变化
  importances <- map_dfr(colnames(X), function(col) {
    # 置换当前特征的取值
    X_perm <- X
    X_perm[[col]] <- sample(X_perm[[col]])
    
    # 预测并计算性能
    perm_pred <- predict(model, X_perm, type = "prob")$.pred_1
    perm_metric <- metric(y, perm_pred)
    
    # 返回重要性：原始性能与置换后性能的差值
    tibble(
      feature = col,
      importance = original_metric - perm_metric,
      original_auroc = original_metric,
      permuted_auroc = perm_metric
    )
  })
  
  return(importances %>% arrange(desc(importance)))
}

# 计算置换重要性
perm_importance <- calculate_perm_importance(final_nnet_wflow, X, y)

# 可视化结果
ggplot(perm_importance, aes(x = reorder(feature, importance), y = importance)) +
  geom_col(fill = "#2c3e50") +
  coord_flip() +
  labs(x = "特征", y = "AUROC下降值（重要性）", title = "神经网络置换特征重要性")

方法2：基于模型权重的特征重要性 #

对于MLP（多层感知机），可以提取输入层到第一个隐藏层的权重，通过权重绝对值的和衡量特征的重要性——权重绝对值越大，该特征对隐藏层输出的影响越大。

# 提取底层Keras模型对象
keras_model <- extract_fit_parsnip(final_nnet_wflow)$fit

# 获取输入层到第一个隐藏层的权重矩阵
input_weights <- keras_model$layers[[1]]$get_weights()[[1]]

# 计算每个特征的权重绝对值之和
weight_importance <- tibble(
  feature = colnames(X),
  importance = apply(abs(input_weights), 2, sum)
) %>% arrange(desc(importance))

# 可视化结果
ggplot(weight_importance, aes(x = reorder(feature, importance), y = importance)) +
  geom_col(fill = "#e74c3c") +
  coord_flip() +
  labs(x = "特征", y = "权重绝对值和", title = "神经网络权重特征重要性")

注意：这种方法依赖模型权重，对于使用ReLU激活的模型，可能受“死亡神经元”影响，结果仅供参考，可靠性不如置换重要性。

方法3：优化你的原始思路（单特征移除法） #

如果一定要用移除特征的方法，可以通过以下方式减少耗时：

• 直接使用已调好的最优参数训练，跳过调参步骤
• 用并行计算加速循环

library(furrr)
plan(multisession) # 开启并行计算

# 定义单特征移除后的模型训练与评估函数
feature_drop_importance <- function(feature) {
  # 创建移除当前特征的预处理配方
  drop_recipe <- ap_recipe %>%
    update_role(!!feature, new_role = "removed") %>%
    step_rm(!!feature)
  
  # 构建工作流并拟合模型
  drop_wflow <- workflow() %>%
    add_recipe(drop_recipe) %>%
    add_model(finalize_model(nnet_model, nnet_best)) %>%
    fit(data = ap_train)
  
  # 计算AUROC
  pred <- predict(drop_wflow, ap_train, type = "prob")$.pred_1
  auroc <- roc_auc_vec(ap_train$broadGroup, pred)
  
  tibble(feature = feature, auroc = auroc)
}

# 并行计算所有特征的AUROC
drop_importance <- future_map_dfr(colnames(X), feature_drop_importance)

# 计算重要性：原始AUROC与移除特征后的AUROC差值
original_auroc <- roc_auc_vec(y, predict(final_nnet_wflow, X, type = "prob")$.pred_1)
drop_importance <- drop_importance %>%
  mutate(importance = original_auroc - auroc) %>%
  arrange(desc(importance))

即使优化后，498个特征的计算量依然较大，优先推荐置换重要性方法。

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