# quickgen_metrics_ui.R library(shinyjs) library(shinyAce) # 新增:统计结果文本格式化函数 format_stat_text <- function(result, dataset_name) { # 1. 处理“无法计算”的情况 if (is.character(result) && grepl("无法计算", result)) { return(result) } # 2. 单样本t检验(htest类) if (inherits(result, "htest") && grepl("One Sample t-test", result$method)) { # 提取关键指标 var_name <- gsub("^x = df\\$|^df\\$", "", as.character(result$data.name)) mean_val <- round(mean(result$data, na.rm = TRUE), 3) n_val <- length(na.omit(result$data)) n_missing <- sum(is.na(result$data)) sd_val <- round(sd(result$data, na.rm = TRUE), 3) se_val <- round(result$stderr, 3) me_val <- round(se_val * qt(0.975, df = result$parameter), 3) # 边际误差 diff_val <- round(result$estimate, 3) t_val <- round(result$statistic, 3) p_val <- if (result$p.value < 0.001) "< .001" else round(result$p.value, 4) df_val <- result$parameter ci_lower <- round(result$conf.int[1], 3) ci_upper <- round(result$conf.int[2], 3) conf_level <- round(attr(result$conf.int, "conf.level") * 100, 1) # 显著性标记 signif <- if (p_val == "< .001") "***" else if (p_val <= 0.001) "***" else if (p_val <= 0.01) "**" else if (p_val <= 0.05) "*" else if (p_val <= 0.1) "." else " " # 组织文本(完全匹配示例格式) text <- sprintf(paste0( "Single mean test\n", "Data : %s \n", "Variable : %s \n", "Confidence: %.1f%% \n", "Null hyp. : the mean of %s = %.1f \n", "Alt. hyp. : the mean of %s is not equal to %.1f \n", " mean n n_missing sd se me\n", " %6.3f %5s %d %6.3f %5.3f %5.3f\n", " diff se t.value p.value df 2.5%% 97.5%% \n", " %6.3f %5.3f %6.3f %8s %5.0f %6.3f %6.3f %s\n", "Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1" ), dataset_name, var_name, conf_level, var_name, result$null.value, var_name, result$null.value, mean_val, format(n_val, big.mark = ","), n_missing, sd_val, se_val, me_val, diff_val, se_val, t_val, p_val, df_val, ci_lower, ci_upper, signif ) return(text) } # 3. 独立样本t检验(htest类) if (inherits(result, "htest") && grepl("Welch Two Sample t-test|Two Sample t-test", result$method)) { # 提取分组变量和数值变量 data_parts <- strsplit(result$data.name, " ~ ")[[1]] var_name <- data_parts[1] group_var <- data_parts[2] group_vals <- levels(factor(df[[group_var]])) # 分组统计 group1_data <- df[[var_name]][df[[group_var]] == group_vals[1]] group2_data <- df[[var_name]][df[[group_var]] == group_vals[2]] mean1 <- round(mean(group1_data, na.rm = TRUE), 3) mean2 <- round(mean(group2_data, na.rm = TRUE), 3) n1 <- length(na.omit(group1_data)) n2 <- length(na.omit(group2_data)) n_missing1 <- sum(is.na(group1_data)) n_missing2 <- sum(is.na(group2_data)) sd1 <- round(sd(group1_data, na.rm = TRUE), 3) sd2 <- round(sd(group2_data, na.rm = TRUE), 3) se1 <- round(sd1 / sqrt(n1), 3) se2 <- round(sd2 / sqrt(n2), 3) me1 <- round(se1 * qt(0.975, df = n1 - 1), 3) me2 <- round(se2 * qt(0.975, df = n2 - 1), 3) # 检验结果 diff_val <- round(result$estimate[1] - result$estimate[2], 3) t_val <- round(result$statistic, 3) p_val <- if (result$p.value < 0.001) "< .001" else round(result$p.value, 4) df_val <- round(result$parameter, 0) ci_lower <- round(result$conf.int[1], 3) ci_upper <- round(result$conf.int[2], 3) conf_level <- round(attr(result$conf.int, "conf.level") * 100, 1) signif <- if (p_val == "< .001") "***" else if (p_val <= 0.001) "***" else if (p_val <= 0.01) "**" else if (p_val <= 0.05) "*" else if (p_val <= 0.1) "." else " " # 组织文本 text <- sprintf(paste0( "Pairwise mean comparisons (t-test)\n", "Data : %s \n", "Variables : %s, %s \n", "Samples : independent \n", "Confidence: %.1f%% \n", "Adjustment: None \n", " mean n n_missing sd se me\n", " %6s %6.3f %5s %d %6.3f %5.3f %5.3f\n", " %6s %6.3f %5s %d %6.3f %5.3f %5.3f\n", " Null hyp. Alt. hyp. diff p.value \n", " %s = %s %s not equal to %s %6.3f %8s %s\n", "Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1" ), dataset_name, group_var, var_name, conf_level, group_vals[1], mean1, format(n1, big.mark = ","), n_missing1, sd1, se1, me1, group_vals[2], mean2, format(n2, big.mark = ","), n_missing2, sd2, se2, me2, group_vals[1], group_vals[2], group_vals[1], group_vals[2], diff_val, p_val, signif ) return(text) } # 4. 线性回归(lm类) if (inherits(result, "lm")) { # 提取模型信息 model_formula <- as.character(result$call$formula) var_dep <- model_formula[2] vars_indep <- gsub("^ ~ ", "", model_formula[1]) # 系数表 coef_sum <- summary(result)$coefficients coef_text <- " Estimate Std.Error t.value p.value Signif.\n" for (i in 1:nrow(coef_sum)) { term <- rownames(coef_sum)[i] est <- round(coef_sum[i, 1], 4) se <- round(coef_sum[i, 2], 4) t_val <- round(coef_sum[i, 3], 3) p_val <- if (coef_sum[i, 4] < 0.001) "< .001" else round(coef_sum[i, 4], 4) signif <- if (p_val == "< .001") "***" else if (p_val <= 0.001) "***" else if (p_val <= 0.01) "**" else if (p_val <= 0.05) "*" else if (p_val <= 0.1) "." else " " coef_text <- paste0(coef_text, sprintf(" %12s %8.4f %8.4f %6.3f %8s %3s\n", term, est, se, t_val, p_val, signif)) } # 模型拟合度 r2 <- round(summary(result)$r.squared, 4) r2_adj <- round(summary(result)$adj.r.squared, 4) n_val <- nrow(result$model) n_missing <- nrow(df) - n_val # 组织文本 text <- sprintf(paste0( "Linear Regression Model\n", "Data : %s \n", "Formula : %s ~ %s \n", "Dependent : %s \n", "Independent: %s \n", "Sample : n = %s, n_missing = %d \n", "Fit : R² = %.4f, Adjusted R² = %.4f \n", "%s", "Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1" ), dataset_name, var_dep, vars_indep, var_dep, vars_indep, format(n_val, big.mark = ","), n_missing, r2, r2_adj, coef_text ) return(text) } # 5. 其他统计方法(卡方检验、方差分析等,按示例风格扩展) if (inherits(result, "htest") && grepl("Chi-squared test", result$method)) { # 卡方检验文本格式化(类似逻辑,提取列联表、卡方值、p值等) data_parts <- strsplit(result$data.name, " ~ ")[[1]] var1 <- data_parts[1] var2 <- data_parts[2] contingency <- table(df[[var1]], df[[var2]], useNA = "no") chi_val <- round(result$statistic, 3) df_val <- result$parameter p_val <- if (result$p.value < 0.001) "< .001" else round(result$p.value, 4) signif <- if (p_val == "< .001") "***" else if (p_val <= 0.001) "***" else if (p_val <= 0.01) "**" else if (p_val <= 0.05) "*" else if (p_val <= 0.1) "." else " " text <- sprintf(paste0( "Chi-squared Test of Independence\n", "Data : %s \n", "Variables : %s (row), %s (column) \n", "Contingency Table:\n%s\n", "Test Statistic: Chi-squared = %.3f, df = %.0f, p-value = %s %s\n", "Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1" ), dataset_name, var1, var2, capture.output(print(contingency)), chi_val, df_val, p_val, signif ) return(text) } # 6. 直接输出原始结果 return(capture.output(print(result))) } ## ==================== 右下角浮框 ==================== ui_metrics_progress <- tags$div( id = "metrics_progress_box", style = "display:none; position:fixed; bottom:15px; right:15px; width:220px; z-index:9999; background:#f5f5f5; color:#333; border:1px solid #337ab7; border-radius:4px; padding:10px 15px; box-shadow:0 2px 8px rgba(0,0,0,.25);", tags$strong(i18n$t("AI calculating...")), tags$div(class = "progress", tags$div(class = "progress-bar progress-bar-striped active", style = "width:100%")) ) ## ======== 警告弹窗======== ui_metrics_warn <- tags$div( id = "metrics_warn_box", style = "display:none; position:fixed; bottom:15px; right:15px; width:220px; z-index:9999; background:#fff3cd; color:#856404; border:1px solid #ffeaa7; border-radius:4px; padding:10px 15px; box-shadow:0 2px 8px rgba(0,0,0,.25);", tags$strong(i18n$t("Warning:Please enter a request related to scientific research statistical calculation.")) ) ## ==================== 统一入口 ==================== output$quickgen_metrics <- renderUI({ stat_tab_panel( menu = i18n$t("Oneclick generation > AI assistance"), tool = i18n$t("AI generates descriptive statistics(metrics)"), tool_ui = "metrics_main_ui", output_panels = tabPanel( title = i18n$t("Metrics Assistant"), value = "metrics_panel", uiOutput("metrics_result_area") ) ) }) ## ==================== 右侧 Metrics 面板 ==================== output$metrics_main_ui <- renderUI({ tagList( useShinyjs(), ui_metrics_progress, ui_metrics_warn, wellPanel( i18n$t("Describe your analysis request:"), returnTextAreaInput("metrics_prompt", label = NULL, placeholder = i18n$t("e. g. 1. Single mean test for age (null mean=35) in insurance; 2. Chi-squared test between sex and smoker; 3. Linear regression of charges on bmi+age"), rows = 4, value = state_init("metrics_prompt", "")), fluidRow( column(6, uiOutput("ui_metrics_submit")), column(6, uiOutput("metrics_loading")) ) ), wellPanel( i18n$t("Generated R code"), uiOutput("metrics_r_code_block"), fluidRow( column(6, actionButton("metrics_run_code", i18n$t("Run code"), icon = icon("play"), class = "btn-success")), column(6, actionButton("metrics_edit_code", i18n$t("Edit code"), icon = icon("edit"), class = "btn-default")) ) ), help_and_report( modal_title = i18n$t("AI generates descriptive statistics(metrics)"), fun_name = "quickgen_metrics", help_file = inclMD(file.path(getOption("radiant.path.quickgen"), "app/tools/help/quickgen_metrics.md")), lic = "by-sa" ) ) }) ## ==================== 控件渲染 ==================== output$ui_metrics_submit <- renderUI({ req(input$dataset) actionButton("metrics_submit", i18n$t("Send"), icon = icon("magic"), class = "btn-primary") }) output$metrics_loading <- renderUI({ if (isTRUE(r_values$metrics_loading)) tags$div(class = "progress", tags$div(class = "progress-bar progress-bar-striped active", style = "width:100%", i18n$t("Calling metrics calculation model..."))) }) ## ==================== reactiveValues ==================== r_values <- reactiveValues( metrics_r_code = "", metrics_result_type = "text", # 仅保留text/plot/error metrics_result_ready = FALSE, metrics_loading = FALSE ) ## ==================== 生成代码 ==================== observeEvent(input$metrics_submit, { if (is.empty(input$metrics_prompt)) return(showNotification(i18n$t("Please enter a statistical calculation request"), type = "error")) r_values$metrics_loading <- TRUE shinyjs::show("metrics_progress_box") # 显示右下角进度框 on.exit({ r_values$metrics_loading <- FALSE shinyjs::hide("metrics_progress_box") # 无论成功失败都隐藏 }) res <- try(do.call(metrics_generate, list(prompt = input$metrics_prompt, dataset = input$dataset, envir = r_data)), silent = TRUE) if (inherits(res, "try-error")) { showNotification(paste(i18n$t("Metrics API error:"), res), type = "error") return() } r_values$metrics_r_code <- res$r_code r_values$metrics_result_type <- res$type r_values$metrics_result_ready <- FALSE r_values$auto_run <- res$auto_run if (res$type == "empty") { shinyjs::show("metrics_warn_box") shinyjs::delay(3000, shinyjs::hide("metrics_warn_box")) return() } if (isTRUE(r_values$auto_run)) shinyjs::click("metrics_run_code") }) ## ==================== 显示 R 代码 ==================== output$metrics_r_code_block <- renderUI({ codes <- r_values$metrics_r_code tags$pre(codes, style = "background:#f5f5f5; padding:10px; border-radius:4px; font-family:monospace; white-space:pre-wrap; min-height:100px;") }) ## ==================== 运行代码 ==================== observeEvent(input$metrics_run_code, { shinyjs::hide("metrics_progress_box") if (is.empty(r_values$metrics_r_code)) return() if (trimws(r_values$metrics_r_code) == "" || identical(r_values$metrics_result_type, "empty")) { shinyjs::show("metrics_warn_box") shinyjs::delay(3000, shinyjs::hide("metrics_warn_box")) return() } tryCatch({ # 执行代码并获取原始结果 result <- do.call(metrics_run_code, list(r_code = r_values$metrics_r_code, envir = r_data)) r_data$metrics_temp_result <- result dataset_name <- input$dataset # 获取当前数据集名称 # 分支1:屏蔽图表输出 if (inherits(result, "gg") || inherits(result, "ggplot") || inherits(result, "lattice")) { r_values$metrics_result_type <- "text" output$metrics_result_text <- renderText(i18n$t("This tool only supports statistical metrics calculation, not chart generation")) } # 分支2:所有统计结果转为结构化文本 else { r_values$metrics_result_type <- "text" # 调用格式化函数,生成示例风格的文本 formatted_text <- format_stat_text(result, dataset_name) # 输出文本(保留换行和空格对齐) output$metrics_result_text <- renderText(paste(formatted_text, collapse = "\n")) } r_values$metrics_result_ready <- TRUE }, error = function(e) { r_values$metrics_result_type <- "error" # 错误文本格式化 err_msg <- if (grepl("object .* not found", e$message)) { paste0(i18n$t("Error: Target column does not exist - "), e$message) } else if (grepl("non-numeric argument", e$message)) { paste0(i18n$t("Error: Variable type mismatch (e.g., t-test requires numeric variables) - "), e$message) } else { paste0(i18n$t("Error: "), e$message) } output$metrics_result_error <- renderText(err_msg) r_values$metrics_result_ready <- TRUE showNotification(err_msg, type = "error", duration = NULL) }) }, ignoreInit = TRUE) ## ======== 结果展示区(仅文本/错误输出)======== output$metrics_result_area <- renderUI({ req(r_values$metrics_result_ready) tagList( # 所有结果均用文本框展示(含图表屏蔽提示、统计结果、错误) conditionalPanel( condition = "output.metrics_result_type == 'text' || output.metrics_result_type == 'error'", verbatimTextOutput("metrics_result_text", placeholder = TRUE) ) ) }) output$metrics_result_type <- reactive({ r_values$metrics_result_type }) outputOptions(output, "metrics_result_type", suspendWhenHidden = FALSE) ## ==================== 编辑代码模态框 ==================== observeEvent(input$metrics_edit_code, { showModal( modalDialog( title = i18n$t("Edit R Code"), size = "l", footer = tagList( actionButton("metrics_save_code", i18n$t("Save Changes"), class = "btn-primary"), modalButton(i18n$t("Cancel")) ), aceEditor( "metrics_code_editor", mode = "r", theme = getOption("radiant.ace_theme", "tomorrow"), wordWrap = TRUE, value = r_values$metrics_r_code, placeholder = i18n$t("Edit the generated R code here..."), vimKeyBinding = getOption("radiant.ace_vim.keys", FALSE), tabSize = getOption("radiant.ace_tabSize", 2), useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE), showInvisibles = getOption("radiant.ace_showInvisibles", FALSE), autoScrollEditorIntoView = TRUE, minLines = 15, maxLines = 30 ) ) ) }) ## ==================== 保存代码 ==================== observeEvent(input$metrics_save_code, { r_values$metrics_r_code <- input$metrics_code_editor r_values$auto_run <- FALSE removeModal() }) ## ==================== 报告 / 截图 ==================== metrics_report <- function() {} observeEvent(input$metrics_report, metrics_report()) observeEvent(input$metrics_screenshot, radiant_screenshot_modal("modal_metrics_screenshot")) observeEvent(input$modal_metrics_screenshot, { metrics_report(); removeModal() })