## ========== coxp_ui.R ========== ## 1. 常量 ----------------------------------------------------------------- coxp_predict <- setNames(c("none", "data", "cmd", "datacmd"), c(i18n$t("None"), i18n$t("Data"), i18n$t("Command"), i18n$t("Data & Command"))) coxp_lines <- setNames(c("line", "loess", "jitter"), c(i18n$t("Line"), i18n$t("Loess"), i18n$t("Jitter"))) coxp_plots <- setNames( c("none", "dist", "vip", "coef", "survival", "cumhaz", "schoenfeld", "martingale"), c(i18n$t("None"), i18n$t("Distribution"), i18n$t("Permutation Importance"), i18n$t("Coefficient plot"), i18n$t("Survival curves"), i18n$t("Cumulative hazard"), i18n$t("Schoenfeld residuals"), i18n$t("Martingale residuals")) ) ## 2. 参数收集 ------------------------------------------------------------- coxp_args <- list() coxp_plot_args <- list() coxp_pred_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_plot_inputs <- reactive({ args <- list() # 传递用户设置的置信水平 args$conf_lev <- input$coxp_conf_lev %||% 0.95 # 1. 处理 plots 参数 if (is.empty(input$coxp_plots, "none")) { args$plots <- character(0) } else { args$plots <- c(input$coxp_plots) } # 2. 处理 incl 参数 (用于 coef) if (input$coxp_plots == "coef") { args$incl <- input$coxp_incl args$intercept <- input$coxp_intercept } # 3. 处理 lines 参数 (用于 martingale) if (input$coxp_plots == "martingale") { args$lines <- input$coxp_lines } # 4. 处理 nrobs 参数 if (input$coxp_plots %in% c("dist", "martingale")) { args$nrobs <- input$coxp_nrobs } # 5. 添加 shiny 标志 args$shiny <- TRUE return(args) }) 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$conf_lev <- input$coxp_conf_lev %||% 0.95 args$dec <- 3 return(args) }) ## 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 ) }) ## 5. 预测 / 绘图 / 刷新按钮 ---------------------------------------------- observeEvent(input$dataset, { updateSelectInput(session, "coxp_predict", selected = "none") updateSelectInput(session, "coxp_plots", selected = "none") }) 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)) }) run_refresh(coxp_args, "coxp", tabs = "tabs_coxp", label = i18n$t("Estimate model"), relabel = i18n$t("Re-estimate model")) ## 6. 主 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.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( "input.coxp_predict != 'none'", sliderInput("coxp_conf_lev", i18n$t("Confidence level:"), min = 0.80, max = 0.99, value = state_init("coxp_conf_lev", 0.95), step = 0.01) ), 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", "cox_hr"))), 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 == 'martingale'", checkboxGroupInput( "coxp_lines", i18n$t("Add lines:"), coxp_lines, selected = state_group("coxp_lines", "loess") ) ) ) ), 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")) ) ) }) ## 7. 绘图尺寸 ------------------------------------------------------------ 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) switch(input$coxp_plots, "dist" = { plot_height <- (plot_height / 2) * ceiling((nr_vars + 2) / 2) # +2 for time/status }, "coef" = { incl <- paste0("^(", paste0(input$coxp_incl, "[|]*", collapse = "|"), ")") nr_coeff <- if (is.empty(input$coxp_incl)) nr_vars else length(input$coxp_incl) plot_height <- 300 + 20 * nr_coeff }, "vip" = { plot_height <- max(500, 30 * nr_vars) }, "survival" = { plot_height <- 400 plot_width <- 600 }, "cumhaz" = { plot_height <- 400 plot_width <- 600 }, "schoenfeld" = { plot_height <- 400 }, "martingale" = { plot_height <- 400 } ) 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) ## 8. 输出注册 ------------------------------------------------------------- output$coxp <- renderUI({ register_print_output("summary_coxp", ".summary_coxp") register_print_output("predict_coxp", ".predict_print_coxp") 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", 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 ) }) ## 9. 可用性检查 ---------------------------------------------------------- coxp_available <- reactive({ if (!input$dataset %in% names(r_data)) { return(i18n$t("请先加载有效数据集")) } # 检查时间变量 if (is.null(input$coxp_time) || input$coxp_time == "" || !input$coxp_time %in% colnames(r_data[[input$dataset]])) { return(i18n$t("请选择数据集中存在的数值型变量")) } # 检查状态变量 if (is.null(input$coxp_status) || input$coxp_status == "" || !input$coxp_status %in% colnames(r_data[[input$dataset]])) { return(i18n$t("请选择数据集中存在的变量")) } # 检查解释变量 if (is.null(input$coxp_evar) || length(input$coxp_evar) == 0 || length(setdiff(input$coxp_evar, colnames(r_data[[input$dataset]]))) > 0) { return(i18n$t("请选择至少一个数据集中存在的变量")) } return("available") }) ## 10. 模型估计 .coxp <- eventReactive(input$coxp_run, { ds <- tryCatch( get_data(input$dataset, vars = c(), envir = r_data), error = function(e) return(paste("数据集获取失败:", e$message)) ) if (is.character(ds)) return(ds %>% add_class("coxp")) time_var <- input$coxp_time if (!time_var %in% colnames(ds)) return("时间变量不存在于数据集中" %>% add_class("coxp")) if (!is.numeric(ds[[time_var]])) return("时间变量必须是数值型" %>% add_class("coxp")) status_var <- input$coxp_status if (!status_var %in% colnames(ds)) return("状态变量不存在于数据集中" %>% add_class("coxp")) surv_vec <- ds[[status_var]] if (is.factor(surv_vec) || is.character(surv_vec)) { lev <- unique(surv_vec) if (length(lev) != 2) return("状态变量必须是二分类(两个水平)" %>% add_class("coxp")) ds[[status_var]] <- as.numeric(factor(surv_vec, levels = lev)) - 1L } else if (!all(unique(surv_vec) %in% c(0, 1))) { return("状态变量必须只包含 0 和 1" %>% add_class("coxp")) } n_event <- sum(ds[[status_var]]) if (n_event < 1) return("数据中未发生任何事件(status = 1)" %>% add_class("coxp")) evar_missing <- setdiff(input$coxp_evar, colnames(ds)) if (length(evar_missing) > 0) return(paste("解释变量不存在:", paste(evar_missing, collapse = ", ")) %>% add_class("coxp")) rhs <- if (length(input$coxp_evar) > 0) { paste(input$coxp_evar, collapse = " + ") } else { "1" } form <- as.formula(paste0("Surv(", time_var, ", ", status_var, ") ~ ", rhs)) model <- tryCatch( survival::coxph(form, data = ds), error = function(e) return(paste("coxph 模型失败:", e$message)) ) if (is.character(model)) return(model %>% add_class("coxp")) coxp( dataset = input$dataset, time = time_var, status = status_var, evar = input$coxp_evar, data_filter = if (input$show_filter) input$data_filter else "", arr = if (input$show_filter) input$data_arrange else "", rows = if (input$show_filter) input$data_rows else NULL, envir = r_data ) }) ## 11. summary / predict / plot -------------------------------------------- .summary_coxp <- reactive({ if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **")) obj <- .coxp() if (is.character(obj)) { cat(obj, "\n") return() } summary.coxp(obj, dec = 3) }) .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({ pred <- .predict_coxp() if (is.character(pred)) { cat(pred, "\n") return() } print.coxp.predict(pred, n = 10) }) .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()) valid_plots <- c("dist", "vip", "coef", "survival", "cumhaz", "schoenfeld", "martingale") if (!input$coxp_plots %in% valid_plots) { return(i18n$t("Selected plot type is not supported for Cox models.")) } if (input$coxp_plots %in% c("pdp", "pred_plot")) { check_for_pdp_pred_plots("coxp") } withProgress(message = i18n$t("Generating plots"), value = 1, { do.call(plot, c(list(x = .coxp()), coxp_plot_inputs())) }) }) ## 12. 报告 / 下载 / 存储 ------------------------------------------------- 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")) { plot_inp <- coxp_plot_inputs() if (is.null(plot_inp$plots) || length(plot_inp$plots) == 0) { plot_inp$plots <- "" } inp <- check_plot_inputs(plot_inp) inp_out[[2]] <- clean_args(inp, list()) 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, ")") } } 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_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)) }) ## 13. 下载 ---------------------------------------------------------------- dl_coxp_coef <- function(path) { if (!pressed(input$coxp_run)) { cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path) return() } coxp_obj <- .coxp() if (is.character(coxp_obj)) { cat(i18n$t("Model error: "), coxp_obj, file = path) return() } if (inherits(coxp_obj, "coxp") && !is.null(coxp_obj$model)) { coxph_model <- coxp_obj$model } else { cat(i18n$t("Invalid Cox model object. Cannot export coefficients."), file = path) return() } if (!inherits(coxph_model, "coxph")) { cat(i18n$t("Invalid Cox model object. Cannot export coefficients."), file = path) return() } sum_obj <- summary(coxph_model) conf_int <- exp(confint(coxph_model)) n_info <- data.frame( Content = paste0("n=", sum_obj$n, ", number of events=", sum_obj$nevent), stringsAsFactors = FALSE ) coef_table <- as.data.frame(sum_obj$coefficients) coef_table$Variable <- rownames(coef_table) p_col <- grep("Pr(>|z|)", colnames(coef_table), value = TRUE) coef_table$"Pr(>|z|)" <- if (length(p_col) > 0) as.numeric(coef_table[[p_col]]) else NA coef_table$Signif <- if (all(is.numeric(coef_table$"Pr(>|z|)"))) { cut(coef_table$"Pr(>|z|)", breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), labels = c("***", "**", "*", ".", " ")) } else { rep("", nrow(coef_table)) } coef_text <- do.call(rbind, lapply(1:nrow(coef_table), function(i) { row <- coef_table[i, ] data.frame( Content = sprintf( "%-10s %8.4f %10.4f %8.4f %8.4f %10s %5s", row$Variable, row$coef, row$`exp(coef)`, row$`se(coef)`, row$z, ifelse(row$"Pr(>|z|)" < 0.0001, "<0.0001", sprintf("%.4f", row$"Pr(>|z|)")), as.character(row$Signif) ), stringsAsFactors = FALSE ) })) signif_note <- data.frame( Content = "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1", stringsAsFactors = FALSE ) hr_text <- if (nrow(conf_int) > 0) { do.call(rbind, lapply(1:nrow(conf_int), function(i) { var <- rownames(conf_int)[i] exp_coef <- exp(sum_obj$coefficients[var, "coef"]) exp_neg_coef <- 1 / exp_coef data.frame( Content = sprintf( "%-10s %10.4f %10.4f %10.4f %10.4f", var, exp_coef, exp_neg_coef, conf_int[i, 1], conf_int[i, 2] ), stringsAsFactors = FALSE ) })) } else { data.frame(Content = "No HR confidence interval available", stringsAsFactors = FALSE) } hr_header <- data.frame( Content = sprintf("%-10s %10s %10s %10s %10s", "", "exp(coef)", "exp(-coef)", "lower .95", "upper .95"), stringsAsFactors = FALSE ) concordance <- data.frame( Content = paste0("Concordance=", sprintf("%.3f", sum_obj$concordance[1]), " (se = ", sprintf("%.3f", sum_obj$concordance[2]), " )"), stringsAsFactors = FALSE ) format_test <- function(name, test) { if (!is.null(test)) { paste0(name, "=", sprintf("%.1f", test[1]), " on ", test[2], " df, p=", ifelse(test[3] < 0.0001, "<0.0001", sprintf("%.4f", test[3]))) } } tests <- data.frame( Content = c( format_test("Likelihood ratio test", sum_obj$logtest), format_test("Wald test", sum_obj$waldtest), format_test("Score (logrank) test", sum_obj$sctest) ), stringsAsFactors = FALSE ) all_parts <- list( n_info, data.frame(Content = "", stringsAsFactors = FALSE), coef_text, data.frame(Content = "", stringsAsFactors = FALSE), signif_note, data.frame(Content = "", stringsAsFactors = FALSE), hr_header, hr_text, data.frame(Content = "", stringsAsFactors = FALSE), concordance, data.frame(Content = "", stringsAsFactors = FALSE), tests ) write.csv(do.call(rbind, all_parts), file = path, row.names = FALSE, na = "", fileEncoding = "UTF-8", quote = FALSE) } 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)) { cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path) return() } pred <- .predict_coxp() if (is.character(pred)) { cat(i18n$t("Prediction error: "), pred, file = path) return() } write.csv(pred, file = path, row.names = FALSE, fileEncoding = "UTF-8") } 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", 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 ) ## 14. 报告 / 截图 --------------------------------------------------------- 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() })