diff --git a/radiant.basics/NAMESPACE b/radiant.basics/NAMESPACE index 0499a295ec89bcffdec4d58a597ecbbbcdb574ef..546a8d69ef9e1894b1e78cba4a8c7054f3384bd9 100644 --- a/radiant.basics/NAMESPACE +++ b/radiant.basics/NAMESPACE @@ -7,6 +7,7 @@ S3method(plot,correlation) S3method(plot,cross_tabs) S3method(plot,goodness) S3method(plot,homo_variance_test) +S3method(plot,mda) S3method(plot,normality_test) S3method(plot,prob_binom) S3method(plot,prob_chisq) @@ -27,6 +28,7 @@ S3method(summary,correlation) S3method(summary,cross_tabs) S3method(summary,goodness) S3method(summary,homo_variance_test) +S3method(summary,mda) S3method(summary,normality_test) S3method(summary,prob_binom) S3method(summary,prob_chisq) @@ -48,6 +50,7 @@ export(correlation) export(cross_tabs) export(goodness) export(homo_variance_test) +export(mda) export(normality_test) export(prob_binom) export(prob_chisq) diff --git a/radiant.basics/R/mda.R b/radiant.basics/R/mda.R new file mode 100644 index 0000000000000000000000000000000000000000..2ddf7bbf18a86a73b471a9dd2f4ad7f06ae70c43 --- /dev/null +++ b/radiant.basics/R/mda.R @@ -0,0 +1,448 @@ +############################################ +## Multigroup Difference Analysis (ANOVA/Kruskal-Wallis) +############################################ +#' @export +mda <- function(dataset, + var, + group, + normality_type = c("overall", "by_group"), + data_filter = "", + envir = parent.frame()) { + + # 1. 基础参数处理 + normality_type <- match.arg(normality_type, choices = c("overall", "by_group")) + 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 + ) + + # 3. 数据校验 + if (!var %in% colnames(dataset)) { + stop(paste("因变量", var, "未在数据集中找到!"), call. = FALSE) + } + if (!group %in% colnames(dataset)) { + stop(paste("分组变量", group, "未在数据集中找到!"), call. = FALSE) + } + if (!is.numeric(dataset[[var]])) { + stop(paste("因变量", var, "必须是数值型(当前类型:", class(dataset[[var]]), ")!"), call. = FALSE) + } + + # 4. 有效样本过滤:剔除任一变量缺失的样本 + valid_indices <- !is.na(dataset[[var]]) & !is.na(dataset[[group]]) + valid_data <- dataset[valid_indices, ] # 仅保留有效样本的2列数据 + if (nrow(valid_data) == 0) { + stop("无有效样本(所有样本的因变量/分组变量存在缺失值)!", call. = FALSE) + } + + # 5. 分组变量处理:强制转因子+校验水平 + valid_data[[group]] <- as.factor(valid_data[[group]]) # 强制转因子,避免字符型干扰 + valid_levels <- length(levels(valid_data[[group]])) # 用levels()确保因子水平正确 + if (valid_levels < 2) { + stop(paste("分组变量有效水平不足2个(当前水平数:", valid_levels, "),无法执行检验!"), call. = FALSE) + } + + # 6. 检验计算:调用辅助函数 + homo_res <- run_homo_test(valid_data, var, group) # 方差齐性检验 + norm_res <- run_norm_test(valid_data, var, group, normality_type) # 正态性检验 + + # 7. 绘图数据准备 + plot_obj <- list( + norm = list( + data = valid_data[[var]], + group_data = if (normality_type == "by_group") { + # 把命名向量转为无命名列表,避免asJSON警告 + lapply(split(valid_data[[var]], valid_data[[group]]), function(x) x) + } else NULL, + var = var, + group = group, + type = normality_type + ), + homo = list( + data = valid_data, + var = var, + group = group + ) + ) + + # 8. 结果打包:对齐单独检验的输出结构 + out <- structure( + list( + df_name = df_name, + 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, # 正态性检验结果 + plot_obj = plot_obj + ), + class = "mda" + ) + out +} + +# ------------------------------ +# 辅助函数1:方差齐性检验 +# ------------------------------ +run_homo_test <- function(valid_data, var, group) { + x <- valid_data[[var]] + g <- valid_data[[group]] + res <- tibble::tibble(Test = character(), Statistic = numeric(), p.value = numeric()) + + # 1. Levene检验 + if (requireNamespace("car", quietly = TRUE)) { + tmp <- tryCatch( + expr = car::leveneTest(x ~ g), + error = function(e) { + message(paste("Levene检验执行失败:", e$message)) + return(NULL) + } + ) + if (!is.null(tmp) && nrow(tmp) > 0) { + res <- tibble::add_row(res, + Test = "Levene", + Statistic = as.numeric(tmp[["F value"]][1]), + p.value = as.numeric(tmp[["Pr(>F)"]][1])) + } + } else { + res <- tibble::add_row(res, + Test = "Levene", + Statistic = NA_real_, + p.value = NA_real_) + message("提示:需安装car包以运行Levene检验") + } + + # 2. Bartlett检验 + tmp <- tryCatch( + expr = stats::bartlett.test(x, g), + error = function(e) { + message(paste("Bartlett检验执行失败:", e$message)) + return(NULL) + } + ) + if (!is.null(tmp)) { + res <- tibble::add_row(res, + Test = "Bartlett", + Statistic = as.numeric(tmp$statistic), + p.value = as.numeric(tmp$p.value)) + } else { + res <- tibble::add_row(res, + Test = "Bartlett", + Statistic = NA_real_, + p.value = NA_real_) + } + + # 3. Fligner检验 + tmp <- tryCatch( + expr = stats::fligner.test(x, g), + error = function(e) { + message(paste("Fligner检验执行失败:", e$message)) + return(NULL) + } + ) + if (!is.null(tmp)) { + res <- tibble::add_row(res, + Test = "Fligner", + Statistic = as.numeric(tmp$statistic), + p.value = as.numeric(tmp$p.value)) + } else { + res <- tibble::add_row(res, + Test = "Fligner", + Statistic = NA_real_, + p.value = NA_real_) + } + + res +} + +# ------------------------------ +# 辅助函数2:正态性检验 +# ------------------------------ +run_norm_test <- function(valid_data, var, group, normality_type) { + x <- valid_data[[var]] + g <- valid_data[[group]] + res <- tibble::tibble(Group = character(), Test = character(), Statistic = numeric(), p.value = numeric()) + + # 1. 整体正态性检验 + if (normality_type == "overall") { + res <- dplyr::bind_rows(res, get_single_norm(x, group_label = "Overall")) + } + + # 2. 按分组正态性检验 + if (normality_type == "by_group") { + for (level in levels(g)) { + group_x <- x[g == level] + res <- dplyr::bind_rows(res, get_single_norm(group_x, group_label = level)) + } + } + + res +} + +# ------------------------------ +# 辅助函数3:单组正态性检验 +# ------------------------------ +get_single_norm <- function(x, group_label) { + res <- tibble::tibble(Group = group_label, Test = character(), Statistic = numeric(), p.value = numeric()) + n <- length(x) + + # 1. Shapiro-Wilk检验 + if (n >= 3 && n <= 5000) { + tmp <- tryCatch( + expr = stats::shapiro.test(x), + error = function(e) { + message(paste("Shapiro-Wilk检验(", group_label, ")失败:", e$message, sep = "")) + return(NULL) + } + ) + if (!is.null(tmp)) { + res <- tibble::add_row(res, + Group = group_label, + Test = "Shapiro-Wilk", + Statistic = tmp$statistic, + p.value = tmp$p.value) + } + } else { + res <- tibble::add_row(res, + Group = group_label, + Test = "Shapiro-Wilk", + Statistic = NA_real_, + p.value = NA_real_) + message(paste("Shapiro-Wilk检验(", group_label, ")跳过:样本量需3-5000(当前n=", n, ")", sep = "")) + } + + # 2. Lilliefors-KS检验 + if (requireNamespace("nortest", quietly = TRUE)) { + tmp <- tryCatch( + expr = nortest::lillie.test(x), + error = function(e) { + message(paste("Lilliefors-KS检验(", group_label, ")失败:", e$message, sep = "")) + return(NULL) + } + ) + if (!is.null(tmp)) { + res <- tibble::add_row(res, + Group = group_label, + Test = "Lilliefors-KS", + Statistic = tmp$statistic, + p.value = tmp$p.value) + } else { + res <- tibble::add_row(res, + Group = group_label, + Test = "Lilliefors-KS", + Statistic = NA_real_, + p.value = NA_real_) + } + } else { + res <- tibble::add_row(res, + Group = group_label, + Test = "Lilliefors-KS", + Statistic = NA_real_, + p.value = NA_real_) + message("提示:需安装nortest包以运行KS/AD检验") + } + + # 3. Anderson-Darling检验 + if (requireNamespace("nortest", quietly = TRUE)) { + tmp <- tryCatch( + expr = nortest::ad.test(x), + error = function(e) { + message(paste("Anderson-Darling检验(", group_label, ")失败:", e$message, sep = "")) + return(NULL) + } + ) + if (!is.null(tmp)) { + res <- tibble::add_row(res, + Group = group_label, + Test = "Anderson-Darling", + Statistic = tmp$statistic, + p.value = tmp$p.value) + } else { + res <- tibble::add_row(res, + Group = group_label, + Test = "Anderson-Darling", + Statistic = NA_real_, + p.value = NA_real_) + } + } else { + res <- tibble::add_row(res, + Group = group_label, + Test = "Anderson-Darling", + Statistic = NA_real_, + p.value = NA_real_) + } + + res +} + +# ------------------------------ +# Summary方法 +# ------------------------------ +#' @export +summary.mda <- function(object, dec = 3, ...) { + # 1. 基础信息 + cat("Multigroup Difference Analysis (ANOVA/KW)\n") + cat("Data :", object$df_name, "\n") + cat("Dependent var:", object$var, "(numeric)\n") + cat("Group var :", object$group, "(factor,", length(levels(object$plot_obj$homo$data[[object$group]])), "levels)\n") + cat("Normality test:", object$normality_type, "\n") + cat("Valid samples:", object$valid_n, "\n\n") + + # 2. 正态性检验结果 + cat("=== 1. Normality Test Results ===\n") + if (nrow(object$norm_res) == 0) { + cat(" No valid normality test results.\n\n") + } else { + norm_formatted <- object$norm_res %>% + dplyr::mutate( + Statistic = as.character(round(Statistic, dec)), # 转为字符型,统一类型 + 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)) # 数值转字符 + ) + ) %>% + as.data.frame(stringsAsFactors = FALSE) + + print(norm_formatted, row.names = FALSE, right = FALSE) + cat("\n") + } + + # 3. 方差齐性检验结果 + cat("=== 2. Homogeneity of Variance Results ===\n") + if (nrow(object$homo_res) == 0) { + cat(" No valid homogeneity test results.\n\n") + } else { + homo_formatted <- object$homo_res %>% + dplyr::mutate( + Statistic = as.character(round(Statistic, dec)), # 转为字符型,统一类型 + 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)) # 数值转字符 + ) + ) %>% + as.data.frame(stringsAsFactors = FALSE) + + print(homo_formatted, row.names = FALSE, right = FALSE) + cat("\n") + } + + # 4. 结论提示 + cat("=== 3. Interpretation Tips ===\n") + cat("• 正态性:p ≥ 0.05 → 满足正态性假设\n") + cat("• 方差齐性:p ≥ 0.05 → 满足方差齐性假设\n") + cat("• 若同时满足这两个假设 → 使用方差分析(ANOVA)\n") + cat("• 若任一假设不满足 → 使用Kruskal-Wallis检验\n") + + invisible(object) +} + +# ------------------------------ +# Plot方法 +# ------------------------------ +#' @export +plot.mda <- function(x, + plots = c("norm_qq", "norm_hist", "homo_box"), + shiny = FALSE, custom = FALSE, ...) { + # 1. 基础校验 + if (length(plots) == 0) { + return(ggplot2::ggplot() + + ggplot2::annotate("text", x = 1, y = 1, label = i18n$t("No plots selected")) + + ggplot2::theme_void()) + } + + plot_list <- list() + var_name <- x$var + group_name <- x$group + + # 2. 正态性检验图表 + # 2.1 Q-Q图 + if ("norm_qq" %in% plots) { + if (x$normality_type == "overall") { + p <- ggplot2::ggplot(data.frame(y = x$plot_obj$norm$data), ggplot2::aes(sample = y)) + + ggplot2::stat_qq(color = "#2E86AB", size = 1) + + ggplot2::stat_qq_line(color = "#A23B72", linetype = "dashed") + + ggplot2::labs(x = "Theoretical Quantiles", + y = paste("Empirical Quantiles (", var_name, ")", sep = ""), + title = "Normality: Q-Q Plot (Overall)") + + ggplot2::theme_minimal() + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12)) + plot_list[["norm_qq"]] <- p + } else { + # 按分组画QQ图 + group_data <- x$plot_obj$norm$group_data + for (level in names(group_data)) { + p <- ggplot2::ggplot(data.frame(y = group_data[[level]]), ggplot2::aes(sample = y)) + + ggplot2::stat_qq(color = "#2E86AB", size = 1) + + ggplot2::stat_qq_line(color = "#A23B72", linetype = "dashed") + + ggplot2::labs(x = "Theoretical Quantiles", + y = paste("Empirical Quantiles (", var_name, ")", sep = ""), + title = paste("Normality: Q-Q Plot (", level, ")", sep = "")) + + ggplot2::theme_minimal() + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12)) + plot_list[[paste("norm_qq_", level, sep = "")]] <- p + } + } + } + + # 2.2 直方图 + if ("norm_hist" %in% plots) { + if (x$normality_type == "overall") { + p <- ggplot2::ggplot(data.frame(y = x$plot_obj$norm$data), ggplot2::aes(x = y)) + + ggplot2::geom_histogram(fill = "#F18F01", alpha = 0.7, bins = 30) + + ggplot2::labs(x = var_name, y = "Count", + title = "Normality: Histogram (Overall)") + + ggplot2::theme_minimal() + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12)) + plot_list[["norm_hist"]] <- p + } else { + # 按分组画直方图 + group_data <- x$plot_obj$norm$group_data + for (level in names(group_data)) { + p <- ggplot2::ggplot(data.frame(y = group_data[[level]]), ggplot2::aes(x = y)) + + ggplot2::geom_histogram(fill = "#F18F01", alpha = 0.7, bins = 30) + + ggplot2::labs(x = var_name, y = "Count", + title = paste("Normality: Histogram (", level, ")", sep = "")) + + ggplot2::theme_minimal() + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12)) + plot_list[[paste("norm_hist_", level, sep = "")]] <- p + } + } + } + + # 3. 方差齐性检验图表 + if ("homo_box" %in% plots) { + p <- ggplot2::ggplot(x$plot_obj$homo$data, + ggplot2::aes(x = .data[[group_name]], + y = .data[[var_name]], + fill = .data[[group_name]])) + + ggplot2::geom_boxplot(alpha = 0.7, show.legend = FALSE) + + ggplot2::scale_fill_brewer(palette = "Set2") + + ggplot2::labs(x = group_name, y = var_name, + title = "Homogeneity: Boxplot by Group") + + ggplot2::theme_minimal() + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12)) + plot_list[["homo_box"]] <- p + } + + # 4. 组合图表 + combined_plot <- patchwork::wrap_plots(plot_list, ncol = 1, guides = "collect") + + # 5. 输出 + if (shiny) { + print(combined_plot) + return(invisible(combined_plot)) + } else { + return(combined_plot) + } +} diff --git a/radiant.basics/inst/app/init.R b/radiant.basics/inst/app/init.R index 76b33b87222ef0e7312a2eb9092eb879b339cdc3..596e4b189055798e78f99d0b1be80aaaf6ebc4d2 100644 --- a/radiant.basics/inst/app/init.R +++ b/radiant.basics/inst/app/init.R @@ -4,6 +4,8 @@ r_url_list[["Single mean"]] <- list("tabs_single_mean" = list("Summary" = "basics/single-mean/", "Plot" = "basics/single-mean/plot/")) r_url_list[["Compare means(t-test/Wilcoxon rank-sum test)"]] <- list("tabs_compare_means" = list("Summary" = "basics/compare-means/", "Plot" = "basics/compare-means/plot/")) +r_url_list[["Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"]] <- + list("tabs_mda" = list("Summary" = "basics/mda/", "Plot" = "basics/mda/plot/")) r_url_list[["Single proportion"]] <- list("tabs_single_prop" = list("Summary" = "basics/single-prop/", "Plot" = "basics/single-prop/plot/")) r_url_list[["Compare proportions"]] <- @@ -35,8 +37,9 @@ options( "----", i18n$t("Means"), tabPanel(i18n$t("Single mean"), uiOutput("single_mean")), tabPanel(i18n$t("Compare means(t-test/Wilcoxon rank-sum test)"), uiOutput("compare_means")), - tabPanel(i18n$t("Normality test"),uiOutput("normality_test")), - tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")), + #tabPanel(i18n$t("Normality test"),uiOutput("normality_test")), + #tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")), + tabPanel(i18n$t("Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"),uiOutput("mda")), "----", i18n$t("Proportions"), tabPanel(i18n$t("Single proportion"), uiOutput("single_prop")), tabPanel(i18n$t("Compare proportions"), uiOutput("compare_props")), diff --git a/radiant.basics/inst/app/tools/analysis/mda_ui.R b/radiant.basics/inst/app/tools/analysis/mda_ui.R new file mode 100644 index 0000000000000000000000000000000000000000..249873711fc24993b75384862a66847170b09281 --- /dev/null +++ b/radiant.basics/inst/app/tools/analysis/mda_ui.R @@ -0,0 +1,310 @@ +############################################ +## Multigroup Difference Analysis (ANOVA/KW) - UI +## 对齐单独检验的UI设计:简洁+严格校验+统一风格 +############################################ +## 1. 翻译标签(对齐单独检验的i18n逻辑,保持术语一致) +mda_norm_type <- c("overall", "by_group") +names(mda_norm_type) <- c(i18n$t("Overall (Whole variable)"), + i18n$t("By Group (Each level separately)")) + +mda_plots <- c("norm_qq", "norm_hist", "homo_box") +names(mda_plots) <- c(i18n$t("Normality: Q-Q Plot"), + i18n$t("Normality: Histogram"), + i18n$t("Homogeneity: Boxplot by Group")) + +## 2. 函数形参 +mda_args <- as.list(formals(mda)) +mda_args <- mda_args[names(mda_args) %in% c("dataset", "var", "group", "normality_type", "data_filter")] + +## 3. 输入收集 +mda_inputs <- reactive({ + req(input$dataset) + # 基础参数 + inputs <- list( + dataset = input$dataset, + 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", + envir = r_data + ) + # 校验参数完整性 + for (arg in names(mda_args)) { + if (is.null(inputs[[arg]])) inputs[[arg]] <- mda_args[[arg]] + } + inputs +}) + +## 4. 因变量选择 +output$ui_mda_var <- renderUI({ + req(input$dataset) + current_data <- get_data(input$dataset, envir = r_data) + is_num <- sapply(current_data, function(col) is.numeric(col) || is.ts(col)) + num_vars <- names(is_num)[is_num] + + if (length(num_vars) == 0) { + return(div(class = "alert alert-warning", i18n$t("No numeric variables in dataset. Please select another dataset."))) + } + + # 提取变量类型并组合标签 + var_types <- sapply(current_data[, num_vars, drop = FALSE], function(col) class(col)[1]) + choices <- setNames(nm = paste0(num_vars, " {", var_types, "}"), object = num_vars) + + selectInput( + inputId = "mda_var", + label = i18n$t("Dependent variable:"), + choices = c("None" = "", choices), + selected = state_single("mda_var", num_vars), + multiple = FALSE + ) +}) + +## 5. 分组变量选择 +output$ui_mda_group <- renderUI({ + req(input$dataset) + current_data <- get_data(input$dataset, envir = r_data) + is_group <- sapply(current_data, function(col) is.factor(col) || is.character(col)) + group_candidates <- names(is_group)[is_group] + + valid_groups <- character(0) + for (grp in group_candidates) { + grp_vals <- current_data[[grp]] + valid_levels <- length(unique(grp_vals[!is.na(grp_vals)])) + if (valid_levels >= 2) { + valid_groups <- c(valid_groups, grp) + } + } + + if (length(valid_groups) == 0) { + return(div(class = "alert alert-warning", i18n$t("No valid grouping variables (need ≥2 levels)."))) + } + + #提取变量类型并组合标签 + group_types <- sapply(current_data[, valid_groups, drop = FALSE], function(col) class(col)[1]) + choices <- setNames(nm = paste0(valid_groups, " {", group_types, "}"), object = valid_groups) + + selectInput( + inputId = "mda_group", + label = i18n$t("Grouping variable:"), + choices = choices, + selected = state_single("mda_group", valid_groups), + multiple = FALSE + ) +}) + + +## 6. 正态性检验类型选择 +output$ui_mda_normality_type <- renderUI({ + selectInput( + inputId = "mda_normality_type", + label = i18n$t("Normality test:"), + choices = mda_norm_type, + selected = state_single("mda_normality_type", mda_norm_type, "overall"), + multiple = FALSE + ) +}) + +## 7. 主UI +output$ui_mda <- renderUI({ + req(input$dataset) + tagList( + wellPanel( + # Summary标签页 + conditionalPanel( + condition = "input.tabs_mda == 'Summary'", + uiOutput("ui_mda_var"), + uiOutput("ui_mda_group"), + uiOutput("ui_mda_normality_type") + ), + # Plot标签页 + conditionalPanel( + condition = "input.tabs_mda == 'Plot'", + selectizeInput( + inputId = "mda_plots", + label = i18n$t("Select plots:"), + choices = mda_plots, + selected = state_multiple("mda_plots", mda_plots, "norm_qq"), # 默认选QQ图 + multiple = TRUE, + options = list( + placeholder = i18n$t("Select plot types"), + plugins = list("remove_button", "drag_drop") + ) + ) + ) + ), + # 帮助与报告 + help_and_report( + modal_title = i18n$t("Multigroup Difference Analysis (ANOVA/KW)"), + fun_name = "mda", + help_file = inclMD(file.path(getOption("radiant.path.basics"), + "app/tools/help/mda.md")) + ) + ) +}) + +## 8. 图表尺寸 +mda_plot_dims <- reactive({ + req(.mda()) + plot_count <- length(input$mda_plots) + group_count <- if (.mda()$normality_type == "by_group") { + length(levels(.mda()$plot_obj$homo$data[[.mda()$group]])) + } else { + 1 + } + base_subplot_height_px <- 350 + total_height_px <- base_subplot_height_px * plot_count * group_count + total_height_px <- min(total_height_px, 2000) + total_height_px <- max(total_height_px, 400) + + list( + width = 700, + height = total_height_px + ) +}) + +mda_plot_width <- function() mda_plot_dims()$width +mda_plot_height <- function() mda_plot_dims()$height + +## 9. 输出面板 +output$mda <- renderUI({ + # 注册输出 + register_print_output("summary_mda", ".summary_mda") + register_plot_output("plot_mda", ".plot_mda", + height_fun = "mda_plot_height") + + # 标签页 + mda_panels <- tabsetPanel( + id = "tabs_mda", + tabPanel( + title = i18n$t("Summary"), + value = "Summary", + verbatimTextOutput("summary_mda", placeholder = TRUE) + ), + tabPanel( + title = i18n$t("Plot"), + value = "Plot", + download_link("dlp_mda"), # 下载按钮 + plotOutput("plot_mda", height = "100%"), + style = "margin-top: 10px;" + ) + ) + + # 整合到Radiant标准面板 + stat_tab_panel( + menu = i18n$t("Basics > Means"), + tool = i18n$t("Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"), + tool_ui = "ui_mda", + output_panels = mda_panels + ) +}) + +## 10. 可用性检验 +mda_available <- reactive({ + req(input$dataset) + current_data <- get_data(input$dataset, envir = r_data) + + # 1. 校验因变量 + if (not_available(input$mda_var) || !input$mda_var %in% colnames(current_data)) { + return(i18n$t("Please select a valid numeric dependent variable.")) + } + + # 2. 校验分组变量 + if (not_available(input$mda_group) || !input$mda_group %in% colnames(current_data)) { + return(i18n$t("Please select a valid grouping variable.")) + } + + # 3. 校验分组变量水平 + group_vals <- current_data[[input$mda_group]] + valid_levels <- length(unique(group_vals[!is.na(group_vals)])) + if (valid_levels < 2) { + return(i18n$t("Grouping variable has <2 valid levels. Choose another.")) + } + + # 4. 校验有效样本 + valid_n <- sum(!is.na(current_data[[input$mda_var]]) & !is.na(current_data[[input$mda_group]])) + if (valid_n < 5) { # 最小样本量校验 + return(i18n$t(paste("Valid samples are too few (n=", valid_n, "). Need at least 5.", sep = ""))) + } + + "available" # 所有校验通过 +}) + +## 11. 计算核心 +.mda <- reactive({ + req(mda_available() == "available") + do.call(mda, mda_inputs()) +}) + +.summary_mda <- reactive({ + req(mda_available() == "available") + summary(.mda()) +}) + +.plot_mda <- reactive({ + req(mda_available() == "available") + validate(need(input$mda_plots, i18n$t("Please select at least one plot type first."))) + # 进度提示 + withProgress(message = i18n$t("Generating plots..."), value = 0.5, { + p <- plot(.mda(), plots = input$mda_plots, shiny = TRUE) + setProgress(value = 1) + }) + p +}) + +## 12. 下载与截图 +# 图表下载 +download_handler( + id = "dlp_mda", + fun = function(file) { + # 1. 校验图表对象 + plot_obj <- .plot_mda() + width_in <- mda_plot_width() / 96 + height_in <- mda_plot_height() / 96 + + ggsave( + filename = file, + plot = plot_obj, + width = width_in, + height = height_in, + device = "png", + dpi = 300, + limitsize = FALSE, + bg = "white" + ) + }, + fn = function() paste0(input$dataset, "_mda_plots"), + type = "png", + caption = i18n$t("Save plots") +) + +# 报告生成 +mda_report <- function() { + req(mda_available() == "available") + figs <- length(input$mda_plots) > 0 + # 报告结构 + update_report( + inp_main = clean_args(mda_inputs(), mda_args), + fun_name = "mda", + inp_out = if (figs) list("", list(plots = input$mda_plots)) else list(""), + outputs = if (figs) c("summary", "plot") else "summary", + figs = figs, + fig.width = mda_plot_width(), + fig.height = mda_plot_height() + ) +} + +# 截图功能 +observeEvent(input$mda_report, { + r_info[["latest_screenshot"]] <- NULL + mda_report() +}) + +observeEvent(input$mda_screenshot, { + r_info[["latest_screenshot"]] <- NULL + radiant_screenshot_modal("modal_mda_screenshot") +}) + +observeEvent(input$modal_mda_screenshot, { + mda_report() + removeModal() +}) diff --git a/radiant.basics/inst/app/tools/help/mda.md b/radiant.basics/inst/app/tools/help/mda.md new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391