Skip to content

R
Radiant
Commit d72d0476 authored by wuzekai's avatar wuzekai
Browse files
Options

update

parent 22652dec
Show whitespace changes
Inline Side-by-side
Showing with 399 additions and 140 deletions
Dockerfile
View file @ d72d0476
...@@ -10,17 +10,16 @@ RUN R -e "install.packages(c('shiny', 'shinydashboard', 'remotes','readxl'), rep ...@@ -10,17 +10,16 @@ RUN R -e "install.packages(c('shiny', 'shinydashboard', 'remotes','readxl'), rep
RUN echo 'options(radiant.shinyFiles = FALSE)' >> /usr/local/lib/R/etc/Rprofile.site RUN echo 'options(radiant.shinyFiles = FALSE)' >> /usr/local/lib/R/etc/Rprofile.site
COPY . /srv/shiny-server/ COPY . /srv/shiny-server/
COPY set_path.R /usr/local/lib/R/etc/Rprofile.site.d/00-radiant-path.R COPY set_path.R /usr/local/lib/R/etc/Rprofile.site.d/00-radiant-path.R
RUN echo 'source("/srv/shiny-server/radiant.model/R/coxp.R")' >> /usr/local/lib/R/etc/Rprofile.site
# 安装所有子模块 # 安装所有模块
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.data',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.data',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.basics',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.basics',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.model',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.model',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.multivariate',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.multivariate',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.design',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.design',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant.quickgen',dependencies=TRUE, type='source', upgrade='never')" RUN R -e "remotes::install_local('/srv/shiny-server/radiant.quickgen',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
RUN R -e "remotes::install_local('/srv/shiny-server/radiant-master',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
# 安装主 radiant 应用
RUN R -e "remotes::install_local('/srv/shiny-server/radiant-master',dependencies=TRUE, type='source', upgrade='never')"
WORKDIR /data WORKDIR /data
CMD ["R", "-e", "radiant::radiant(host='0.0.0.0', port=3838)"] CMD ["R", "-e", "radiant::radiant(host='0.0.0.0', port=3838)"]
......
radiant-master/inst/translations/translation_zh.csv
View file @ d72d0476
...@@ -137,6 +137,7 @@ Probabilities:,概率：,"goodness_ui.R,randomizer_ui.R" ...@@ -137,6 +137,7 @@ Probabilities:,概率：,"goodness_ui.R,randomizer_ui.R"
"Enter probabilities (e.g., 1/2 1/2)",输入概率（例如：1/2 1/2）,"goodness_ui.R,randomizer_ui.R" "Enter probabilities (e.g., 1/2 1/2)",输入概率（例如：1/2 1/2）,"goodness_ui.R,randomizer_ui.R"
Discrete,离散分布,"prob_calc_ui.R,simulater_ui.R" Discrete,离散分布,"prob_calc_ui.R,simulater_ui.R"
F,F 分布,prob_calc_ui.R F,F 分布,prob_calc_ui.R
t,t 分布,prob_calc_ui.R
Log normal,对数正态分布,"prob_calc_ui.R,simulater_ui.R" Log normal,对数正态分布,"prob_calc_ui.R,simulater_ui.R"
Poisson,泊松分布,"prob_calc_ui.R,simulater_ui.R" Poisson,泊松分布,"prob_calc_ui.R,simulater_ui.R"
Values,数值,prob_calc_ui.R Values,数值,prob_calc_ui.R
...@@ -456,7 +457,7 @@ All,全部,"view_ui.R,evalbin_ui.R, evalreg_ui.R" ...@@ -456,7 +457,7 @@ All,全部,"view_ui.R,evalbin_ui.R, evalreg_ui.R"
"Table slice {input$view_tab_slice} will be applied on Download, Store, or Report",表格切片 {input$view_tab_slice} 将应用于下载、存储或报告,view_ui.R "Table slice {input$view_tab_slice} will be applied on Download, Store, or Report",表格切片 {input$view_tab_slice} 将应用于下载、存储或报告,view_ui.R
Dataset ',数据集 ',view_ui.R Dataset ',数据集 ',view_ui.R
' was successfully added to the datasets dropdown. Add code to Report > Rmd or Report > R to (re)create the dataset by clicking the report icon on the bottom left of your screen.,' 已成功添加到数据集下拉菜单中。通过点击左下角的报告图标，在 Report > Rmd 或 Report > R 中添加代码以（重新）创建数据集。,view_ui.R ' was successfully added to the datasets dropdown. Add code to Report > Rmd or Report > R to (re)create the dataset by clicking the report icon on the bottom left of your screen.,' 已成功添加到数据集下拉菜单中。通过点击左下角的报告图标，在 Report > Rmd 或 Report > R 中添加代码以（重新）创建数据集。,view_ui.R
Distribution,分布,"visualize_ui.R,logistic_ui.R" Distribution,分布图,"visualize_ui.R,logistic_ui.R"
Surface,表面图,visualize_ui.R Surface,表面图,visualize_ui.R
Line,折线图,"visualize_ui.R,regress_ui.R" Line,折线图,"visualize_ui.R,regress_ui.R"
Box-plot,箱线图,visualize_ui.R Box-plot,箱线图,visualize_ui.R
...@@ -818,7 +819,7 @@ Odds, "赔率", "logistic_ui.R" ...@@ -818,7 +819,7 @@ Odds, "赔率", "logistic_ui.R"
Correlations, "相关性", "logistic_ui.R" Correlations, "相关性", "logistic_ui.R"
Model fit, "模型拟合", "logistic_ui.R" Model fit, "模型拟合", "logistic_ui.R"
Coefficient (OR) plot, "系数（OR）图", "logistic_ui.R" Coefficient (OR) plot, "系数（OR）图", "logistic_ui.R"
Influential observations, "影响观察值", "logistic_ui.R" Influential observations, "影响点图", "logistic_ui.R"
This analysis requires a response variable with two levels and one or more explanatory variables. If these variables are not available please select another dataset.,该分析需要一个具有两个级别的响应变量以及一个或多个解释变量。如果这些变量不可用，请选择另一个数据集。, "logistic_ui.R" This analysis requires a response variable with two levels and one or more explanatory variables. If these variables are not available please select another dataset.,该分析需要一个具有两个级别的响应变量以及一个或多个解释变量。如果这些变量不可用，请选择另一个数据集。, "logistic_ui.R"
Drop intercept,去除截距项,mnl_ui.R Drop intercept,去除截距项,mnl_ui.R
RRRs,相对风险比 (RRR),mnl_ui.R RRRs,相对风险比 (RRR),mnl_ui.R
...@@ -1182,8 +1183,12 @@ Estimate class probabilities,估计类别概率,svm_ui.R ...@@ -1182,8 +1183,12 @@ Estimate class probabilities,估计类别概率,svm_ui.R
Choose Excel file:,选择Excel文件：,manage_ui.R Choose Excel file:,选择Excel文件：,manage_ui.R
Sheet index (1-based):,工作表索引（从1开始）：,manage_ui.R Sheet index (1-based):,工作表索引（从1开始）：,manage_ui.R
First row as header,第一行为表头,manage_ui.R First row as header,第一行为表头,manage_ui.R
Time variable:,生存时间变量：,cox_ui.R Time variable:,生存时间变量：,coxp_ui.R
Status variable:,事件状态变量：,cox_ui.R Status variable:,事件状态变量：,coxp_ui.R
AI running...,大模型运行中...,quickgen_ai_ui.R AI running...,大模型运行中...,quickgen_ai_ui.R
Warning:Please enter a request related to descriptive statistics or visualization.,警告：请输入与描述性统计或可视化相关的请求。,quickgen_ai_ui.R Warning:Please enter a request related to descriptive statistics or visualization.,警告：请输入与描述性统计或可视化相关的请求。,quickgen_ai_ui.R
Boxplot,箱型图,homo_variance_test_ui.R Boxplot,箱型图,homo_variance_test_ui.R
Survival curves,生存曲线,coxp_ui.R
Cumulative hazard,累积风险,coxp_ui.R
Schoenfeld residuals,Schoenfeld残差图,coxp_ui.R
Martingale residuals,鞅残差图,coxp_ui.R
radiant.model/R/coxp.R
View file @ d72d0476
...@@ -63,9 +63,9 @@ coxp <- function(dataset, ...@@ -63,9 +63,9 @@ coxp <- function(dataset,
} }
if ("robust" %in% check) { if ("robust" %in% check) {
model <- survival::coxph(form, data = dataset, robust = TRUE) model <- survival::coxph(form, data = dataset, robust = TRUE, x = TRUE, y = TRUE)
} else { } else {
model <- survival::coxph(form, data = dataset) model <- survival::coxph(form, data = dataset, x = TRUE, y = TRUE)
} }
## 失败模型保护 ## 失败模型保护
...@@ -96,6 +96,9 @@ coxp <- function(dataset, ...@@ -96,6 +96,9 @@ coxp <- function(dataset,
out$n <- n out$n <- n
out$n_event <- n_event out$n_event <- n_event
out$concordance <- conc out$concordance <- conc
out$model$model <- dataset[, all.vars(form), drop = FALSE]
out$time_var <- time
out$status_var <- status
add_class(out, c("coxp", "model")) add_class(out, c("coxp", "model"))
} }
...@@ -174,11 +177,11 @@ predict.coxp <- function(object, pred_data = NULL, pred_cmd = "", ...@@ -174,11 +177,11 @@ predict.coxp <- function(object, pred_data = NULL, pred_cmd = "",
if (is.null(pred_data)) { if (is.null(pred_data)) {
newdata <- envir$.model_frame %||% object$model$model newdata <- envir$.model_frame %||% object$model$model
} else { } else {
# 获取预测数据集（只取模型需要的变量，但先全取以便校验） # 获取预测数据集
newdata <- get_data(pred_data, vars = NULL, envir = envir) newdata <- get_data(pred_data, vars = NULL, envir = envir)
# 变量存在性校验 # 变量存在性校验
model_evar <- object$evar # 模型使用的解释变量 model_evar <- object$evar
pred_cols <- colnames(newdata) pred_cols <- colnames(newdata)
missing_vars <- setdiff(model_evar, pred_cols) missing_vars <- setdiff(model_evar, pred_cols)
...@@ -295,7 +298,6 @@ print.coxp.predict <- function(x, ..., n = 10) { ...@@ -295,7 +298,6 @@ print.coxp.predict <- function(x, ..., n = 10) {
return(invisible(x)) return(invisible(x))
} }
# 应用新列名
colnames(x_df) <- new_colnames colnames(x_df) <- new_colnames
cat("Cox Proportional Hazards Regression\n") cat("Cox Proportional Hazards Regression\n")
...@@ -359,77 +361,314 @@ store.coxp.predict <- function(dataset, object, name = "hr", ...) { ...@@ -359,77 +361,314 @@ store.coxp.predict <- function(dataset, object, name = "hr", ...) {
#' @export #' @export
plot.coxp <- function(x, plots = "none", incl = NULL, incl_int = NULL, plot.coxp <- function(x, plots = "none", incl = NULL, incl_int = NULL,
conf_lev = 0.95, intercept = FALSE, conf_lev = 0.95, intercept = FALSE, lines = "",
shiny = FALSE, custom = FALSE, ...) { nrobs = -1, shiny = FALSE, custom = FALSE, ...) {
# 输入验证：检查模型是否有效
if (is.character(x)) return(x) if (is.character(x)) return(x)
if (is.empty(plots) || plots == "none") return(invisible()) if (is.null(x$model)) {
return("** 无效的模型输入：未找到模型数据 **")
}
# 检查是否有选择的图表类型
if (length(plots) == 0 || all(plots == "none")) {
if (shiny) {
return("** 无图表可显示。请选择图表类型或重新运行计算 **")
} else {
return(invisible())
}
}
plot_list <- list() plot_list <- list()
nrCol <- 2 # 默认2列布局
# 1. 系数图 (coef)
if ("coef" %in% plots) { if ("coef" %in% plots) {
# 提取系数和 CI nrCol <- 1
tryCatch({
coef_df <- broom::tidy(x$model, conf.int = TRUE, conf.level = conf_lev) coef_df <- broom::tidy(x$model, conf.int = TRUE, conf.level = conf_lev)
coef_df$hr <- exp(coef_df$estimate) coef_df$hr <- exp(coef_df$estimate)
coef_df$hr_low <- exp(coef_df$conf.low) coef_df$hr_low <- exp(coef_df$conf.low)
coef_df$hr_high <- exp(coef_df$conf.high) 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) { if (length(incl) > 0) {
incl_regex <- paste0("^(", paste(incl, collapse = "|"), ")") incl_regex <- paste0("^(", paste(incl, collapse = "|"), ")")
coef_df <- coef_df[grepl(incl_regex, coef_df$term), ] coef_df <- coef_df[grepl(incl_regex, coef_df$term), ]
} }
if (nrow(coef_df) == 0) { if (nrow(coef_df) == 0) {
plot_list[["coef"]] <- "** No coefficients to plot **" plot_list[["coef"]] <- "** 无系数可绘制（可能已排除所有变量）**"
} else { } else {
p <- ggplot(coef_df, aes(x = term, y = hr, ymin = hr_low, ymax = hr_high)) + p <- ggplot2::ggplot(coef_df,
geom_pointrange() + ggplot2::aes(x = .data$term, y = .data$hr,
geom_hline(yintercept = 1, linetype = "dashed", color = "red") + ymin = .data$hr_low, ymax = .data$hr_high)) +
scale_x_discrete(limits = rev) + ggplot2::geom_pointrange() +
coord_flip() + ggplot2::geom_hline(yintercept = 1, linetype = "dashed", color = "red") +
labs(x = "", y = "Hazard Ratio (HR)", title = "Coefficient Plot (HR)") ggplot2::scale_x_discrete(limits = rev(coef_df$term)) +
ggplot2::coord_flip() +
ggplot2::labs(x = "", y = "风险比 (HR)",
title = "Cox模型系数（风险比）") +
ggplot2::theme(axis.text.y = ggplot2::element_text(hjust = 0))
plot_list[["coef"]] <- p plot_list[["coef"]] <- p
} }
}, error = function(e) {
plot_list[["coef"]] <- paste0("** 系数图生成失败：", e$message, " **")
})
} }
# 2. 分布直方图 (dist)
if ("dist" %in% plots) { if ("dist" %in% plots) {
data <- x$model$model tryCatch({
vars <- c(x$time, x$status, x$evar) dist_data <- x$model$model
for (v in vars) { if (is.null(x$evar) || length(x$evar) == 0) {
if (v %in% colnames(data)) { plot_list[["dist"]] <- "** 无解释变量可绘制分布 **"
p <- visualize(data, xvar = v, bins = 30, custom = TRUE) } else {
for (v in x$evar) {
if (v %in% colnames(dist_data)) {
p <- visualize(dist_data, xvar = v, bins = 10, custom = TRUE) +
ggplot2::labs(title = paste(v, "的分布"))
plot_list[[paste0("dist_", v)]] <- p plot_list[[paste0("dist_", v)]] <- p
} else {
plot_list[[paste0("dist_", v)]] <- paste0("** 变量 ", v, " 不在数据中 **")
}
} }
} }
}, error = function(e) {
plot_list[["dist_error"]] <- paste0("** 分布图生成失败：", e$message, " **")
})
} }
# 3. 特征重要性图 (vip)
if ("vip" %in% plots) { if ("vip" %in% plots) {
nrCol <- 1
tryCatch({
if (length(x$evar) < 2) {
plot_list[["vip"]] <- "** 至少需要2个变量才能生成特征重要性图 **"
} else {
coef_df <- broom::tidy(x$model) coef_df <- broom::tidy(x$model)
coef_df$Importance <- abs(coef_df$estimate) if (!"statistic" %in% colnames(coef_df)) {
plot_list[["vip"]] <- "** 无法获取统计量，无法生成特征重要性图 **"
} else {
coef_df$Importance <- abs(coef_df$statistic) # 使用z统计量
coef_df <- coef_df[order(coef_df$Importance, decreasing = TRUE), ] 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|)") p <- visualize(coef_df, xvar = "term", yvar = "Importance",
type = "bar", custom = TRUE) +
ggplot2::coord_flip() +
ggplot2::labs(title = "特征重要性", x = "", y = "重要性") +
ggplot2::theme(axis.text.y = ggplot2::element_text(hjust = 0))
plot_list[["vip"]] <- p plot_list[["vip"]] <- p
} }
}
}, error = function(e) {
plot_list[["vip"]] <- paste0("** 特征重要性图生成失败：", e$message, " **")
})
}
if ("pdp" %in% plots || "pred_plot" %in% plots) { # 4. 生存曲线图 (survival)
plot_list[["pdp"]] <- "** PDP not yet implemented for Cox **" if ("survival" %in% plots) {
nrCol <- 1
tryCatch({
# 检查时间和事件变量是否存在
if (is.null(x$time_var) || is.null(x$status_var)) {
plot_list[["survival"]] <- "** 模型缺少时间变量或事件变量，无法生成生存曲线 **"
} else if (!x$time_var %in% colnames(x$model$model)) {
plot_list[["survival"]] <- paste0("** 时间变量 '", x$time_var, "' 不在模型数据中 **")
} else if (!x$status_var %in% colnames(x$model$model)) {
plot_list[["survival"]] <- paste0("** 事件变量 '", x$status_var, "' 不在模型数据中 **")
} else {
# 检查是否有事件发生
event_count <- sum(x$model$model[[x$status_var]] == 1, na.rm = TRUE)
if (event_count == 0) {
plot_list[["survival"]] <- "** 数据中无事件发生（status全为0），无法生成生存曲线 **"
} else {
# 计算生存曲线
surv_fit <- survival::survfit(x$model, conf.int = TRUE, conf.lev = conf_lev)
if (is.null(surv_fit) || length(surv_fit$time) == 0) {
plot_list[["survival"]] <- "** 无法计算生存曲线，请检查模型和数据 **"
} else {
# 构建生存数据框
surv_df <- data.frame(
time = surv_fit$time,
surv = surv_fit$surv,
lower = ifelse(exists("lower", surv_fit), surv_fit$lower, NA),
upper = ifelse(exists("upper", surv_fit), surv_fit$upper, NA)
)
p <- ggplot2::ggplot(surv_df, ggplot2::aes(x = .data$time, y = .data$surv)) +
ggplot2::geom_line(color = "blue", linewidth = 1) +
ggplot2::geom_ribbon(ggplot2::aes(ymin = .data$lower, ymax = .data$upper),
alpha = 0.2, fill = "blue", na.rm = TRUE) +
ggplot2::labs(title = "基线生存函数",
x = "时间", y = "生存概率") +
ggplot2::ylim(0, 1)
plot_list[["survival"]] <- p
}
}
}
}, error = function(e) {
plot_list[["survival"]] <- paste0("** 生存曲线生成失败：", e$message, " **")
})
} }
if ("influence" %in% plots) { # 5. 累积风险图 (cumhaz)
plot_list[["influence"]] <- "** Influence plot not yet implemented **" if ("cumhaz" %in% plots) {
nrCol <- 1
tryCatch({
# 检查时间和事件变量是否存在
if (is.null(x$time_var) || is.null(x$status_var)) {
plot_list[["cumhaz"]] <- "** 模型缺少时间变量或事件变量，无法生成累积风险曲线 **"
} else if (!x$time_var %in% colnames(x$model$model)) {
plot_list[["cumhaz"]] <- paste0("** 时间变量 '", x$time_var, "' 不在模型数据中 **")
} else if (!x$status_var %in% colnames(x$model$model)) {
plot_list[["cumhaz"]] <- paste0("** 事件变量 '", x$status_var, "' 不在模型数据中 **")
} else {
# 检查是否有事件发生
event_count <- sum(x$model$model[[x$status_var]] == 1, na.rm = TRUE)
if (event_count == 0) {
plot_list[["cumhaz"]] <- "** 数据中无事件发生（status全为0），无法生成累积风险曲线 **"
} else {
# 计算生存曲线用于转换为累积风险
surv_fit <- survival::survfit(x$model)
if (is.null(surv_fit) || length(surv_fit$time) == 0) {
plot_list[["cumhaz"]] <- "** 无法计算累积风险，请检查模型和数据 **"
} else {
# 构建累积风险数据框，处理surv=0的情况
cumhaz_df <- data.frame(
time = surv_fit$time,
cumhaz = ifelse(surv_fit$surv > 0 & !is.na(surv_fit$surv),
-log(surv_fit$surv), NA)
)
# 检查是否有有效数据
valid_rows <- sum(!is.na(cumhaz_df$cumhaz))
if (valid_rows < 2) {
plot_list[["cumhaz"]] <- "** 有效数据不足，无法生成累积风险曲线 **"
} else {
p <- ggplot2::ggplot(cumhaz_df, ggplot2::aes(x = .data$time, y = .data$cumhaz)) +
ggplot2::geom_line(color = "red", linewidth = 1, na.rm = TRUE) +
ggplot2::labs(title = "基线累积风险函数",
x = "时间", y = "累积风险")
plot_list[["cumhaz"]] <- p
}
}
} }
}
}, error = function(e) {
plot_list[["cumhaz"]] <- paste0("** 累积风险曲线生成失败：", e$message, " **")
})
}
# 6. Schoenfeld残差图 (schoenfeld)
if ("schoenfeld" %in% plots) {
nrCol <- 1
tryCatch({
# 检查事件变量是否存在
if (is.null(x$status_var)) {
plot_list[["schoenfeld"]] <- "** 模型缺少事件变量，无法计算Schoenfeld残差 **"
} else if (!x$status_var %in% colnames(x$model$model)) {
plot_list[["schoenfeld"]] <- paste0("** 事件变量 '", x$status_var, "' 不在模型数据中 **")
} else {
# 检查事件数是否足够（至少2个）
event_count <- sum(x$model$model[[x$status_var]] == 1, na.rm = TRUE)
if (event_count < 2) {
plot_list[["schoenfeld"]] <- "** 事件数不足（至少需要2个事件），无法检验PH假设 **"
} else {
# 计算Schoenfeld残差
schoenfeld <- survival::cox.zph(x$model)
if (is.null(schoenfeld) || is.null(schoenfeld$time) || is.null(schoenfeld$y)) {
plot_list[["schoenfeld"]] <- "** 无法计算Schoenfeld残差（可能PH假设严重违反）**"
} else {
# 处理单变量和多变量情况
residual_vec <- if (is.matrix(schoenfeld$y)) {
schoenfeld$y[, 1] # 多变量时取第一列
} else {
schoenfeld$y # 单变量时直接使用向量
}
# 构建残差数据框
resid_df <- data.frame(
time = schoenfeld$time,
residual = residual_vec
)
# 检查有效数据
if (nrow(resid_df) < 2 || all(is.na(resid_df$residual))) {
plot_list[["schoenfeld"]] <- "** 有效残差不足，无法生成Schoenfeld图 **"
} else {
p <- ggplot2::ggplot(resid_df,
ggplot2::aes(x = .data$time, y = .data$residual)) +
ggplot2::geom_point(alpha = 0.6, na.rm = TRUE) +
ggplot2::geom_smooth(method = "loess", color = "red", se = TRUE, na.rm = TRUE) +
ggplot2::geom_hline(yintercept = 0, linetype = "dashed") +
ggplot2::labs(title = "Schoenfeld残差 - 检验PH假设",
x = "时间", y = "标准化Schoenfeld残差")
plot_list[["schoenfeld"]] <- p
}
}
}
}
}, error = function(e) {
plot_list[["schoenfeld"]] <- paste0("** Schoenfeld残差图生成失败：", e$message, " **")
})
}
# 7. 鞅残差图 (martingale)
if ("martingale" %in% plots) {
nrCol <- 1
tryCatch({
# 计算鞅残差和线性预测值
martingale_resid <- residuals(x$model, type = "martingale")
linear_pred <- predict(x$model, type = "lp")
if (is.null(martingale_resid) || is.null(linear_pred)) {
plot_list[["martingale"]] <- "** 模型无法计算残差或线性预测值（可能拟合失败）**"
} else if (length(martingale_resid) != length(linear_pred)) {
plot_list[["martingale"]] <- "** 残差与线性预测值长度不匹配，无法绘图 **"
} else {
resid_df <- data.frame(linear_pred = linear_pred,
martingale = martingale_resid) %>%
stats::na.omit()
if (nrow(resid_df) < 10) {
plot_list[["martingale"]] <- paste0("** 有效数据点不足（仅", nrow(resid_df), "个），无法生成有意义的图 **")
} else {
p <- ggplot2::ggplot(resid_df,
ggplot2::aes(x = .data$linear_pred, y = .data$martingale)) +
ggplot2::geom_point(alpha = 0.6) +
ggplot2::labs(title = "鞅残差 vs 线性预测值",
x = "线性预测值", y = "鞅残差")
# 输出 if ("line" %in% lines)
if (length(plot_list) == 0) return(invisible()) p <- p + ggplot2::geom_smooth(method = "lm", se = FALSE,
color = "red", linewidth = 1.2)
if ("loess" %in% lines)
p <- p + ggplot2::geom_smooth(method = "loess", color = "blue", se = TRUE)
if ("jitter" %in% lines)
p <- p + ggplot2::geom_jitter(width = 0.2, height = 0.2,
alpha = 0.3, color = "darkgreen")
plot_list[["martingale"]] <- p
}
}
}, error = function(e) {
plot_list[["martingale"]] <- paste0("** 鞅残差图生成失败：", e$message, " **")
})
}
# 检查是否有可显示的图
if (length(plot_list) == 0) {
return("** 无法生成任何图表。请检查模型设置和数据有效性 **")
}
# 输出图表
if (custom) { if (custom) {
if (length(plot_list) == 1) return(plot_list[[1]]) else return(plot_list) if (length(plot_list) == 1) plot_list[[1]] else plot_list
} else { } else {
patchwork::wrap_plots(plot_list, ncol = 2) %>% if (length(plot_list) == 1) {
(function(x) if (isTRUE(shiny)) x else print(x)) plot_list[[1]]
} else {
patchwork::wrap_plots(plot_list, ncol = nrCol)
}
} }
} }
\ No newline at end of file
radiant.model/inst/app/tools/analysis/coxp_ui.R
View file @ d72d0476
...@@ -8,11 +8,11 @@ coxp_lines <- setNames(c("line", "loess", "jitter"), ...@@ -8,11 +8,11 @@ coxp_lines <- setNames(c("line", "loess", "jitter"),
c(i18n$t("Line"), i18n$t("Loess"), i18n$t("Jitter"))) c(i18n$t("Line"), i18n$t("Loess"), i18n$t("Jitter")))
coxp_plots <- setNames( coxp_plots <- setNames(
c("none", "dist", "vip", "pred_plot", "pdp", "coef", "influence"), c("none", "dist", "vip", "coef", "survival", "cumhaz", "schoenfeld", "martingale"),
c(i18n$t("None"), i18n$t("Distribution"), c(i18n$t("None"), i18n$t("Distribution"),
i18n$t("Permutation Importance"), i18n$t("Prediction plots"), i18n$t("Permutation Importance"), i18n$t("Coefficient plot"),
i18n$t("Partial Dependence"), i18n$t("Coefficient plot"), i18n$t("Survival curves"), i18n$t("Cumulative hazard"),
i18n$t("Influential observations")) i18n$t("Schoenfeld residuals"), i18n$t("Martingale residuals"))
) )
## 2. 参数收集 ------------------------------------------------------------- ## 2. 参数收集 -------------------------------------------------------------
...@@ -34,7 +34,41 @@ coxp_inputs <- reactive({ ...@@ -34,7 +34,41 @@ coxp_inputs <- reactive({
args args
}) })
coxp_plot_inputs <- reactive({ list() }) 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({ coxp_pred_inputs <- reactive({
args <- coxp_pred_args args <- coxp_pred_args
...@@ -99,27 +133,6 @@ output$ui_coxp_incl <- renderUI({ ...@@ -99,27 +133,6 @@ output$ui_coxp_incl <- renderUI({
) )
}) })
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
)
})
## 5. 预测 / 绘图 / 刷新按钮 ---------------------------------------------- ## 5. 预测 / 绘图 / 刷新按钮 ----------------------------------------------
observeEvent(input$dataset, { observeEvent(input$dataset, {
updateSelectInput(session, "coxp_predict", selected = "none") updateSelectInput(session, "coxp_predict", selected = "none")
...@@ -187,15 +200,10 @@ output$ui_coxp <- renderUI({ ...@@ -187,15 +200,10 @@ output$ui_coxp <- renderUI({
selectInput("coxp_plots", i18n$t("Plots:"), choices = coxp_plots, selectInput("coxp_plots", i18n$t("Plots:"), choices = coxp_plots,
selected = state_single("coxp_plots", coxp_plots)), selected = state_single("coxp_plots", coxp_plots)),
conditionalPanel( conditionalPanel(
condition = "input.coxp_plots == 'coef' || input.coxp_plots == 'pdp' || input.coxp_plots == 'pred_plot'", condition = "input.coxp_plots == 'martingale'",
uiOutput("ui_coxp_incl"), checkboxGroupInput(
conditionalPanel( "coxp_lines", i18n$t("Add lines:"), coxp_lines,
condition = "input.coxp_plots == 'coef'", selected = state_group("coxp_lines", "loess")
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")
) )
) )
) )
...@@ -214,30 +222,34 @@ coxp_plot <- reactive({ ...@@ -214,30 +222,34 @@ coxp_plot <- reactive({
if (is.empty(input$coxp_plots, "none")) return() if (is.empty(input$coxp_plots, "none")) return()
plot_width <- 650 plot_width <- 650
plot_height <- 500 plot_height <- 500
nr_vars <- length(input$coxp_evar) + 1 nr_vars <- length(input$coxp_evar)
switch(input$coxp_plots,
if (input$coxp_plots == "dist") { "dist" = {
plot_height <- (plot_height / 2) * ceiling(nr_vars / 2) plot_height <- (plot_height / 2) * ceiling((nr_vars + 2) / 2) # +2 for time/status
} else if (input$coxp_plots == "dashboard") { },
plot_height <- 1.5 * plot_height "coef" = {
} 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 = "|"), ")") incl <- paste0("^(", paste0(input$coxp_incl, "[|]*", collapse = "|"), ")")
nr_coeff <- sum(grepl(incl, .coxp()$coeff$label)) nr_coeff <- if (is.empty(input$coxp_incl)) nr_vars else length(input$coxp_incl)
plot_height <- 300 + 20 * nr_coeff 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) "vip" = {
} else if (input$coxp_plots == "vip") {
plot_height <- max(500, 30 * nr_vars) 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) "survival" = {
plot_height <- max(250, ceiling(nr_vars / 2) * 250) plot_height <- 400
if (length(input$coxp_incl_int) > 0) { plot_width <- 600
plot_width <- plot_width + min(2, length(input$coxp_incl_int)) * 90 },
} "cumhaz" = {
plot_height <- 400
plot_width <- 600
},
"schoenfeld" = {
plot_height <- 400
},
"martingale" = {
plot_height <- 400
} }
)
list(plot_width = plot_width, plot_height = plot_height) list(plot_width = plot_width, plot_height = plot_height)
}) })
...@@ -398,7 +410,7 @@ coxp_available <- reactive({ ...@@ -398,7 +410,7 @@ coxp_available <- reactive({
if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **")) 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 (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 (coxp_available() != "available") return(coxp_available())
valid_plots <- c("coef", "dist", "vip", "pdp", "pred_plot", "influence") valid_plots <- c("dist", "vip", "coef", "survival", "cumhaz", "schoenfeld", "martingale")
if (!input$coxp_plots %in% valid_plots) { if (!input$coxp_plots %in% valid_plots) {
return(i18n$t("Selected plot type is not supported for Cox models.")) return(i18n$t("Selected plot type is not supported for Cox models."))
} }
...@@ -406,7 +418,7 @@ coxp_available <- reactive({ ...@@ -406,7 +418,7 @@ coxp_available <- reactive({
check_for_pdp_pred_plots("coxp") check_for_pdp_pred_plots("coxp")
} }
withProgress(message = i18n$t("Generating plots"), value = 1, { withProgress(message = i18n$t("Generating plots"), value = 1, {
do.call(plot, c(list(x = .coxp()), coxp_plot_inputs(), shiny = TRUE)) do.call(plot, c(list(x = .coxp()), coxp_plot_inputs()))
}) })
}) })
...@@ -417,7 +429,11 @@ coxp_report <- function() { ...@@ -417,7 +429,11 @@ coxp_report <- function() {
inp_out <- list(list(prn = TRUE), "") inp_out <- list(list(prn = TRUE), "")
figs <- FALSE figs <- FALSE
if (!is.empty(input$coxp_plots, "none")) { if (!is.empty(input$coxp_plots, "none")) {
inp <- check_plot_inputs(coxp_plot_inputs()) 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]] <- clean_args(inp, list())
inp_out[[2]]$custom <- FALSE inp_out[[2]]$custom <- FALSE
outputs <- c(outputs, "plot") outputs <- c(outputs, "plot")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment