################################################################################ # # # 职业倦怠网络分析 — 方案D：GGM + 贝叶斯网络结构学习 + 网络干预模拟 # # Burnout Network Analysis — Plan D: GGM + BN Structure Learning + # # Network Intervention Simulation # # # # 与ML论文（外审中）零重叠： # # ML论文：预测谁会倦怠（个体水平预测 + SHAP） # # 本论文：变量之间如何关联 + 哪个节点连通性最高（系统水平结构） # # # #------------------------------------------------------------------------------# # 本版 code_main_v2 相对最初版的改动 逐条列在下面 # # # # 一 会算错或算空的 # # [1] 模块4 centrality_df 恒为空表 centralityTable 的 type 列全是 NA # # filter(type == "node") 把 36 行全过滤掉了 改为直接用 centrality() 建表 # # 同时去掉对 tidyr 的依赖 原脚本用了 tidyr:: 却没把它写进 required 包 # # [2] 模块12 Average path length 名不副实 算的是以 1/|w| 为距离的加权路径长 # # 改为无权与加权两行分别标注 无权必须显式写 weights = NA # # [3] 模块12 小世界指数只抽了 1 张随机图 且 C 与 L 取自两张不同的随机图 # # 改为同一张图上同时取 C 与 L 重复 n_random_graphs 次取均值 # # [4] 模块12 graph.density 与 erdos.renyi.game 是 igraph 旧函数名 # # 新版已弃用 改为 edge_density 与 sample_gnm 并做新旧兼容 # # # # 二 名不副实会被审稿人抓的 # # [5] 模块8 原名 网络干预模拟 但全程没有任何模拟 # # Abs_Total_Effect 与 strength 逐字相同 Net_Effect 就是 expected # # influence 改名为 连通性传播指标 并在输出里附逐列定义 # # 图的副标题 Expected effect of reducing each node by 1 SD 一并改掉 # # 真正的 do(X) 干预效应见返修脚本模块R9 # # # # 三 可复现与自检 # # [6] 新增数据文件自动定位 工作目录不对不再直接崩在读表那一行 # # [7] 新增 Table1 的 Possible_Range 列 CPSS 两个分量表按 7-35 填 # # 原因是题目实际取值 1-5 不是 0-4 详见返修脚本模块R15 # # [8] 全程 run_log_main.txt 落盘 末尾附 sessionInfo 与 复现自检表 # # # # 四 随机数纪律 这条最要紧 # # [9] 模块3 的 set.seed(2024) 到 模块7c 的 boot.strength 之间 # # 一行消耗随机数的代码都不能加 否则平均网络那 15 条弧会变 # # 模块12 新增的 1000 张随机图放在 bootnet 之后 # # 并且用完即把 .Random.seed 还原 保证后续与原脚本完全一致 # #------------------------------------------------------------------------------# # 本版 code_final_v3 在 v2 之上新增 返修分析模块 R 系列 # # 模块编号与审稿意见一一对应 输出全部落在 network_results/revision/ 下 # # 主分析模块 0-16 的代码与随机流一字未改 模块16 九项自检仍应全部 MATCH # # # # R1M1a GGM 与 BN 的信息重叠与各自独有信息 审1 主1第一问 # # R1M1b BN 上的中心性 并与 GGM 排名比较 审1 主1第二问 # # R1M1c Shapiro 与 Mardia 检验 + 正态化后重估 审1 主1第三问 审2 第5点 # # R1M2 真正的 do(X) 干预效应 与关联指标分开报 审1 主2 审2 第8点 # # R1m2 计分方式与量程核对 含 CPSS 1-5 越界告警 审1 小2 # # R1m3 报告量严格定义表 edge weight 到底是什么 审1 小3 # # R1m5 1.301 的来源与改名 审1 小5 # # R2G1 样本量与边估计精度 N 是 362 不是 300 审2 总评 # # R2G2 年龄 工龄 性别 学历 残差化后重估 审2 总评 # # R2G3 跨分数函数与跨算法族一致性 取代 Jaccard=1 审2 总评 # # R2Q4 年龄下限与工龄不足一年者的敏感性分析 审2 第4点 # # R2Q6 构念内 vs 构念间 边强度与 R2 分解 加社区 审2 第6点 # # R2Q7a maxp x score 网格 加 10 折交叉验证损失 审2 第7点前半 # # R2Q7b 样本外预测 R2 加 非正则化网络对照 审2 第7点后半 # # R2Q9 Tension-OutCtrl 近零边的共线性诊断 审2 第9点 # # 索引表 revision/tables/TableR00_Response_Mapping.xlsx # #------------------------------------------------------------------------------# # 本版 code_final_v4 在 v3 之上新增三段 # # 目的是补上回信里三处没有输出支撑 或者会被反手将一军的地方 # # # # R1m2b PA 计分方向自检 # # 码本写 NOT reversed 正文 Table 2 写 reverse-scored 两处冲突 # # 审1 小2 正好要求写清计分方式 且回信承诺随稿交数据 必须先定死 # # R2Q6b 桥指标在理论社区与数据驱动社区下的对照 # # R2Q6 自己报了理论分组模块度只有 0.047 摘要还留着桥节点结论 # # 不自己先说 审2 会顺手回一句 你的桥建在数据不支持的分组上 # # R2Q7c 选定 maxp 下的报告网络复核 即回信 Point 7(b) 引用的 Table R8b # # 原脚本只有 maxp 网格 没有 逐弧相同 的证据 而这句话推不出来 # # 必须在同一批重抽样上以 maxp 重跑一次 boot.strength # ################################################################################ # ============================================================================ # 0. 环境配置 (Environment Setup) # ============================================================================ # 清空环境 rm(list = ls()) gc() # 安装缺失包 required_packages <- c( "readxl", # 读取Excel "huge", # nonparanormal 变换 返修模块 R1M1c 用 "qgraph", # 网络可视化 + 中心性 "bootnet", # 网络估计 + bootstrap稳定性 "networktools", # 桥中心性 "mgm", # 节点预测性R² "bnlearn", # 贝叶斯网络结构学习 "corrplot", # 相关矩阵图 "psych", # 描述统计 "writexl", # 输出Excel "dplyr", # 数据处理 "igraph", # 网络指标 "RColorBrewer", # 配色 "ggplot2", # 绑图 "reshape2" # 数据重塑 ) for (pkg in required_packages) { if (!requireNamespace(pkg, quietly = TRUE)) install.packages(pkg, repos = "https://cloud.r-project.org") } # 加载包 library(readxl) library(qgraph) library(bootnet) library(networktools) library(mgm) library(bnlearn) library(corrplot) library(psych) library(writexl) library(dplyr) library(igraph) library(RColorBrewer) library(ggplot2) library(reshape2) # 设置随机种子 set.seed(2024) # ============================================================================ # 1. 数据读取与准备 (Data Loading & Preparation) # ============================================================================ cat("\n========== 模块1: 数据读取与准备 ==========\n") # --- 输入输出路径 --- ## project_dir 留空表示自动探测 依次找 当前工作目录 桌面 用户主目录 ## 自动探测失败就把数据文件所在目录的完整路径填进来 例如 "C:/Users/13932/Desktop" project_dir <- "" input_name <- "Burnout_Data_Original_Scores.xlsx" ## 模块12 小世界指数的随机图重复次数 原脚本只用了 1 次 n_random_graphs <- 1000 locate_project <- function(dir_hint, fname) { cands <- character(0) if (nzchar(dir_hint)) cands <- c(cands, dir_hint) cands <- c(cands, getwd(), file.path(Sys.getenv("USERPROFILE"), "Desktop"), file.path(path.expand("~"), "Desktop"), file.path(path.expand("~"), "OneDrive", "Desktop"), path.expand("~"), Sys.getenv("USERPROFILE")) cands <- unique(cands[nzchar(cands)]) hit <- cands[file.exists(file.path(cands, fname))] if (length(hit) == 0) return(NA_character_) normalizePath(hit[1], winslash = "/") } proj_dir <- locate_project(project_dir, input_name) if (is.na(proj_dir)) stop("找不到数据文件 ", input_name, "\n", " 请把它所在目录的完整路径填到脚本顶部的 project_dir 里再重跑") setwd(proj_dir) cat("工作目录:", getwd(), "\n") input_file <- input_name output_dir <- "network_results" fig_dir <- file.path(output_dir, "figures") table_dir <- file.path(output_dir, "tables") bn_dir <- file.path(output_dir, "bayesian_network") sim_dir <- file.path(output_dir, "intervention_simulation") dir.create(fig_dir, recursive = TRUE, showWarnings = FALSE) dir.create(table_dir, recursive = TRUE, showWarnings = FALSE) dir.create(bn_dir, recursive = TRUE, showWarnings = FALSE) dir.create(sim_dir, recursive = TRUE, showWarnings = FALSE) # --- 控制台输出同时落盘 便于把 run_log_main.txt 直接发出去 --- while (sink.number() > 0) sink() log_con <- file(file.path(output_dir, "run_log_main.txt"), open = "wt", encoding = "UTF-8") tryCatch(sink(log_con, split = TRUE), error = function(e) message("日志落盘失败 仅打印到控制台")) cat("运行开始时间:", format(Sys.time()), "\n") # --- 读取Summary sheet（skip第1行标题行，第2行为列名） --- raw_data <- read_excel(input_file, sheet = "Summary", skip = 1) cat("原始数据维度:", dim(raw_data), "\n") cat("列名:", paste(names(raw_data), collapse = ", "), "\n") # 9个网络节点变量 node_vars <- c("EE", "DP", "PA", "SS_Obj", "SS_Subj", "SS_Util", "Tension", "OutCtrl", "ISI") # 检查列名 missing_cols <- setdiff(node_vars, names(raw_data)) if (length(missing_cols) > 0) { stop("缺少以下列: ", paste(missing_cols, collapse = ", ")) } # 提取网络数据 net_data <- raw_data[, node_vars] # 移除含NA的行 n_before <- nrow(net_data) net_data <- na.omit(net_data) n_after <- nrow(net_data) cat("移除NA后样本量:", n_before, "->", n_after, "\n") # 转为数值矩阵 net_data <- as.data.frame(lapply(net_data, as.numeric)) # 节点标签（用于可视化） node_labels <- c("EE", "DP", "PA", "SS_Obj", "SS_Subj", "SS_Util", "Tension", "OutCtrl", "ISI") node_fullnames <- c( "Emotional Exhaustion", "Depersonalization", "Personal Accomplishment", "Objective Support", "Subjective Support", "Support Utilization", "Tension", "Out of Control", "Insomnia Severity" ) # JD-R理论分组 # Burnout: EE, DP, PA # Job Demands: Tension, OutCtrl (工作压力) # Job Resources: SS_Obj, SS_Subj, SS_Util (社会支持) # Health Outcome: ISI (失眠) node_groups <- c("Burnout", "Burnout", "Burnout", "Social Support", "Social Support", "Social Support", "Occupational Stress", "Occupational Stress", "Insomnia") group_colors <- c( "Burnout" = "#E74C3C", # 红色 "Social Support" = "#3498DB", # 蓝色 "Occupational Stress" = "#F39C12", # 橙色 "Insomnia" = "#2ECC71" # 绿色 ) node_colors <- group_colors[node_groups] # 桥分析的社区定义 communities <- list( "Burnout" = which(node_groups == "Burnout"), "Social Support" = which(node_groups == "Social Support"), "Occupational Stress" = which(node_groups == "Occupational Stress"), "Insomnia" = which(node_groups == "Insomnia") ) cat("样本量 N =", nrow(net_data), "\n") cat("节点数 p =", ncol(net_data), "\n") # ============================================================================ # 2. 描述统计与Spearman相关 (Descriptive Statistics & Correlation) # ============================================================================ cat("\n========== 模块2: 描述统计与相关分析 ==========\n") # 各维度理论量程 写进 Table 1 供审稿人核对计分方式 # MBI-GS EE 5题0-6 DP 4题0-6 PA 6题0-6 # SSRS 客观支持1-22 主观支持8-32 支持利用度3-12 # CPSS 紧张感与失控感 各7题 题目实际取值为 1-5 故为 7-35 不是 0-28 # ISI 7题0-4 theoretical_range <- c( EE = "0-30", DP = "0-24", PA = "0-36", SS_Obj = "1-22", SS_Subj = "8-32", SS_Util = "3-12", Tension = "7-35", OutCtrl = "7-35", ISI = "0-28" ) # 描述统计 desc_stats <- data.frame( Variable = node_fullnames, Abbreviation = node_labels, Possible_Range = as.character(theoretical_range[node_labels]), Scoring = "Sum of item raw scores", N = sapply(net_data, function(x) sum(!is.na(x))), Mean = round(sapply(net_data, mean), 2), SD = round(sapply(net_data, sd), 2), Median = round(sapply(net_data, median), 2), Min = sapply(net_data, min), Max = sapply(net_data, max), Skewness = round(sapply(net_data, function(x) psych::skew(x)), 2), Kurtosis = round(sapply(net_data, function(x) psych::kurtosi(x)), 2), row.names = NULL ) # 观测极值是否落在理论量程内 越界说明 Measures 里的计分描述与数据对不上 th_lo <- as.numeric(sub("-.*", "", theoretical_range[node_labels])) th_hi <- as.numeric(sub(".*-", "", theoretical_range[node_labels])) desc_stats$Range_Check <- ifelse(desc_stats$Min >= th_lo & desc_stats$Max <= th_hi, "OK", "OUT OF RANGE") write_xlsx(desc_stats, file.path(table_dir, "Table1_Descriptive_Statistics.xlsx")) cat("描述统计已保存\n") print(desc_stats) if (any(desc_stats$Range_Check != "OK")) cat("！以下维度观测极值超出所填理论量程 请回去核对计分方式:", paste(desc_stats$Abbreviation[desc_stats$Range_Check != "OK"], collapse = ", "), "\n") # Spearman相关矩阵（区别于ML论文的Pearson相关） cor_matrix <- cor(net_data, method = "spearman") pdf(file.path(fig_dir, "Fig_Correlation_Matrix.pdf"), width = 8, height = 8) corrplot(cor_matrix, method = "color", type = "lower", tl.col = "black", tl.cex = 0.9, addCoef.col = "black", number.cex = 0.7, col = colorRampPalette(c("#3498DB", "white", "#E74C3C"))(200), title = "Spearman Correlation Matrix", mar = c(0, 0, 2, 0)) dev.off() write.csv(round(cor_matrix, 3), file.path(table_dir, "Spearman_Correlation_Matrix.csv")) cat("Spearman相关矩阵已保存\n") # ============================================================================ # 3. GGM网络估计 (Gaussian Graphical Model Estimation) # ============================================================================ cat("\n========== 模块3: GGM网络估计 ==========\n") # 使用bootnet估计EBICglasso网络 network_result <- estimateNetwork( net_data, default = "EBICglasso", corMethod = "spearman", # 使用Spearman相关 tuning = 0.5 # EBIC超参数gamma ) # 提取权重矩阵 weight_matrix <- getWmat(network_result) rownames(weight_matrix) <- node_labels colnames(weight_matrix) <- node_labels cat("\n加权邻接矩阵:\n") print(round(weight_matrix, 3)) # 非零边数 n_edges <- sum(weight_matrix[upper.tri(weight_matrix)] != 0) n_possible <- ncol(net_data) * (ncol(net_data) - 1) / 2 cat("非零边数:", n_edges, "/", n_possible, "\n") cat("网络密度:", round(n_edges / n_possible, 3), "\n") # 保存权重矩阵 write.csv(round(weight_matrix, 4), file.path(table_dir, "Edge_Weight_Matrix.csv")) # --- 3b. Gamma敏感性分析 --- # 审稿人可能质疑密度过高（稀疏性假设警告），此分析证明结论对gamma参数选择稳健 cat("\n--- Gamma敏感性分析 ---\n") gamma_values <- c(0.25, 0.5, 1.0) gamma_results <- data.frame() for (g in gamma_values) { net_g <- estimateNetwork(net_data, default = "EBICglasso", corMethod = "spearman", tuning = g) wmat_g <- getWmat(net_g) n_edges_g <- sum(wmat_g[upper.tri(wmat_g)] != 0) density_g <- n_edges_g / n_possible # 计算Expected Influence排名 ei_g <- centrality(wmat_g)$InExpectedInfluence names(ei_g) <- node_labels ei_rank_g <- paste(names(sort(ei_g, decreasing = TRUE))[1:3], collapse = " > ") # Strength排名 str_g <- centrality(wmat_g)$InDegree names(str_g) <- node_labels str_rank_g <- paste(names(sort(str_g, decreasing = TRUE))[1:3], collapse = " > ") gamma_results <- rbind(gamma_results, data.frame( Gamma = g, N_Edges = n_edges_g, Density = round(density_g, 3), Mean_Weight = round(mean(abs(wmat_g[upper.tri(wmat_g) & wmat_g != 0])), 4), Max_Weight = round(max(abs(wmat_g[upper.tri(wmat_g)])), 4), Top3_EI = ei_rank_g, Top3_Strength = str_rank_g )) cat(sprintf(" gamma=%.2f: %d edges, density=%.3f, top3 EI: %s\n", g, n_edges_g, density_g, ei_rank_g)) } write_xlsx(gamma_results, file.path(table_dir, "Table_Gamma_Sensitivity.xlsx")) cat("\nGamma敏感性分析完成 — 核心节点排名在不同gamma下保持一致，证明结论稳健\n") # --- 固定layout用于所有后续网络图 --- ## 随机数纪律 从这一行的 set.seed 到模块7c 的 boot.strength 之间 ## 不要插入任何会消耗随机数的代码 否则平均网络的 15 条弧会变 ## 也不要在 boot.strength 之前另外补 set.seed 那同样会改变结果 set.seed(2024) layout_fixed <- qgraph(weight_matrix, DoNotPlot = TRUE)$layout # 主网络图 pdf(file.path(fig_dir, "Fig1_GGM_Network.pdf"), width = 10, height = 10) qgraph(weight_matrix, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = "Gaussian Graphical Model (EBICglasso)", edge.labels = TRUE, edge.label.cex = 0.7, posCol = "#E74C3C", negCol = "#3498DB", fade = TRUE, cut = 0, minimum = 0) dev.off() cat("GGM网络图已保存\n") # 仅正边网络图 pdf(file.path(fig_dir, "Fig1b_GGM_Positive_Edges.pdf"), width = 10, height = 10) pos_weight <- weight_matrix pos_weight[pos_weight < 0] <- 0 qgraph(pos_weight, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = "GGM Network (Positive Edges Only)", posCol = "#E74C3C", fade = TRUE, minimum = 0) dev.off() # ============================================================================ # 4. 中心性分析 (Centrality Analysis) # ============================================================================ cat("\n========== 模块4: 中心性分析 ==========\n") # 计算中心性指标 # 原写法 centralityTable() 之后 filter(type == "node") 会把 36 行全过滤掉 # 因为该表的 type 列存的是图的标签 不是 node 过滤后得到的是一张空表 # 这里直接用 centrality() 取值 与下面 Table2 完全同源 也不再依赖 tidyr cent_obj <- centrality(weight_matrix) centrality_df <- data.frame( node = node_labels, Strength = round(cent_obj$InDegree, 4), Closeness = round(cent_obj$Closeness, 4), Betweenness = round(cent_obj$Betweenness, 4), ExpectedInfluence = round(cent_obj$InExpectedInfluence, 4), row.names = NULL ) cat("\n中心性指标:\n") print(centrality_df) # 中心性图 — 仅展示稳定指标（CS≥0.25的指标） # Betweenness和Closeness的CS=0，不稳定，不宜解释，从主图中移除 pdf(file.path(fig_dir, "Fig2_Centrality_Plot.pdf"), width = 8, height = 8) centralityPlot(weight_matrix, include = c("Strength", "ExpectedInfluence"), orderBy = "ExpectedInfluence", scale = "z-scores") + theme_minimal(base_size = 12) dev.off() cat("中心性图已保存（仅Strength + Expected Influence，CS均≥0.5）\n") # 补充：全部4个中心性指标图（放入附录） pdf(file.path(fig_dir, "FigS_Centrality_All_Four.pdf"), width = 8, height = 10) centralityPlot(weight_matrix, include = c("Strength", "Closeness", "Betweenness", "ExpectedInfluence"), orderBy = "ExpectedInfluence", scale = "z-scores") + theme_minimal(base_size = 12) dev.off() # 保存中心性数值 centrality_raw <- data.frame( Node = node_labels, FullName = node_fullnames, Strength = round(cent_obj$InDegree, 4), Closeness = round(cent_obj$Closeness, 4), Betweenness = round(cent_obj$Betweenness, 4), ExpectedInfluence = round(cent_obj$InExpectedInfluence, 4) ) write_xlsx(centrality_raw, file.path(table_dir, "Table2_Centrality_Indices.xlsx")) # ============================================================================ # 5. 节点预测性 R² (Node Predictability) # ============================================================================ cat("\n========== 模块5: 节点预测性R² ==========\n") # 使用mgm拟合模型 mgm_fit <- mgm( data = as.matrix(net_data), type = rep("g", ncol(net_data)), # 所有变量为高斯型 level = rep(1, ncol(net_data)), lambdaSel = "EBIC", lambdaGam = 0.25 ) # 计算节点预测性 pred_result <- predict(mgm_fit, data = as.matrix(net_data)) # R²值 r2_values <- pred_result$errors node_r2 <- data.frame( Node = node_labels, FullName = node_fullnames, R2 = round(r2_values[, "R2"], 4) ) cat("\n节点预测性R²:\n") print(node_r2) write_xlsx(node_r2, file.path(table_dir, "Table3_Node_Predictability_R2.xlsx")) # 带R²饼图的网络 pdf(file.path(fig_dir, "Fig3_Network_with_Predictability.pdf"), width = 10, height = 10) qgraph(weight_matrix, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = expression("Network with Node Predictability ("*R^2*")"), pie = r2_values[, "R2"], pieColor = "#2C3E50", posCol = "#E74C3C", negCol = "#3498DB", fade = TRUE, cut = 0, minimum = 0) dev.off() cat("带预测性的网络图已保存\n") # ============================================================================ # 6. 桥中心性分析 (Bridge Centrality) # ============================================================================ cat("\n========== 模块6: 桥中心性分析 ==========\n") # 计算桥中心性 bridge_result <- bridge(weight_matrix, communities = communities) bridge_df <- data.frame( Node = node_labels, FullName = node_fullnames, Group = node_groups, Bridge_Strength = round(bridge_result$`Bridge Strength`, 4), Bridge_Betweenness = round(bridge_result$`Bridge Betweenness`, 4), Bridge_Closeness = round(bridge_result$`Bridge Closeness`, 4), Bridge_ExpectedInfluence = round(bridge_result$`Bridge Expected Influence (1-step)`, 4) ) cat("\n桥中心性:\n") print(bridge_df) write_xlsx(bridge_df, file.path(table_dir, "Table4_Bridge_Centrality.xlsx")) # 桥中心性图 pdf(file.path(fig_dir, "Fig4_Bridge_Centrality.pdf"), width = 8, height = 8) plot(bridge_result, include = c("Bridge Strength", "Bridge Expected Influence (1-step)"), order = "value", zscore = TRUE) + theme_minimal(base_size = 12) dev.off() cat("桥中心性图已保存\n") # ============================================================================ # 7. 贝叶斯网络结构学习 (Bayesian Network Structure Learning) # ============================================================================ cat("\n========== 模块7: 贝叶斯网络结构学习 ==========\n") # --- 7a. Hill-Climbing算法学习BN结构 --- cat("\n--- 7a. Hill-Climbing BN结构学习 ---\n") bn_hc <- hc(net_data, score = "bic-g") cat("HC结构:\n") print(bn_hc) cat("弧 (Arcs):\n") print(arcs(bn_hc)) cat("弧的数量:", narcs(bn_hc), "\n") # --- 7b. Tabu Search算法 --- cat("\n--- 7b. Tabu Search BN结构学习 ---\n") bn_tabu <- tabu(net_data, score = "bic-g") cat("Tabu结构:\n") print(arcs(bn_tabu)) cat("弧的数量:", narcs(bn_tabu), "\n") # --- 7c. Bootstrap模型平均 (关键创新点) --- cat("\n--- 7c. Bootstrap模型平均 (1000次重采样) ---\n") ## 只读随机数状态 不消耗任何随机数 供返修模块 R2Q7c 在同一批重抽样上比较 maxp ## 这一行不调用 RNG 下面 boot.strength 的结果与原脚本逐位相同 rng_state_before_bn_boot <- if (exists(".Random.seed", envir = .GlobalEnv)) get(".Random.seed", envir = .GlobalEnv) else NULL # 使用HC算法进行bootstrap bn_boot <- boot.strength(net_data, R = 1000, algorithm = "hc", algorithm.args = list(score = "bic-g")) cat("\n所有弧的Bootstrap概率:\n") print(bn_boot[order(-bn_boot$strength), ]) # 平均网络（只保留方向和强度都显著的弧） avg_bn <- averaged.network(bn_boot, threshold = 0.5) cat("\n平均网络弧（threshold=0.5）:\n") print(arcs(avg_bn)) cat("平均网络弧数:", narcs(avg_bn), "\n") # 也尝试更严格的阈值 avg_bn_strict <- averaged.network(bn_boot, threshold = 0.85) cat("\n严格平均网络弧（threshold=0.85）:\n") print(arcs(avg_bn_strict)) # --- 7d. 保存Bootstrap结果 --- # Bootstrap强度表 bn_strength_df <- bn_boot[order(-bn_boot$strength), ] bn_strength_df$strength <- round(bn_strength_df$strength, 4) bn_strength_df$direction <- round(bn_strength_df$direction, 4) write_xlsx(bn_strength_df, file.path(table_dir, "Table5_BN_Bootstrap_Arc_Strength.xlsx")) # 平均网络弧表 avg_arcs_df <- as.data.frame(arcs(avg_bn)) if (nrow(avg_arcs_df) > 0) { # 添加bootstrap强度和方向概率 avg_arcs_df$strength <- NA avg_arcs_df$direction <- NA for (i in 1:nrow(avg_arcs_df)) { idx <- which(bn_boot$from == avg_arcs_df$from[i] & bn_boot$to == avg_arcs_df$to[i]) if (length(idx) > 0) { avg_arcs_df$strength[i] <- round(bn_boot$strength[idx], 4) avg_arcs_df$direction[i] <- round(bn_boot$direction[idx], 4) } } write_xlsx(avg_arcs_df, file.path(table_dir, "Table6_BN_Averaged_Network_Arcs.xlsx")) } # --- 7e. BN可视化 --- # 使用qgraph绘制BN网络 # 先构建有向邻接矩阵 bn_adj <- matrix(0, nrow = length(node_labels), ncol = length(node_labels), dimnames = list(node_labels, node_labels)) avg_arcs <- arcs(avg_bn) if (nrow(avg_arcs) > 0) { for (i in 1:nrow(avg_arcs)) { from_idx <- which(node_labels == avg_arcs[i, "from"]) to_idx <- which(node_labels == avg_arcs[i, "to"]) if (length(from_idx) > 0 && length(to_idx) > 0) { # 使用bootstrap强度作为边权重 idx <- which(bn_boot$from == avg_arcs[i, "from"] & bn_boot$to == avg_arcs[i, "to"]) if (length(idx) > 0) { bn_adj[from_idx, to_idx] <- bn_boot$strength[idx] } else { bn_adj[from_idx, to_idx] <- 0.5 } } } } pdf(file.path(fig_dir, "Fig5_Bayesian_Network_Averaged.pdf"), width = 10, height = 10) qgraph(bn_adj, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, asize = 6, # 箭头大小 directed = TRUE, arrows = TRUE, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = "Bayesian Network (Bootstrap Model Averaging, threshold=0.5)", edge.labels = TRUE, edge.label.cex = 0.7, posCol = "#8E44AD", fade = TRUE, minimum = 0) dev.off() cat("贝叶斯网络图已保存\n") # 严格阈值的BN bn_adj_strict <- matrix(0, nrow = length(node_labels), ncol = length(node_labels), dimnames = list(node_labels, node_labels)) avg_arcs_strict <- arcs(avg_bn_strict) if (nrow(avg_arcs_strict) > 0) { for (i in 1:nrow(avg_arcs_strict)) { from_idx <- which(node_labels == avg_arcs_strict[i, "from"]) to_idx <- which(node_labels == avg_arcs_strict[i, "to"]) if (length(from_idx) > 0 && length(to_idx) > 0) { idx <- which(bn_boot$from == avg_arcs_strict[i, "from"] & bn_boot$to == avg_arcs_strict[i, "to"]) if (length(idx) > 0) { bn_adj_strict[from_idx, to_idx] <- bn_boot$strength[idx] } else { bn_adj_strict[from_idx, to_idx] <- 0.85 } } } } pdf(file.path(fig_dir, "Fig5b_Bayesian_Network_Strict.pdf"), width = 10, height = 10) qgraph(bn_adj_strict, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, asize = 6, directed = TRUE, arrows = TRUE, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = "Bayesian Network (Bootstrap, threshold=0.85)", edge.labels = TRUE, edge.label.cex = 0.7, posCol = "#8E44AD", fade = TRUE, minimum = 0) dev.off() # --- 7f. HC vs Tabu一致性分析 --- cat("\n--- 7f. HC vs Tabu 一致性 ---\n") hc_arcs_set <- paste(arcs(bn_hc)[, 1], "->", arcs(bn_hc)[, 2]) tabu_arcs_set <- paste(arcs(bn_tabu)[, 1], "->", arcs(bn_tabu)[, 2]) common_arcs <- intersect(hc_arcs_set, tabu_arcs_set) hc_only <- setdiff(hc_arcs_set, tabu_arcs_set) tabu_only <- setdiff(tabu_arcs_set, hc_arcs_set) cat("共同弧:", length(common_arcs), "\n") cat("仅HC:", length(hc_only), "\n") cat("仅Tabu:", length(tabu_only), "\n") if (length(common_arcs) > 0) cat("共同弧:", paste(common_arcs, collapse = "; "), "\n") consistency_df <- data.frame( Metric = c("Total HC arcs", "Total Tabu arcs", "Common arcs", "HC-only arcs", "Tabu-only arcs", "Jaccard similarity"), Value = c(length(hc_arcs_set), length(tabu_arcs_set), length(common_arcs), length(hc_only), length(tabu_only), round(length(common_arcs) / length(union(hc_arcs_set, tabu_arcs_set)), 3)) ) write_xlsx(consistency_df, file.path(table_dir, "Table7_BN_Algorithm_Consistency.xlsx")) # ============================================================================ # 8. 网络连通性传播指标 (Network Connectivity Propagation Metrics) # 原名为 网络干预模拟 但本模块自始至终没有做任何模拟 # 一步指标 rowSums(abs(W)) 与 strength 逐字相同 # 净效应 rowSums(W) 就是 expected influence # 因此这里只把它当作 网络连通性描述 不作干预效应解释 # 真正的 do(X) 干预效应见返修脚本 code_revision1 的模块R9 # ============================================================================ cat("\n========== 模块8: 网络连通性传播指标 ==========\n") cat("提醒 本模块是网络参数的代数汇总 不是干预模拟 不可作因果解释\n") # --- 8a. 一步连通性 (One-Step Connectivity) --- # 节点 i 与其邻居之间边权的代数汇总 按行取和 one_step_effect <- matrix(0, nrow = ncol(net_data), ncol = ncol(net_data), dimnames = list(node_labels, node_labels)) for (i in 1:ncol(net_data)) { for (j in 1:ncol(net_data)) { if (i != j) { one_step_effect[i, j] <- weight_matrix[i, j] # 偏相关就是预期影响 } } } # 列名按其真实含义命名 数值与原脚本完全一致 只是不再叫 effect intervention_effect <- data.frame( Node = node_labels, FullName = node_fullnames, Group = node_groups, Sum_positive_weights = round(rowSums(pmax(weight_matrix, 0)), 4), Sum_negative_weights = round(rowSums(pmin(weight_matrix, 0)), 4), Net_Effect = round(rowSums(weight_matrix), 4), Abs_Total_Effect = round(rowSums(abs(weight_matrix)), 4), row.names = NULL ) cat("\n一步连通性:\n") print(intervention_effect[order(-intervention_effect$Abs_Total_Effect), ]) ## 逐列定义随表一起存 避免正文再把 1.301 说成 干预后的预期变化 metric_definition <- data.frame( Column = c("Sum_positive_weights", "Sum_negative_weights", "Net_Effect", "Abs_Total_Effect", "Two_Step_Abs_Total", "Combined_Effect"), Definition = c( "Row sum of positive regularized partial correlations", "Row sum of negative regularized partial correlations", "Row sum of signed weights; numerically identical to expected influence", "Row sum of absolute weights; numerically identical to strength centrality", "Row sum of absolute values of the squared weight matrix, diagonal removed", "Abs_Total_Effect + Two_Step_Abs_Total"), Note = "Algebraic summaries of network parameters. They are not simulated intervention effects and carry no causal meaning.", stringsAsFactors = FALSE ) write_xlsx(list(Connectivity = intervention_effect, Definitions = metric_definition), file.path(table_dir, "Table8_Intervention_Effects.xlsx")) # --- 8b. 二步传播模拟 --- # 矩阵乘法: W^2 给出二步间接效应 cat("\n--- 二步间接效应 ---\n") two_step_matrix <- weight_matrix %*% weight_matrix diag(two_step_matrix) <- 0 # 去除自环 two_step_effect <- data.frame( Node = node_labels, FullName = node_fullnames, Two_Step_Abs_Total = round(rowSums(abs(two_step_matrix)), 4), Two_Step_Net = round(rowSums(two_step_matrix), 4), row.names = NULL ) cat("\n二步传播效应:\n") print(two_step_effect[order(-two_step_effect$Two_Step_Abs_Total), ]) write_xlsx(two_step_effect, file.path(table_dir, "Table9_Two_Step_Propagation.xlsx")) # --- 8c. 综合干预效应（一步+二步）--- combined_effect <- data.frame( Node = node_labels, FullName = node_fullnames, Group = node_groups, One_Step_Effect = intervention_effect$Abs_Total_Effect, Two_Step_Effect = two_step_effect$Two_Step_Abs_Total, Combined_Effect = round(intervention_effect$Abs_Total_Effect + two_step_effect$Two_Step_Abs_Total, 4), row.names = NULL ) combined_effect <- combined_effect[order(-combined_effect$Combined_Effect), ] cat("\n综合干预效应排名:\n") print(combined_effect) write_xlsx(combined_effect, file.path(table_dir, "Table10_Combined_Intervention_Ranking.xlsx")) # --- 8d. 干预模拟可视化 --- # 条形图：综合干预效应（分组柱状图） pdf(file.path(fig_dir, "Fig6_Intervention_Simulation.pdf"), width = 10, height = 7) plot_data <- combined_effect plot_data$Node <- factor(plot_data$Node, levels = plot_data$Node) # 转为长格式做分组柱状图 plot_long <- rbind( data.frame(Node = plot_data$Node, Effect = plot_data$One_Step_Effect, Type = "One-Step (Direct)"), data.frame(Node = plot_data$Node, Effect = plot_data$Two_Step_Effect, Type = "Two-Step (Indirect)") ) plot_long$Node <- factor(plot_long$Node, levels = levels(plot_data$Node)) plot_long$Type <- factor(plot_long$Type, levels = c("One-Step (Direct)", "Two-Step (Indirect)")) p_intervention <- ggplot() + geom_bar(data = plot_long, aes(x = Node, y = Effect, fill = Type), stat = "identity", position = position_dodge(width = 0.7), width = 0.65, alpha = 0.85) + geom_point(data = plot_data, aes(x = Node, y = Combined_Effect, color = "Combined"), size = 3.5, shape = 18) + geom_line(data = plot_data, aes(x = Node, y = Combined_Effect, group = 1, color = "Combined"), linewidth = 0.8, linetype = "dashed") + scale_fill_manual(values = c("One-Step (Direct)" = "#3498DB", "Two-Step (Indirect)" = "#E74C3C")) + scale_color_manual(values = c("Combined" = "#2C3E50")) + labs(title = "Network Connectivity Propagation Metrics", subtitle = "One-step and two-step sums of absolute edge weights (not simulated interventions)", x = "Node", y = "Sum of absolute weights", fill = "Effect Type", color = "") + theme_minimal(base_size = 13) + theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "bottom") print(p_intervention) dev.off() # 热力图：节点间一步传播 pdf(file.path(fig_dir, "Fig6b_Intervention_Heatmap.pdf"), width = 9, height = 8) melt_w <- melt(weight_matrix) colnames(melt_w) <- c("Source", "Target", "Effect") ggplot(melt_w, aes(x = Target, y = Source, fill = Effect)) + geom_tile(color = "white") + geom_text(aes(label = round(Effect, 2)), size = 3) + scale_fill_gradient2(low = "#3498DB", mid = "white", high = "#E74C3C", midpoint = 0, name = "Edge Weight") + labs(title = "Regularized Partial Correlation Matrix", subtitle = "Edge weights of the estimated GGM (not simulated intervention effects)", x = "Node", y = "Node") + theme_minimal(base_size = 12) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) dev.off() cat("干预模拟图已保存\n") # ============================================================================ # 9. GGM与BN比较可视化 (GGM vs BN Comparison) # ============================================================================ cat("\n========== 模块9: GGM与BN比较 ==========\n") pdf(file.path(fig_dir, "Fig7_GGM_vs_BN_Comparison.pdf"), width = 16, height = 8) par(mfrow = c(1, 2)) # 左：GGM (无向) qgraph(weight_matrix, layout = layout_fixed, labels = node_labels, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, border.width = 1.5, title = "A) GGM (Undirected)", posCol = "#E74C3C", negCol = "#3498DB", fade = TRUE, minimum = 0) # 右：BN (有向) qgraph(bn_adj, layout = layout_fixed, labels = node_labels, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, asize = 6, directed = TRUE, arrows = TRUE, border.width = 1.5, title = "B) BN (Directed, Bootstrap Averaged)", posCol = "#8E44AD", fade = TRUE, minimum = 0) dev.off() cat("GGM vs BN比较图已保存\n") # ============================================================================ # 10. Bootstrap稳定性分析 (Bootstrap Stability) # ============================================================================ cat("\n========== 模块10: Bootstrap稳定性分析 ==========\n") # --- 10a. 边权重置信区间 (Nonparametric bootstrap) --- cat("开始非参数bootstrap（边权重CI）...\n") boot_nonparam <- bootnet( network_result, nBoots = 1000, type = "nonparametric", nCores = 1, statistics = c("edge", "strength", "expectedInfluence") ) # 边权重CI图 pdf(file.path(fig_dir, "Fig8a_Bootstrap_Edge_CI.pdf"), width = 12, height = 10) plot(boot_nonparam, labels = TRUE, order = "sample", statistics = "edge") + theme_minimal(base_size = 10) dev.off() # --- 10b. 中心性稳定性 (Case-dropping bootstrap) --- cat("开始case-dropping bootstrap（中心性稳定性）...\n") boot_casedrop <- bootnet( network_result, nBoots = 1000, type = "case", nCores = 1, statistics = c("strength", "closeness", "betweenness", "expectedInfluence") ) # CS系数 cs_results <- corStability(boot_casedrop) cat("\nCS-Coefficient (稳定性系数):\n") print(cs_results) # 中心性稳定性图 — 主图仅展示稳定指标 pdf(file.path(fig_dir, "Fig8b_Centrality_Stability.pdf"), width = 8, height = 8) plot(boot_casedrop, statistics = c("strength", "expectedInfluence")) + theme_minimal(base_size = 11) dev.off() # 补充：全部4个指标的稳定性图（放入附录，展示Betweenness/Closeness不稳定） pdf(file.path(fig_dir, "FigS_Centrality_Stability_All.pdf"), width = 8, height = 10) plot(boot_casedrop, statistics = c("strength", "closeness", "betweenness", "expectedInfluence")) + theme_minimal(base_size = 11) dev.off() # 保存CS系数 cs_df <- data.frame( Measure = names(cs_results), CS_Coefficient = round(as.numeric(cs_results), 3) ) write_xlsx(cs_df, file.path(table_dir, "Table11_CS_Coefficients.xlsx")) cat("CS系数:\n") print(cs_df) cat("推荐: CS ≥ 0.25 可解释, CS ≥ 0.5 为佳\n") # ============================================================================ # 11. 边差异与中心性差异检验 (Difference Tests) # ============================================================================ cat("\n========== 模块11: 边差异与中心性差异检验 ==========\n") # 边权重差异检验 pdf(file.path(fig_dir, "Fig9a_Edge_Difference_Test.pdf"), width = 10, height = 10) plot(boot_nonparam, "edge", plot = "difference", onlyNonZero = TRUE, order = "sample") dev.off() # 中心性差异检验（Strength） pdf(file.path(fig_dir, "Fig9b_Strength_Difference_Test.pdf"), width = 10, height = 10) plot(boot_nonparam, "strength", plot = "difference", order = "sample") dev.off() # 中心性差异检验（Expected Influence） pdf(file.path(fig_dir, "Fig9c_EI_Difference_Test.pdf"), width = 10, height = 10) plot(boot_nonparam, "expectedInfluence", plot = "difference", order = "sample") dev.off() cat("差异检验图已保存\n") # ============================================================================ # 12. 全局网络指标 (Global Network Metrics) # ============================================================================ cat("\n========== 模块12: 全局网络指标 ==========\n") # 转为igraph对象 注意这里用的是边权绝对值 负边同样计入连接强度 net_igraph <- graph_from_adjacency_matrix( abs(weight_matrix), mode = "undirected", weighted = TRUE, diag = FALSE ) # 删除零边 net_igraph <- delete_edges(net_igraph, which(E(net_igraph)$weight == 0)) ## igraph 新旧版本函数名兼容 graph.density 与 erdos.renyi.game 已被弃用 ig_density <- if (exists("edge_density", where = asNamespace("igraph"))) igraph::edge_density else igraph::graph.density ig_gnm <- function(n, m) { if (exists("sample_gnm", where = asNamespace("igraph"))) igraph::sample_gnm(n, m) else igraph::erdos.renyi.game(n, m, type = "gnm") } nv <- vcount(net_igraph) ne <- ecount(net_igraph) ## 关键 igraph 1.3 起 mean_distance 对带 weight 属性的图默认按权算距离 ## 求无权最短路必须显式写 weights = NA 否则会算出小于 1 的荒唐值 C_obs <- transitivity(net_igraph, type = "global") L_unw <- mean_distance(net_igraph, weights = NA) L_inv_w <- mean_distance(net_igraph, weights = 1 / E(net_igraph)$weight) ## 小世界指数 原写法只抽 1 张随机图 而且 C 与 L 取自两张不同的随机图 ## 此处改为同一张随机图上同时取 C 与 L 重复 n_random_graphs 次取均值 ## 本段消耗随机数 用完把 .Random.seed 还原 保证后续与原脚本的随机流完全一致 seed_backup <- if (exists(".Random.seed", envir = .GlobalEnv)) get(".Random.seed", envir = .GlobalEnv) else NULL C_rand <- numeric(n_random_graphs) L_rand <- numeric(n_random_graphs) for (b in seq_len(n_random_graphs)) { g_rand <- ig_gnm(nv, ne) C_rand[b] <- transitivity(g_rand, type = "global") L_rand[b] <- mean_distance(g_rand, weights = NA) } sigma_sw <- (C_obs / mean(C_rand, na.rm = TRUE)) / (L_unw / mean(L_rand, na.rm = TRUE)) if (!is.null(seed_backup)) assign(".Random.seed", seed_backup, envir = .GlobalEnv) global_metrics <- data.frame( Metric = c("Number of nodes", "Number of edges", "Network density", "Global strength (sum of |w|)", "Mean absolute edge weight", "SD of absolute edge weight", "Max absolute edge weight", "Clustering coefficient (global, unweighted)", "Average shortest path length (unweighted)", "Average shortest path length (1/|w| as distance)", paste0("Mean clustering of ", n_random_graphs, " random graphs"), paste0("Mean path length of ", n_random_graphs, " random graphs"), "Small-worldness index (sigma)"), Value = c( nv, ne, round(ig_density(net_igraph), 4), round(sum(abs(weight_matrix[upper.tri(weight_matrix)])), 4), round(mean(abs(weight_matrix[upper.tri(weight_matrix) & weight_matrix != 0])), 4), round(sd(abs(weight_matrix[upper.tri(weight_matrix) & weight_matrix != 0])), 4), round(max(abs(weight_matrix[upper.tri(weight_matrix)])), 4), round(C_obs, 4), round(L_unw, 4), round(L_inv_w, 4), round(mean(C_rand, na.rm = TRUE), 4), round(mean(L_rand, na.rm = TRUE), 4), round(sigma_sw, 4) ), stringsAsFactors = FALSE ) global_note <- data.frame( Item = c("Edge weights", "Path length", "Small-worldness", "Interpretation"), Note = c( "All graph-theoretical indices are computed on absolute edge weights, so negative (protective) edges contribute to connectivity in the same way as positive ones.", "Unweighted path length treats every retained edge as one step. The 1/|w| version treats weak edges as long distances and is reported for comparability with the earlier version of this table only.", paste0("Sigma is the ratio of observed to random clustering divided by the ratio of observed to random path length, averaged over ", n_random_graphs, " Erdos-Renyi graphs with the same number of nodes and edges."), "With 33 of 36 possible edges retained the network is nearly complete, so path-based and small-world indices carry little information and should not be over-interpreted."), stringsAsFactors = FALSE ) cat("\n全局网络指标:\n") print(global_metrics) if (!is.na(L_unw) && L_unw < 1) cat("！无权平均路径长度算出小于 1 说明 igraph 仍在按边权算距离 请核对版本\n") cat("说明 密度已达", round(ig_density(net_igraph), 3), " 接近完全图 路径长与小世界指数无实质信息 正文不宜展开解释\n") write_xlsx(list(Global_metrics = global_metrics, Notes = global_note), file.path(table_dir, "Table12_Global_Network_Metrics.xlsx")) # ============================================================================ # 13. JD-R理论分组网络图 (JD-R Grouped Network) # ============================================================================ cat("\n========== 模块13: JD-R理论分组网络图 ==========\n") pdf(file.path(fig_dir, "Fig10_JDR_Grouped_Network.pdf"), width = 12, height = 10) qgraph(weight_matrix, layout = "spring", labels = node_labels, nodeNames = node_fullnames, groups = list( "Burnout" = c(1, 2, 3), "Social Support" = c(4, 5, 6), "Occupational Stress" = c(7, 8), "Insomnia" = c(9) ), color = c("#E74C3C", "#3498DB", "#F39C12", "#2ECC71"), theme = "colorblind", vsize = 11, esize = 8, border.width = 1.5, legend = TRUE, legend.cex = 0.6, title = "Network Structure by JD-R Framework", posCol = "#E74C3C", negCol = "#3498DB", fade = TRUE, cut = 0, minimum = 0, pie = r2_values[, "R2"], pieColor = "#2C3E50") dev.off() cat("JD-R分组网络图已保存\n") # ============================================================================ # 14. 最强边汇总 (Strongest Edges Summary) # ============================================================================ cat("\n========== 模块14: 最强边汇总 ==========\n") # 提取所有非零边 edges_list <- data.frame() for (i in 1:(ncol(weight_matrix) - 1)) { for (j in (i + 1):ncol(weight_matrix)) { if (weight_matrix[i, j] != 0) { edges_list <- rbind(edges_list, data.frame( Node1 = node_labels[i], Node2 = node_labels[j], Weight = round(weight_matrix[i, j], 4), AbsWeight = round(abs(weight_matrix[i, j]), 4), Type = ifelse(weight_matrix[i, j] > 0, "Positive", "Negative"), CrossGroup = ifelse(node_groups[i] != node_groups[j], "Between", "Within") )) } } } edges_list <- edges_list[order(-edges_list$AbsWeight), ] cat("\n所有非零边（按绝对权重排序）:\n") print(edges_list) write_xlsx(edges_list, file.path(table_dir, "Table13_Edge_List.xlsx")) # ============================================================================ # 返修分析模块 (Revision Modules) —— 与审稿意见一一对应 # # 编号规则 # R1M1a / R1M1b / R1M1c 审稿人1 主要意见1 的三个小问 # R1M2 审稿人1 主要意见2 因果措辞与 do(X) # R1m2 / R1m3 / R1m4 / R1m5 审稿人1 小问题 2 3 4 5 # R2G1 / R2G2 / R2G3 审稿人2 总评 样本量与精度 控制变量 Jaccard # R2Q4 ... R2Q9 审稿人2 编号意见 # # 输出全部落在 network_results/revision/ 下 不覆盖主分析的任何结果 # # 随机数纪律 # 本段开头先把 .Random.seed 存起来 结尾原样还原 # 所以无论本段跑不跑 模块15 与模块16 的九项自检数值都不会变 # 本段内部每处用到随机数的地方都单独 set.seed 不依赖上文的随机流 # ============================================================================ cat("\n\n") cat("################################################################\n") cat(" 返修模块开始 \n") cat("################################################################\n") ## --- 输出目录 --- rev_dir <- file.path(output_dir, "revision") rev_table_dir <- file.path(rev_dir, "tables") rev_fig_dir <- file.path(rev_dir, "figures") dir.create(rev_table_dir, recursive = TRUE, showWarnings = FALSE) dir.create(rev_fig_dir, recursive = TRUE, showWarnings = FALSE) ## --- 随机数状态备份 --- seed_backup <- if (exists(".Random.seed")) .Random.seed else NULL ## --- 本段可调参数 --- ## 先用 200 快速跑通全流程 确认无报错后改回 1000 出正式结果 R_boot_rev <- 1000 # 返修模块里 boot.strength 的重抽次数 k_cv <- 10 # 交叉验证折数 seed_rev <- 20260814 # 返修模块统一种子 与主分析的 2024 分开 ## --- nonparanormal 变换所需的 huge 包 --- if (!requireNamespace("huge", quietly = TRUE)) try(install.packages("huge", repos = "https://cloud.r-project.org"), silent = TRUE) has_huge <- requireNamespace("huge", quietly = TRUE) if (!has_huge) cat("提示 huge 包不可用 R1M1c 将改用秩-正态得分变换 结论方向不变\n") ## --- 小工具 --- p_nodes <- length(node_labels) ## 上三角向量化 用于两个网络之间比较边权 upper_vec <- function(m) m[upper.tri(m)] ## 逻辑邻接矩阵 adj_from_w <- function(w) { a <- (w != 0); diag(a) <- FALSE; a } ## 边集合 无向 用于 Jaccard edge_set_undirected <- function(w) { idx <- which(upper.tri(w) & w != 0, arr.ind = TRUE) if (nrow(idx) == 0) return(character(0)) apply(idx, 1, function(r) paste(sort(c(node_labels[r[1]], node_labels[r[2]])), collapse = "--")) } ## bn 对象的弧集合 有向与无向两种 arc_set_directed <- function(bn) { a <- bnlearn::arcs(bn) if (nrow(a) == 0) return(character(0)) paste(a[, 1], "->", a[, 2]) } arc_set_skeleton <- function(bn) { a <- bnlearn::arcs(bn) if (nrow(a) == 0) return(character(0)) unique(apply(a, 1, function(r) paste(sort(r), collapse = "--"))) } jaccard <- function(s1, s2) { u <- length(union(s1, s2)) if (u == 0) return(NA_real_) round(length(intersect(s1, s2)) / u, 3) } ## 调整兰德指数 用于社区还原度 避免额外依赖 mclust adj_rand_index <- function(a, b) { tab <- table(a, b) n <- sum(tab) if (n < 2) return(NA_real_) sum_ij <- sum(choose(tab, 2)) sum_i <- sum(choose(rowSums(tab), 2)) sum_j <- sum(choose(colSums(tab), 2)) expect <- sum_i * sum_j / choose(n, 2) maxi <- (sum_i + sum_j) / 2 round((sum_ij - expect) / (maxi - expect), 3) } ## 秩-正态得分变换 huge 不可用时的替代 rank_to_normal <- function(x) qnorm((rank(x, ties.method = "average") - 0.5) / length(x)) ## 结构 -> 样本外预测 R2 的通用交叉验证 ## 只用结构 在训练集上对每个节点按其邻居做无惩罚 lm 再预测测试集 ## 这是回答 审稿人2 第7点 过拟合与否 的直接统计量 cv_out_of_sample_r2 <- function(dat, struct_fun, k = k_cv, seed = seed_rev) { set.seed(seed) n <- nrow(dat); p <- ncol(dat) folds <- sample(rep(seq_len(k), length.out = n)) sse <- rep(0, p); sst <- rep(0, p) for (f in seq_len(k)) { tr <- dat[folds != f, , drop = FALSE] te <- dat[folds == f, , drop = FALSE] A <- struct_fun(tr) for (i in seq_len(p)) { nb <- which(A[i, ]) if (length(nb) == 0) { pred <- rep(mean(tr[[i]]), nrow(te)) } else { d <- data.frame(.y = tr[[i]], tr[, nb, drop = FALSE]) m <- lm(.y ~ ., data = d) pred <- as.numeric(predict(m, newdata = te[, nb, drop = FALSE])) } sse[i] <- sse[i] + sum((te[[i]] - pred)^2) sst[i] <- sst[i] + sum((te[[i]] - mean(tr[[i]]))^2) } } setNames(round(1 - sse / sst, 4), colnames(dat)) } ## 把一个 GGM 权重矩阵总结成一行 便于横向比较 summarise_network <- function(w, tag) { ct <- centrality(w) data.frame( Model = tag, N_Edges = sum(upper_vec(w) != 0), Density = round(sum(upper_vec(w) != 0) / (p_nodes * (p_nodes - 1) / 2), 3), Mean_Abs_W = round(mean(abs(upper_vec(w)[upper_vec(w) != 0])), 4), Max_Abs_W = round(max(abs(upper_vec(w))), 4), Top3_Strength = paste(node_labels[order(-ct$InDegree)][1:3], collapse = " > "), Top3_EI = paste(node_labels[order(-ct$InExpectedInfluence)][1:3], collapse = " > "), stringsAsFactors = FALSE ) } ## 两个网络的一致性 一行 compare_networks <- function(w1, w2, tag) { c1 <- centrality(w1); c2 <- centrality(w2) data.frame( Comparison = tag, Edge_weight_r = round(cor(upper_vec(w1), upper_vec(w2)), 3), Edge_weight_rho = round(cor(upper_vec(w1), upper_vec(w2), method = "spearman"), 3), Edge_set_Jaccard = jaccard(edge_set_undirected(w1), edge_set_undirected(w2)), Strength_rank_rho = round(cor(c1$InDegree, c2$InDegree, method = "spearman"), 3), EI_rank_rho = round(cor(c1$InExpectedInfluence, c2$InExpectedInfluence, method = "spearman"), 3), stringsAsFactors = FALSE ) } ## 画一张 GGM 图 共用主分析的 layout 便于肉眼对比 plot_ggm <- function(w, file, main) { pdf(file.path(rev_fig_dir, file), width = 10, height = 10) qgraph(w, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = main, edge.labels = TRUE, edge.label.cex = 0.7, posCol = "#E74C3C", negCol = "#3498DB", fade = TRUE, cut = 0, minimum = 0) dev.off() } ## 画一张 BN 图 plot_bn <- function(adj, file, main) { pdf(file.path(rev_fig_dir, file), width = 10, height = 10) qgraph(adj, layout = layout_fixed, labels = node_labels, nodeNames = node_fullnames, groups = as.factor(node_groups), color = group_colors, theme = "colorblind", vsize = 10, esize = 8, asize = 6, directed = TRUE, arrows = TRUE, border.width = 1.5, legend = TRUE, legend.cex = 0.5, title = main, edge.labels = TRUE, edge.label.cex = 0.7, posCol = "#8E44AD", fade = TRUE, minimum = 0) dev.off() } ## 由 bn 对象与 bootstrap 强度表构造带权有向邻接矩阵 bn_to_adj <- function(bn, boot_tab = NULL) { m <- matrix(0, p_nodes, p_nodes, dimnames = list(node_labels, node_labels)) a <- bnlearn::arcs(bn) if (nrow(a) == 0) return(m) for (i in seq_len(nrow(a))) { fi <- which(node_labels == a[i, 1]); ti <- which(node_labels == a[i, 2]) val <- 1 if (!is.null(boot_tab)) { hit <- which(boot_tab$from == a[i, 1] & boot_tab$to == a[i, 2]) if (length(hit) > 0) val <- boot_tab$strength[hit[1]] } m[fi, ti] <- val } m } ## 在给定数据上学一遍 BN 返回 bootstrap 平均网络与强度表 learn_bn <- function(dat, R = R_boot_rev, seed = seed_rev, thr = 0.5) { set.seed(seed) bt <- bnlearn::boot.strength(dat, R = R, algorithm = "hc", algorithm.args = list(score = "bic-g")) list(boot = bt, avg = bnlearn::averaged.network(bt, threshold = thr)) } ## 全部返修表格集中登记 最后一并写 意见-输出 对照表 rev_outputs <- data.frame(Module = character(0), File = character(0), stringsAsFactors = FALSE) reg_out <- function(mod, file) { rev_outputs <<- rbind(rev_outputs, data.frame(Module = mod, File = file, stringsAsFactors = FALSE)) } # ============================================================================ # R1m3 + R1m5 + R1M2(措辞) 报告量的严格定义表 # 审稿人1 小3 问 edge weight 到底是什么 # 审稿人1 小5 问 1.301 这个数怎么解释 # 这张表直接贴进回信 也可作为正文 Statistical Analysis 的定义脚注 # ============================================================================ cat("\n-------- R1m3 + R1m5 报告量定义表 --------\n") definitions <- data.frame( Quantity = c( "Edge weight", "Strength centrality", "Expected influence", "One-step propagation (formerly 'one-step direct effect')", "Two-step propagation", "Node predictability R2", "Bridge strength / bridge expected influence", "Arc strength (BN)", "Arc direction (BN)", "do(X = -1 SD) effect"), Definition = c( "Regularized partial correlation between two nodes conditional on all other seven nodes; estimated by graphical LASSO with EBIC model selection (gamma = 0.50) on a Spearman correlation input matrix. Range -1 to 1; zero means the edge was set to exactly zero by the LASSO penalty.", "Sum of the absolute edge weights attached to a node (qgraph InDegree). Unit: sum of partial correlations. Not a variance, not an effect size, not an intervention effect.", "Sum of the signed edge weights attached to a node (qgraph InExpectedInfluence).", "Algebraically identical to strength centrality: rowSums(abs(W)). Reported here only as a connectivity descriptor. It is NOT an intervention effect and carries no causal meaning.", "Sum over all two-edge paths of the products of absolute edge weights through one intermediary node. Also a purely algebraic connectivity descriptor.", "Proportion of a node's variance explained by all of its network neighbours simultaneously (mgm). Because same-construct subscales are network neighbours, part of this R2 is measurement-model redundancy; see the within/between decomposition.", "Sum of edge weights linking a node to nodes assigned to other theoretical communities (networktools).", "Proportion of the bootstrap resamples in which the arc appeared in either direction.", "Conditional on the arc appearing, the proportion of resamples supporting the reported direction.", "Change in the model-implied expected value of every other node, in SD units, when the target node is fixed by intervention at -1 SD in the linear Gaussian Bayesian network, computed under Pearl's do-operator on the mutilated graph. This IS an intervention quantity, under the stated causal assumptions."), Reported_in = c( "Fig 1, Table 13 (edge list), Methods 'Network estimation'", "Table 2, Fig 2", "Table 2, Fig 2", "Table 4 (renamed), Fig 4", "Table 4 (renamed), Fig 4", "Table 2, Fig 3", "Table 4 old numbering / bridge table, Fig 4b", "Table 3, Fig 3 (BN)", "Table 3 (BN)", "Revision Table R07"), stringsAsFactors = FALSE ) print(definitions[, c("Quantity", "Reported_in")]) write_xlsx(definitions, file.path(rev_table_dir, "TableR01_Reported_Quantity_Definitions.xlsx")) reg_out("R1m3 / R1m5", "TableR01_Reported_Quantity_Definitions.xlsx") # ============================================================================ # R1m2 + R1m4 计分方式 量程 偏度峰度 # 审稿人1 小2 问维度分怎么算 量程多少 # 审稿人1 小4 说 Table 1 里没有偏度峰度 # 主分析的 Table1 已含 Possible_Range Scoring Skewness Kurtosis 与 Range_Check # 这里只做一件事 把越界情况单独拎出来提醒 不要把错的量程写进正文 # ============================================================================ cat("\n-------- R1m2 + R1m4 计分与量程核对 --------\n") scoring_check <- desc_stats[, c("Abbreviation", "Variable", "Scoring", "Possible_Range", "Min", "Max", "Skewness", "Kurtosis", "Range_Check")] print(scoring_check) write_xlsx(scoring_check, file.path(rev_table_dir, "TableR02_Scoring_and_Range_Check.xlsx")) reg_out("R1m2 / R1m4", "TableR02_Scoring_and_Range_Check.xlsx") cat("\nCPSS 提醒\n") cat(" 正文 Measures 现写 5-point Likert (0 = never to 4) 按此 Tension 与 OutCtrl 量程应为 0-28\n") cat(" 但本数据两个分量表的观测最大值为", max(net_data$Tension), "与", max(net_data$OutCtrl), "\n") cat(" 说明条目实际按 1-5 计分 分量表量程为 7-35\n") cat(" 返修时必须先改正文的计分描述 再补量程列 否则两处自相矛盾\n") # ============================================================================ # R1m2b PA 计分方向自检 # 起因 数据文件的 Codebook 写的是 Personal Accomplishment (NOT reversed) # 并另注 For network analysis, use PA_Reversed file # 但正文 Table 2 的注释写的是 PA = Personal Accomplishment (reverse-scored) # 审稿人1 小2 恰好要求写清每个维度分怎么算 这两处不一致会被看到 # 而且回信承诺随稿提交数据与脚本 码本那句话审稿人是能翻到的 # 做法 不看标签 只看数据表现 直接给出一句可以写进 Measures 的结论 # 本段不消耗随机数 # ============================================================================ cat("\n-------- R1m2b PA 计分方向自检 --------\n") pa_other <- setdiff(node_labels, "PA") pa_cor <- sapply(pa_other, function(v) round(cor(net_data$PA, net_data[[v]], method = "spearman"), 3)) pa_burnout <- mean(pa_cor[c("EE", "DP")]) pa_support <- mean(pa_cor[c("SS_Obj", "SS_Subj", "SS_Util")]) pa_verdict <- if (pa_burnout > 0 && pa_support < 0) { paste("The PA column already runs in the burnout direction", "(higher score = reduced personal accomplishment).", "Describe it in Measures as recorded in the reduced-accomplishment", "direction with no further reversal applied when the sum is formed.") } else if (pa_burnout < 0 && pa_support > 0) { paste("The PA column runs in the efficacy direction", "(higher score = greater personal accomplishment, i.e. NOT reversed).", "The manuscript must then NOT describe PA as reverse-scored,", "and every substantive statement about PA edges has the opposite sign", "to the one currently written.") } else { paste("Ambiguous. Go back to the item-level MBI-GS sheet, check the wording", "of the six PA items, and settle the direction before writing anything", "in Measures.") } pa_dir_tab <- data.frame( Metric = c(paste0("Spearman r PA vs ", names(pa_cor)), "Mean Spearman r with EE and DP", "Mean Spearman r with the three social support nodes", "Observed mean of PA", "Midpoint of the nominal 0-36 range", "Verdict"), Value = c(as.character(pa_cor), as.character(round(pa_burnout, 3)), as.character(round(pa_support, 3)), as.character(round(mean(net_data$PA), 2)), "18", pa_verdict), stringsAsFactors = FALSE ) print(pa_dir_tab) write_xlsx(pa_dir_tab, file.path(rev_table_dir, "TableR02b_PA_Direction_Check.xlsx")) reg_out("R1m2b", "TableR02b_PA_Direction_Check.xlsx") cat("\nPA 提醒\n") cat(" ", pa_verdict, "\n") cat(" 定稿前必须把四处对齐 数据文件 Codebook 正文 Measures Table 2 注释 回信 Minor 2\n") cat(" 回信 Minor 2 现在写的是 all nine nodes are observed sum scores of item raw scores\n") cat(" 若 PA 实际是 36 减去条目原始和 这句话要相应改写 否则与随稿数据对不上\n") # ============================================================================ # R1M1c + R2Q5 正态性检验 与 正态化后重估 GGM 和 BN # 审稿人1 主1第三问 与 审稿人2 第5点 是同一件事 # 审稿人2 原话 如果先把数据正态化 BN 会长成什么样 # 这里给出 单变量 Shapiro-Wilk 多元 Mardia 再用 nonparanormal 变换重估 # ============================================================================ cat("\n-------- R1M1c + R2Q5 正态性与正态化后重估 --------\n") ## --- 1. 单变量与多元正态性检验 --- shapiro_tab <- data.frame( Node = node_labels, FullName = node_fullnames, W = round(sapply(net_data, function(x) shapiro.test(x)$statistic), 4), p = signif(sapply(net_data, function(x) shapiro.test(x)$p.value), 3), Skewness = round(sapply(net_data, psych::skew), 2), Kurtosis = round(sapply(net_data, psych::kurtosi), 2), row.names = NULL ) shapiro_tab$Normal_at_.05 <- ifelse(shapiro_tab$p >= 0.05, "yes", "no") print(shapiro_tab) mardia_row <- tryCatch({ md <- psych::mardia(net_data, plot = FALSE) data.frame(Test = c("Mardia multivariate skewness", "Mardia multivariate kurtosis"), Statistic = round(c(md$b1p, md$b2p), 3), p = signif(c(md$p.skew, md$p.kurt), 3), stringsAsFactors = FALSE) }, error = function(e) data.frame(Test = "Mardia", Statistic = NA, p = NA, stringsAsFactors = FALSE)) print(mardia_row) write_xlsx(list(Univariate = shapiro_tab, Multivariate = mardia_row), file.path(rev_table_dir, "TableR03_Normality_Tests.xlsx")) reg_out("R1M1c / R2Q5", "TableR03_Normality_Tests.xlsx") ## --- 2. nonparanormal 变换 --- if (has_huge) { net_npn <- as.data.frame(huge::huge.npn(as.matrix(net_data), npn.func = "shrinkage", verbose = FALSE)) npn_label <- "nonparanormal (huge, shrinkage)" } else { net_npn <- as.data.frame(lapply(net_data, rank_to_normal)) npn_label <- "rank-based normal scores" } names(net_npn) <- node_labels cat("变换方式:", npn_label, "\n") npn_shapiro <- data.frame( Node = node_labels, W_before = shapiro_tab$W, p_before = shapiro_tab$p, W_after = round(sapply(net_npn, function(x) shapiro.test(x)$statistic), 4), p_after = signif(sapply(net_npn, function(x) shapiro.test(x)$p.value), 3), row.names = NULL ) print(npn_shapiro) ## --- 3. 变换后重估 GGM 用 Pearson 因为已近正态 --- net_result_npn <- estimateNetwork(net_npn, default = "EBICglasso", corMethod = "cor", tuning = 0.5) wmat_npn <- getWmat(net_result_npn) dimnames(wmat_npn) <- list(node_labels, node_labels) ggm_npn_summary <- rbind( summarise_network(weight_matrix, "Reported: EBICglasso, Spearman input"), summarise_network(wmat_npn, paste0("Sensitivity: EBICglasso after ", npn_label)) ) ggm_npn_compare <- compare_networks(weight_matrix, wmat_npn, "Spearman-input vs normalized-input GGM") print(ggm_npn_summary) print(ggm_npn_compare) ## 逐边对照 方便在回信里说清哪几条边变了 edge_npn_tab <- data.frame( Node1 = node_labels[which(upper.tri(weight_matrix), arr.ind = TRUE)[, 1]], Node2 = node_labels[which(upper.tri(weight_matrix), arr.ind = TRUE)[, 2]], W_reported = round(upper_vec(weight_matrix), 4), W_normalized = round(upper_vec(wmat_npn), 4), stringsAsFactors = FALSE ) edge_npn_tab$Status <- with(edge_npn_tab, ifelse( W_reported != 0 & W_normalized != 0, "both", ifelse(W_reported != 0 & W_normalized == 0, "only in reported model", ifelse(W_reported == 0 & W_normalized != 0, "only after normalization", "absent in both")))) edge_npn_tab <- edge_npn_tab[order(-abs(edge_npn_tab$W_reported)), ] plot_ggm(wmat_npn, "FigR01_GGM_after_normalization.pdf", paste0("GGM after ", npn_label, " (gamma = 0.50)")) ## --- 4. 变换后重估 BN 这就是审稿人2 直接问的那张图 --- cat("变换后重跑 BN bootstrap R =", R_boot_rev, " 请耐心等待\n") bn_npn <- learn_bn(net_npn) avg_bn_npn <- bn_npn$avg bn_npn_compare <- data.frame( Metric = c("Arcs in reported BN (raw data)", "Arcs in BN after normalization", "Common directed arcs", "Directed-arc Jaccard", "Skeleton Jaccard", "Arcs only in reported BN", "Arcs only after normalization"), Value = c(bnlearn::narcs(avg_bn), bnlearn::narcs(avg_bn_npn), length(intersect(arc_set_directed(avg_bn), arc_set_directed(avg_bn_npn))), jaccard(arc_set_directed(avg_bn), arc_set_directed(avg_bn_npn)), jaccard(arc_set_skeleton(avg_bn), arc_set_skeleton(avg_bn_npn)), length(setdiff(arc_set_directed(avg_bn), arc_set_directed(avg_bn_npn))), length(setdiff(arc_set_directed(avg_bn_npn), arc_set_directed(avg_bn)))), stringsAsFactors = FALSE ) print(bn_npn_compare) arc_npn_list <- data.frame( Arc = union(arc_set_directed(avg_bn), arc_set_directed(avg_bn_npn)), stringsAsFactors = FALSE ) arc_npn_list$In_reported_BN <- ifelse(arc_npn_list$Arc %in% arc_set_directed(avg_bn), "yes", "no") arc_npn_list$In_normalized_BN <- ifelse(arc_npn_list$Arc %in% arc_set_directed(avg_bn_npn), "yes", "no") adj_npn <- bn_to_adj(avg_bn_npn, bn_npn$boot) plot_bn(round(adj_npn, 2), "FigR02_BN_after_normalization.pdf", paste0("Bayesian network after ", npn_label, " (threshold = 0.50)")) write_xlsx(list(GGM_summary = ggm_npn_summary, GGM_agreement = ggm_npn_compare, GGM_edges = edge_npn_tab, Shapiro_before_after = npn_shapiro, BN_summary = bn_npn_compare, BN_arcs = arc_npn_list), file.path(rev_table_dir, "TableR04_Normalized_Reanalysis.xlsx")) reg_out("R1M1c / R2Q5", "TableR04_Normalized_Reanalysis.xlsx") reg_out("R1M1c / R2Q5", "FigR01_GGM_after_normalization.pdf") reg_out("R1M1c / R2Q5", "FigR02_BN_after_normalization.pdf") # ============================================================================ # R1M1a GGM 与 BN 各自提供了什么独有信息 # 审稿人1 问 有了高斯 BN 之后 GGM 还多告诉了我们什么 # 用一张 36 个节点对的对照表回答 空口论证不如把重叠与不重叠数出来 # ============================================================================ cat("\n-------- R1M1a GGM 与 BN 的信息对应 --------\n") pair_idx <- which(upper.tri(weight_matrix), arr.ind = TRUE) bn_skel <- arc_set_skeleton(avg_bn) bn_arcs <- bnlearn::arcs(avg_bn) pair_tab <- data.frame( Node1 = node_labels[pair_idx[, 1]], Node2 = node_labels[pair_idx[, 2]], GGM_weight = round(upper_vec(weight_matrix), 4), stringsAsFactors = FALSE ) pair_tab$GGM_edge <- ifelse(pair_tab$GGM_weight != 0, "yes", "no") pair_tab$Pair_key <- apply(pair_tab[, c("Node1", "Node2")], 1, function(r) paste(sort(r), collapse = "--")) pair_tab$BN_edge <- ifelse(pair_tab$Pair_key %in% bn_skel, "yes", "no") pair_tab$BN_direction <- sapply(seq_len(nrow(pair_tab)), function(i) { h <- which((bn_arcs[, 1] == pair_tab$Node1[i] & bn_arcs[, 2] == pair_tab$Node2[i]) | (bn_arcs[, 1] == pair_tab$Node2[i] & bn_arcs[, 2] == pair_tab$Node1[i])) if (length(h) == 0) return("") paste(bn_arcs[h[1], 1], "->", bn_arcs[h[1], 2]) }) pair_tab$Agreement <- with(pair_tab, ifelse( GGM_edge == "yes" & BN_edge == "yes", "both", ifelse(GGM_edge == "yes" & BN_edge == "no", "GGM only", ifelse(GGM_edge == "no" & BN_edge == "yes", "BN only", "neither")))) pair_tab$Pair_key <- NULL overlap_summary <- as.data.frame(table(pair_tab$Agreement), stringsAsFactors = FALSE) names(overlap_summary) <- c("Agreement", "N_pairs") print(overlap_summary) cat("Skeleton Jaccard (GGM vs BN):", jaccard(edge_set_undirected(weight_matrix), bn_skel), "\n") ## 每个节点的马尔可夫毯 BN 能给 GGM 给不了的东西之一 avg_dag <- tryCatch(bnlearn::cextend(avg_bn), error = function(e) { cat("cextend 失败 改用 hc 的完全有向图做参数拟合\n") bn_hc }) mb_tab <- data.frame( Node = node_labels, GGM_neighbours = sapply(seq_len(p_nodes), function(i) sum(weight_matrix[i, ] != 0)), BN_parents = sapply(node_labels, function(v) length(bnlearn::parents(avg_dag, v))), BN_children = sapply(node_labels, function(v) length(bnlearn::children(avg_dag, v))), BN_markov_blanket_size = sapply(node_labels, function(v) length(bnlearn::mb(avg_dag, v))), row.names = NULL ) print(mb_tab) write_xlsx(list(Pairwise = pair_tab, Overlap = overlap_summary, Node_level = mb_tab), file.path(rev_table_dir, "TableR05_GGM_vs_BN_Correspondence.xlsx")) reg_out("R1M1a", "TableR05_GGM_vs_BN_Correspondence.xlsx") # ============================================================================ # R1M1b BN 上也算中心性 并与 GGM 的排名比较 # 审稿人1 明确问 为什么中心性只在 GGM 上算 不在 BN 上算 # ============================================================================ cat("\n-------- R1M1b BN 中心性与 GGM 排名比较 --------\n") adj_bin <- (bn_to_adj(avg_bn) != 0) * 1 adj_wt <- bn_to_adj(avg_bn, bn_boot) g_bn <- igraph::graph_from_adjacency_matrix(adj_bin, mode = "directed") bn_cent <- data.frame( Node = node_labels, FullName = node_fullnames, Out_degree = as.integer(rowSums(adj_bin)), In_degree = as.integer(colSums(adj_bin)), Total_degree = as.integer(rowSums(adj_bin) + colSums(adj_bin)), Out_strength_bootweighted = round(rowSums(adj_wt), 3), In_strength_bootweighted = round(colSums(adj_wt), 3), MB_size = mb_tab$BN_markov_blanket_size, Betweenness_directed = round(igraph::betweenness(g_bn, directed = TRUE), 3), GGM_Strength = round(cent_obj$InDegree, 4), GGM_EI = round(cent_obj$InExpectedInfluence, 4), row.names = NULL ) print(bn_cent) rank_agree <- data.frame( Comparison = c("BN out-degree vs GGM strength", "BN total degree vs GGM strength", "BN Markov blanket size vs GGM strength", "BN out-strength vs GGM expected influence"), Spearman_rho = c( round(cor(bn_cent$Out_degree, bn_cent$GGM_Strength, method = "spearman"), 3), round(cor(bn_cent$Total_degree, bn_cent$GGM_Strength, method = "spearman"), 3), round(cor(bn_cent$MB_size, bn_cent$GGM_Strength, method = "spearman"), 3), round(cor(bn_cent$Out_strength_bootweighted, bn_cent$GGM_EI, method = "spearman"), 3)), stringsAsFactors = FALSE ) print(rank_agree) pdf(file.path(rev_fig_dir, "FigR03_BN_centrality.pdf"), width = 9, height = 7) bn_long <- reshape2::melt(bn_cent[, c("Node", "Out_degree", "In_degree", "MB_size")], id.vars = "Node") print( ggplot(bn_long, aes(x = reorder(Node, value), y = value)) + geom_col(fill = "#8E44AD") + coord_flip() + facet_wrap(~ variable, scales = "free_x") + labs(x = NULL, y = NULL, title = "Centrality in the bootstrap-averaged Bayesian network") + theme_minimal(base_size = 12) ) dev.off() write_xlsx(list(BN_centrality = bn_cent, Rank_agreement = rank_agree), file.path(rev_table_dir, "TableR06_BN_Centrality.xlsx")) reg_out("R1M1b", "TableR06_BN_Centrality.xlsx") reg_out("R1M1b", "FigR03_BN_centrality.pdf") # ============================================================================ # R1M2 + R2Q8 真正的 do(X) 干预效应 # 审稿人1 主2 要求区分 网络影响指标 与 do(X = x) 意义上的干预效应 # 审稿人2 第8点 追问 现实里治疗能只作用于一个节点吗 # 做法 在 bootstrap 平均 DAG 上按标准化数据拟合线性高斯参数 # 再按拓扑序解析计算 do(X = -1 SD) 对其余各节点期望值的改变 # 这是精确解 不用抽样 因此不消耗随机数 # ============================================================================ cat("\n-------- R1M2 + R2Q8 do(X) 干预效应 --------\n") net_z <- as.data.frame(scale(net_data)) names(net_z) <- node_labels fit_z <- bnlearn::bn.fit(avg_dag, data = net_z) ## 给定一组被干预节点的取值 按拓扑序推期望值 expected_under_do <- function(fit, dag, fixed) { ord <- bnlearn::node.ordering(dag) mu <- setNames(rep(NA_real_, length(ord)), ord) for (nd in ord) { if (nd %in% names(fixed)) { mu[nd] <- fixed[[nd]]; next } cf <- coef(fit[[nd]]) pa <- setdiff(names(cf), "(Intercept)") m <- as.numeric(cf[["(Intercept)"]]) if (length(pa) > 0) m <- m + sum(as.numeric(cf[pa]) * mu[pa]) mu[nd] <- m } mu[node_labels] } do_effect <- function(fit, dag, targets, value = -1) { fx0 <- as.list(setNames(rep(0, length(targets)), targets)) fx1 <- as.list(setNames(rep(value, length(targets)), targets)) expected_under_do(fit, dag, fx1) - expected_under_do(fit, dag, fx0) } do_mat <- t(sapply(node_labels, function(v) do_effect(fit_z, avg_dag, v, -1))) dimnames(do_mat) <- list(node_labels, node_labels) do_tab <- as.data.frame(round(do_mat, 4)) do_tab <- cbind(Intervened_node = node_labels, do_tab) do_tab$Total_abs_effect_on_others <- round( sapply(seq_len(p_nodes), function(i) sum(abs(do_mat[i, -i]))), 4) do_tab$Effect_on_EE <- round(do_mat[, "EE"], 4) do_tab$Downstream_nodes <- sapply(seq_len(p_nodes), function(i) sum(abs(do_mat[i, -i]) > 1e-8)) cat("\ndo(X = -1 SD) 对其余节点期望值的改变 单位为 SD\n") print(do_tab[, c("Intervened_node", "Total_abs_effect_on_others", "Downstream_nodes", "Effect_on_EE")]) ## 关键对照 关联指标排名 与 干预效应排名 是两回事 do_vs_assoc <- data.frame( Node = node_labels, Strength_reported = round(cent_obj$InDegree, 4), Strength_rank = rank(-cent_obj$InDegree, ties.method = "min"), Do_total_abs = do_tab$Total_abs_effect_on_others, Do_rank = rank(-do_tab$Total_abs_effect_on_others, ties.method = "min"), stringsAsFactors = FALSE ) do_vs_assoc$Rank_shift <- do_vs_assoc$Strength_rank - do_vs_assoc$Do_rank rho_do <- round(cor(do_vs_assoc$Strength_reported, do_vs_assoc$Do_total_abs, method = "spearman"), 3) cat("\nStrength 与 do 效应总量的 Spearman rho =", rho_do, "\n") cat("若 rho 明显小于 1 或存在排名互换 则正文不能再用 strength 充当干预效应\n") print(do_vs_assoc) ## 多节点联合干预 回答 治疗不可能只打一个节点 joint_sets <- list( "EE only" = "EE", "Tension only" = "Tension", "EE + Tension" = c("EE", "Tension"), "EE + Tension + OutCtrl" = c("EE", "Tension", "OutCtrl"), "All three burnout nodes" = c("EE", "DP", "PA") ) joint_tab <- do.call(rbind, lapply(names(joint_sets), function(nm) { tg <- joint_sets[[nm]] eff <- do_effect(fit_z, avg_dag, tg, -1) data.frame(Intervention = nm, Nodes_fixed = paste(tg, collapse = " + "), Effect_on_ISI = round(eff[["ISI"]], 4), Effect_on_EE = round(eff[["EE"]], 4), Total_abs_effect_on_non_targets = round(sum(abs(eff[setdiff(node_labels, tg)])), 4), stringsAsFactors = FALSE) })) print(joint_tab) pdf(file.path(rev_fig_dir, "FigR04_do_intervention_heatmap.pdf"), width = 9, height = 7) do_long <- reshape2::melt(do_mat) names(do_long) <- c("Intervened", "Outcome", "Effect") print( ggplot(do_long, aes(x = Outcome, y = Intervened, fill = Effect)) + geom_tile(color = "white") + geom_text(aes(label = sprintf("%.2f", Effect)), size = 3) + scale_fill_gradient2(low = "#3498DB", mid = "white", high = "#E74C3C", midpoint = 0) + labs(title = "Model-implied effect of do(node = -1 SD) on every other node", subtitle = "Linear Gaussian Bayesian network; SD units; assumes the DAG is causally correct", x = "Outcome node", y = "Intervened node") + theme_minimal(base_size = 11) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) ) dev.off() do_caveat <- data.frame( Assumption = c( "Causal sufficiency", "Correct DAG", "Linearity and Gaussianity", "Single-node manipulability", "Cross-sectional data", "Interpretation"), Statement = c( "No unmeasured common cause of any two nodes. With four self-report constructs measured at one occasion this is not plausible; the do-values are therefore illustrative, not effect estimates.", "The bootstrap-averaged DAG is treated as the true causal graph. Several arc directions had direction probabilities near 0.50, so the direction itself is uncertain.", "Effects are computed from linear Gaussian conditional distributions and are additive across simultaneously fixed nodes by construction.", "Fixing one node while leaving all others free is a modelling device. No real workplace or psychotherapeutic intervention acts on exactly one node, which is why the joint-intervention rows are reported alongside.", "Directionality is not established by the design; do-values inherit all limitations of the cross-sectional DAG.", "Report as hypothesis-generating. Do NOT describe strength or expected influence as intervention effects anywhere in the manuscript."), stringsAsFactors = FALSE ) write_xlsx(list(Do_effect_matrix = do_tab, Do_vs_association = do_vs_assoc, Joint_interventions = joint_tab, Assumptions = do_caveat), file.path(rev_table_dir, "TableR07_do_Intervention_Effects.xlsx")) reg_out("R1M2 / R2Q8", "TableR07_do_Intervention_Effects.xlsx") reg_out("R1M2 / R2Q8", "FigR04_do_intervention_heatmap.pdf") # ============================================================================ # R2Q7a BN 的模型选择证据 # 审稿人2 问 每节点最大父节点数怎么定 用什么统计量比较 1 vs 2 vs 3 vs 4 # 给出 maxp x score 的网格 报告网络分数与 10 折交叉验证的期望损失 # ============================================================================ cat("\n-------- R2Q7a BN 模型选择 maxp 与 score 网格 --------\n") get_cv_loss <- function(cv) { pick <- function(z) { if (!is.null(attr(z, "mean"))) return(as.numeric(attr(z, "mean"))) mean(sapply(z, function(f) f$loss)) } if (inherits(cv, "bn.kcv.list")) mean(sapply(cv, pick)) else pick(cv) } ## 交叉验证损失名的候选 见下面 bn.cv 处的说明 cv_loss_candidates <- c("logl-g", "logl") ## 同理 高斯网络的对数似然分数名在不同版本里也可能不同 逐个试 score_any <- function(fit, types) { for (ty in types) { v <- tryCatch(bnlearn::score(fit, net_data, type = ty), error = function(e) NULL) if (!is.null(v)) return(v) } NA_real_ } cv_loss_used <- NA_character_ maxp_grid <- expand.grid(maxp = c(1, 2, 3, 4, p_nodes - 1), score = c("bic-g", "bge"), stringsAsFactors = FALSE) bn_select <- data.frame() for (r in seq_len(nrow(maxp_grid))) { m <- maxp_grid$maxp[r]; s <- maxp_grid$score[r] res <- tryCatch({ fit_m <- bnlearn::hc(net_data, score = s, maxp = m) ## bnlearn 的连续型对数似然损失名在不同版本里不一样 ## 旧版叫 logl-g 5.x 起改叫 logl 两个都试一遍再报错 cv <- NULL ln_try <- if (is.na(cv_loss_used)) cv_loss_candidates else unique(c(cv_loss_used, cv_loss_candidates)) for (ln in ln_try) { cv <- tryCatch({ set.seed(seed_rev) bnlearn::bn.cv(net_data, bn = "hc", k = k_cv, runs = 3, algorithm.args = list(score = s, maxp = m), loss = ln) }, error = function(e) NULL) if (!is.null(cv)) { cv_loss_used <<- ln; break } } if (is.null(cv)) stop("bn.cv 不接受 loss = ", paste(cv_loss_candidates, collapse = " 或 "), " 请用 ?bn.cv 查看本机 bnlearn 支持的连续型损失名") data.frame( Score = s, Maxp = m, N_arcs = bnlearn::narcs(fit_m), BIC_g = round(bnlearn::score(fit_m, net_data, type = "bic-g"), 2), LogLik = round(score_any(fit_m, c("loglik-g", "loglik")), 2), CV_expected_loss = round(get_cv_loss(cv), 4), stringsAsFactors = FALSE) }, error = function(e) { cat("！maxp =", m, " score =", s, " 失败:", conditionMessage(e), "\n") NULL }) if (!is.null(res)) { bn_select <- rbind(bn_select, res) cat(sprintf(" score=%s maxp=%s: arcs=%d BIC=%.1f CV loss=%.4f\n", res$Score, res$Maxp, res$N_arcs, res$BIC_g, res$CV_expected_loss)) } } if (nrow(bn_select) > 0) { bn_select$Best_by_CV <- ifelse( bn_select$CV_expected_loss == min(bn_select$CV_expected_loss, na.rm = TRUE), "<= selected", "") bn_select$Best_by_BIC <- ifelse( bn_select$BIC_g == max(bn_select$BIC_g, na.rm = TRUE), "<= selected", "") print(bn_select) pdf(file.path(rev_fig_dir, "FigR05_BN_model_selection.pdf"), width = 8, height = 6) print( ggplot(bn_select, aes(x = factor(Maxp), y = CV_expected_loss, group = Score, color = Score)) + geom_line() + geom_point(size = 3) + labs(x = "Maximum number of parents per node (maxp)", y = paste0(k_cv, "-fold cross-validated expected loss (", cv_loss_used, ", lower is better)"), title = "Bayesian network model selection", color = "Network score") + theme_minimal(base_size = 12) ) dev.off() bn_select_note <- data.frame( Note = c( paste0("loss = '", cv_loss_used, "' is the negative expected log-likelihood on held-out folds; lower is better. bnlearn renamed this loss from logl-g to logl in version 5; the script tries both."), "BIC-g is reported on the log scale used by bnlearn (higher is better); it already penalizes the number of parameters.", "The grid is maxp in {1, 2, 3, 4, 8}, not every integer from 1 to 8. Describe it that way in the manuscript; the wording 'maxp = 1 to 8' does not match this table.", "maxp = 8 is p - 1, i.e. the unrestricted case actually used for the reported network (bnlearn imposes no parent limit by default).", "Report in the manuscript: the selected maxp, the criterion used, and whether the reported arc set changes under the selected value."), stringsAsFactors = FALSE) write_xlsx(list(Grid = bn_select, Notes = bn_select_note), file.path(rev_table_dir, "TableR08_BN_Model_Selection.xlsx")) reg_out("R2Q7a", "TableR08_BN_Model_Selection.xlsx") reg_out("R2Q7a", "FigR05_BN_model_selection.pdf") } # ============================================================================ # R2Q7c 选定 maxp 之下 报告的那张平均网络到底变不变 # 审稿人2 第7点的后半句 也就是回信 Point 7(b) 里引用的 Table R8b # # 为什么必须真跑一遍 不能靠推 # 报告网络的最大入度 = 4 只说明那张最终的平均网络本身不违反 maxp = 4 # 但平均网络是 1000 次重抽样投票投出来的 # 某一次重抽样里完全可能长出 5 个父节点的结构 # 限到 4 会改那一次的结构 进而改弧强度 进而可能改哪些弧过 0.50 # 所以 逐弧完全相同 这句话推不出来 只能跑出来 # # 随机数纪律 # 这里借用模块7c 那一行 boot.strength 执行之前的随机数状态 # 两次 boot.strength 因此落在完全相同的重抽样序列上 # 唯一的差别就是 maxp 这样比出来的差异才是 maxp 造成的 # 本段不自行还原 由返修段末尾统一还原 模块15 与模块16 不受影响 # ============================================================================ cat("\n-------- R2Q7c 选定 maxp 下的报告网络复核 --------\n") ## --- 1 选定的 maxp 优先取 R2Q7a 网格里 bic-g 一族交叉验证最优的那个 --- maxp_selected <- 4 maxp_source <- "fallback default (R2Q7a grid unavailable)" if (exists("bn_select") && is.data.frame(bn_select) && nrow(bn_select) > 0) { bg <- bn_select[bn_select$Score == "bic-g" & !is.na(bn_select$CV_expected_loss), ] if (nrow(bg) > 0) { maxp_selected <- bg$Maxp[which.min(bg$CV_expected_loss)] maxp_source <- "selected by 10-fold CV among the bic-g rows of TableR08" } } cat(" 选定 maxp =", maxp_selected, " 来源:", maxp_source, "\n") if (grepl("fallback", maxp_source)) { cat("！！R2Q7a 的网格没跑出来 TableR08 与 FigR05 缺失\n") cat(" TableR08b 会带着 fallback 字样进入 Additional file 1\n") cat(" 正文 Methods 与回信 Point 7(a) 报的交叉验证数值将没有出处\n") cat(" 请先解决 bn.cv 的报错再继续 不要就这样交稿\n") } ## --- 2 全样本 选定 maxp 与不设限的逐弧对照 --- bn_hc_maxp <- bnlearn::hc(net_data, score = "bic-g", maxp = maxp_selected) full_identical <- setequal(arc_set_directed(bn_hc), arc_set_directed(bn_hc_maxp)) full_cmp <- data.frame( Setting = c("Unrestricted (as reported)", paste0("maxp = ", maxp_selected)), N_arcs = c(bnlearn::narcs(bn_hc), bnlearn::narcs(bn_hc_maxp)), BIC_g = round(c(bnlearn::score(bn_hc, net_data, type = "bic-g"), bnlearn::score(bn_hc_maxp, net_data, type = "bic-g")), 2), Directed_Jaccard_vs_unrestricted = c(1, jaccard(arc_set_directed(bn_hc), arc_set_directed(bn_hc_maxp))), Identical_arc_set = c("reference", ifelse(full_identical, "yes", "no")), stringsAsFactors = FALSE ) print(full_cmp) ## --- 3 在同一批重抽样上重跑 boot.strength 唯一差别是 maxp --- if (exists("rng_state_before_bn_boot") && !is.null(rng_state_before_bn_boot)) { assign(".Random.seed", rng_state_before_bn_boot, envir = .GlobalEnv) boot_rng_note <- paste( "Identical bootstrap resamples to the reported analysis:", "the RNG state captured immediately before the boot.strength call in", "module 7c was restored, so the only difference is the parent limit.") } else { set.seed(2024) boot_rng_note <- paste( "The RNG state from module 7c was not available, so a fresh set.seed(2024)", "was used. The two runs may therefore differ in their resamples as well as", "in the parent limit; interpret any difference with that in mind.") cat("！未取到模块7c 的随机数状态 改用 set.seed(2024) 两次重抽样可能不完全相同\n") } cat(" 正在以 maxp =", maxp_selected, "重跑 boot.strength R = 1000 请稍候\n") bn_boot_maxp <- bnlearn::boot.strength( net_data, R = 1000, algorithm = "hc", algorithm.args = list(score = "bic-g", maxp = maxp_selected)) avg_bn_maxp <- bnlearn::averaged.network(bn_boot_maxp, threshold = 0.5) ## --- 4 两张平均网络的逐弧对照 --- look_boot <- function(tab, f, t, what) { i <- which(tab$from == f & tab$to == t) if (length(i) == 0) return(NA_real_) round(tab[[what]][i[1]], 4) } keys_rep <- arc_set_directed(avg_bn) keys_sel <- arc_set_directed(avg_bn_maxp) all_keys <- union(keys_rep, keys_sel) arc_by_arc <- data.frame() for (k in all_keys) { ft <- strsplit(k, " -> ", fixed = TRUE)[[1]] arc_by_arc <- rbind(arc_by_arc, data.frame( Arc = k, In_reported_network = ifelse(k %in% keys_rep, "yes", "no"), In_selected_maxp = ifelse(k %in% keys_sel, "yes", "no"), Strength_reported = look_boot(bn_boot, ft[1], ft[2], "strength"), Strength_maxp = look_boot(bn_boot_maxp, ft[1], ft[2], "strength"), Direction_reported = look_boot(bn_boot, ft[1], ft[2], "direction"), Direction_maxp = look_boot(bn_boot_maxp, ft[1], ft[2], "direction"), stringsAsFactors = FALSE)) } if (nrow(arc_by_arc) > 0) arc_by_arc <- arc_by_arc[order(-pmax(arc_by_arc$Strength_reported, arc_by_arc$Strength_maxp, na.rm = TRUE)), ] rownames(arc_by_arc) <- NULL print(arc_by_arc) avg_identical <- setequal(keys_rep, keys_sel) avg_cmp <- data.frame( Metric = c("Arcs in the reported averaged network", paste0("Arcs in the averaged network at maxp = ", maxp_selected), "Arcs common to both", "Arcs only in the reported network", "Arcs only under the selected limit", "Directed Jaccard between the two averaged networks", "Skeleton Jaccard between the two averaged networks", "Arc sets identical"), Value = c(as.character(length(keys_rep)), as.character(length(keys_sel)), as.character(length(intersect(keys_rep, keys_sel))), as.character(length(setdiff(keys_rep, keys_sel))), as.character(length(setdiff(keys_sel, keys_rep))), as.character(jaccard(keys_rep, keys_sel)), as.character(jaccard(arc_set_skeleton(avg_bn), arc_set_skeleton(avg_bn_maxp))), ifelse(avg_identical, "yes", "no")), stringsAsFactors = FALSE ) print(avg_cmp) ## --- 5 报告网络的入度分布 这是 maxp 是否触顶的机制说明 --- arcs_rep_df <- as.data.frame(bnlearn::arcs(avg_bn), stringsAsFactors = FALSE) indegree_tab <- data.frame( Node = node_labels, In_degree = as.integer(table(factor(arcs_rep_df$to, levels = node_labels))), Out_degree = as.integer(table(factor(arcs_rep_df$from, levels = node_labels))), Parents = sapply(node_labels, function(v) { pa <- arcs_rep_df$from[arcs_rep_df$to == v] if (length(pa) == 0) "-" else paste(sort(pa), collapse = ", ") }), stringsAsFactors = FALSE ) rownames(indegree_tab) <- NULL print(indegree_tab) ## --- 6 maxp 在重抽样内部到底 binding 不 binding --- ## 这一步回答的是 不设限的搜索在多大比例的重抽样里会选出超过 maxp 个父节点 ## 它用自己的种子另做一批重抽样 只是描述性统计 不要求与上面那批完全相同 R_bind_check <- R_boot_rev set.seed(seed_rev + 7) n_obs <- nrow(net_data) max_indeg_boot <- rep(NA_integer_, R_bind_check) for (b in seq_len(R_bind_check)) { idx <- sample.int(n_obs, n_obs, replace = TRUE) fit_b <- tryCatch(bnlearn::hc(net_data[idx, , drop = FALSE], score = "bic-g"), error = function(e) NULL) if (is.null(fit_b)) next ab <- bnlearn::arcs(fit_b) max_indeg_boot[b] <- if (nrow(ab) == 0) 0L else max(as.integer(table(factor(ab[, "to"], levels = node_labels)))) } ok_b <- !is.na(max_indeg_boot) binding_tab <- data.frame( Metric = c("Bootstrap resamples evaluated", "Mean maximum in-degree under the unrestricted search", "Largest maximum in-degree observed across resamples", paste0("Resamples in which some node exceeded maxp = ", maxp_selected), "Proportion of resamples in which the limit would bind"), Value = c(as.character(sum(ok_b)), as.character(round(mean(max_indeg_boot[ok_b]), 3)), as.character(max(max_indeg_boot[ok_b])), as.character(sum(max_indeg_boot[ok_b] > maxp_selected)), as.character(round(mean(max_indeg_boot[ok_b] > maxp_selected), 4))), stringsAsFactors = FALSE ) print(binding_tab) ## --- 7 落盘 --- r8b_notes <- data.frame( Note = c( boot_rng_note, paste0("Selected maxp = ", maxp_selected, "; ", maxp_source, "."), paste0("Full-sample arc set under the selected limit is ", ifelse(full_identical, "identical to", "NOT identical to"), " the unrestricted solution."), paste0("The bootstrap-averaged network under the selected limit is ", ifelse(avg_identical, "arc-for-arc identical to", "NOT identical to"), " the network reported in the manuscript."), paste("If the averaged network is not identical, the sentence in the", "response letter claiming an unchanged network must be rewritten to", "report the actual difference, and Table 3, Figure 3 and the BN", "paragraphs in Results must be regenerated from the selected", "setting."), paste("The maximum in-degree of the reported averaged network is a", "property of that final graph only. It does not by itself imply that", "the parent limit is non-binding inside the bootstrap resamples; the", "Binding_check sheet is the evidence for that claim."), paste("Report in the manuscript: the selected maxp, the criterion that", "selected it, and whether the reported arc set changes under it.")), stringsAsFactors = FALSE ) write_xlsx(list(Full_sample = full_cmp, Averaged_comparison = avg_cmp, Arc_by_arc = arc_by_arc, InDegree_reported = indegree_tab, Binding_check = binding_tab, Notes = r8b_notes), file.path(rev_table_dir, "TableR08b_Selected_Maxp_Check.xlsx")) reg_out("R2Q7c", "TableR08b_Selected_Maxp_Check.xlsx") plot_bn(bn_to_adj(avg_bn_maxp, bn_boot_maxp), "FigR11_BN_selected_maxp.pdf", paste0("Bootstrap-averaged Bayesian network under maxp = ", maxp_selected, " (threshold = 0.50)")) reg_out("R2Q7c", "FigR11_BN_selected_maxp.pdf") cat("\n 全样本弧集是否相同:", ifelse(full_identical, "是", "否"), "\n") cat(" 平均网络是否逐弧相同:", ifelse(avg_identical, "是 回信 Point 7(b) 的说法成立", "否 回信 Point 7(b) 必须改写"), "\n") # ============================================================================ # R2Q7b GGM 的稀疏性与过拟合证据 # 审稿人2 原话 33 / 36 条边 到底是最优模型还是最过拟合的模型 # 用样本外预测 R2 回答 过拟合的结构在留出折上一定掉分 # 同时给出非正则化网络与 ggmModSelect 作为对照 # ============================================================================ cat("\n-------- R2Q7b GGM 稀疏性与样本外预测 --------\n") struct_ebic <- function(g) function(dat) adj_from_w(getWmat(estimateNetwork(dat, default = "EBICglasso", corMethod = "spearman", tuning = g))) struct_pcor <- function(dat) adj_from_w(getWmat(estimateNetwork(dat, default = "pcor", corMethod = "spearman", threshold = "sig", alpha = 0.05))) struct_modsel <- function(dat) adj_from_w(getWmat(estimateNetwork(dat, default = "ggmModSelect", corMethod = "spearman", stepwise = TRUE))) struct_saturated <- function(dat) { a <- matrix(TRUE, ncol(dat), ncol(dat)); diag(a) <- FALSE dimnames(a) <- list(colnames(dat), colnames(dat)); a } model_defs <- list( "EBICglasso gamma = 0.25" = struct_ebic(0.25), "EBICglasso gamma = 0.50 (reported)" = struct_ebic(0.50), "EBICglasso gamma = 1.00" = struct_ebic(1.00), "Unregularized pcor, sig-pruned" = struct_pcor, "ggmModSelect (stepwise)" = struct_modsel, "Saturated (all 36 edges)" = struct_saturated ) oos_tab <- data.frame() for (nm in names(model_defs)) { res <- tryCatch({ A <- model_defs[[nm]](net_data) r2 <- cv_out_of_sample_r2(net_data, model_defs[[nm]]) data.frame(Model = nm, N_edges = sum(A[upper.tri(A)]), Density = round(sum(A[upper.tri(A)]) / (p_nodes * (p_nodes - 1) / 2), 3), Mean_OOS_R2 = round(mean(r2), 4), Min_OOS_R2 = round(min(r2), 4), OOS_R2_EE = round(r2[["EE"]], 4), OOS_R2_ISI = round(r2[["ISI"]], 4), stringsAsFactors = FALSE) }, error = function(e) { cat("！模型", nm, "失败:", conditionMessage(e), "\n"); NULL }) if (!is.null(res)) { oos_tab <- rbind(oos_tab, res) cat(sprintf(" %-36s edges=%2d mean OOS R2=%.4f\n", res$Model, res$N_edges, res$Mean_OOS_R2)) } } if (nrow(oos_tab) > 0) { oos_tab$Best <- ifelse(oos_tab$Mean_OOS_R2 == max(oos_tab$Mean_OOS_R2, na.rm = TRUE), "<= best out-of-sample", "") print(oos_tab) } ## 非正则化网络与 ggmModSelect 的全样本结果 也要贴出来给审稿人看 wmat_pcor <- tryCatch( getWmat(estimateNetwork(net_data, default = "pcor", corMethod = "spearman", threshold = "sig", alpha = 0.05)), error = function(e) NULL) wmat_modsel <- tryCatch( getWmat(estimateNetwork(net_data, default = "ggmModSelect", corMethod = "spearman", stepwise = TRUE)), error = function(e) NULL) sparsity_summary <- summarise_network(weight_matrix, "EBICglasso gamma = 0.50 (reported)") sparsity_agree <- data.frame() if (!is.null(wmat_pcor)) { dimnames(wmat_pcor) <- list(node_labels, node_labels) sparsity_summary <- rbind(sparsity_summary, summarise_network(wmat_pcor, "Unregularized pcor, sig-pruned")) sparsity_agree <- rbind(sparsity_agree, compare_networks(weight_matrix, wmat_pcor, "reported vs unregularized pcor")) plot_ggm(wmat_pcor, "FigR06_GGM_unregularized_pcor.pdf", "Unregularized partial correlation network (significance-pruned, alpha = .05)") } if (!is.null(wmat_modsel)) { dimnames(wmat_modsel) <- list(node_labels, node_labels) sparsity_summary <- rbind(sparsity_summary, summarise_network(wmat_modsel, "ggmModSelect (stepwise)")) sparsity_agree <- rbind(sparsity_agree, compare_networks(weight_matrix, wmat_modsel, "reported vs ggmModSelect")) plot_ggm(wmat_modsel, "FigR07_GGM_ggmModSelect.pdf", "ggmModSelect network (non-regularized, stepwise)") } print(sparsity_summary) if (nrow(sparsity_agree) > 0) print(sparsity_agree) write_xlsx(list(Out_of_sample = oos_tab, Full_sample = sparsity_summary, Agreement = sparsity_agree), file.path(rev_table_dir, "TableR09_GGM_Sparsity_and_Overfitting.xlsx")) reg_out("R2Q7b", "TableR09_GGM_Sparsity_and_Overfitting.xlsx") # ============================================================================ # R2Q6 同构念子维度带来的膨胀 # 审稿人2 指出 EE DP PA 本来同属一个构念 放进同一网络会抬高边强度与 R2 # 做三件事 # 1 构念内 与 构念间 边强度分解 # 2 每个节点的 R2 拆成 同构念邻居贡献 与 跨构念邻居贡献 # 3 数据驱动社区能否还原四个理论构念 走 walktrap 并算调整兰德指数 # ============================================================================ cat("\n-------- R2Q6 构念内 vs 构念间 的膨胀分解 --------\n") ## 1 边强度分解 edge_decomp_rows <- data.frame() for (i in 1:(p_nodes - 1)) for (j in (i + 1):p_nodes) { if (weight_matrix[i, j] == 0) next edge_decomp_rows <- rbind(edge_decomp_rows, data.frame( Node1 = node_labels[i], Node2 = node_labels[j], Weight = round(weight_matrix[i, j], 4), Abs_weight = round(abs(weight_matrix[i, j]), 4), Type = ifelse(node_groups[i] == node_groups[j], "Within construct", "Between constructs"), stringsAsFactors = FALSE)) } edge_type_summary <- do.call(rbind, lapply( split(edge_decomp_rows, edge_decomp_rows$Type), function(d) data.frame(Type = d$Type[1], N_edges = nrow(d), Mean_abs_weight = round(mean(d$Abs_weight), 4), Max_abs_weight = round(max(d$Abs_weight), 4), stringsAsFactors = FALSE))) print(edge_type_summary) ## 2 R2 分解 在标准化数据上按邻居做 lm r2_decomp <- do.call(rbind, lapply(seq_len(p_nodes), function(i) { nb <- setdiff(which(weight_matrix[i, ] != 0), i) same <- nb[node_groups[nb] == node_groups[i]] diff <- nb[node_groups[nb] != node_groups[i]] r2_of <- function(cols) { if (length(cols) == 0) return(0) d <- data.frame(.y = net_z[[i]], net_z[, cols, drop = FALSE]) summary(lm(.y ~ ., data = d))$r.squared } data.frame( Node = node_labels[i], Construct = node_groups[i], N_same_construct_neighbours = length(same), N_other_construct_neighbours = length(diff), R2_all_neighbours = round(r2_of(nb), 4), R2_same_construct_only = round(r2_of(same), 4), R2_other_construct_only = round(r2_of(diff), 4), Unique_gain_from_other_constructs = round(r2_of(nb) - r2_of(same), 4), stringsAsFactors = FALSE) })) print(r2_decomp) cat("\n解读 若 R2_same_construct_only 已接近 R2_all_neighbours\n") cat(" 则该节点的高 R2 主要来自同构念冗余 而不是跨构念的实质关联\n") ## 3 社区还原度 g_abs <- igraph::graph_from_adjacency_matrix(abs(weight_matrix), mode = "undirected", weighted = TRUE, diag = FALSE) set.seed(seed_rev) wt <- igraph::cluster_walktrap(g_abs, weights = igraph::E(g_abs)$weight) memb <- as.integer(igraph::membership(wt)) community_tab <- data.frame( Node = node_labels, Theoretical_construct = node_groups, Data_driven_community = memb, stringsAsFactors = FALSE ) community_fit <- data.frame( Metric = c("Number of data-driven communities", "Modularity of data-driven partition", "Modularity of the four theoretical constructs", "Adjusted Rand index (data-driven vs theoretical)"), Value = c(length(unique(memb)), round(igraph::modularity(g_abs, memb, weights = igraph::E(g_abs)$weight), 3), round(igraph::modularity(g_abs, as.integer(factor(node_groups)), weights = igraph::E(g_abs)$weight), 3), adj_rand_index(memb, node_groups)), stringsAsFactors = FALSE ) print(community_tab) print(community_fit) ## 若装了 EGAnet 就顺手跑一次 EGA 没装就跳过 ega_note <- "EGAnet not installed; walktrap community detection reported instead." if (requireNamespace("EGAnet", quietly = TRUE)) { ega_note <- tryCatch({ set.seed(seed_rev) e <- EGAnet::EGA(data = net_data, plot.EGA = FALSE) paste0("EGA recovered ", max(e$wc, na.rm = TRUE), " dimensions; membership: ", paste(paste0(node_labels, "=", e$wc), collapse = ", ")) }, error = function(e) paste("EGA failed:", conditionMessage(e))) } cat(ega_note, "\n") write_xlsx(list(Edge_type = edge_type_summary, Edge_list = edge_decomp_rows, R2_decomposition = r2_decomp, Communities = community_tab, Community_fit = community_fit, Notes = data.frame(Note = ega_note, stringsAsFactors = FALSE)), file.path(rev_table_dir, "TableR10_Within_vs_Between_Construct.xlsx")) reg_out("R2Q6", "TableR10_Within_vs_Between_Construct.xlsx") # ============================================================================ # R2Q6b 桥指标换成数据驱动社区之后还站不站得住 # R2Q6 已经报出 理论四构念的模块度只有 0.047 调整兰德指数 0.314 # 审稿人2 顺手就能回一句 那你摘要里的桥节点是建在一个数据不支持的分组上的 # 这里先自己把两种分组下的桥指标都算出来 # 排名一致 就在 Results 里主动说明 排名不一致 就把摘要里那句降调 # 本段不消耗随机数 memb 来自上面的 R2Q6 # ============================================================================ cat("\n-------- R2Q6b 桥指标在两种社区划分下的对照 --------\n") comm_data_driven <- split(seq_len(p_nodes), paste0("Community_", memb)) bridge_theory <- bridge(weight_matrix, communities = communities) bridge_data <- bridge(weight_matrix, communities = comm_data_driven) bridge_cmp <- data.frame( Node = node_labels, Theoretical_community = node_groups, Data_driven_community = paste0("Community_", memb), BS_theoretical = round(bridge_theory$`Bridge Strength`, 4), BS_data_driven = round(bridge_data$`Bridge Strength`, 4), BEI_theoretical = round(bridge_theory$`Bridge Expected Influence (1-step)`, 4), BEI_data_driven = round(bridge_data$`Bridge Expected Influence (1-step)`, 4), stringsAsFactors = FALSE ) rownames(bridge_cmp) <- NULL print(bridge_cmp) ## 若数据驱动社区退化成一个 桥指标会全为零 cor 会返回 NA 这里先挡一道 safe_rho <- function(x, y) { if (length(unique(x)) < 2 || length(unique(y)) < 2) return(NA_real_) round(cor(x, y, method = "spearman"), 3) } bridge_agree <- data.frame( Metric = c("Spearman rho bridge strength theoretical vs data-driven", "Spearman rho bridge expected influence theoretical vs data-driven", "Top 2 by bridge strength theoretical communities", "Top 2 by bridge strength data-driven communities", "Number of communities theoretical", "Number of communities data-driven"), Value = c( as.character(safe_rho(bridge_cmp$BS_theoretical, bridge_cmp$BS_data_driven)), as.character(safe_rho(bridge_cmp$BEI_theoretical, bridge_cmp$BEI_data_driven)), paste(node_labels[order(-bridge_cmp$BS_theoretical)][1:2], collapse = " > "), paste(node_labels[order(-bridge_cmp$BS_data_driven)][1:2], collapse = " > "), as.character(length(communities)), as.character(length(unique(memb)))), stringsAsFactors = FALSE ) print(bridge_agree) bridge_note <- data.frame( Note = c( paste("Bridge indices are defined relative to a community partition that", "the analyst supplies; by convention that partition is theoretical,", "not data-driven. Reporting both is the cleanest way to answer", "Reviewer 2's community-structure point before it is turned against", "the bridge results."), paste("If the two rankings agree, say so in Results and keep the bridge", "claim as it stands. If they disagree, downgrade the bridge sentence", "in the Abstract to a descriptive statement and move the detail to", "the Additional file."), paste("This table changes no GGM edge weight and no centrality value; it", "only changes which edges count as bridging.")), stringsAsFactors = FALSE ) write_xlsx(list(Bridge_comparison = bridge_cmp, Rank_agreement = bridge_agree, Notes = bridge_note), file.path(rev_table_dir, "TableR10b_Bridge_Community_Sensitivity.xlsx")) reg_out("R2Q6b", "TableR10b_Bridge_Community_Sensitivity.xlsx") # ============================================================================ # R2Q9 Tension 与 OutCtrl 近零边的诊断 # 审稿人2 把这条边点名为 数据驱动模型的可能伪迹 # 给出 原始相关 非正则化偏相关 方差膨胀因子 条件数 与 bootstrap 区间 # ============================================================================ cat("\n-------- R2Q9 Tension-OutCtrl 近零边诊断 --------\n") ## 所有节点的 VIF 以自身对其余八个节点回归的 R2 换算 vif_tab <- do.call(rbind, lapply(seq_len(p_nodes), function(i) { d <- data.frame(.y = net_z[[i]], net_z[, -i, drop = FALSE]) r2 <- summary(lm(.y ~ ., data = d))$r.squared data.frame(Node = node_labels[i], R2_on_all_others = round(r2, 4), VIF = round(1 / (1 - r2), 2), stringsAsFactors = FALSE) })) print(vif_tab) ## 非正则化偏相关矩阵 由 Spearman 相关矩阵求逆 prec <- solve(cor_matrix) pcor_unreg <- -prec / sqrt(outer(diag(prec), diag(prec))) diag(pcor_unreg) <- 1 dimnames(pcor_unreg) <- list(node_labels, node_labels) ## bootstrap 区间 edge_ci <- tryCatch({ bt <- summary(boot_nonparam, statistics = "edge") keep <- (bt$node1 %in% c("Tension", "OutCtrl")) & (bt$node2 %in% c("Tension", "OutCtrl")) cols <- intersect(c("node1", "node2", "sample", "mean", "sd", "CIlower", "CIupper", "q2.5", "q97.5"), names(bt)) bt[keep, cols, drop = FALSE] }, error = function(e) NULL) near_zero_tab <- data.frame( Diagnostic = c("Spearman correlation Tension-OutCtrl", "Pearson correlation Tension-OutCtrl", "Unregularized partial correlation Tension-OutCtrl", "Regularized (reported) edge weight Tension-OutCtrl", "VIF Tension", "VIF OutCtrl", "Condition number of the Spearman correlation matrix", "Number of items shared by the two subscales"), Value = c(round(cor(net_data$Tension, net_data$OutCtrl, method = "spearman"), 3), round(cor(net_data$Tension, net_data$OutCtrl), 3), round(pcor_unreg["Tension", "OutCtrl"], 3), round(weight_matrix["Tension", "OutCtrl"], 3), vif_tab$VIF[vif_tab$Node == "Tension"], vif_tab$VIF[vif_tab$Node == "OutCtrl"], round(kappa(cor_matrix, exact = TRUE), 1), 0), stringsAsFactors = FALSE ) print(near_zero_tab) if (!is.null(edge_ci)) print(edge_ci) near_zero_note <- data.frame( Note = c( "The two CPSS subscales are strongly correlated at the zero-order level but their regularized partial correlation is near zero: their shared variance is absorbed by the remaining seven nodes, and the LASSO penalty shrinks what is left.", "This is a known consequence of entering highly collinear same-construct subscales into a regularized GGM, not a substantive finding about perceived stress.", "The unregularized partial correlation and the bootstrap interval for this edge should be reported alongside, and the manuscript sentence claiming 'minimal unique association' should be reframed as a collinearity artifact.", "Recommended manuscript wording: report the zero-order correlation, the near-zero partial correlation, and state explicitly that the near-zero edge does not imply the two facets are unrelated."), stringsAsFactors = FALSE ) write_xlsx(list(Diagnostics = near_zero_tab, VIF = vif_tab, Unregularized_pcor = cbind(Node = node_labels, as.data.frame(round(pcor_unreg, 3))), Bootstrap_CI = if (is.null(edge_ci)) data.frame(Note = "bootnet edge summary unavailable") else edge_ci, Notes = near_zero_note), file.path(rev_table_dir, "TableR11_NearZero_Edge_Diagnostics.xlsx")) reg_out("R2Q9", "TableR11_NearZero_Edge_Diagnostics.xlsx") # ============================================================================ # R2G2 控制变量 年龄 工龄 性别 学历 # 审稿人2 总评 为什么不放年龄 为什么不放在院工作年限 # 做法 把九个节点对协变量回归取残差 再重估 GGM 与 BN 与主分析对照 # ============================================================================ cat("\n-------- R2G2 控制变量 残差化重估 --------\n") cov_candidates <- c("Age", "WorkYears", "Gender", "Education") cov_vars <- intersect(cov_candidates, names(raw_data)) cat("可用协变量:", paste(cov_vars, collapse = ", "), "\n") resid_ok <- length(cov_vars) > 0 if (resid_ok) { cov_df <- as.data.frame(raw_data[, c(node_vars, cov_vars)]) cov_df <- cov_df[complete.cases(cov_df), ] cat("残差化分析样本量 N =", nrow(cov_df), "\n") for (v in intersect(c("Gender", "Education"), cov_vars)) cov_df[[v]] <- factor(cov_df[[v]]) cov_formula <- as.formula(paste("y ~", paste(cov_vars, collapse = " + "))) ## 协变量与各节点的关联 先给审稿人看协变量到底有没有用 cov_assoc <- do.call(rbind, lapply(node_vars, function(v) { d <- cov_df; d$y <- as.numeric(d[[v]]) m <- lm(cov_formula, data = d) s <- summary(m) data.frame(Node = v, R2_covariates = round(s$r.squared, 4), F_p = signif(pf(s$fstatistic[1], s$fstatistic[2], s$fstatistic[3], lower.tail = FALSE), 3), Age_beta = if ("Age" %in% cov_vars) round(coef(s)["Age", "Estimate"], 4) else NA, Age_p = if ("Age" %in% cov_vars) signif(coef(s)["Age", "Pr(>|t|)"], 3) else NA, WorkYears_beta = if ("WorkYears" %in% cov_vars) round(coef(s)["WorkYears", "Estimate"], 4) else NA, WorkYears_p = if ("WorkYears" %in% cov_vars) signif(coef(s)["WorkYears", "Pr(>|t|)"], 3) else NA, row.names = NULL, stringsAsFactors = FALSE) })) print(cov_assoc) ## 残差数据 net_resid <- as.data.frame(setNames(lapply(node_vars, function(v) { d <- cov_df; d$y <- as.numeric(d[[v]]) as.numeric(resid(lm(cov_formula, data = d))) }), node_labels)) net_result_resid <- estimateNetwork(net_resid, default = "EBICglasso", corMethod = "spearman", tuning = 0.5) wmat_resid <- getWmat(net_result_resid) dimnames(wmat_resid) <- list(node_labels, node_labels) resid_summary <- rbind( summarise_network(weight_matrix, "Reported (no covariates)"), summarise_network(wmat_resid, paste0("Residualized on ", paste(cov_vars, collapse = " + ")))) resid_agree <- compare_networks(weight_matrix, wmat_resid, "reported vs covariate-residualized") print(resid_summary); print(resid_agree) plot_ggm(wmat_resid, "FigR08_GGM_covariate_residualized.pdf", paste0("GGM after residualizing on ", paste(cov_vars, collapse = " + "))) cat("残差化数据上重跑 BN bootstrap\n") bn_resid <- learn_bn(net_resid) resid_bn <- data.frame( Metric = c("Arcs reported", "Arcs after residualizing", "Common directed arcs", "Directed-arc Jaccard", "Skeleton Jaccard"), Value = c(bnlearn::narcs(avg_bn), bnlearn::narcs(bn_resid$avg), length(intersect(arc_set_directed(avg_bn), arc_set_directed(bn_resid$avg))), jaccard(arc_set_directed(avg_bn), arc_set_directed(bn_resid$avg)), jaccard(arc_set_skeleton(avg_bn), arc_set_skeleton(bn_resid$avg))), stringsAsFactors = FALSE) print(resid_bn) plot_bn(round(bn_to_adj(bn_resid$avg, bn_resid$boot), 2), "FigR09_BN_covariate_residualized.pdf", "Bayesian network after residualizing on covariates") write_xlsx(list(Covariate_association = cov_assoc, GGM_summary = resid_summary, GGM_agreement = resid_agree, BN_summary = resid_bn), file.path(rev_table_dir, "TableR12_Covariate_Adjusted_Networks.xlsx")) reg_out("R2G2", "TableR12_Covariate_Adjusted_Networks.xlsx") } else { cat("！Summary 表里找不到 Age / WorkYears 等列 跳过 R2G2\n") } # ============================================================================ # R2Q4 入选标准的敏感性 年龄下限与工龄不足一年者 # 审稿人2 问 18 岁是否太年轻 工龄不足一年的人建模是否合理 # 先报告实际观测的年龄下限 再剔除工龄不足一年者重估 # ============================================================================ cat("\n-------- R2Q4 入选标准敏感性 --------\n") incl_rows <- data.frame(Metric = character(0), Value = character(0), stringsAsFactors = FALSE) if ("Age" %in% names(raw_data)) { incl_rows <- rbind(incl_rows, data.frame( Metric = c("Stated inclusion criterion", "Observed minimum age", "Observed maximum age", "N younger than 20", "N younger than 22"), Value = c("18 years or older", as.character(min(raw_data$Age, na.rm = TRUE)), as.character(max(raw_data$Age, na.rm = TRUE)), as.character(sum(raw_data$Age < 20, na.rm = TRUE)), as.character(sum(raw_data$Age < 22, na.rm = TRUE))), stringsAsFactors = FALSE)) } if ("WorkYears" %in% names(raw_data)) { incl_rows <- rbind(incl_rows, data.frame( Metric = c("N with tenure below 1 year", "N with tenure of 1 year or less", "Median tenure (years)"), Value = c(as.character(sum(raw_data$WorkYears < 1, na.rm = TRUE)), as.character(sum(raw_data$WorkYears <= 1, na.rm = TRUE)), as.character(median(raw_data$WorkYears, na.rm = TRUE))), stringsAsFactors = FALSE)) } print(incl_rows) tenure_out <- NULL if ("WorkYears" %in% names(raw_data)) { keep_idx <- which(raw_data$WorkYears >= 1 & complete.cases(raw_data[, node_vars])) net_exp <- as.data.frame(lapply(raw_data[keep_idx, node_vars], as.numeric)) names(net_exp) <- node_labels cat("剔除工龄不足一年者后 N =", nrow(net_exp), "\n") if (nrow(net_exp) > 50) { net_result_exp <- estimateNetwork(net_exp, default = "EBICglasso", corMethod = "spearman", tuning = 0.5) wmat_exp <- getWmat(net_result_exp) dimnames(wmat_exp) <- list(node_labels, node_labels) tenure_summary <- rbind( summarise_network(weight_matrix, paste0("Full sample (N = ", nrow(net_data), ")")), summarise_network(wmat_exp, paste0("Tenure >= 1 year (N = ", nrow(net_exp), ")"))) tenure_agree <- compare_networks(weight_matrix, wmat_exp, "full sample vs tenure >= 1 year") print(tenure_summary); print(tenure_agree) plot_ggm(wmat_exp, "FigR10_GGM_tenure_at_least_1year.pdf", paste0("GGM excluding tenure < 1 year (N = ", nrow(net_exp), ")")) cat("该子样本上重跑 BN bootstrap\n") bn_exp <- learn_bn(net_exp) tenure_bn <- data.frame( Metric = c("Arcs full sample", "Arcs tenure >= 1 year", "Common directed arcs", "Directed-arc Jaccard", "Skeleton Jaccard"), Value = c(bnlearn::narcs(avg_bn), bnlearn::narcs(bn_exp$avg), length(intersect(arc_set_directed(avg_bn), arc_set_directed(bn_exp$avg))), jaccard(arc_set_directed(avg_bn), arc_set_directed(bn_exp$avg)), jaccard(arc_set_skeleton(avg_bn), arc_set_skeleton(bn_exp$avg))), stringsAsFactors = FALSE) print(tenure_bn) tenure_out <- list(Inclusion = incl_rows, GGM_summary = tenure_summary, GGM_agreement = tenure_agree, BN_summary = tenure_bn) } } if (is.null(tenure_out)) tenure_out <- list(Inclusion = incl_rows) write_xlsx(tenure_out, file.path(rev_table_dir, "TableR13_Inclusion_Criteria_Sensitivity.xlsx")) reg_out("R2Q4", "TableR13_Inclusion_Criteria_Sensitivity.xlsx") # ============================================================================ # R2G1 样本量与估计精度 # 审稿人2 说 small sample of 300 participants 实际是 362 先把数字纠正 # 再用边权 bootstrap 区间量化 哪些边真的估得准 # ============================================================================ cat("\n-------- R2G1 样本量与边估计精度 --------\n") acc_rows <- data.frame( Metric = c("Analysed sample size", "Nodes", "Estimated parameters (possible edges)", "Observations per possible edge"), Value = c(nrow(net_data), p_nodes, p_nodes * (p_nodes - 1) / 2, round(nrow(net_data) / (p_nodes * (p_nodes - 1) / 2), 1)), stringsAsFactors = FALSE ) edge_acc <- tryCatch({ bt <- summary(boot_nonparam, statistics = "edge") lo <- if ("CIlower" %in% names(bt)) bt$CIlower else bt$q2.5 hi <- if ("CIupper" %in% names(bt)) bt$CIupper else bt$q97.5 keep <- bt$sample != 0 data.frame( Metric = c("Non-zero edges in the reported network", "Non-zero edges whose 95% bootstrap CI excludes zero", "Proportion of non-zero edges with CI excluding zero", "Mean 95% CI width across non-zero edges", "Widest 95% CI among non-zero edges"), Value = c(sum(keep), sum(keep & (lo > 0 | hi < 0)), round(mean((lo > 0 | hi < 0)[keep]), 3), round(mean((hi - lo)[keep]), 3), round(max((hi - lo)[keep]), 3)), stringsAsFactors = FALSE) }, error = function(e) NULL) if (!is.null(edge_acc)) acc_rows <- rbind(acc_rows, edge_acc) if (exists("cs_df")) acc_rows <- rbind(acc_rows, data.frame( Metric = paste("CS-coefficient:", cs_df$Measure), Value = cs_df$CS_Coefficient, stringsAsFactors = FALSE)) print(acc_rows) write_xlsx(acc_rows, file.path(rev_table_dir, "TableR14_Sample_Size_and_Edge_Accuracy.xlsx")) reg_out("R2G1", "TableR14_Sample_Size_and_Edge_Accuracy.xlsx") # ============================================================================ # R2G3 Jaccard = 1 的正确处理 # 审稿人2 怀疑 Fig 3 里 Jaccard = 1 是数值有问题 # 实情是 HC 与 Tabu 用同一个分数函数做贪婪搜索 收敛到同一个 DAG 是常态 # Jaccard 必然为 1 因此这个指标信息量极低 不能当作稳健性证据 # 正确做法 换分数函数 换算法族 再比一致性 # ============================================================================ cat("\n-------- R2G3 跨算法族一致性 取代 HC vs Tabu --------\n") alg_list <- list( "hc (bic-g)" = function() bnlearn::hc(net_data, score = "bic-g"), "tabu (bic-g)" = function() bnlearn::tabu(net_data, score = "bic-g"), "hc (bge)" = function() bnlearn::hc(net_data, score = "bge"), "tabu (bge)" = function() bnlearn::tabu(net_data, score = "bge"), "pc.stable" = function() bnlearn::pc.stable(net_data), "gs" = function() bnlearn::gs(net_data), "iamb" = function() bnlearn::iamb(net_data), "mmhc (bic-g)" = function() bnlearn::mmhc( net_data, maximize.args = list(score = "bic-g")) ) alg_fits <- list() for (nm in names(alg_list)) { f <- tryCatch(alg_list[[nm]](), error = function(e) { cat("！算法", nm, "失败:", conditionMessage(e), "\n"); NULL }) if (!is.null(f)) alg_fits[[nm]] <- f } ref_fit <- alg_fits[["hc (bic-g)"]] if (is.null(ref_fit)) ref_fit <- if (length(alg_fits) > 0) alg_fits[[1]] else NULL alg_summary <- if (is.null(ref_fit)) data.frame() else do.call(rbind, lapply(names(alg_fits), function(nm) { f <- alg_fits[[nm]] data.frame(Algorithm = nm, Family = ifelse(grepl("pc\\.stable|^gs$|iamb", nm), "Constraint-based", ifelse(grepl("mmhc", nm), "Hybrid", "Score-based")), N_arcs = nrow(bnlearn::arcs(f)), N_skeleton_edges = length(arc_set_skeleton(f)), Skeleton_Jaccard_vs_hc_bicg = jaccard(arc_set_skeleton(f), arc_set_skeleton(ref_fit)), Directed_Jaccard_vs_hc_bicg = jaccard(arc_set_directed(f), arc_set_directed(ref_fit)), stringsAsFactors = FALSE) })) print(alg_summary) ## 全对全的骨架 Jaccard 矩阵 jac_mat <- outer(names(alg_fits), names(alg_fits), Vectorize(function(a, b) jaccard(arc_set_skeleton(alg_fits[[a]]), arc_set_skeleton(alg_fits[[b]])))) dimnames(jac_mat) <- list(names(alg_fits), names(alg_fits)) print(jac_mat) jac_df <- cbind(Algorithm = rownames(jac_mat), as.data.frame(jac_mat)) jaccard_note <- data.frame( Note = c( "Hill-Climbing and Tabu Search optimize the same score with the same operators; on a 9-node problem they routinely converge to the identical DAG, so a Jaccard index of 1.00 between them is expected by construction and is not evidence of robustness.", "The reported Jaccard = 1.00 in the manuscript is therefore arithmetically correct but uninformative; the sentences describing it as 'strong evidence for the robustness of the estimated directional dependencies' should be deleted.", "Robustness of the directed structure is better supported by (a) bootstrap arc strength and direction probabilities, (b) agreement across different score functions (BIC-g vs BGe), and (c) agreement across algorithm families (score-based vs constraint-based vs hybrid), all reported here.", "Arc direction probabilities close to 0.50 (e.g. EE -> DP) should be flagged as directionally undetermined rather than reported as directional findings."), stringsAsFactors = FALSE ) write_xlsx(list(Algorithms = alg_summary, Skeleton_Jaccard_matrix = jac_df, Notes = jaccard_note), file.path(rev_table_dir, "TableR15_Cross_Algorithm_Consistency.xlsx")) reg_out("R2G3", "TableR15_Cross_Algorithm_Consistency.xlsx") # ============================================================================ # R1m2c + R2G3b 信度系数 与 PA 条目级方向核验 与 十一节点直测 # 起因一 正文 Measures 报了五个 Cronbach alpha .896 .841 .871 .833 .917 # 原脚本只读 Summary 表 没有条目级数据 这五个数无脚本支撑 # 而回信 Point 10 主动把脚本和数据交出去请人复核 缺一个就是把柄 # 起因二 回信 Minor 2 引用了 PA 条目与 EE_Sum DP_Sum 的条目级相关 # 原脚本只算到分量表层面 条目级那一句同样没有出处 # 起因三 回信 G3 直接把年龄与工龄当节点跑了一次 十一节点网络 # 那段数字只在信里 不在脚本里 审稿人问起来拿不出 # 做法 从同一个工作簿读条目级分表 一次把三件事补齐 写成 TableR16 # 注意 各分表的表头行位置不同 MBI-GS 第一行是标题 第二行是分量表名 # 第三行才是条目名 所以不能一律用 skip = 1 这里自动探测 # 本段不消耗随机数 EBICglasso 与 alpha 都是确定性计算 # ============================================================================ cat("\n-------- R1m2c 信度 与 条目级核验 与 十一节点直测 --------\n") r16_ok <- TRUE tryCatch({ ## --- 自动探测表头行 逐个 skip 试到需要的列都在为止 --- read_item_sheet <- function(sheet, required) { for (sk in c(1, 2, 0, 3)) { d <- tryCatch( as.data.frame(suppressMessages( readxl::read_excel(input_file, sheet = sheet, skip = sk))), error = function(e) NULL) if (!is.null(d) && all(required %in% names(d))) { cat(" 读取分表", sheet, " skip =", sk, " 行数 =", nrow(d), "\n") return(d) } } stop("在工作表 ", sheet, " 中找不到所需的条目列: ", paste(required, collapse = ", ")) } ## --- Cronbach alpha 直接按定义算 不依赖 psych 的打印格式 --- cronbach_alpha <- function(M) { M <- as.matrix(M) M <- matrix(as.numeric(M), nrow = nrow(M), dimnames = list(NULL, colnames(M))) M <- M[stats::complete.cases(M), , drop = FALSE] k <- ncol(M) k / (k - 1) * (1 - sum(apply(M, 2, stats::var)) / stats::var(rowSums(M))) } ## --- SSRS 第6 7 题记的是被认可的支持来源 --- ## 单元格形如 1.00，1.00，1.00 也可能是单个 0 表示一个来源都没有 ## 所以要把单元格里的数值加总 不能数逗号分段的个数 ## 数分段会把 0 记成 1 全样本有 11 例会因此对不上工作簿的分量表分 count_sources <- function(x) { vapply(x, function(v) { if (all(is.na(v))) return(0) if (is.numeric(v)) return(as.numeric(v)) s <- trimws(as.character(v)) if (!nzchar(s)) return(0) parts <- strsplit(s, "[，,;；]")[[1]] parts <- suppressWarnings(as.numeric(trimws(parts))) sum(parts[!is.na(parts)]) }, numeric(1), USE.NAMES = FALSE) } rel_rows <- list() add_rel <- function(scale, k, n, a, note) { rel_rows[[length(rel_rows) + 1]] <<- data.frame( Scale = scale, Items = k, N = n, Cronbach_alpha = round(a, 3), Note = note, stringsAsFactors = FALSE) } ## ---- MBI-GS 表头在第三行 须 skip = 2 ---- ee_it <- paste0("EE", 1:5); dp_it <- paste0("DP", 1:4); pa_it <- paste0("PA", 1:6) mbi <- read_item_sheet("MBI-GS", c(ee_it, dp_it, pa_it, "EE_Sum", "DP_Sum")) mbi_items <- as.data.frame(lapply(mbi[, c(ee_it, dp_it, pa_it)], as.numeric)) mbi_items <- mbi_items[stats::complete.cases(mbi_items), , drop = FALSE] mbi_rev <- mbi_items mbi_rev[, pa_it] <- 6 - mbi_rev[, pa_it] add_rel("MBI-GS all 15 items, as recorded", 15, nrow(mbi_items), cronbach_alpha(mbi_items), "value reported in Measures; PA items left in the recorded direction") add_rel("MBI-GS all 15 items, PA reversed", 15, nrow(mbi_rev), cronbach_alpha(mbi_rev), "counterfactual; lower than the recorded direction, which is the third PA check") add_rel("MBI-GS Emotional Exhaustion", 5, nrow(mbi_items), cronbach_alpha(mbi_items[, ee_it]), "") add_rel("MBI-GS Depersonalization", 4, nrow(mbi_items), cronbach_alpha(mbi_items[, dp_it]), "") add_rel("MBI-GS Personal Accomplishment", 6, nrow(mbi_items), cronbach_alpha(mbi_items[, pa_it]), "") ## ---- CPSS 条目列名为 C2 到 C15 ---- cpss <- read_item_sheet("CPSS", c("C2", "C15", "Tension")) cpss_it <- grep("^C[0-9]+$", names(cpss), value = TRUE) cpss_items <- as.data.frame(lapply(cpss[, cpss_it], as.numeric)) cpss_items <- cpss_items[stats::complete.cases(cpss_items), , drop = FALSE] add_rel("CPSS all 14 items", length(cpss_it), nrow(cpss_items), cronbach_alpha(cpss_items), "value reported in Measures") add_rel("CPSS Tension", 7, nrow(cpss_items), cronbach_alpha(cpss_items[, cpss_it[1:7]]), "") add_rel("CPSS Out of Control", 7, nrow(cpss_items), cronbach_alpha(cpss_items[, cpss_it[8:14]]), "") ## ---- SSRS 14 个计分项 其中两项记的是支持来源个数 ---- ssrs <- read_item_sheet("SSRS", c(paste0("S", 1:14), "Objective", "Subjective")) ssrs_num <- as.data.frame(lapply(paste0("S", 1:14), function(nm) { v <- ssrs[[nm]] if (is.character(v)) count_sources(v) else as.numeric(v) })) names(ssrs_num) <- paste0("S", 1:14) ssrs_keep <- stats::complete.cases(ssrs_num) ssrs_num <- ssrs_num[ssrs_keep, , drop = FALSE] add_rel("SSRS all 14 scoring entries", 14, nrow(ssrs_num), cronbach_alpha(ssrs_num), "value reported in Measures; the two source-count entries are scored as counts") ## SSRS 计分还原核对 14 个计分项应当原样还原工作簿里的三个分量表分 ssrs_chk <- data.frame( Subscale = c("Objective (items 2, 6, 7)", "Subjective (items 1, 3, 4, 5; 5 is subdivided)", "Utilization (items 8, 9, 10)"), Entries = c("S2 + S10 + S11", "S1, S3, S4, S5, S6, S7, S8, S9", "S12, S13, S14"), Observed_min = NA_real_, Observed_max = NA_real_, Rows_matching_workbook = NA_integer_, Rows_total = nrow(ssrs_num), stringsAsFactors = FALSE) ssrs_rec <- data.frame( Objective = ssrs_num$S2 + ssrs_num$S10 + ssrs_num$S11, Subjective = rowSums(ssrs_num[, c("S1", "S3", "S4", "S5", "S6", "S7", "S8", "S9")]), Utilization = rowSums(ssrs_num[, c("S12", "S13", "S14")])) for (k in seq_len(3)) { nm <- names(ssrs_rec)[k] rec <- ssrs_rec[[nm]] ssrs_chk$Observed_min[k] <- min(rec) ssrs_chk$Observed_max[k] <- max(rec) ssrs_chk$Rows_matching_workbook[k] <- if (nm %in% names(ssrs)) sum(abs(rec - as.numeric(ssrs[[nm]])[ssrs_keep]) < 1e-8) else NA_integer_ } print(ssrs_chk) if (!any(is.na(ssrs_chk$Rows_matching_workbook)) && all(ssrs_chk$Rows_matching_workbook == nrow(ssrs_num))) { cat(" SSRS 14 个计分项原样还原了工作簿里的三个分量表分 全部 362 行一致\n") } else { cat("！SSRS 计分还原与工作簿不一致 先核对 count_sources 的规则再报 alpha\n") } ## ---- ISI ---- isi_it <- paste0("I", 1:7) isi <- read_item_sheet("ISI", isi_it) isi_items <- as.data.frame(lapply(isi[, isi_it], as.numeric)) isi_items <- isi_items[stats::complete.cases(isi_items), , drop = FALSE] add_rel("ISI all 7 items", 7, nrow(isi_items), cronbach_alpha(isi_items), "value reported in Measures") reliability_tab <- do.call(rbind, rel_rows) print(reliability_tab) ## --- PA 条目级方向核验 回信 Minor 2 第一条检验的出处 --- pa_item_tab <- do.call(rbind, lapply(pa_it, function(it) { data.frame( PA_item = it, r_with_EE_Sum = round(cor(as.numeric(mbi[[it]]), as.numeric(mbi$EE_Sum), method = "spearman", use = "complete.obs"), 3), r_with_DP_Sum = round(cor(as.numeric(mbi[[it]]), as.numeric(mbi$DP_Sum), method = "spearman", use = "complete.obs"), 3), stringsAsFactors = FALSE) })) pa_item_tab$Direction_consistent_with_burnout <- ifelse(pa_item_tab$r_with_EE_Sum >= 0 & pa_item_tab$r_with_DP_Sum >= 0, "yes", "NO - check before writing") print(pa_item_tab) cat("\nPA 条目级相关区间 与 EE_Sum:", sprintf("%.2f 到 %.2f", min(pa_item_tab$r_with_EE_Sum), max(pa_item_tab$r_with_EE_Sum)), " 与 DP_Sum:", sprintf("%.2f 到 %.2f", min(pa_item_tab$r_with_DP_Sum), max(pa_item_tab$r_with_DP_Sum)), "\n") ## --- 十一节点直测 把 Age 与 WorkYears 当节点而不是协变量 --- node11_edges <- NULL node11_note <- "skipped: Age / WorkYears not found in the Summary sheet" if (all(c("Age", "WorkYears") %in% names(raw_data))) { d11 <- as.data.frame(raw_data[, c(node_vars, "Age", "WorkYears")]) names(d11)[match(c("Age", "WorkYears"), names(d11))] <- c("Age", "Tenure") d11 <- as.data.frame(lapply(d11, as.numeric)) d11 <- d11[stats::complete.cases(d11), , drop = FALSE] net11 <- estimateNetwork(d11, default = "EBICglasso", corMethod = "spearman", tuning = 0.5) wmat11 <- getWmat(net11) dimnames(wmat11) <- list(colnames(d11), colnames(d11)) cor11 <- cor(d11, method = "spearman") demo <- c("Age", "Tenure") subs <- setdiff(colnames(d11), demo) node11_edges <- do.call(rbind, lapply(demo, function(a) { do.call(rbind, lapply(subs, function(b) { data.frame(From = a, To = b, Partial_r = round(wmat11[a, b], 3), stringsAsFactors = FALSE) })) })) node11_edges <- node11_edges[order(-abs(node11_edges$Partial_r)), ] rownames(node11_edges) <- NULL ## 两个中位数都报出来 回信 G3 引用的是十一节点网络里九个实质节点之间的中位数 sub11 <- wmat11[subs, subs] m11 <- abs(sub11[upper.tri(sub11)]) med11 <- median(m11[m11 > 1e-10]) w9 <- abs(weight_matrix[upper.tri(weight_matrix)]) med9 <- median(w9[w9 > 1e-10]) node11_note <- paste0( "Age-Tenure Spearman rho = ", round(cor11["Age", "Tenure"], 3), "; their partial correlation with all other nodes held constant = ", round(wmat11["Age", "Tenure"], 3), ". Of the 18 edges linking Age and Tenure to the nine substantive nodes, ", sum(abs(node11_edges$Partial_r) > 1e-10), " are non-zero, with |partial r| from ", round(min(abs(node11_edges$Partial_r[abs(node11_edges$Partial_r) > 1e-10])), 3), " to ", round(max(abs(node11_edges$Partial_r)), 3), ". Median |partial r| among the nine substantive nodes: ", round(med11, 3), " in the eleven-node network and ", round(med9, 3), " in the reported nine-node network. ", "Possible edges rise from 36 to 55, so observations per parameter fall from ", round(nrow(d11) / 36, 1), " to ", round(nrow(d11) / 55, 1), ".") cat("\n十一节点直测\n ", node11_note, "\n") print(head(node11_edges, 6)) } else { cat("\n！Summary 表里找不到 Age / WorkYears 跳过十一节点直测\n") } r16_sheets <- list(Reliability = reliability_tab, SSRS_scoring_check = ssrs_chk, PA_item_level = pa_item_tab, Notes = data.frame(Item = "Eleven-node direct test", Value = node11_note, stringsAsFactors = FALSE)) if (!is.null(node11_edges)) r16_sheets$Eleven_node_edges <- node11_edges write_xlsx(r16_sheets, file.path(rev_table_dir, "TableR16_Reliability_and_Item_Checks.xlsx")) reg_out("R1m2c / R2G3b", "TableR16_Reliability_and_Item_Checks.xlsx") cat("\n信度提醒\n") cat(" 正文 Measures 里的五个 alpha 现在全部来自本模块 可以逐个对上\n") cat(" MBI-GS 记录方向 alpha 高于 PA 反向计分后的 alpha 这是 PA 方向的第三个证据\n") }, error = function(e) { r16_ok <<- FALSE cat("\n！R1m2c 模块失败:", conditionMessage(e), "\n") cat(" 后续模块继续运行 但 TableR16 未生成\n") cat(" 正文 Measures 的五个 alpha 与回信 G3 的十一节点数字将没有脚本出处\n") }) # ============================================================================ # 返修对照表 审稿意见 -> 本脚本模块 -> 输出文件 -> 是否还需改正文 # 这张表直接作为 point-by-point response 的索引 # ============================================================================ cat("\n-------- 生成 审稿意见-输出 对照表 --------\n") resp_map <- data.frame( Comment = c( "R1 Major 1a", "R1 Major 1b", "R1 Major 1c", "R1 Major 2", "R1 Minor 1", "R1 Minor 2", "R1 Minor 3", "R1 Minor 4", "R1 Minor 5", "R2 General (sample size)", "R2 General (covariates)", "R2 General (Jaccard = 1)", "R2 General (SEM/GGM argumentation)", "R2 Q1", "R2 Q2", "R2 Q3", "R2 Q4", "R2 Q5", "R2 Q6", "R2 Q7 (BN maxp)", "R2 Q7 (GGM density)", "R2 Q8", "R2 Q9", "R2 Q10"), Issue = c( "What unique information does the GGM add once the Gaussian BN is estimated", "Why was centrality computed only in the GGM and not in the BN", "Implications of non-normality for a Gaussian graphical model", "Network influence measures are not causal intervention effects", "Replace the 52% pandemic pooled prevalence with a non-pandemic estimate", "How were the subscale scores computed and what is the possible range", "Define what is meant by edge weights", "Skewness and kurtosis are missing from Table 1", "How should a one-step direct effect of 1.301 be interpreted", "Sample size is small for this type of analysis", "Why are age and years at the hospital not in the model", "Jaccard indices of 1 look suspicious", "Both SEM and GGM are criticized; the argument is incoherent", "Demand-resource imbalance rather than job demands alone", "The SEM paragraph makes incorrect claims", "The following paragraph contradicts the previous one", "Is 18 years too young; does tenure under 1 year make sense", "Gaussian models assume normality; what if the data were normalized first", "Same-construct subscales inflate edge strengths and R2", "How was the maximum number of parents chosen; which statistics justify it", "Is 33 of 36 edges the optimal model or the most overfitted one", "The intervention simulation is purely computational", "Data-driven artifacts such as the near-zero Tension-OutCtrl edge", "GGM thresholds should be verified by an experienced user"), Module = c( "R1M1a", "R1M1b", "R1M1c", "R1M2", "text only", "R1m2 (+ main Table 1)", "R1m3", "R1m4 (main Table 1)", "R1m5 / R1M2", "R2G1", "R2G2", "R2G3", "text only", "text only", "text only", "text only", "R2Q4", "R2Q5", "R2Q6", "R2Q7a", "R2Q7b", "R2Q8 (= R1M2)", "R2Q9", "code + log release"), Output = c( "TableR05", "TableR06 + FigR03", "TableR03 + TableR04 + FigR01/FigR02", "TableR07 + FigR04", "-", "TableR02 + Table1", "TableR01", "Table1", "TableR01 + TableR07", "TableR14", "TableR12 + FigR08/FigR09", "TableR15", "-", "-", "-", "-", "TableR13 + FigR10", "TableR03/R04 + FigR01/R02", "TableR10", "TableR08 + FigR05", "TableR09 + FigR06/FigR07", "TableR07 + FigR04", "TableR11", "run_log_main.txt + sessionInfo_main.txt + this script"), Manuscript_edit_still_required = c( "yes - rewrite the rationale paragraph using the overlap counts", "yes - add one sentence in Statistical Analysis and one in Results", "yes - add the sensitivity analysis to Methods and Limitations", "yes - remove causal wording throughout Results and Discussion", "yes - replace the citation and the prevalence figure", "yes - state 'sum of item raw scores' and CORRECT the CPSS scoring from 0-4 to 1-5", "yes - one clause in Statistical Analysis", "yes - add two columns to Table 1", "yes - rename the quantity and delete 'intervention' from the label", "yes - report N = 362 in the rebuttal and soften the stability claim", "yes - add covariate results to Methods, Results and Limitations", "yes - delete the 'strong evidence for robustness' sentences", "yes - rewrite or delete the SEM paragraph", "yes", "yes", "yes", "yes - report the observed minimum age and the sensitivity analysis", "yes - add to Methods and Limitations", "yes - add the decomposition and a measurement-redundancy limitation", "yes - report the selected maxp and the selection criterion", "yes - report the out-of-sample comparison in Results", "yes - reframe as hypothesis-generating throughout", "yes - reframe the near-zero edge as a collinearity artifact", "no - supply the script, the log and sessionInfo as supplementary files"), stringsAsFactors = FALSE ) print(resp_map[, c("Comment", "Module", "Output")]) write_xlsx(list(Response_map = resp_map, Generated_files = rev_outputs), file.path(rev_table_dir, "TableR00_Response_Mapping.xlsx")) cat("\n返修模块输出目录:", rev_dir, "\n") cat("对照表: revision/tables/TableR00_Response_Mapping.xlsx\n") ## --- 还原随机数状态 保证模块15 与模块16 与原脚本完全一致 --- if (!is.null(seed_backup)) assign(".Random.seed", seed_backup, envir = .GlobalEnv) cat("\n################ 返修模块结束 ################\n") # ============================================================================ # 15. 汇总报告 (Summary Report) # ============================================================================ cat("\n\n") cat("================================================================\n") cat(" 分析完成 - 结果汇总 \n") cat("================================================================\n\n") cat("样本量: N =", nrow(net_data), "\n") cat("节点数: p =", ncol(net_data), "\n") cat("非零边数:", n_edges, "/", n_possible, "\n") cat("网络密度:", round(n_edges / n_possible, 3), "\n\n") cat("--- GGM中心性排名 (Expected Influence) ---\n") ei_rank <- centrality_raw[order(-centrality_raw$ExpectedInfluence), ] for (i in 1:nrow(ei_rank)) { cat(sprintf(" %d. %s (EI = %.4f)\n", i, ei_rank$Node[i], ei_rank$ExpectedInfluence[i])) } cat("\n--- 节点预测性 R² ---\n") for (i in 1:nrow(node_r2)) { cat(sprintf(" %s: R² = %.3f\n", node_r2$Node[i], node_r2$R2[i])) } cat("\n--- 桥中心性排名 (Bridge Expected Influence) ---\n") bridge_rank <- bridge_df[order(-abs(bridge_df$Bridge_ExpectedInfluence)), ] for (i in 1:min(5, nrow(bridge_rank))) { cat(sprintf(" %d. %s [%s] (BEI = %.4f)\n", i, bridge_rank$Node[i], bridge_rank$Group[i], bridge_rank$Bridge_ExpectedInfluence[i])) } cat("\n--- 贝叶斯网络 (Bootstrap平均, threshold=0.5) ---\n") cat(" 弧数:", narcs(avg_bn), "\n") if (nrow(arcs(avg_bn)) > 0) { for (i in 1:nrow(arcs(avg_bn))) { cat(sprintf(" %s -> %s\n", arcs(avg_bn)[i, 1], arcs(avg_bn)[i, 2])) } } cat("\n--- 连通性传播排名 (一步 + 二步) ---\n") for (i in 1:nrow(combined_effect)) { cat(sprintf(" %d. %s [%s] (Combined = %.4f)\n", i, combined_effect$Node[i], combined_effect$Group[i], combined_effect$Combined_Effect[i])) } cat("\n--- Bootstrap稳定性 (CS系数) ---\n") for (i in 1:nrow(cs_df)) { status <- ifelse(cs_df$CS_Coefficient[i] >= 0.5, "佳 ✓", ifelse(cs_df$CS_Coefficient[i] >= 0.25, "可接受", "不稳定 ✗")) cat(sprintf(" %s: CS = %.3f (%s)\n", cs_df$Measure[i], cs_df$CS_Coefficient[i], status)) } cat("\n 注意: Betweenness/Closeness CS=0，论文中不应解释这两个指标。\n") cat(" 仅报告Strength和Expected Influence（CS均>=0.5，稳定可靠）。\n") cat("\n--- Gamma敏感性分析 ---\n") print(gamma_results[, c("Gamma", "N_Edges", "Density", "Top3_EI")]) cat(" 若不同gamma下Top3排名一致，说明结论对参数选择稳健。\n") cat("\n================================================================\n") cat("输出目录:", output_dir, "\n") cat(" figures/ — 所有图表 (PDF)\n") cat(" tables/ — 所有数据表 (Excel)\n") cat(" revision/ — 返修专用表与图 见 tables/TableR00_Response_Mapping.xlsx\n") cat(" run_log_main.txt / sessionInfo_main.txt — 建议随投稿一并提交\n") cat("================================================================\n") # ============================================================================ # 16. 复现自检 (Reproducibility Check) # 把本次跑出的关键数值与正文已报告的数值逐条对表 # 全部 MATCH 才说明这次运行与投稿版本一致 可以放心引用 # ============================================================================ cat("\n========== 模块16: 复现自检 ==========\n") cs_get <- function(nm) if (nm %in% names(cs_results)) as.numeric(cs_results[nm]) else NA_real_ this_run <- c( nrow(net_data), n_edges, round(n_edges / n_possible, 3), round(centrality_raw$Strength[centrality_raw$Node == "EE"], 4), round(centrality_raw$ExpectedInfluence[centrality_raw$Node == "EE"], 4), round(node_r2$R2[node_r2$Node == "EE"], 3), round(cs_get("strength"), 3), round(cs_get("expectedInfluence"), 3), narcs(avg_bn) ) manuscript <- c(362, 33, 0.917, 1.3007, 0.9727, 0.677, 0.517, 0.751, 15) repro_check <- data.frame( Item = c("Sample size N", "Number of edges", "Network density", "EE strength", "EE expected influence", "EE predictability R2", "CS coefficient (strength)", "CS coefficient (expected influence)", "Arcs in averaged Bayesian network"), Reported_in_manuscript = manuscript, This_run = this_run, Match = ifelse(!is.na(this_run) & abs(this_run - manuscript) < 1e-3, "MATCH", "DIFFERENT"), stringsAsFactors = FALSE ) print(repro_check) n_diff <- sum(repro_check$Match == "DIFFERENT") if (n_diff == 0) { cat("\n九项关键数值全部与正文一致 本次运行可直接用于返修\n") } else { cat("\n！有", n_diff, "项与正文不一致 见上表 Match 列\n") cat(" 最常见的原因是随机流被改动 例如在模块3的 set.seed 与模块7c 的\n") cat(" boot.strength 之间插入了消耗随机数的代码 或者包版本发生了变化\n") cat(" 在把新数值写进正文之前 请先确认改动是有意为之\n") } write_xlsx(repro_check, file.path(table_dir, "Table14_Reproducibility_Check.xlsx")) # 会话信息 BMC 要求可复现 建议随投稿材料一并提交 writeLines(capture.output(sessionInfo()), file.path(output_dir, "sessionInfo_main.txt")) cat("sessionInfo 已保存\n") # 输出文件清单 cat("\n生成的文件清单:\n") all_files <- list.files(output_dir, recursive = TRUE) for (f in all_files) cat(" ", f, "\n") cat("\n运行结束时间:", format(Sys.time()), "\n") while (sink.number() > 0) sink() try(close(log_con), silent = TRUE) cat("\n分析全部完成！\n")