############################################ ## 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")) 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","test_method")] ## 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, test_method = input$mda_test_method, envir = r_data ) # 校验参数完整性 for (arg in names(mda_args)) { if (is.null(inputs[[arg]]) || 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"), 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( 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() })