#' @tool_code ST_CORRELATION #' @name 相关分析 #' @version 1.0.0 #' @description Pearson/Spearman 相关系数计算 #' @author SSA-Pro Team library(glue) library(ggplot2) library(base64enc) run_analysis <- function(input) { # ===== 初始化 ===== logs <- c() log_add <- function(msg) { logs <<- c(logs, paste0("[", Sys.time(), "] ", msg)) } on.exit({}, add = TRUE) # ===== 数据加载 ===== log_add("开始加载输入数据") df <- tryCatch( load_input_data(input), error = function(e) { log_add(paste("数据加载失败:", e$message)) return(NULL) } ) if (is.null(df)) { return(make_error(ERROR_CODES$E100_INTERNAL_ERROR, details = "数据加载失败")) } log_add(glue("数据加载成功: {nrow(df)} 行, {ncol(df)} 列")) p <- input$params guardrails_cfg <- input$guardrails var_x <- p$var_x var_y <- p$var_y method <- tolower(p$method %||% "auto") # pearson, spearman, auto # ===== 参数校验 ===== if (!(var_x %in% names(df))) { return(make_error(ERROR_CODES$E001_COLUMN_NOT_FOUND, col = var_x)) } if (!(var_y %in% names(df))) { return(make_error(ERROR_CODES$E001_COLUMN_NOT_FOUND, col = var_y)) } # ===== 数据清洗 ===== original_rows <- nrow(df) df <- df[!is.na(df[[var_x]]) & !is.na(df[[var_y]]), ] removed_rows <- original_rows - nrow(df) if (removed_rows > 0) { log_add(glue("数据清洗: 移除 {removed_rows} 行缺失值 (剩余 {nrow(df)} 行)")) } x_vals <- df[[var_x]] y_vals <- df[[var_y]] n <- length(x_vals) # ===== 护栏检查 ===== guardrail_results <- list() warnings_list <- c() # 样本量检查 sample_check <- check_sample_size(n, min_required = 10, action = ACTION_WARN) guardrail_results <- c(guardrail_results, list(sample_check)) log_add(glue("样本量检查: N = {n}, {sample_check$reason}")) guardrail_status <- run_guardrail_chain(guardrail_results) if (guardrail_status$status == "blocked") { return(list( status = "blocked", message = guardrail_status$reason, trace_log = logs )) } if (length(guardrail_status$warnings) > 0) { warnings_list <- c(warnings_list, guardrail_status$warnings) } # ===== 方法选择 ===== final_method <- method if (method == "auto") { log_add("自动选择相关方法(检验正态性)") # 检验两个变量的正态性 norm_x <- check_normality(x_vals, alpha = 0.05) norm_y <- check_normality(y_vals, alpha = 0.05) log_add(glue("{var_x} 正态性: p = {round(norm_x$p_value, 4)}, {norm_x$reason}")) log_add(glue("{var_y} 正态性: p = {round(norm_y$p_value, 4)}, {norm_y$reason}")) if (norm_x$passed && norm_y$passed) { final_method <- "pearson" log_add("两变量均满足正态性,使用 Pearson 相关") } else { final_method <- "spearman" log_add("存在非正态变量,使用 Spearman 秩相关") warnings_list <- c(warnings_list, "变量不满足正态性,自动切换为 Spearman 秩相关") } } # ===== 核心计算 ===== log_add(glue("执行 {final_method} 相关分析")) result <- cor.test(x_vals, y_vals, method = final_method) r_value <- result$estimate p_value <- result$p.value # 相关系数解释 r_abs <- abs(r_value) r_interpretation <- if (r_abs < 0.1) "可忽略" else if (r_abs < 0.3) "弱" else if (r_abs < 0.5) "中等" else if (r_abs < 0.7) "较强" else "强" log_add(glue("r = {round(r_value, 4)}, p = {round(p_value, 4)}, 相关强度: {r_interpretation}")) # ===== 生成图表 ===== log_add("生成散点图") plot_base64 <- tryCatch({ generate_scatter_plot(df, var_x, var_y, r_value, p_value, final_method) }, error = function(e) { log_add(paste("图表生成失败:", e$message)) NULL }) # ===== 生成可复现代码 ===== original_filename <- if (!is.null(input$original_filename) && nchar(input$original_filename) > 0) { input$original_filename } else { "data.csv" } reproducible_code <- glue(' # SSA-Pro 自动生成代码 # 工具: 相关分析 # 时间: {Sys.time()} # ================================ library(ggplot2) # 数据准备 df <- read.csv("{original_filename}") var_x <- "{var_x}" var_y <- "{var_y}" # 数据清洗 df <- df[!is.na(df[[var_x]]) & !is.na(df[[var_y]]), ] # {final_method} 相关分析 result <- cor.test(df[[var_x]], df[[var_y]], method = "{final_method}") print(result) # 可视化 ggplot(df, aes(x = .data[[var_x]], y = .data[[var_y]])) + geom_point(alpha = 0.6) + geom_smooth(method = "lm", se = TRUE, color = "#3b82f6") + theme_minimal() + labs(title = paste("Correlation:", var_x, "vs", var_y), subtitle = paste("r =", round(result$estimate, 3), ", p =", round(result$p.value, 4))) ') # ===== 返回结果 ===== log_add("分析完成") output_results <- list( method = if (final_method == "pearson") "Pearson product-moment correlation" else "Spearman's rank correlation rho", method_code = final_method, statistic = jsonlite::unbox(round(as.numeric(r_value), 4)), p_value = jsonlite::unbox(as.numeric(p_value)), p_value_fmt = format_p_value(p_value), interpretation = r_interpretation, n = n, variables = list(x = var_x, y = var_y), descriptive = list( x = list( variable = var_x, mean = round(mean(x_vals), 3), sd = round(sd(x_vals), 3), median = round(median(x_vals), 3) ), y = list( variable = var_y, mean = round(mean(y_vals), 3), sd = round(sd(y_vals), 3), median = round(median(y_vals), 3) ) ) ) # Pearson 相关有置信区间 if (final_method == "pearson" && !is.null(result$conf.int)) { output_results$conf_int <- as.numeric(result$conf.int) } # ===== 构建 report_blocks ===== blocks <- list() # Block 1: 分析概况 blocks[[length(blocks) + 1]] <- make_kv_block(list( "变量 X" = var_x, "变量 Y" = var_y, "样本量" = as.character(n), "分析方法" = final_method ), title = "分析概况") # Block 2: 相关分析结果表 ci_str <- if (final_method == "pearson" && !is.null(result$conf.int)) { sprintf("[%.3f, %.3f]", result$conf.int[1], result$conf.int[2]) } else { "-" } corr_headers <- c("r 值", "P 值", "95% CI", "相关强度") corr_rows <- list(c( as.character(round(r_value, 4)), format_p_value(p_value), ci_str, r_interpretation )) blocks[[length(blocks) + 1]] <- make_table_block(corr_headers, corr_rows, title = "相关分析结果") # Block 3: 散点图 if (!is.null(plot_base64)) { blocks[[length(blocks) + 1]] <- make_image_block(plot_base64, title = "散点图", alt = paste(var_x, "vs", var_y)) } # Block 4: 结论摘要 conclusion_text <- glue( "**{var_x}** 与 **{var_y}** 的 {final_method} 相关系数为 r = {round(r_value, 3)} (P {format_p_value(p_value)}),相关强度为 **{r_interpretation}**。" ) blocks[[length(blocks) + 1]] <- make_markdown_block(conclusion_text, title = "结论摘要") return(list( status = "success", message = "分析完成", warnings = if (length(warnings_list) > 0) warnings_list else NULL, results = output_results, report_blocks = blocks, plots = if (!is.null(plot_base64)) list(plot_base64) else list(), trace_log = logs, reproducible_code = as.character(reproducible_code) )) } # 辅助函数:生成散点图 generate_scatter_plot <- function(df, var_x, var_y, r_value, p_value, method) { # 限制点数防止图表过大 if (nrow(df) > 1000) { set.seed(42) df <- df[sample(nrow(df), 1000), ] } p <- ggplot(df, aes(x = .data[[var_x]], y = .data[[var_y]])) + geom_point(alpha = 0.5, color = "#64748b", size = 2) + geom_smooth(method = "lm", se = TRUE, color = "#3b82f6", fill = "#93c5fd") + theme_minimal() + labs( title = paste("Correlation:", var_x, "vs", var_y), subtitle = paste0( ifelse(method == "pearson", "Pearson ", "Spearman "), "r = ", round(r_value, 3), ", p ", format_p_value(p_value) ), x = var_x, y = var_y ) tmp_file <- tempfile(fileext = ".png") ggsave(tmp_file, p, width = 6, height = 5, dpi = 100) base64_str <- base64encode(tmp_file) unlink(tmp_file) return(paste0("data:image/png;base64,", base64_str)) } # 辅助:空值合并运算符 `%||%` <- function(a, b) if (is.null(a)) b else a