## ========== coxp_ui.R 去错版 ========== ## 1. 常量 ----------------------------------------------------------------- coxp_show_interactions <- setNames(c("", 2, 3), c(i18n$t("None"), i18n$t("2-way"), i18n$t("3-way"))) coxp_predict <- setNames(c("none", "data", "cmd", "datacmd"), c(i18n$t("None"), i18n$t("Data"), i18n$t("Command"), i18n$t("Data & Command"))) coxp_check <- setNames(c("robust"), c(i18n$t("Robust"))) coxp_sum_check <- setNames(c("rmse", "confint"), c(i18n$t("RMSE"), i18n$t("Confidence intervals"))) coxp_lines <- setNames(c("line", "loess", "jitter"), c(i18n$t("Line"), i18n$t("Loess"), i18n$t("Jitter"))) coxp_plots <- setNames( c("none", "dist", "correlations", "scatter", "vip", "pred_plot", "pdp", "dashboard", "resid_pred", "coef", "influence"), c(i18n$t("None"), i18n$t("Distribution"), i18n$t("Correlations"), i18n$t("Scatter"), i18n$t("Permutation Importance"), i18n$t("Prediction plots"), i18n$t("Partial Dependence"), i18n$t("Dashboard"), i18n$t("Residual vs explanatory"), i18n$t("Coefficient plot"), i18n$t("Influential observations")) ) ## 2. 参数收集 ------------------------------------------------------------- ## 不再取 formals,全部用空列表占位 coxp_args <- list() coxp_sum_args <- list() coxp_plot_args <- list() coxp_pred_args <- list() coxp_pred_plot_args <- list() ## 输入收集 reactive coxp_inputs <- reactive({ args <- list() args$data_filter <- if (input$show_filter) input$data_filter else "" args$arr <- if (input$show_filter) input$data_arrange else "" args$rows <- if (input$show_filter) input$data_rows else "" args$dataset <- input$dataset ## 其余参数手动映射 for (i in r_drop(names(args))) { args[[i]] <- input[[paste0("coxp_", i)]] } args }) coxp_sum_inputs <- reactive({ args <- coxp_sum_args for (i in names(args)) args[[i]] <- input[[paste0("coxp_", i)]] args }) coxp_plot_inputs <- reactive({ list() }) coxp_pred_inputs <- reactive({ args <- coxp_pred_args for (i in names(args)) args[[i]] <- input[[paste0("coxp_", i)]] args$pred_cmd <- "" args$pred_data <- "" if (input$coxp_predict == "cmd") { args$pred_cmd <- gsub("\\s{2,}", " ", input$coxp_pred_cmd) %>% gsub(";\\s+", ";", .) %>% gsub("\"", "\'", .) } else if (input$coxp_predict == "data") { args$pred_data <- input$coxp_pred_data } else if (input$coxp_predict == "datacmd") { args$pred_cmd <- gsub("\\s{2,}", " ", input$coxp_pred_cmd) %>% gsub(";\\s+", ";", .) %>% gsub("\"", "\'", .) args$pred_data <- input$coxp_pred_data } args }) coxp_pred_plot_inputs <- reactive({ list() }) ## 3. 变量选择 UI ---------------------------------------------------------- output$ui_coxp_time <- renderUI({ isNum <- .get_class() %in% c("integer", "numeric", "ts") vars <- varnames()[isNum] selectInput("coxp_time", i18n$t("Time variable:"), vars, selected = state_single("coxp_time", vars)) }) output$ui_coxp_status <- renderUI({ vars <- varnames() selectInput("coxp_status", i18n$t("Status variable:"), vars, selected = state_single("coxp_status", vars)) }) output$ui_coxp_evar <- renderUI({ req(available(input$coxp_time), available(input$coxp_status)) vars <- setdiff(varnames(), c(input$coxp_time, input$coxp_status)) selectInput("coxp_evar", i18n$t("Explanatory variables:"), vars, selected = state_multiple("coxp_evar", vars), multiple = TRUE, size = min(10, length(vars)), selectize = FALSE) }) ## 4. 交互 / 包含 / 测试变量 ---------------------------------------------- output$ui_coxp_incl <- renderUI({ req(available(input$coxp_evar)) vars <- input$coxp_evar if (input[["coxp_plots"]] == "coef") { vars_init <- vars } else { vars_init <- c() } selectInput( "coxp_incl", i18n$t("Explanatory variables to include:"), choices = vars, selected = state_multiple("coxp_incl", vars, vars_init), multiple = TRUE, size = min(10, length(vars)), selectize = FALSE ) }) output$ui_coxp_incl_int <- renderUI({ req(available(input$coxp_evar)) choices <- character(0) vars <- input$coxp_evar if (length(vars) > 1) { choices <- iterms(vars, 2) } else { updateSelectInput(session, "coxp_incl_int", choices = choices, selected = choices) return() } selectInput( "coxp_incl_int", label = i18n$t("2-way interactions to explore:"), choices = choices, selected = state_multiple("coxp_incl_int", choices), multiple = TRUE, size = min(8, length(choices)), selectize = FALSE ) }) output$ui_coxp_test_var <- renderUI({ req(available(input$coxp_evar)) vars <- input$coxp_evar if (!is.null(input$coxp_int)) vars <- c(vars, input$coxp_int) selectizeInput("coxp_test_var", i18n$t("Variables to test:"), choices = vars, selected = state_multiple("coxp_test_var", vars), multiple = TRUE, options = list(placeholder = i18n$t("None"), plugins = list("remove_button"))) }) ## 5. 交互选择 ------------------------------------------------------------ output$ui_coxp_show_interactions <- renderUI({ vars <- input$coxp_evar isNum <- .get_class() %in% c("integer", "numeric", "ts") if (any(vars %in% varnames()[isNum])) { choices <- coxp_show_interactions[1:3] } else { choices <- coxp_show_interactions[1:max(min(3, length(input$coxp_evar)), 1)] } radioButtons("coxp_show_interactions", i18n$t("Interactions:"), choices = choices, selected = state_init("coxp_show_interactions"), inline = TRUE) }) output$ui_coxp_int <- renderUI({ choices <- character(0) if (is.empty(input$coxp_show_interactions)) return() vars <- input$coxp_evar if (not_available(vars)) return() isNum <- intersect(vars, varnames()[.get_class() %in% c("integer", "numeric", "ts")]) if (length(isNum) > 0) choices <- qterms(isNum, input$coxp_show_interactions) if (length(vars) > 1) choices <- c(choices, iterms(vars, input$coxp_show_interactions)) if (length(choices) == 0) return() selectInput("coxp_int", label = NULL, choices = choices, selected = state_init("coxp_int"), multiple = TRUE, size = min(8, length(choices)), selectize = FALSE) }) ## 6. 预测 / 绘图 / 刷新按钮 ---------------------------------------------- observeEvent(input$dataset, { updateSelectInput(session, "coxp_predict", selected = "none") updateSelectInput(session, "coxp_plots", selected = "none") }) output$ui_coxp_predict_plot <- renderUI({ predict_plot_controls("coxp") }) output$ui_coxp_nrobs <- renderUI({ nrobs <- nrow(.get_data()) choices <- c("1,000" = 1000, "5,000" = 5000, "10,000" = 10000, "All" = -1) %>% .[. < nrobs] selectInput("coxp_nrobs", i18n$t("Number of data points plotted:"), choices = choices, selected = state_single("coxp_nrobs", choices, 1000)) }) output$ui_coxp_store_res_name <- renderUI({ req(input$dataset) textInput("coxp_store_res_name", i18n$t("Store residuals:"), "", placeholder = i18n$t("Provide variable name")) }) run_refresh(coxp_args, "coxp", tabs = "tabs_coxp", label = i18n$t("Estimate model"), relabel = i18n$t("Re-estimate model")) ## 7. 主 UI ---------------------------------------------------------------- output$ui_coxp <- renderUI({ req(input$dataset) tagList( conditionalPanel( condition = "input.tabs_coxp == 'Summary'", wellPanel( actionButton("coxp_run", i18n$t("Estimate model"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") ) ), wellPanel( conditionalPanel( condition = "input.tabs_coxp == 'Summary'", uiOutput("ui_coxp_time"), uiOutput("ui_coxp_status"), uiOutput("ui_coxp_evar"), conditionalPanel( condition = "input.coxp_evar != null", uiOutput("ui_coxp_show_interactions"), conditionalPanel( condition = "input.coxp_show_interactions != ''", uiOutput("ui_coxp_int") ), uiOutput("ui_coxp_test_var"), checkboxGroupInput("coxp_check", NULL, coxp_check, selected = state_group("coxp_check"), inline = TRUE), checkboxGroupInput("coxp_sum_check", NULL, coxp_sum_check, selected = state_group("coxp_sum_check"), inline = TRUE) ) ), conditionalPanel( condition = "input.tabs_coxp == 'Predict'", selectInput("coxp_predict", i18n$t("Prediction input type:"), coxp_predict, selected = state_single("coxp_predict", coxp_predict, "none")), conditionalPanel( "input.coxp_predict == 'data' | input.coxp_predict == 'datacmd'", selectizeInput("coxp_pred_data", i18n$t("Prediction data:"), choices = c("None" = "", r_info[["datasetlist"]]), selected = state_single("coxp_pred_data", c("None" = "", r_info[["datasetlist"]]))) ), conditionalPanel( "input.coxp_predict == 'cmd' | input.coxp_predict == 'datacmd'", returnTextAreaInput("coxp_pred_cmd", i18n$t("Prediction command:"), value = state_init("coxp_pred_cmd", ""), rows = 3, placeholder = i18n$t("Type a formula to set values for model variables (e.g., age = 60; sex = 'Male') and press return")) ), conditionalPanel( condition = "input.coxp_predict != 'none'", checkboxInput("coxp_pred_plot", i18n$t("Plot predictions"), state_init("coxp_pred_plot", FALSE)), conditionalPanel( "input.coxp_pred_plot == true", uiOutput("ui_coxp_predict_plot") ) ), conditionalPanel( "input.coxp_predict == 'data' | input.coxp_predict == 'datacmd'", tags$table( tags$td(textInput("coxp_store_pred_name", i18n$t("Store predictions:"), state_init("coxp_store_pred_name", "pred_coxp"))), tags$td(actionButton("coxp_store_pred", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top") ) ) ), conditionalPanel( condition = "input.tabs_coxp == 'Plot'", selectInput("coxp_plots", i18n$t("Plots:"), choices = coxp_plots, selected = state_single("coxp_plots", coxp_plots)), conditionalPanel( condition = "input.coxp_plots == 'coef' | input.coxp_plots == 'pdp' | input$coxp_plots == 'pred_plot'", uiOutput("ui_coxp_incl"), conditionalPanel( condition = "input.coxp_plots == 'coef'", checkboxInput("coxp_intercept", i18n$t("Include intercept"), state_init("coxp_intercept", FALSE)) ), conditionalPanel( condition = "input.coxp_plots == 'pdp' | input.coxp_plots == 'pred_plot'", uiOutput("ui_coxp_incl_int") ) ), conditionalPanel( condition = "input.coxp_plots %in% c('correlations','scatter','dashboard','resid_pred')", uiOutput("ui_coxp_nrobs"), conditionalPanel( condition = "input.coxp_plots != 'correlations'", checkboxGroupInput("coxp_lines", NULL, coxp_lines, selected = state_group("coxp_lines"), inline = TRUE) ) ) ), conditionalPanel( condition = "(input.tabs_coxp == 'Summary' && input$coxp_sum_check != undefined && input$coxp_sum_check.indexOf('confint') >= 0) || (input.tabs_coxp == 'Predict' && input$coxp_predict != 'none') || (input.tabs_coxp == 'Plot' && input$coxp_plots == 'coef')", sliderInput("coxp_conf_lev", i18n$t("Confidence level:"), min = 0.80, max = 0.99, value = state_init("coxp_conf_lev", .95), step = 0.01) ), conditionalPanel( condition = "input.tabs_coxp == 'Summary'", tags$table( tags$td(uiOutput("ui_coxp_store_res_name")), tags$td(actionButton("coxp_store_res", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top") ) ) ), help_and_report( modal_title = i18n$t("Cox Proportional Hazards Regression"), fun_name = "coxp", help_file = inclMD(file.path(getOption("radiant.path.model"), "app/tools/help/cox.md")) ) ) }) ## 8. 绘图尺寸 ------------------------------------------------------------ coxp_plot <- reactive({ if (coxp_available() != "available") return() if (is.empty(input$coxp_plots, "none")) return() plot_width <- 650 plot_height <- 500 nr_vars <- length(input$coxp_evar) + 1 if (input$coxp_plots == "dist") { plot_height <- (plot_height / 2) * ceiling(nr_vars / 2) } else if (input$coxp_plots == "dashboard") { plot_height <- 1.5 * plot_height } else if (input$coxp_plots == "correlations") { plot_height <- 150 * nr_vars plot_width <- 150 * nr_vars } else if (input$coxp_plots == "coef") { incl <- paste0("^(", paste0(input$coxp_incl, "[|]*", collapse = "|"), ")") nr_coeff <- sum(grepl(incl, .coxp()$coeff$label)) plot_height <- 300 + 20 * nr_coeff } else if (input$coxp_plots %in% c("scatter", "resid_pred")) { plot_height <- (plot_height / 2) * ceiling((nr_vars - 1) / 2) } else if (input$coxp_plots == "vip") { plot_height <- max(500, 30 * nr_vars) } else if (input$coxp_plots %in% c("pdp", "pred_plot")) { nr_vars <- length(input$coxp_incl) + length(input$coxp_incl_int) plot_height <- max(250, ceiling(nr_vars / 2) * 250) if (length(input$coxp_incl_int) > 0) { plot_width <- plot_width + min(2, length(input$coxp_incl_int)) * 90 } } list(plot_width = plot_width, plot_height = plot_height) }) coxp_plot_width <- function() coxp_plot() %>% (function(x) if (is.list(x)) x$plot_width else 650) coxp_plot_height <- function() coxp_plot() %>% (function(x) if (is.list(x)) x$plot_height else 500) coxp_pred_plot_height <- function() if (input$coxp_pred_plot) 500 else 1 ## 9. 输出注册 ------------------------------------------------------------- output$coxp <- renderUI({ register_print_output("summary_coxp", ".summary_coxp") register_print_output("predict_coxp", ".predict_print_coxp") register_plot_output("predict_plot_coxp", ".predict_plot_coxp", height_fun = "coxp_pred_plot_height") register_plot_output("plot_coxp", ".plot_coxp", height_fun = "coxp_plot_height", width_fun = "coxp_plot_width") coxp_output_panels <- tabsetPanel( id = "tabs_coxp", tabPanel(i18n$t("Summary"), value = "Summary", download_link("dl_coxp_coef"), br(), verbatimTextOutput("summary_coxp")), tabPanel(i18n$t("Predict"), value = "Predict", conditionalPanel("input.coxp_pred_plot == true", download_link("dlp_coxp_pred"), plotOutput("predict_plot_coxp", width = "100%", height = "100%")), download_link("dl_coxp_pred"), br(), verbatimTextOutput("predict_coxp")), tabPanel(i18n$t("Plot"), value = "Plot", download_link("dlp_coxp"), plotOutput("plot_coxp", width = "100%", height = "100%")) ) stat_tab_panel( menu = i18n$t("Model > Estimate"), tool = i18n$t("Cox Proportional Hazards Regression"), tool_ui = "ui_coxp", output_panels = coxp_output_panels ) }) ## 10. 可用性检查 ---------------------------------------------------------- coxp_available <- eventReactive(input$coxp_run, { if (not_available(input$coxp_time)) { i18n$t("This analysis requires a time variable of type integer/numeric.") %>% suggest_data("lung") } else if (not_available(input$coxp_status)) { i18n$t("Please select a status (event) variable.") %>% suggest_data("lung") } else if (not_available(input$coxp_evar)) { i18n$t("Please select one or more explanatory variables.") %>% suggest_data("lung") } else { "available" } }) ## 11. 模型估计 ------------------------------------------------------------ .coxp <- eventReactive(input$coxp_run, { ci <- coxp_inputs() ci$envir <- r_data withProgress(message = i18n$t("Estimating Cox model"), value = 1, do.call(coxph, ci)) }) ## 12. summary / predict / plot -------------------------------------------- .summary_coxp <- reactive({ if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **")) if (coxp_available() != "available") return(coxp_available()) summary(.coxp()$model) # 直接调 survival 的 summary }) .predict_coxp <- reactive({ if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **")) if (coxp_available() != "available") return(coxp_available()) if (is.empty(input$coxp_predict, "none")) return(i18n$t("** Select prediction input **")) if ((input$coxp_predict == "data" || input$coxp_predict == "datacmd") && is.empty(input$coxp_pred_data)) return(i18n$t("** Select data for prediction **")) if (input$coxp_predict == "cmd" && is.empty(input$coxp_pred_cmd)) return(i18n$t("** Enter prediction commands **")) withProgress(message = i18n$t("Generating predictions"), value = 1, { pi <- coxp_pred_inputs() pi$object <- .coxp() pi$envir <- r_data do.call(predict, pi) }) }) .predict_print_coxp <- reactive({ .predict_coxp() %>% { if (is.character(.)) cat(., "\n") else print(.) } }) .predict_plot_coxp <- reactive({ req(pressed(input$coxp_run), input$coxp_pred_plot, available(input$coxp_xvar), !is.empty(input$coxp_predict, "none")) withProgress(message = i18n$t("Generating prediction plot"), value = 1, do.call(plot, c(list(x = .predict_coxp()), coxp_pred_plot_inputs()))) }) .plot_coxp <- reactive({ if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **")) if (is.empty(input$coxp_plots, "none")) return(i18n$t("Please select a plot from the drop-down menu")) if (coxp_available() != "available") return(coxp_available()) if (!input$coxp_plots %in% c("coef", "dist", "influence", "vip", "pdp", "pred_plot")) req(input$coxp_nrobs) check_for_pdp_pred_plots("coxp") withProgress(message = i18n$t("Generating plots"), value = 1, { if (input$coxp_plots == "correlations") { capture_plot(do.call(plot, c(list(x = .coxp()), coxp_plot_inputs()))) } else { do.call(plot, c(list(x = .coxp()), coxp_plot_inputs(), shiny = TRUE)) } }) }) ## 13. 报告 / 下载 / 存储 ------------------------------------------------- coxp_report <- function() { if (is.empty(input$coxp_evar)) return(invisible()) outputs <- c("summary") inp_out <- list(list(prn = TRUE), "") figs <- FALSE if (!is.empty(input$coxp_plots, "none")) { inp <- check_plot_inputs(coxp_plot_inputs()) inp_out[[2]] <- clean_args(inp, list()) # coxp_plot_args 已空 inp_out[[2]]$custom <- FALSE outputs <- c(outputs, "plot") figs <- TRUE } if (!is.empty(input$coxp_store_res_name)) { fixed <- fix_names(input$coxp_store_res_name) updateTextInput(session, "coxp_store_res_name", value = fixed) xcmd <- paste0(input$dataset, " <- store(", input$dataset, ", result, name = \"", fixed, "\")\n") } else { xcmd <- "" } if (!is.empty(input$coxp_predict, "none") && (!is.empty(input$coxp_pred_data) || !is.empty(input$coxp_pred_cmd))) { pred_args <- clean_args(coxp_pred_inputs(), list()) if (!is.empty(pred_args$pred_cmd)) pred_args$pred_cmd <- strsplit(pred_args$pred_cmd, ";\\s*")[[1]] else pred_args$pred_cmd <- NULL if (!is.empty(pred_args$pred_data)) pred_args$pred_data <- as.symbol(pred_args$pred_data) else pred_args$pred_data <- NULL inp_out[[2 + figs]] <- pred_args outputs <- c(outputs, "pred <- predict") xcmd <- paste0(xcmd, "print(pred, n = 10)") if (input$coxp_predict %in% c("data", "datacmd")) { fixed <- unlist(strsplit(input$coxp_store_pred_name, "(\\s*,\\s*|\\s*;\\s*)")) %>% fix_names() %>% deparse(., control = getOption("dctrl"), width.cutoff = 500L) xcmd <- paste0(xcmd, "\n", input$coxp_pred_data, " <- store(", input$coxp_pred_data, ", pred, name = ", fixed, ")") } if (input$coxp_pred_plot && !is.empty(input$coxp_xvar)) { inp_out[[3 + figs]] <- clean_args(coxp_pred_plot_inputs(), list()) inp_out[[3 + figs]]$result <- "pred" outputs <- c(outputs, "plot") figs <- TRUE } } update_report( inp_main = clean_args(coxp_inputs(), coxp_args), fun_name = "coxp", inp_out = inp_out, outputs = outputs, figs = figs, fig.width = coxp_plot_width(), fig.height = coxp_plot_height(), xcmd = xcmd ) } observeEvent(input$coxp_store_res, { req(pressed(input$coxp_run)) robj <- .coxp() if (!is.list(robj)) return() fixed <- fix_names(input$coxp_store_res_name) updateTextInput(session, "coxp_store_res_name", value = fixed) withProgress(message = i18n$t("Storing residuals"), value = 1, r_data[[input$dataset]] <- store(r_data[[input$dataset]], robj, name = fixed)) }) observeEvent(input$coxp_store_pred, { req(!is.empty(input$coxp_pred_data), pressed(input$coxp_run)) pred <- .predict_coxp() if (is.null(pred)) return() fixed <- fix_names(input$coxp_store_pred_name) updateTextInput(session, "coxp_store_pred_name", value = fixed) withProgress(message = i18n$t("Storing predictions"), value = 1, r_data[[input$coxp_pred_data]] <- store(r_data[[input$coxp_pred_data]], pred, name = fixed)) }) ## 14. 下载 ---------------------------------------------------------------- dl_coxp_coef <- function(path) { if (pressed(input$coxp_run)) { write.coeff(.coxp(), file = path) } else { cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path) } } download_handler( id = "dl_coxp_coef", fun = dl_coxp_coef, fn = function() paste0(input$dataset, "_coxp_coef"), type = "csv", caption = i18n$t("Save Cox coefficients") ) dl_coxp_pred <- function(path) { if (pressed(input$coxp_run)) { write.csv(.predict_coxp(), file = path, row.names = FALSE) } else { cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path) } } download_handler( id = "dl_coxp_pred", fun = dl_coxp_pred, fn = function() paste0(input$dataset, "_coxp_pred"), type = "csv", caption = i18n$t("Save Cox predictions") ) download_handler( id = "dlp_coxp_pred", fun = download_handler_plot, fn = paste0(input$dataset, "_coxp_pred"), type = "png", caption = i18n$t("Save Cox prediction plot"), plot = .predict_plot_coxp, width = plot_width, height = coxp_pred_plot_height ) download_handler( id = "dlp_coxp", fun = download_handler_plot, fn = function() paste0(input$dataset, "_", input$coxp_plots, "_coxp"), type = "png", caption = i18n$t("Save Cox plot"), plot = .plot_coxp, width = coxp_plot_width, height = coxp_plot_height ) ## 15. 报告 / 截图 --------------------------------------------------------- observeEvent(input$coxp_report, { r_info[["latest_screenshot"]] <- NULL coxp_report() }) observeEvent(input$coxp_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_coxp_screenshot") }) observeEvent(input$modal_coxp_screenshot, { coxp_report() removeModal() })