diff --git a/radiant.basics/NAMESPACE b/radiant.basics/NAMESPACE index 546a8d69ef9e1894b1e78cba4a8c7054f3384bd9..b07bd30e73b68b9f20d58268702f0347588fe063 100644 --- a/radiant.basics/NAMESPACE +++ b/radiant.basics/NAMESPACE @@ -48,6 +48,7 @@ export(compare_props) export(cor2df) export(correlation) export(cross_tabs) +export(get_single_norm) export(goodness) export(homo_variance_test) export(mda) @@ -65,6 +66,10 @@ export(prob_unif) export(radiant.basics) export(radiant.basics_viewer) export(radiant.basics_window) +export(run_anova) +export(run_homo_test) +export(run_kw) +export(run_norm_test) export(single_mean) export(single_prop) import(ggplot2) diff --git a/radiant.basics/R/mda.R b/radiant.basics/R/mda.R index 2ddf7bbf18a86a73b471a9dd2f4ad7f06ae70c43..9e3d0c70aa7588e42a6684dc3b177d210f3b9439 100644 --- a/radiant.basics/R/mda.R +++ b/radiant.basics/R/mda.R @@ -6,18 +6,18 @@ mda <- function(dataset, var, group, normality_type = c("overall", "by_group"), - data_filter = "", + test_method = c("anova", "kw"), envir = parent.frame()) { # 1. 基础参数处理 normality_type <- match.arg(normality_type, choices = c("overall", "by_group")) + test_method <- match.arg(test_method, choices = c("anova", "kw")) df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset)) # 2. 数据提取:只保留“因变量+分组变量” dataset <- get_data( dataset, vars = c(var, group), # 强制只取2个核心变量,剔除冗余列 - filt = data_filter, na.rm = FALSE, # 先不删缺失值,后续统一过滤 envir = envir ) @@ -51,6 +51,13 @@ mda <- function(dataset, homo_res <- run_homo_test(valid_data, var, group) # 方差齐性检验 norm_res <- run_norm_test(valid_data, var, group, normality_type) # 正态性检验 + core_test_res <- NULL + if (test_method == "anova") { + core_test_res <- run_anova(valid_data, var, group) + } else if (test_method == "kw") { + core_test_res <- run_kw(valid_data, var, group) + } + # 7. 绘图数据准备 plot_obj <- list( norm = list( @@ -77,10 +84,11 @@ mda <- function(dataset, var = var, group = group, normality_type = normality_type, - data_filter = if (data_filter == "") "None" else data_filter, valid_n = nrow(valid_data), # 有效样本量 homo_res = homo_res, # 方差齐性检验结果 norm_res = norm_res, # 正态性检验结果 + test_method = test_method, + core_test_res = core_test_res, plot_obj = plot_obj ), class = "mda" @@ -91,6 +99,7 @@ mda <- function(dataset, # ------------------------------ # 辅助函数1:方差齐性检验 # ------------------------------ +#' @export run_homo_test <- function(valid_data, var, group) { x <- valid_data[[var]] g <- valid_data[[group]] @@ -165,6 +174,7 @@ run_homo_test <- function(valid_data, var, group) { # ------------------------------ # 辅助函数2:正态性检验 # ------------------------------ +#' @export run_norm_test <- function(valid_data, var, group, normality_type) { x <- valid_data[[var]] g <- valid_data[[group]] @@ -189,6 +199,7 @@ run_norm_test <- function(valid_data, var, group, normality_type) { # ------------------------------ # 辅助函数3:单组正态性检验 # ------------------------------ +#' @export get_single_norm <- function(x, group_label) { res <- tibble::tibble(Group = group_label, Test = character(), Statistic = numeric(), p.value = numeric()) n <- length(x) @@ -282,12 +293,110 @@ get_single_norm <- function(x, group_label) { res } +# ------------------------------ +# 辅助函数4:方差分析(ANOVA) +# ------------------------------ +#' @export +run_anova <- function(valid_data, var, group) { + tryCatch({ + # 1. 使用列名创建公式 + formula <- reformulate(group, var) + aov_model <- stats::aov(formula, data = valid_data) + aov_summary <- summary(aov_model)[[1]] + + # 2. 检查行数 + if (nrow(aov_summary) < 2) { + stop("ANOVA结果不完整,无法提取统计量") + } + + # 3. 稳健提取:假设最后一行是残差,其余是模型项 + residual_row_idx <- nrow(aov_summary) + model_row_idx <- 1:(nrow(aov_summary) - 1) + + # 4. 安全提取函数(避免空值) + safe_extract <- function(df, row_idx, col, default = NA_real_) { + if (length(row_idx) == 0 || is.na(row_idx)) return(default) + val <- df[row_idx, col] + if (is.null(val) || length(val) == 0 || all(is.na(val))) return(default) + return(as.numeric(val[1])) + } + + # 5. 构建结果(确保每列长度严格为2) + res <- tibble::tibble( + Source = c("Between Groups", "Within Groups (Residuals)"), + Df = c( + as.integer(safe_extract(aov_summary, model_row_idx, "Df", NA_integer_)), + as.integer(safe_extract(aov_summary, residual_row_idx, "Df", NA_integer_)) + ), + Sum_Sq = c( + round(safe_extract(aov_summary, model_row_idx, "Sum Sq"), 3), + round(safe_extract(aov_summary, residual_row_idx, "Sum Sq"), 3) + ), + Mean_Sq = c( + round(safe_extract(aov_summary, model_row_idx, "Mean Sq"), 3), + round(safe_extract(aov_summary, residual_row_idx, "Mean Sq"), 3) + ), + F_Value = c( + round(safe_extract(aov_summary, model_row_idx, "F value"), 3), + NA_real_ + ), + p_Value = c( + round(safe_extract(aov_summary, model_row_idx, "Pr(>F)"), 4), + NA_real_ + ), + Sig = c( + sig_stars(safe_extract(aov_summary, model_row_idx, "Pr(>F)")), + "" + ) + ) + return(res) + }, error = function(e) { + message(paste("ANOVA执行失败:", e$message)) + return(tibble::tibble( + Source = c("Between Groups", "Within Groups (Residuals)"), + Df = NA_integer_, Sum_Sq = NA_real_, Mean_Sq = NA_real_, + F_Value = NA_real_, p_Value = NA_real_, Sig = "" + )) + }) +} + + +# ------------------------------ +# 辅助函数5:Kruskal-Wallis检验 +# ------------------------------ +#' @export +run_kw <- function(valid_data, var, group) { + x <- valid_data[[var]] + g <- valid_data[[group]] + + tryCatch({ + kw_model <- stats::kruskal.test(x ~ g, data = valid_data) + # 整理KW结果表格 + res <- tibble::tibble( + Test = "Kruskal-Wallis", + Chi_Sq = round(as.numeric(kw_model$statistic), 3), + Df = as.integer(kw_model$parameter), + p_Value = round(as.numeric(kw_model$p.value), 4), + Sig = sig_stars(kw_model$p.value) + ) + return(res) + }, error = function(e) { + message(paste("Kruskal-Wallis执行失败:", e$message)) + return(tibble::tibble( + Test = "Kruskal-Wallis", + Chi_Sq = NA_real_, Df = NA_integer_, + p_Value = NA_real_, Sig = "" + )) + }) +} + + # ------------------------------ # Summary方法 # ------------------------------ #' @export summary.mda <- function(object, dec = 3, ...) { - # 1. 基础信息 + # 0. 基础信息 cat("Multigroup Difference Analysis (ANOVA/KW)\n") cat("Data :", object$df_name, "\n") cat("Dependent var:", object$var, "(numeric)\n") @@ -295,7 +404,7 @@ summary.mda <- function(object, dec = 3, ...) { cat("Normality test:", object$normality_type, "\n") cat("Valid samples:", object$valid_n, "\n\n") - # 2. 正态性检验结果 + # 1. 正态性检验结果 cat("=== 1. Normality Test Results ===\n") if (nrow(object$norm_res) == 0) { cat(" No valid normality test results.\n\n") @@ -316,7 +425,7 @@ summary.mda <- function(object, dec = 3, ...) { cat("\n") } - # 3. 方差齐性检验结果 + # 2. 方差齐性检验结果 cat("=== 2. Homogeneity of Variance Results ===\n") if (nrow(object$homo_res) == 0) { cat(" No valid homogeneity test results.\n\n") @@ -337,12 +446,55 @@ summary.mda <- function(object, dec = 3, ...) { cat("\n") } - # 4. 结论提示 + # 3. 结论提示 cat("=== 3. Interpretation Tips ===\n") cat("• 正态性:p ≥ 0.05 → 满足正态性假设\n") cat("• 方差齐性:p ≥ 0.05 → 满足方差齐性假设\n") cat("• 若同时满足这两个假设 → 使用方差分析(ANOVA)\n") - cat("• 若任一假设不满足 → 使用Kruskal-Wallis检验\n") + cat("• 若任一假设不满足 → 使用Kruskal-Wallis检验\n\n") + + # 4.结果提示 + if (is.null(object$core_test_res) || nrow(object$core_test_res) == 0) { + cat(" No valid core test result.\n\n") + } else { + # 根据选择的方法,格式化并显示结果 + if (object$test_method == "anova") { + cat("=== 4. Analysis of Variance (ANOVA)===\n") + # 格式化ANOVA结果 + core_formatted <- object$core_test_res %>% + dplyr::mutate( + p_Value = dplyr::case_when( + is.na(p_Value) ~ "", + p_Value < 0.001 ~ "<0.001", + p_Value < 0.01 ~ as.character(round(p_Value, 3)), + TRUE ~ as.character(round(p_Value, 4)) + ), + F_Value = ifelse(is.na(F_Value), "", as.character(F_Value)), + Df = as.character(Df), + Sum_Sq = as.character(Sum_Sq), + Mean_Sq = as.character(Mean_Sq) + ) %>% + as.data.frame(stringsAsFactors = FALSE) + print(core_formatted, row.names = FALSE, right = FALSE) + } else if (object$test_method == "kw") { + cat("=== 4. Kruskal-Wallis Test===\n") + # 格式化KW结果 + core_formatted <- object$core_test_res %>% + dplyr::mutate( + p_Value = dplyr::case_when( + is.na(p_Value) ~ "", + p_Value < 0.001 ~ "<0.001", + p_Value < 0.01 ~ as.character(round(p_Value, 3)), + TRUE ~ as.character(round(p_Value, 4)) + ), + Chi_Sq = as.character(Chi_Sq), + Df = as.character(Df) + ) %>% + as.data.frame(stringsAsFactors = FALSE) + print(core_formatted, row.names = FALSE, right = FALSE) + } + cat("\n") + } invisible(object) } diff --git a/radiant.basics/inst/app/tools/analysis/mda_ui.R b/radiant.basics/inst/app/tools/analysis/mda_ui.R index 249873711fc24993b75384862a66847170b09281..59fef656013c962371da98d51f823de33fbcbcb4 100644 --- a/radiant.basics/inst/app/tools/analysis/mda_ui.R +++ b/radiant.basics/inst/app/tools/analysis/mda_ui.R @@ -12,9 +12,13 @@ names(mda_plots) <- c(i18n$t("Normality: Q-Q Plot"), i18n$t("Normality: Histogram"), i18n$t("Homogeneity: Boxplot by Group")) +mda_test_methods <- c("anova", "kw") +names(mda_test_methods) <- c(i18n$t("Analysis of Variance (ANOVA)"), + i18n$t("Kruskal-Wallis Test")) + ## 2. 函数形参 mda_args <- as.list(formals(mda)) -mda_args <- mda_args[names(mda_args) %in% c("dataset", "var", "group", "normality_type", "data_filter")] +mda_args <- mda_args[names(mda_args) %in% c("dataset", "var", "group", "normality_type","test_method")] ## 3. 输入收集 mda_inputs <- reactive({ @@ -25,12 +29,12 @@ mda_inputs <- reactive({ var = input$mda_var, group = input$mda_group, normality_type = input$mda_normality_type, - data_filter = if (input$show_filter) input$data_filter else "None", + test_method = input$mda_test_method, envir = r_data ) # 校验参数完整性 for (arg in names(mda_args)) { - if (is.null(inputs[[arg]])) inputs[[arg]] <- mda_args[[arg]] + if (is.null(inputs[[arg]]) || inputs[[arg]] == "") inputs[[arg]] <- mda_args[[arg]] } inputs }) @@ -114,7 +118,14 @@ output$ui_mda <- renderUI({ condition = "input.tabs_mda == 'Summary'", uiOutput("ui_mda_var"), uiOutput("ui_mda_group"), - uiOutput("ui_mda_normality_type") + uiOutput("ui_mda_normality_type"), + radioButtons( + inputId = "mda_test_method", + label = i18n$t("Select test method:"), + choices = mda_test_methods, + selected = state_single("mda_test_method", mda_test_methods, "anova"), + inline = FALSE + ) ), # Plot标签页 conditionalPanel(