From ad60c0cfaa562831854d73d15b0bca9ebeeb8964 Mon Sep 17 00:00:00 2001
From: wuzekai <3025054974@qq.com>
Date: Mon, 13 Oct 2025 17:25:07 +0800
Subject: [PATCH] update
---
radiant-master/inst/app/server.R | 4 +-
.../inst/translations/translation_zh.csv | 6 +-
.../inst/app/tools/help/homo_variance_test.md | 19 +
.../inst/app/tools/help/normality_test.md | 19 +
radiant.data/inst/app/tools/app/stop.R | 2 +-
radiant.model/R/cox.R | 346 +++++++++++--
.../inst/app/tools/analysis/cox_ui.R | 483 +++++++++---------
.../app/tools/analysis/quickgen_basic_ui.R | 10 +-
8 files changed, 603 insertions(+), 286 deletions(-)
diff --git a/radiant-master/inst/app/server.R b/radiant-master/inst/app/server.R
index f1742db..fcd6db1 100644
--- a/radiant-master/inst/app/server.R
+++ b/radiant-master/inst/app/server.R
@@ -55,7 +55,7 @@ shinyServer(function(input, output, session) {
sidebarLayout(
sidebarPanel(
help_data_panel,
- help_quickgen_panel, # 添加 quickgen 的 help 面板
+ help_quickgen_panel,
help_design_panel,
help_basics_panel,
help_model_panel,
@@ -66,7 +66,7 @@ shinyServer(function(input, output, session) {
mainPanel(
HTML(paste0("Select help files to show and search
")),
htmlOutput("help_data"),
- htmlOutput("help_quickgen"), # 添加 quickgen 的 help 输出
+ htmlOutput("help_quickgen"),
htmlOutput("help_design"),
htmlOutput("help_basics"),
htmlOutput("help_model"),
diff --git a/radiant-master/inst/translations/translation_zh.csv b/radiant-master/inst/translations/translation_zh.csv
index cc4d151..01224b3 100644
--- a/radiant-master/inst/translations/translation_zh.csv
+++ b/radiant-master/inst/translations/translation_zh.csv
@@ -1159,9 +1159,9 @@ Edit the generated R code here...,在此处编辑生成的R代码...,quickgen_ai
Normality test,正态性检验,init.R
Homogeneity of variance test,方差齐性检验,init.R
Basics > Normality,基础统计 > 正态性,normality_test_ui.R
-Shapiro-Wilk,SW检验,normality_test_ui.R
-Kolmogorov-Smirnov,K-S检验,normality_test_ui.R
-Anderson-Darling,AD检验,normality_test_ui.R
+Shapiro-Wilk,夏皮罗-威尔克检验,normality_test_ui.R
+Kolmogorov-Smirnov,柯尔莫哥洛夫-斯米尔诺夫检验,normality_test_ui.R
+Anderson-Darling,安德森-达林检验,normality_test_ui.R
Basics > Homogeneity,基础统计 > 方差齐性,homo_variance_test_ui.R
Grouping variable:,分组变量：,homo_variance_test_ui.R
Test method:,检验方法：,homo_variance_test_ui.R
diff --git a/radiant.basics/inst/app/tools/help/homo_variance_test.md b/radiant.basics/inst/app/tools/help/homo_variance_test.md
index e69de29..c1913d9 100644
--- a/radiant.basics/inst/app/tools/help/homo_variance_test.md
+++ b/radiant.basics/inst/app/tools/help/homo_variance_test.md
@@ -0,0 +1,19 @@
+> 方差齐性检验
+
+基于 Levene（莱文检验）、Bartlett（巴特利特检验）、Fligner（弗林格检验）等方差齐性检验方法，对多组数据的总体方差是否相等进行统计推断，为后续其他需要方差齐性假设的参数检验提供适用前提与决策依据。
+
+## Levene（莱文检验）
+
+Levene 检验把每组原始数据先转换成与组内中心距离的绝对值，再对这些绝对偏差做单因素方差分析，只要组间平均偏离程度差异显著，就推断方差不齐；由于使用了离差绝对值，它对偏离正态分布、存在厚尾或异常值的情况非常稳健，样本量不等、分布偏斜时依然能保持较好的检验效能，因此在实验设计和生物统计中被广泛当作默认的方差齐性判断工具。
+
+
+
+## Bartlett（巴特利特检验）
+
+Bartlett 检验直接比较各组样本方差的大小，通过计算方差加权平均与几何平均之间的差距来度量齐性，差距越大越倾向拒绝方差齐性假设；它在数据确实来自正态总体时具有最高的检验功效，能够最早发现微小的方差差异，但只要总体稍偏离正态，尤其是出现偏斜或异常值时，容易错误地夸大差异，导致假阳性率升高，因此更适合在已确认正态性的前提下使用。
+
+
+
+## Fligner（弗林格检验）
+
+Fligner 检验把每组观测值转换为整体秩次，再对这些秩离差进行类似 Levene 的方差分析，由于整个过程只依赖秩的大小而不涉及具体数值，它对分布形态几乎没有任何要求，即使在严重偏斜、多峰或含有极端值的情况下也能维持稳定的显著性水平，适用于完全不确定分布形状、希望获得稳健结论的探索性分析，但相应地其检测微小方差差异的灵敏度略低于 Bartlett 和 Levene。
\ No newline at end of file
diff --git a/radiant.basics/inst/app/tools/help/normality_test.md b/radiant.basics/inst/app/tools/help/normality_test.md
index e69de29..df6bd03 100644
--- a/radiant.basics/inst/app/tools/help/normality_test.md
+++ b/radiant.basics/inst/app/tools/help/normality_test.md
@@ -0,0 +1,19 @@
+> 正态性检验
+
+基于 Shapiro-Wilk（夏皮罗-威尔克检验）、Kolmogorov-Smirnov（柯尔莫哥洛夫-斯米尔诺夫检验）、Anderson-Darling（安德森-达林检验）等正态性检验方法，对样本数据是否服从正态分布进行统计推断，为后续参数检验或建模方法的选择提供前提依据。
+
+## Shapiro-Wilk（夏皮罗-威尔克检验）
+
+Shapiro-Wilk 检验的核心思路是把样本按大小排序后，用一套专门系数去衡量这些次序统计量与理论正态分位点之间的线性相关程度。如果散点几乎落在一条直线上，就说明数据和正态分布非常吻合；只要出现轻微偏斜、厚尾或者一两个异常值，直线就会弯曲，检验统计量迅速下降，从而在小样本环境下也能高效地捕捉到非正态信号。由于它对各种常见偏离模式都很敏感，学术界普遍把它视为样本量不超过五十时的首选正态性判别工具。
+
+
+
+## Kolmogorov-Smirnov（柯尔莫哥洛夫-斯米尔诺夫检验）
+
+Kolmogorov-Smirnov 检验通过把样本的经验分布函数与一条完全确定参数的正态分布曲线全程重叠，寻找两者在垂直方向上的最大差距来判断拟合优劣。这个最大距离越大，说明样本整体越不像正态。其优点在于概念直观、可以一眼看出差异出现在哪个区间，并且不仅限于正态性，还能推广到任意两个分布之间的比较；不过当分布参数需要从样本估计时，必须使用 Lilliefors 修正临界值，否则容易过于宽松，而且它的注意力主要集中在分布中部，对两端的偏离相对迟钝，因此在尾部存在异常值或轻微双峰的情况下，检验功效会低于其他专门针对正态性的方法。
+
+
+
+## Anderson-Darling（安德森-达林检验）
+
+Anderson-Darling 检验同样对比经验分布与理论正态曲线，但在计算整体差异时给尾部施加了更高的权重，使得分布两端即使只有轻微偏离也会被迅速放大。这种设计让它对偏斜、双峰、厚尾以及个别极端值极其敏感，特别适合需要重点监控尾部行为的场景，例如质量管理和金融风险评估。由于统计量对异常值反应强烈，在实际应用中建议先对数据进行异常值检查；当样本量处于二十到两百之间时，它在常见正态性检验中通常拥有最高的检验力，能够最早发现隐蔽的非正态特征。
\ No newline at end of file
diff --git a/radiant.data/inst/app/tools/app/stop.R b/radiant.data/inst/app/tools/app/stop.R
index 011e27f..76e40b4 100644
--- a/radiant.data/inst/app/tools/app/stop.R
+++ b/radiant.data/inst/app/tools/app/stop.R
@@ -4,7 +4,7 @@
observeEvent(input$stop_radiant, {
shinyalert::shinyalert(
title = "确认停止",
- text = "停止按钮会将所有容器都关闭！确定停止吗？",
+ text = "停止按钮会将所有页面都关闭！确定停止吗？",
type = "warning",
showCancelButton = TRUE,
confirmButtonCol = "#d33",
diff --git a/radiant.model/R/cox.R b/radiant.model/R/cox.R
index 220a9d4..f0db521 100644
--- a/radiant.model/R/cox.R
+++ b/radiant.model/R/cox.R
@@ -46,7 +46,6 @@ coxp <- function(dataset,
if (length(lv) != 2) {
return("Status variable must be binary (0/1 or two levels)." %>% add_class("coxp"))
}
- ## 统一成 0/1：按字母顺序或因子水平，第二个水平当作“事件=1”
dataset[[status]] <- as.numeric(factor(surv_status, levels = lv)) - 1L
} else {
return("Status variable must be numeric 0/1 or binary factor." %>% add_class("coxp"))
@@ -57,14 +56,12 @@ coxp <- function(dataset,
}
}
- ## ---- 构造公式 ----------------------------------------------------------
if (missing(form)) {
rhs <- if (length(evar) == 0) "1" else paste(evar, collapse = " + ")
if (!is.empty(int)) rhs <- paste(rhs, paste(int, collapse = " + "), sep = " + ")
form <- as.formula(paste("Surv(", time, ", ", status, ") ~ ", rhs))
}
- ## ---- 模型估计 ----------------------------------------------------------
if ("robust" %in% check) {
model <- survival::coxph(form, data = dataset, robust = TRUE)
} else {
@@ -80,12 +77,14 @@ coxp <- function(dataset,
coef_df <- broom::tidy(model, conf.int = TRUE) # 系数、HR、CI、p
n <- nrow(dataset) # 样本量
n_event <- sum(dataset[[status]]) # 事件数
- conc <- survival::survConcordance.fit(y = Surv(dataset[[time]], dataset[[status]]),
- x = predict(model, type = "lp"))$concordance
-
- cat("coef:", length(coef(model)), " n=", nrow(dataset),
- " events=", sum(dataset[[status]]), "\n")
-
+ conc <- tryCatch(
+ survival::concordancefit(
+ y = Surv(dataset[[time]], dataset[[status]]),
+ x = predict(model, type = "lp"),
+ data = dataset
+ )$concordance,
+ error = function(e) NA
+ )
## 打包返回
out <- as.list(environment())
out$model <- model
@@ -101,49 +100,336 @@ coxp <- function(dataset,
}
#' @export
-summary.coxp <- function(object, ...) {
- if (is.character(object)) return(object)
- # 检查模型对象有效性
+summary.coxp <- function(object, dec = 3, ...) {
+ if (is.character(object)) {
+ cat(object, "\n")
+ return(invisible(object))
+ }
+
if (!inherits(object$model, "coxph")) {
cat("** Invalid Cox model object. **\n")
return(invisible(object))
}
- # 输出基础信息
- cat("Cox Proportional Hazards\n")
- cat("Data:", object$df_name, " N=", object$n, " Events=", object$n_event, "\n")
- cat("Concordance=", round(object$concordance, 3), "\n\n")
- # 输出模型summary
- summary(object$model)
+
+ ## 基础模型信息
+ cat("Cox Proportional Hazards Regression\n")
+ cat("Data:", object$df_name, "\n")
+ if (!is.empty(object$data_filter)) {
+ cat("Filter:", gsub("\\n", "", object$data_filter), "\n")
+ }
+ if (!is.empty(object$arr)) {
+ cat("Arrange:", gsub("\\n", "", object$arr), "\n")
+ }
+ if (!is.empty(object$rows)) {
+ cat("Slice:", gsub("\\n", "", object$rows), "\n")
+ }
+ cat("Time variable :", object$time, "\n")
+ cat("Status variable :", object$status, "\n")
+ cat("Explanatory vars:", paste(object$evar, collapse = ", "), "\n")
+ cat("N =", object$n, ", Events =", object$n_event, "\n")
+ cat("Concordance =", sprintf("%.3f", object$concordance), "\n\n")
+
+ ## 系数表
+ coef_df <- object$coef_df
+ coef_df$sig_star <- sig_stars(coef_df$p.value) %>% format(justify = "left")
+ coef_df$label <- rownames(coef_df)
+
+ ## 格式化输出
+ coeff <- coef_df %>%
+ mutate(
+ HR = sprintf("%.3f", exp(estimate)),
+ `HR.low` = sprintf("%.3f", exp(conf.low)),
+ `HR.high` = sprintf("%.3f", exp(conf.high)),
+ coef = sprintf("%.3f", estimate),
+ se = sprintf("%.3f", std.error),
+ z = sprintf("%.3f", statistic),
+ p = ifelse(p.value < .001, "< .001", sprintf("%.3f", p.value))
+ ) %>%
+ select(label, coef, se, z, p, sig_star, HR, HR.low, HR.high)
+
+ colnames(coeff) <- c(" ", "Coef", "SE", "z", "p", " ", "HR", "HR.lower", "HR.upper")
+ print.data.frame(coeff, row.names = FALSE)
+
+ cat("\nSignif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1\n\n")
+
+ ## 模型检验
+ sm <- summary(object$model)
+ cat("Likelihood ratio test =", sprintf("%.2f", sm$logtest[1]), "on", sm$logtest[2], "df, p =",
+ ifelse(sm$logtest[3] < .0001, "< .0001", sprintf("%.4f", sm$logtest[3])), "\n")
+ cat("Wald test =", sprintf("%.2f", sm$waldtest[1]), "on", sm$waldtest[2], "df, p =",
+ ifelse(sm$waldtest[3] < .0001, "< .0001", sprintf("%.4f", sm$waldtest[3])), "\n")
+ cat("Score (logrank) test =", sprintf("%.2f", sm$sctest[1]), "on", sm$sctest[2], "df, p =",
+ ifelse(sm$sctest[3] < .0001, "< .0001", sprintf("%.4f", sm$sctest[3])), "\n")
+
invisible(object)
}
#' @export
predict.coxp <- function(object, pred_data = NULL, pred_cmd = "",
- dec = 3, envir = parent.frame(), ...) {
+ conf_lev = 0.95, dec = 3, envir = parent.frame(), ...) {
if (is.character(object)) return(object)
- ## 构造预测数据框
+ # 1. 构造预测数据
if (is.null(pred_data)) {
- newdata <- envir$.model_frame # 若无新数据，默认用训练集
+ newdata <- envir$.model_frame %||% object$model$model
} else {
- newdata <- get_data(pred_data, envir = envir)
+ # 获取预测数据集（只取模型需要的变量，但先全取以便校验）
+ newdata <- get_data(pred_data, vars = NULL, envir = envir)
+
+ # 变量存在性校验
+ model_evar <- object$evar # 模型使用的解释变量
+ pred_cols <- colnames(newdata)
+ missing_vars <- setdiff(model_evar, pred_cols)
+
+ if (length(missing_vars) > 0) {
+ return(paste0(
+ "All variables in the model must also be in the prediction data\n",
+ "Variables in the model: ", paste(model_evar, collapse = ", "), "\n",
+ "Variables not available in prediction data: ", paste(missing_vars, collapse = ", ")
+ ) %>% add_class("coxp.predict"))
+ }
+ newdata <- newdata[, model_evar, drop = FALSE]
}
+
+ # 2. 应用 pred_cmd
if (!is.empty(pred_cmd)) {
newdata <- modify_data(newdata, pred_cmd, envir = envir)
}
- ## 线性预测值 + HR
- lp <- predict(object$model, newdata = newdata, type = "lp")
- hr <- exp(lp)
- res <- data.frame(lp = round(lp, dec), hr = round(hr, dec))
- attr(res, "pred_type") <- "linear predictor & hazard ratio"
- res
+ # 3. 过滤全NA的列
+ newdata <- newdata[, colSums(is.na(newdata)) != nrow(newdata), drop = FALSE]
+ if (ncol(newdata) == 0 && length(object$evar) > 0) {
+ return(paste("预测数据中无有效解释变量列（需包含：", paste(object$evar, collapse = ", "), "）") %>% add_class("coxp.predict"))
+ }
+
+ # 4. 核心预测计算
+ pred_cox <- predict(
+ object$model,
+ newdata = newdata,
+ type = "lp",
+ se.fit = TRUE
+ )
+ z_val <- qnorm((1 + conf_lev) / 2)
+ lp_lower <- pred_cox$fit - z_val * pred_cox$se.fit
+ lp_upper <- pred_cox$fit + z_val * pred_cox$se.fit
+ hr <- exp(pred_cox$fit)
+ hr_lower <- exp(lp_lower)
+ hr_upper <- exp(lp_upper)
+
+ # 5. 构建结果数据框
+ pred_result <- data.frame(
+ lp = round(pred_cox$fit, dec),
+ HR = round(hr, dec),
+ lp_lower = round(lp_lower, dec),
+ lp_upper = round(lp_upper, dec),
+ HR_lower = round(hr_lower, dec),
+ HR_upper = round(hr_upper, dec),
+ check.names = FALSE,
+ stringsAsFactors = FALSE
+ )
+ pred_full <- cbind(newdata, pred_result)
+
+ # 6. 添加元信息
+ pred_full <- pred_full %>%
+ radiant.data::set_attr("radiant_df_name", object$df_name) %>%
+ radiant.data::set_attr("radiant_time", object$time) %>%
+ radiant.data::set_attr("radiant_status", object$status) %>%
+ radiant.data::set_attr("radiant_evar_actual", colnames(newdata)) %>%
+ radiant.data::set_attr("radiant_conf_lev", conf_lev) %>%
+ radiant.data::set_attr("radiant_dec", dec) %>%
+ add_class(c("coxp.predict", "model.predict"))
+
+ return(pred_full)
}
+
#' @export
print.coxp.predict <- function(x, ..., n = 10) {
- cat("Cox PH predictions (linear predictor & hazard ratio):\n")
- print(head(x, n))
+ if (is.character(x)) {
+ cat(x, "\n")
+ return(invisible(x))
+ }
+
+ # 转为数据框
+ x_df <- as.data.frame(x, stringsAsFactors = FALSE)
+
+ df_name <- attr(x_df, "radiant_df_name") %||% "Unknown"
+ time_var <- attr(x_df, "radiant_time") %||% "Unknown"
+ status_var <- attr(x_df, "radiant_status") %||% "Unknown"
+ conf_lev <- attr(x_df, "radiant_conf_lev") %||% 0.95
+ dec <- attr(x_df, "radiant_dec") %||% 3
+ ci_perc <- paste0(c(round((1 - conf_lev) / 2 * 100, 1),
+ round((1 + conf_lev) / 2 * 100, 1)), "%")
+
+ total_cols <- ncol(x_df)
+ result_count <- 6
+
+ if (total_cols < result_count) {
+ cat("Error: Not enough columns for prediction results (need at least 6 result columns).\n")
+ return(invisible(x))
+ }
+
+ evar_count_actual <- total_cols - result_count
+ evar_cols_actual <- colnames(x_df)[1:evar_count_actual]
+
+ new_result_names <- c(
+ "lp",
+ "HR",
+ ci_perc[1],
+ ci_perc[2],
+ paste0("HR_", ci_perc[1]),
+ paste0("HR_", ci_perc[2])
+ )
+
+ # 拼接完整列名向量
+ new_colnames <- c(evar_cols_actual, new_result_names)
+
+ # 最终校验
+ if (length(new_colnames) != total_cols) {
+ cat("Error: Column name length mismatch.\n")
+ cat("Total columns:", total_cols, "\n")
+ cat("Constructed names:", length(new_colnames), "\n")
+ cat("evar_cols_actual:", paste(evar_cols_actual, collapse = ", "), "\n")
+ cat("new_result_names:", paste(new_result_names, collapse = ", "), "\n")
+ return(invisible(x))
+ }
+
+ # 应用新列名
+ colnames(x_df) <- new_colnames
+
+ cat("Cox Proportional Hazards Regression\n")
+ cat("Data :", df_name, "\n")
+ cat("Time variable :", time_var, "\n")
+ cat("Status variable :", status_var, "\n")
+ cat("Explanatory variables:", if (length(evar_cols_actual) > 0) paste(evar_cols_actual, collapse = ", ") else "None", "\n")
+ cat("Confidence level :", paste0(conf_lev * 100, "%"), "\n")
+ cat("Total columns :", total_cols, "(Explanatory:", evar_count_actual, ", Result:", result_count, ")\n")
+
+ total_rows <- nrow(x_df)
+ if (n == -1 || total_rows <= n) {
+ cat("Rows shown :", total_rows, "of", total_rows, "\n")
+ out_df <- x_df
+ } else {
+ cat("Rows shown :", n, "of", total_rows, "\n")
+ out_df <- head(x_df, n)
+ }
+ cat("\n")
+
+ # 格式化数值列
+ numeric_cols <- (evar_count_actual + 1):total_cols
+ if (length(numeric_cols) > 0) {
+ out_df[, numeric_cols] <- lapply(out_df[, numeric_cols, drop = FALSE], function(col) {
+ sprintf(paste0("%.", dec, "f"), as.numeric(col))
+ })
+ }
+
+ print(out_df, row.names = FALSE)
invisible(x)
+}
+
+#' @export
+store.coxp.predict <- function(dataset, object, name = "hr", ...) {
+ if (is.empty(name)) name <- "hr"
+ name <- unlist(strsplit(name, "(\\s*,\\s*|\\s*;\\s*|\\s+)")) %>%
+ gsub("\\s", "", .) %>%
+ .[1]
+
+ pred_col <- "HR"
+ if (!pred_col %in% colnames(object)) {
+ stop("Prediction column 'HR' not found in prediction object.")
+ }
+
+ pred_df <- object[, pred_col, drop = FALSE]
+ colnames(pred_df) <- name
+
+ evar_actual <- attr(object, "radiant_evar_actual") %||%
+ attr(object, "radiant_evar") %||% character(0)
+
+ indr <- indexr(dataset, vars = evar_actual, filt = "", rows = NULL,
+ cmd = attr(object, "radiant_pred_cmd"))
+
+ out_df <- as.data.frame(matrix(NA, nrow = nrow(dataset), ncol = 1), stringsAsFactors = FALSE)
+ out_df[indr$ind, 1] <- pred_df[[1]]
+ colnames(out_df) <- name
+
+ dataset[, name] <- out_df
+ dataset
+}
+
+#' @export
+plot.coxp <- function(x, plots = "none", incl = NULL, incl_int = NULL,
+ conf_lev = 0.95, intercept = FALSE,
+ shiny = FALSE, custom = FALSE, ...) {
+ if (is.character(x)) return(x)
+ if (is.empty(plots) || plots == "none") return(invisible())
+
+ plot_list <- list()
+
+ if ("coef" %in% plots) {
+ # 提取系数和 CI
+ coef_df <- broom::tidy(x$model, conf.int = TRUE, conf.level = conf_lev)
+ coef_df$hr <- exp(coef_df$estimate)
+ coef_df$hr_low <- exp(coef_df$conf.low)
+ coef_df$hr_high <- exp(coef_df$conf.high)
+ coef_df$term <- coef_df$term
+
+ if (!intercept) {
+ coef_df <- coef_df[!grepl("Intercept", coef_df$term), ]
+ }
+
+ if (length(incl) > 0) {
+ incl_regex <- paste0("^(", paste(incl, collapse = "|"), ")")
+ coef_df <- coef_df[grepl(incl_regex, coef_df$term), ]
+ }
+
+ if (nrow(coef_df) == 0) {
+ plot_list[["coef"]] <- "** No coefficients to plot **"
+ } else {
+ p <- ggplot(coef_df, aes(x = term, y = hr, ymin = hr_low, ymax = hr_high)) +
+ geom_pointrange() +
+ geom_hline(yintercept = 1, linetype = "dashed", color = "red") +
+ scale_x_discrete(limits = rev) +
+ coord_flip() +
+ labs(x = "", y = "Hazard Ratio (HR)", title = "Coefficient Plot (HR)")
+ plot_list[["coef"]] <- p
+ }
+ }
+
+ if ("dist" %in% plots) {
+ data <- x$model$model
+ vars <- c(x$time, x$status, x$evar)
+ for (v in vars) {
+ if (v %in% colnames(data)) {
+ p <- visualize(data, xvar = v, bins = 30, custom = TRUE)
+ plot_list[[paste0("dist_", v)]] <- p
+ }
+ }
+ }
+
+ if ("vip" %in% plots) {
+ coef_df <- broom::tidy(x$model)
+ coef_df$Importance <- abs(coef_df$estimate)
+ coef_df <- coef_df[order(coef_df$Importance, decreasing = TRUE), ]
+ p <- visualize(coef_df, xvar = "term", yvar = "Importance", type = "bar", custom = TRUE) +
+ coord_flip() + labs(title = "Variable Importance (|coef|)")
+ plot_list[["vip"]] <- p
+ }
+
+ if ("pdp" %in% plots || "pred_plot" %in% plots) {
+ plot_list[["pdp"]] <- "** PDP not yet implemented for Cox **"
+ }
+
+ if ("influence" %in% plots) {
+ plot_list[["influence"]] <- "** Influence plot not yet implemented **"
+ }
+
+ # 输出
+ if (length(plot_list) == 0) return(invisible())
+ if (custom) {
+ if (length(plot_list) == 1) return(plot_list[[1]]) else return(plot_list)
+ } else {
+ patchwork::wrap_plots(plot_list, ncol = 2) %>%
+ (function(x) if (isTRUE(shiny)) x else print(x))
+ }
}
\ No newline at end of file
diff --git a/radiant.model/inst/app/tools/analysis/cox_ui.R b/radiant.model/inst/app/tools/analysis/cox_ui.R
index c5fa2b7..e9e5321 100644
--- a/radiant.model/inst/app/tools/analysis/cox_ui.R
+++ b/radiant.model/inst/app/tools/analysis/cox_ui.R
@@ -1,34 +1,25 @@
## ========== 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"))
+ c("none", "dist", "vip", "pred_plot", "pdp", "coef", "influence"),
+ c(i18n$t("None"), i18n$t("Distribution"),
+ i18n$t("Permutation Importance"), i18n$t("Prediction plots"),
+ i18n$t("Partial Dependence"), i18n$t("Coefficient plot"),
+ i18n$t("Influential observations"))
)
## 2. 参数收集 -------------------------------------------------------------
coxp_args <- list()
-coxp_sum_args <- list()
coxp_plot_args <- list()
coxp_pred_args <- list()
-coxp_pred_plot_args <- list()
## 输入收集 reactive
coxp_inputs <- reactive({
@@ -44,17 +35,14 @@ coxp_inputs <- reactive({
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
+ # 收集所有预测参数（含新增的coxp_conf_lev）
for (i in names(args)) args[[i]] <- input[[paste0("coxp_", i)]]
+
+ # 处理预测数据/命令（保留原有逻辑）
args$pred_cmd <- ""
args$pred_data <- ""
if (input$coxp_predict == "cmd") {
@@ -67,11 +55,13 @@ coxp_pred_inputs <- reactive({
gsub(";\\s+", ";", .) %>% gsub("\"", "\'", .)
args$pred_data <- input$coxp_pred_data
}
- args
+
+ args$conf_lev <- input$coxp_conf_lev %||% 0.95
+ args$dec <- 3
+
+ return(args)
})
-coxp_pred_plot_inputs <- reactive({ list() })
-
## 3. 变量选择 UI ----------------------------------------------------------
output$ui_coxp_time <- renderUI({
isNum <- .get_class() %in% c("integer", "numeric", "ts")
@@ -131,52 +121,12 @@ output$ui_coxp_incl_int <- renderUI({
)
})
-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. 预测 / 绘图 / 刷新按钮 ----------------------------------------------
+## 5. 预测 / 绘图 / 刷新按钮 ----------------------------------------------
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]
@@ -184,14 +134,9 @@ output$ui_coxp_nrobs <- renderUI({
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 ----------------------------------------------------------------
+## 6. 主 UI ----------------------------------------------------------------
output$ui_coxp <- renderUI({
req(input$dataset)
tagList(
@@ -206,20 +151,7 @@ output$ui_coxp <- renderUI({
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)
- )
+ uiOutput("ui_coxp_evar")
),
conditionalPanel(
condition = "input.tabs_coxp == 'Predict'",
@@ -238,17 +170,15 @@ output$ui_coxp <- renderUI({
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")
- )
+ "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", "pred_coxp"))),
+ 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")
)
)
@@ -268,29 +198,6 @@ output$ui_coxp <- renderUI({
condition = "input.coxp_plots == 'pdp' | input.coxp_plots == 'pred_plot'",
uiOutput("ui_coxp_incl_int")
)
- ),
- conditionalPanel(
- condition = "['correlations', 'scatter', 'dashboard', 'resid_pred'].indexOf(input.coxp_plots) !== -1",
- 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")
)
)
),
@@ -302,7 +209,7 @@ output$ui_coxp <- renderUI({
)
})
-## 8. 绘图尺寸 ------------------------------------------------------------
+## 7. 绘图尺寸 ------------------------------------------------------------
coxp_plot <- reactive({
if (coxp_available() != "available") return()
if (is.empty(input$coxp_plots, "none")) return()
@@ -337,13 +244,11 @@ coxp_plot <- reactive({
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. 输出注册 -------------------------------------------------------------
+## 8. 输出注册 -------------------------------------------------------------
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(
@@ -352,9 +257,6 @@ output$coxp <- renderUI({
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",
@@ -370,118 +272,103 @@ output$coxp <- renderUI({
)
})
-## 10. 可用性检查 ----------------------------------------------------------
+## 9. 可用性检查 ----------------------------------------------------------
coxp_available <- reactive({
if (!input$dataset %in% names(r_data)) {
- return(i18n$t("数据集不存在：请先加载有效数据集"))
+ return(i18n$t("请先加载有效数据集"))
}
# 检查时间变量
if (is.null(input$coxp_time) || input$coxp_time == "" || !input$coxp_time %in% colnames(r_data[[input$dataset]])) {
- return(i18n$t("时间变量无效：请选择数据集中存在的数值型变量"))
+ return(i18n$t("请选择数据集中存在的数值型变量"))
}
# 检查状态变量
if (is.null(input$coxp_status) || input$coxp_status == "" || !input$coxp_status %in% colnames(r_data[[input$dataset]])) {
- return(i18n$t("状态变量无效：请选择数据集中存在的变量"))
+ 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(i18n$t("请选择至少一个数据集中存在的变量"))
}
return("available")
})
-## 11. 模型估计
+## 10. 模型估计
.coxp <- eventReactive(input$coxp_run, {
- cat("---->coxp reactive entered")
- # 严格校验变量
- ds <- tryCatch({
- get_data(input$dataset, vars = c(), envir = r_data) # 先获取完整数据集
- }, error = function(e) return(paste("数据集获取失败：", e$message)))
+ 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"))
- if (is.character(ds)) return(ds) # 数据集不存在，返回错误
+ 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"))
- # 校验时间变量
- if (!input$coxp_time %in% colnames(ds)) {
- return(paste("时间变量不存在：数据集中无「", input$coxp_time, "」列", sep = ""))
- }
- if (!is.numeric(ds[[input$coxp_time]])) {
- return(paste("时间变量类型错误：「", input$coxp_time, "」需为数值型（整数/小数）", sep = ""))
- }
+ status_var <- input$coxp_status
+ if (!status_var %in% colnames(ds))
+ return("状态变量不存在于数据集中" %>% add_class("coxp"))
- # 校验状态变量
- if (!input$coxp_status %in% colnames(ds)) {
- return(paste("状态变量不存在：数据集中无「", input$coxp_status, "」列", sep = ""))
+ surv_vec <- ds[[status_var]]
+ if (is.factor(surv_vec) || is.character(surv_vec)) {
+ lev <- unique(surv_vec)
+ if (length(lev) != 2)
+ return("状态变量必须是二分类（0/1 或两个水平）" %>% 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"))
}
- sv <- ds[[input$coxp_status]]
- sv <- if (is.factor(sv)) as.numeric(sv) - 1 else sv # 因子转0/1
- sv <- ifelse(sv %in% c(0, 1), sv, 0) # 非0/1强制为0
- n_event <- sum(sv)
- if (n_event < 1) {
- return(paste("事件数不足：状态变量转换后仅", n_event, "个事件（需至少1个），请检查状态变量编码"))
- }
- ds[[input$coxp_status]] <- sv
+ 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 = "、"), "」列", sep = ""))
+ 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))
- # 构建模型并运行
- form <- as.formula(paste0("Surv(", input$coxp_time, ", ", input$coxp_status, ") ~ ", paste(input$coxp_evar, collapse = " + ")))
- model <- tryCatch({
- survival::coxph(form, data = ds)
- }, error = function(e) return(paste("coxph模型失败：", gsub("\n", " ", e$message))))
+ model <- tryCatch(
+ survival::coxph(form, data = ds),
+ error = function(e) return(paste("coxph 模型失败：", e$message))
+ )
+ if (is.character(model))
+ return(model %>% add_class("coxp"))
- return(model)
+ 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
+ )
})
-## 12. summary / predict / plot --------------------------------------------
+## 11. summary / predict / plot --------------------------------------------
.summary_coxp <- reactive({
- if (not_pressed(input$coxp_run)) {
- return(i18n$t("** 请点击「估计模型」按钮运行分析 **"))
- }
+ if (not_pressed(input$coxp_run))
+ return(i18n$t("** Press the Estimate button to estimate the model **"))
- # 先检查可用性（提前拦截无效操作）
- avail_msg <- coxp_available()
- if (avail_msg != "available") {
- return(paste0("** 前置检查失败：", avail_msg, " **"))
- }
-
- # 获取模型结果（可能是coxph对象或错误文本）
- model_result <- .coxp()
-
- # 处理错误文本
- if (is.character(model_result)) {
- return(paste0("** 模型运行失败：", model_result, " **"))
- }
+ obj <- .coxp()
- # 处理有效模型
- if (inherits(model_result, "coxph")) {
- # 检查是否有系数（避免无系数的空模型）
- if (length(coef(model_result)) == 0) {
- return(i18n$t("** 未估计出系数：可能存在完全共线性、事件数不足或变量无效 **"))
- }
- # 输出标准summary
- return(summary(model_result))
+ if (is.character(obj)) {
+ cat(obj, "\n")
+ return()
}
- # 其他未知错误
- return(i18n$t("** 未知错误：请检查数据集和变量设置 **"))
+ summary.coxp(obj, dec = 3)
})
-## 确保UI输出绑定正确
-output$summary_coxp <- renderPrint({
- res <- .summary_coxp()
- if (is.character(res)) {
- cat(res, "\n")
- } else {
- print(res)
- }
-})
-
-
.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())
@@ -500,31 +387,31 @@ output$summary_coxp <- renderPrint({
})
.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())))
+ 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())
- if (!input$coxp_plots %in% c("coef", "dist", "influence", "vip", "pdp", "pred_plot")) req(input$coxp_nrobs)
- check_for_pdp_pred_plots("coxp")
+ valid_plots <- c("coef", "dist", "vip", "pdp", "pred_plot", "influence")
+ 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, {
- 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))
- }
+ do.call(plot, c(list(x = .coxp()), coxp_plot_inputs(), shiny = TRUE))
})
})
-## 13. 报告 / 下载 / 存储 -------------------------------------------------
+## 12. 报告 / 下载 / 存储 -------------------------------------------------
coxp_report <- function() {
if (is.empty(input$coxp_evar)) return(invisible())
outputs <- c("summary")
@@ -532,7 +419,7 @@ coxp_report <- function() {
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]] <- clean_args(inp, list())
inp_out[[2]]$custom <- FALSE
outputs <- c(outputs, "plot")
figs <- TRUE
@@ -557,12 +444,6 @@ coxp_report <- function() {
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),
@@ -576,16 +457,6 @@ coxp_report <- function() {
)
}
-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()
@@ -596,13 +467,133 @@ observeEvent(input$coxp_store_pred, {
r_data[[input$coxp_pred_data]] <- store(r_data[[input$coxp_pred_data]], pred, name = fixed))
})
-## 14. 下载 ----------------------------------------------------------------
+## 13. 下载 ----------------------------------------------------------------
dl_coxp_coef <- function(path) {
- if (pressed(input$coxp_run)) {
- write.coeff(.coxp(), file = path)
- } else {
+ 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(
@@ -614,11 +605,16 @@ download_handler(
)
dl_coxp_pred <- function(path) {
- if (pressed(input$coxp_run)) {
- write.csv(.predict_coxp(), file = path, row.names = FALSE)
- } else {
+ 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(
@@ -629,17 +625,6 @@ download_handler(
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,
@@ -651,7 +636,7 @@ download_handler(
height = coxp_plot_height
)
-## 15. 报告 / 截图 ---------------------------------------------------------
+## 14. 报告 / 截图 ---------------------------------------------------------
observeEvent(input$coxp_report, {
r_info[["latest_screenshot"]] <- NULL
coxp_report()
diff --git a/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R b/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
index ed9f114..5a5406b 100644
--- a/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
+++ b/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
@@ -1,3 +1,11 @@
+is.empty <- function(x, empty = "\\s*") {
+ if (is.null(x)) return(TRUE)
+ if (is.atomic(x) && length(x) == 0) return(TRUE)
+ if (!is.character(x)) return(FALSE)
+ is_not(x) ||
+ (length(x) == 1 && any(grepl(paste0("^", empty, "$"), x)))
+}
+
make_desc_text <- function(df) {
if (is.null(df) || nrow(df) == 0) return(i18n$t("No data available"))
num_cols <- sapply(df, is.numeric)
@@ -875,7 +883,7 @@ observeEvent(input$qgb_store, {
r_data[[dataset]] <- tmp
register(dataset)
updateSelectInput(session, "dataset", selected = input$dataset)
-
+
showModal(
modalDialog(
title = i18n$t("Data Stored"),
--
2.22.0