############################################ ## Homogeneity of variance test - ui ############################################ ## 1. 翻译标签 hv_method <- c("levene", "bartlett", "fligner") names(hv_method) <- c(i18n$t("Levene"), i18n$t("Bartlett"), i18n$t("Fligner")) hv_plots <- c("hist", "density", "boxplot") names(hv_plots) <- c(i18n$t("Histogram"), i18n$t("Density"), i18n$t("Boxplot")) ## 2. 函数形参 hv_args <- as.list(formals(homo_variance_test)) ## 3. 收集输入 hv_inputs <- reactive({ hv_args$data_filter <- if (input$show_filter) input$data_filter else "" hv_args$dataset <- input$dataset for (i in r_drop(names(hv_args))) { hv_args[[i]] <- input[[paste0("hv_", i)]] } hv_args }) ## 4. 变量选择(numeric + grouping) output$ui_hv_var <- renderUI({ isNum <- .get_class() %in% c("integer", "numeric", "ts") vars <- c("None" = "", varnames()[isNum]) selectInput( inputId = "hv_var", label = i18n$t("Variable (select one):"), choices = vars, selected = state_single("hv_var", vars), multiple = FALSE ) }) output$ui_hv_group <- renderUI({ vars <- groupable_vars() selectInput( inputId = "hv_group", label = i18n$t("Grouping variable:"), choices = vars, selected = state_single("hv_group", vars), multiple = FALSE ) }) ## 5. 主 UI output$ui_homo_variance_test <- renderUI({ req(input$dataset) tagList( wellPanel( conditionalPanel( condition = "input.tabs_homo_variance_test == 'Summary'", uiOutput("ui_hv_var"), uiOutput("ui_hv_group"), selectInput( inputId = "hv_method", label = i18n$t("Test method:"), choices = hv_method, selected = state_single("hv_method", hv_method, "levene"), multiple = FALSE ), sliderInput( "hv_conf_lev", i18n$t("Confidence level:"), min = 0.85, max = 0.99, value = state_init("hv_conf_lev", 0.95), step = 0.01 ) ), conditionalPanel( condition = "input.tabs_homo_variance_test == 'Plot'", selectizeInput( inputId = "hv_plots", label = i18n$t("Select plots:"), choices = hv_plots, selected = state_multiple("hv_plots", hv_plots, "boxplot"), multiple = TRUE, options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop")) ) ) ), help_and_report( modal_title = i18n$t("Homogeneity of variance test"), fun_name = "homo_variance_test", help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/homo_variance_test.md")) ) ) }) ## 6. 画图尺寸 hv_plot <- reactive({ list(plot_width = 650, plot_height = 400 * max(length(input$hv_plots), 1)) }) hv_plot_width <- function() hv_plot()$plot_width hv_plot_height <- function() hv_plot()$plot_height ## 7. 输出面板 output$homo_variance_test <- renderUI({ register_print_output("summary_homo_variance_test", ".summary_homo_variance_test") register_plot_output("plot_homo_variance_test", ".plot_homo_variance_test", height_fun = "hv_plot_height") hv_output_panels <- tabsetPanel( id = "tabs_homo_variance_test", tabPanel(title = i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_homo_variance_test")), tabPanel(title = i18n$t("Plot"), value = "Plot", download_link("dlp_homo_variance_test"), plotOutput("plot_homo_variance_test", height = "100%")) ) stat_tab_panel( menu = i18n$t("Basics > Homogeneity"), tool = i18n$t("Homogeneity of variance test"), tool_ui = "ui_homo_variance_test", output_panels = hv_output_panels ) }) ## 8. 可用性检查 hv_available <- reactive({ if (not_available(input$hv_var)) return(i18n$t("This analysis requires a numeric variable. If none are\navailable please select another dataset.") %>% suggest_data("demand_uk")) if (not_available(input$hv_group)) return(i18n$t("Please select a grouping variable.")) "available" }) ## 9. 计算核心 .homo_variance_test <- reactive({ hvi <- hv_inputs() hvi$envir <- r_data do.call(homo_variance_test, hvi) }) .summary_homo_variance_test <- reactive({ if (hv_available() != "available") return(hv_available()) summary(.homo_variance_test()) }) .plot_homo_variance_test <- reactive({ if (hv_available() != "available") return(hv_available()) validate(need(input$hv_plots, i18n$t("Nothing to plot. Please select a plot type"))) withProgress(message = i18n$t("Generating plots"), value = 1, plot(.homo_variance_test(), plots = input$hv_plots, shiny = TRUE)) }) ## 10. Report homo_variance_test_report <- function() { if (is.empty(input$hv_var)) return(invisible()) figs <- length(input$hv_plots) > 0 outputs <- if (figs) c("summary", "plot") else "summary" inp_out <- if (figs) list("", list(plots = input$hv_plots, custom = FALSE)) else list("", "") update_report(inp_main = clean_args(hv_inputs(), hv_args), fun_name = "homo_variance_test", inp_out = inp_out, outputs = outputs, figs = figs, fig.width = hv_plot_width(), fig.height = hv_plot_height()) } ## 11. 下载 & 截图 download_handler( id = "dlp_homo_variance_test", fun = download_handler_plot, fn = function() paste0(input$dataset, "_homo_variance_test"), type = "png", caption = i18n$t("Save homogeneity of variance plot"), plot = .plot_homo_variance_test, width = hv_plot_width, height = hv_plot_height ) observeEvent(input$homo_variance_test_report, { r_info[["latest_screenshot"]] <- NULL homo_variance_test_report() }) observeEvent(input$homo_variance_test_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_homo_variance_test_screenshot") }) observeEvent(input$modal_homo_variance_test_screenshot, { homo_variance_test_report() removeModal() })