AIclinicalresearch/r-statistics-service/tools/correlation.R

#' @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