Skip to content

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

update

parent 105b9543
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1090 additions and 413 deletions
README.md deleted 100644 → 0
View file @ 105b9543
# radiant
科研统计分析工具
Statistical Analysis System
\ No newline at end of file
notice.txt 0 → 100644
View file @ f926635b
上传模块
devtools::install_local("/home/wuzekai/radiant/radiant.data", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.basics", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.design", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.model", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.multivariate", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.quickgen", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant-master", force = TRUE)
清理原文件
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.data
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.basics
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.design
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.model
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.multivariate
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.quickgen
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant-master
启动软件
sudo -i
conda activate radiant
cd /home/wuzekai/radiant
R
options(browser = 'false'); radiant::radiant(host='0.0.0.0', port=8105)
杀掉端口
lsof -i :8105
kill -9 <PID>
\ No newline at end of file
radiant-master/inst/translations/translation_zh.csv
View file @ f926635b
......@@ -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,SW检验,normality_test_ui.R
Kolmogorov-Smirnov,K-S检验,normality_test_ui.R
Anderson-Darling,AD检验,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
......@@ -1186,3 +1186,4 @@ Time variable:,生存时间变量：,cox_ui.R
Status variable:,事件状态变量：,cox_ui.R
AI running...,大模型运行中...,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
radiant.basics/DESCRIPTION
View file @ f926635b
Package: radiant.basics
Type: Package
Title: Basics Menu for Radiant: Business Analytics using R and Shiny
Version: 1.6.6
Date: 2024-5-14
Authors@R: person("Vincent", "Nijs", , "radiant@rady.ucsd.edu", c("aut", "cre"))
Description: The Radiant Basics menu includes interfaces for probability
calculation, central limit theorem simulation, comparing means and proportions,
goodness-of-fit testing, cross-tabs, and correlation. The application extends
the functionality in 'radiant.data'.
Depends:
R (>= 4.3.0),
radiant.data (>= 1.6.6)
Imports:
ggplot2 (>= 2.2.1),
scales (>= 0.4.0),
dplyr (>= 1.0.7),
tidyr (>= 0.8.2),
magrittr (>= 1.5),
shiny (>= 1.8.1),
psych (>= 1.8.3.3),
import (>= 1.1.0),
lubridate (>= 1.7.4),
polycor (>= 0.7.10),
patchwork (>= 1.0.0),
shiny.i18n,
rlang (>= 1.0.6)
Suggests:
testthat (>= 2.0.0),
pkgdown (>= 1.1.0),
markdown (>= 1.3)
URL: https://github.com/radiant-rstats/radiant.basics/,
https://radiant-rstats.github.io/radiant.basics/,
https://radiant-rstats.github.io/docs/
BugReports: https://github.com/radiant-rstats/radiant.basics/issues/
License: AGPL-3 | file LICENSE
LazyData: true
Encoding: UTF-8
Language: en-US
RoxygenNote: 7.3.2
Package: radiant.basics
Type: Package
Title: Basics Menu for Radiant: Business Analytics using R and Shiny
Version: 1.6.6
Date: 2024-5-14
Authors@R: person("Vincent", "Nijs", , "radiant@rady.ucsd.edu", c("aut", "cre"))
Description: The Radiant Basics menu includes interfaces for probability
calculation, central limit theorem simulation, comparing means and proportions,
goodness-of-fit testing, cross-tabs, and correlation. The application extends
the functionality in 'radiant.data'.
Depends:
R (>= 4.3.0),
radiant.data (>= 1.6.6)
Imports:
ggplot2 (>= 2.2.1),
scales (>= 0.4.0),
dplyr (>= 1.0.7),
tidyr (>= 0.8.2),
magrittr (>= 1.5),
shiny (>= 1.8.1),
psych (>= 1.8.3.3),
import (>= 1.1.0),
lubridate (>= 1.7.4),
polycor (>= 0.7.10),
patchwork (>= 1.0.0),
shiny.i18n,
rlang (>= 1.0.6),
ggpp,
nortest
Suggests:
testthat (>= 2.0.0),
pkgdown (>= 1.1.0),
markdown (>= 1.3)
URL: https://github.com/radiant-rstats/radiant.basics/,
https://radiant-rstats.github.io/radiant.basics/,
https://radiant-rstats.github.io/docs/
BugReports: https://github.com/radiant-rstats/radiant.basics/issues/
License: AGPL-3 | file LICENSE
LazyData: true
Encoding: UTF-8
Language: en-US
RoxygenNote: 7.3.2
radiant.basics/R/homo_variance_test.R
View file @ f926635b
############################################
## Homogeneity of variance test - 空壳版（照抄 single_mean）
## Homogeneity of variance test
############################################
# Homogeneity of variance tests for radiant.basics
#' @export
homo_variance_test <- function(dataset, var, group, method = "levene",
conf_lev = .95, data_filter = "",
homo_variance_test <- function(dataset, var, group,
method = c("levene", "bartlett", "fligner"),
data_filter = "",
envir = parent.frame()) {
# 获取数据
df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset))
dataset <- get_data(dataset, var, group, filt = data_filter, na.rm = TRUE, envir = envir)
dataset <- get_data(
dataset,
vars = c(var, group),
filt = data_filter,
na.rm = FALSE,
envir = envir
)
# 校验变量存在性
if (!var %in% colnames(dataset)) {
stop(paste("变量", var, "未在数据集中找到！"), call. = FALSE)
}
if (!group %in% colnames(dataset)) {
stop(paste("分组变量", group, "未在数据集中找到！"), call. = FALSE)
}
# 提取变量
x <- dataset[[var]]
g <- dataset[[group]]
if (!is.numeric(x)) stop(i18n$t("Variable must be numeric"))
if (length(unique(g)) < 2) stop(i18n$t("Grouping variable must have at least 2 levels"))
## ---- 空壳结果 ----
res <- tibble::tribble(
~Test, ~Statistic, ~p.value,
"Levene", 0.42, 0.52,
"Bartlett", 0.38, 0.54,
"Fligner", 0.45, 0.50
g_raw <- dataset[[group]]
# 校验数值变量类型
if (!is.numeric(x)) {
stop(paste("变量", var, "必须是数值型！"), call. = FALSE)
}
# 计算有效样本
valid_indices <- !is.na(g_raw) & !is.na(x)
valid_data <- dataset[valid_indices, ] # 保留有效样本的完整数据（用于绘图）
valid_g <- g_raw[valid_indices]
valid_levels <- length(unique(valid_g))
# 数据不足判断
if (valid_levels < 2) {
return(structure(
list(
df_name = df_name,
var = var,
group = group,
valid_data = valid_data, # 传递有效数据用于绘图提示
res = tibble(
Test = "无法执行检验",
Statistic = NA_real_,
p.value = NA_character_
)
),
class = "homo_variance_test"
))
}
# 转换分组为因子
g <- factor(valid_g)
# 检验计算
res <- tibble::tibble(
Test = character(),
Statistic = numeric(),
p.value = numeric()
)
dat_summary <- dataset %>%
group_by(!!sym(group)) %>%
summarise(
n = n(),
mean = mean(!!sym(var), na.rm = TRUE),
sd = sd(!!sym(var), na.rm = TRUE),
.groups = "drop"
)
# Levene检验
if ("levene" %in% method && requireNamespace("car", quietly = TRUE)) {
tmp <- tryCatch(car::leveneTest(x[valid_indices] ~ g), error = function(e) NULL)
if (!is.null(tmp) && nrow(tmp) > 0) {
res <- tibble::add_row(res,
Test = "Levene",
Statistic = as.numeric(tmp[["F value"]][1]),
p.value = as.numeric(tmp[["Pr(>F)"]][1]))
}
}
## 绘图数据
plot_obj <- list(hist = list(type = "hist", data = dataset, var = var, group = group),
density = list(type = "density", data = dataset, var = var, group = group),
boxplot = list(type = "boxplot", data = dataset, var = var, group = group))
# Bartlett检验
if ("bartlett" %in% method) {
tmp <- tryCatch(stats::bartlett.test(x[valid_indices], g), error = function(e) NULL)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Test = "Bartlett",
Statistic = as.numeric(tmp$statistic),
p.value = as.numeric(tmp$p.value))
}
}
as.list(environment()) %>% add_class("homo_variance_test")
# Fligner检验
if ("fligner" %in% method) {
tmp <- tryCatch(stats::fligner.test(x[valid_indices], g), error = function(e) NULL)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Test = "Fligner",
Statistic = as.numeric(tmp$statistic),
p.value = as.numeric(tmp$p.value))
}
}
# 返回结果（包含有效数据用于绘图）
structure(
list(
df_name = df_name,
var = var,
group = group,
valid_data = valid_data, # 新增：保存有效样本数据
res = res
),
class = "homo_variance_test"
)
}
# Summary method
#' @export
summary.homo_variance_test <- function(object, dec = 3, ...) {
# 标准化说明文字（与正态性检验格式一致）
cat("Homogeneity of variance tests\n")
cat("Data :", object$df_name, "\n")
if (!is.empty(object$data_filter)) {
cat("Filter :", gsub("\\n", "", object$data_filter), "\n")
}
cat("Variable :", object$var, "\n")
cat("Group :", object$group, "\n\n")
## 打印统计量表
object$res %>%
as.data.frame(stringsAsFactors = FALSE) %>%
format_df(dec = dec) %>%
print(row.names = FALSE)
cat("\n")
# 格式化结果表格
result_table <- object$res %>%
dplyr::mutate(
Statistic = round(Statistic, dec),
p.value = dplyr::case_when(
p.value < 0.001 ~ "<0.001",
is.na(p.value) ~ "",
TRUE ~ as.character(round(p.value, dec))
)
)
# 打印结果表格
print(as.data.frame(result_table), row.names = FALSE)
invisible(object)
}
# Plot method
#' @export
plot.homo_variance_test <- function(x, plots = c("boxplot", "density"),
plot.homo_variance_test <- function(x, plots = c("boxplot", "density", "hist"),
shiny = FALSE, custom = FALSE, ...) {
# 1. 提取有效数据（用于绘图）
valid_data <- x$valid_data
if (nrow(valid_data) == 0) {
return(ggplot2::ggplot() +
ggplot2::annotate("text", x = 1, y = 1, label = i18n$t("No valid data for plotting")) +
ggplot2::theme_void())
}
# 2. 定义变量名（用于图表标签）
var_name <- x$var
group_name <- x$group
# 3. 初始化图形列表
plot_list <- list()
# 4. 生成箱线图（按分组展示数值变量分布）
if ("boxplot" %in% plots) {
plot_list[[which("boxplot" == plots)]] <-
ggplot(x$dat_summary, aes(x = .data[[x$group]], y = .data[[x$var]])) +
geom_boxplot(fill = "lightblue", alpha = 0.7)
p <- ggplot2::ggplot(valid_data,
ggplot2::aes(x = .data[[group_name]],
y = .data[[var_name]],
fill = .data[[group_name]])) +
ggplot2::geom_boxplot(alpha = 0.7, show.legend = FALSE) +
ggplot2::labs(x = group_name,
y = var_name,
title = i18n$t("Boxplot by Group")) +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
plot_list[["boxplot"]] <- p
}
# 5. 生成密度图（按分组展示数值变量分布）
if ("density" %in% plots) {
plot_list[[which("density" == plots)]] <-
ggplot(x$dat_summary, aes(x = .data[[x$var]], fill = .data[[x$group]])) +
geom_density(alpha = 0.5)
p <- ggplot2::ggplot(valid_data,
ggplot2::aes(x = .data[[var_name]],
fill = .data[[group_name]],
color = .data[[group_name]])) +
ggplot2::geom_density(alpha = 0.3) +
ggplot2::labs(x = var_name,
y = i18n$t("Density"),
title = i18n$t("Density by Group"),
fill = group_name,
color = group_name) +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
plot_list[["density"]] <- p
}
# 6. 生成直方图（按分组展示数值变量分布）
if ("hist" %in% plots) {
plot_list[[which("hist" == plots)]] <-
ggplot(x$dat_summary, aes(x = .data[[x$var]], fill = .data[[x$group]])) +
geom_histogram(alpha = 0.5, position = "identity", bins = 30)
p <- ggplot2::ggplot(valid_data,
ggplot2::aes(x = .data[[var_name]],
fill = .data[[group_name]])) +
ggplot2::geom_histogram(position = "identity", alpha = 0.5, bins = 30) +
ggplot2::labs(x = var_name,
y = i18n$t("Count"),
title = i18n$t("Histogram by Group"),
fill = group_name) +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
plot_list[["hist"]] <- p
}
# 7. 处理未选择图表类型的情况
if (length(plot_list) == 0) {
return(ggplot2::ggplot() +
ggplot2::annotate("text", x = 1, y = 1, label = i18n$t("No plots selected")) +
ggplot2::theme_void())
}
if (length(plot_list) == 0) return(invisible())
patchwork::wrap_plots(plot_list, ncol = 1) %>%
{ if (shiny) print(.) else print(.) }
invisible(x)
}
\ No newline at end of file
# 8. 组合图表（按选择顺序排列）
combined_plot <- patchwork::wrap_plots(plot_list[plots], ncol = 1)
# 9. 在Shiny中显示或返回图表
if (shiny) {
print(combined_plot)
invisible(x)
} else {
combined_plot
}
}
radiant.basics/R/normality_test.R
View file @ f926635b
......@@ -3,36 +3,97 @@
############################################
# Batch normality tests for radiant.basics
#
#' @export
normality_test <- function(dataset, var, method = "shapiro",
conf_lev = .95, data_filter = "",
normality_test <- function(dataset,
var,
method = c("shapiro", "ks", "ad"),
data_filter = "",
envir = parent.frame()) {
## 1. 定义支持的检验方法
supported_methods <- c("shapiro", "ks", "ad")
## 2. 处理多选方法：过滤无效值+设置默认
method <- intersect(method, supported_methods)
if (length(method) == 0) method <- "shapiro"
method <- match.arg(method, choices = supported_methods, several.ok = TRUE)
## 3. 取数据
df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset))
dataset <- get_data(dataset, var, filt = data_filter, na.rm = TRUE, envir = envir)
x <- dataset[[var]]
x <- dataset[[var]]
if (!is.numeric(x)) stop(i18n$t("Variable must be numeric"))
x <- x[!is.na(x)] # 剔除缺失
## ---- 空壳结果 ----
res <- tibble::tribble(
~Test, ~Statistic, ~p.value,
"Shapiro-Wilk", 0.99, 0.12,
"Kolmogorov-Smirnov", 0.05, 0.30,
"Anderson-Darling", 0.80, 0.25
## 4. 初始化结果表格
res <- tibble::tibble(
Test = character(),
Statistic = numeric(),
p.value = numeric()
)
dat_summary <- tibble::tribble(
~mean, ~n, ~n_missing, ~sd, ~se,
mean(x, na.rm = TRUE), length(x), sum(is.na(x)), sd(x, na.rm = TRUE), sd(x, na.rm = TRUE)/sqrt(length(x))
## 5. 逐方法计算
if ("shapiro" %in% method) {
tmp <- tryCatch(stats::shapiro.test(x),
error = function(e) {
stop("Shapiro-Wilk 需要 3 ≤ n ≤ 5000，当前 n = ", length(x),
"\n请换 KS 或 AD 方法。")
})
res <- tibble::add_row(res,
Test = "Shapiro-Wilk",
Statistic = tmp$statistic,
p.value = tmp$p.value)
}
if ("ks" %in% method) {
if (requireNamespace("nortest", quietly = TRUE)) {
tmp <- nortest::lillie.test(x)
res <- tibble::add_row(res,
Test = "Lilliefors-KS",
Statistic = tmp$statistic,
p.value = tmp$p.value)
}
}
if ("ad" %in% method) {
if (requireNamespace("nortest", quietly = TRUE)) {
tmp <- nortest::ad.test(x)
res <- tibble::add_row(res,
Test = "Anderson-Darling",
Statistic = tmp$statistic,
p.value = tmp$p.value)
}
}
## 6. 样本描述
dat_summary <- tibble::tibble(
mean = mean(x),
n = length(x),
n_missing = sum(is.na(dataset[[var]])),
sd = sd(x),
se = sd(x) / sqrt(length(x))
)
## 绘图数据
plot_obj <- list(qq = list(type = "qq", data = x),
hist = list(type = "hist", data = x),
pp = list(type = "pp", data = x),
density = list(type = "density", data = x))
## 7. 绘图对象
plot_obj <- list(
qq = list(type = "qq", data = x),
hist = list(type = "hist", data = x),
pp = list(type = "pp", data = x),
density = list(type = "density", data = x)
)
as.list(environment()) %>% add_class("normality_test")
## 8. 打包返回
out <- list(
df_name = df_name,
var = var,
method = method,
data_filter = data_filter,
res = res,
dat_summary = dat_summary,
x = x,
plot_obj = plot_obj
)
class(out) <- "normality_test"
out
}
# Summary method
......@@ -47,6 +108,7 @@ summary.normality_test <- function(object, dec = 3, ...) {
## 打印统计量表
object$res %>%
mutate(p.value = format.pval(p.value, digits = 3, eps = 1e-4)) %>%
as.data.frame(stringsAsFactors = FALSE) %>%
format_df(dec = dec) %>%
print(row.names = FALSE)
......@@ -69,9 +131,18 @@ plot.normality_test <- function(x, plots = c("qq", "hist"),
geom_histogram(fill = "blue", bins = 30)
}
if ("pp" %in% plots) {
n <- length(x$x)
i <- 1:n
p <- (i - 0.5) / n
theoretical <- qnorm(p)
empirical <- sort(scale(x$x))
plot_list[[which("pp" == plots)]] <-
ggplot(data.frame(y = x$x), aes(sample = y)) +
stat_pp_band() + stat_pp_line() + stat_pp_point()
ggplot(data.frame(theoretical = theoretical, empirical = empirical), aes(theoretical, empirical)) +
geom_point(colour = "blue") +
geom_abline(intercept = 0, slope = 1, linetype = "dashed", colour = "red") +
labs(x = "Theoretical quantiles", y = "Empirical quantiles",
title = "P-P plot") +
theme_minimal()
}
if ("density" %in% plots) {
plot_list[[which("density" == plots)]] <-
......
radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R
View file @ f926635b
......@@ -20,31 +20,63 @@ hv_args <- as.list(formals(homo_variance_test))
hv_inputs <- reactive({
hv_args$data_filter <- if (input$show_filter) input$data_filter else ""
hv_args$dataset <- input$dataset
hv_args$method <- input$hv_method
# 确保正确收集分组变量和数值变量
for (i in r_drop(names(hv_args))) {
hv_args[[i]] <- input[[paste0("hv_", i)]]
}
hv_args
})
## 4. 变量选择（numeric + grouping）
## 4. 数值变量选择
output$ui_hv_var <- renderUI({
isNum <- .get_class() %in% c("integer", "numeric", "ts")
vars <- c("None" = "", varnames()[isNum])
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
isNum <- sapply(current_data, function(col) is.numeric(col) || is.ts(col))
num_vars <- names(isNum)[isNum]
if (length(num_vars) == 0) {
return(div(class = "alert alert-warning", i18n$t("No numeric variables in dataset.")))
}
vars <- c("None" = "", num_vars)
selectInput(
inputId = "hv_var", label = i18n$t("Variable (select one):"),
choices = vars, selected = state_single("hv_var", vars), multiple = FALSE
inputId = "hv_var",
label = i18n$t("Variable (select one):"),
choices = vars,
selected = state_single("hv_var", vars),
multiple = FALSE
)
})
## 5. 分组变量选择
output$ui_hv_group <- renderUI({
vars <- groupable_vars()
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
# 仅保留因子/字符型变量
group_candidates <- names(which(sapply(current_data, function(col)
is.factor(col) || is.character(col)
)))
# 筛选有效水平≥2的分组变量
valid_groups <- character(0)
for (grp in group_candidates) {
grp_vals <- current_data[[grp]]
valid_levels <- length(unique(grp_vals[!is.na(grp_vals)]))
if (valid_levels >= 2) {
valid_groups <- c(valid_groups, grp)
}
}
if (length(valid_groups) == 0) {
return(div(class = "alert alert-warning", i18n$t("No valid grouping variables (need ≥2 levels).")))
}
selectInput(
inputId = "hv_group", label = i18n$t("Grouping variable:"),
choices = vars, selected = state_single("hv_group", vars), multiple = FALSE
inputId = "hv_group",
label = i18n$t("Grouping variable:"),
choices = valid_groups,
selected = state_single("hv_group", valid_groups),
multiple = FALSE
)
})
## 5. 主 UI
## 6. 主UI
output$ui_homo_variance_test <- renderUI({
req(input$dataset)
tagList(
......@@ -53,22 +85,21 @@ output$ui_homo_variance_test <- renderUI({
condition = "input.tabs_homo_variance_test == 'Summary'",
uiOutput("ui_hv_var"),
uiOutput("ui_hv_group"),
selectInput(
inputId = "hv_method", label = i18n$t("Test method:"),
selectizeInput(
inputId = "hv_method",
label = i18n$t("Test method:"),
choices = hv_method,
selected = state_single("hv_method", hv_method, "levene"),
multiple = FALSE
),
sliderInput(
"hv_conf_lev", i18n$t("Confidence level:"),
min = 0.85, max = 0.99,
value = state_init("hv_conf_lev", 0.95), step = 0.01
selected = state_multiple("hv_method", hv_method, "levene"),
multiple = TRUE,
options = list(placeholder = i18n$t("Select methods"),
plugins = list("remove_button", "drag_drop"))
)
),
conditionalPanel(
condition = "input.tabs_homo_variance_test == 'Plot'",
selectizeInput(
inputId = "hv_plots", label = i18n$t("Select plots:"),
inputId = "hv_plots",
label = i18n$t("Select plots:"),
choices = hv_plots,
selected = state_multiple("hv_plots", hv_plots, "boxplot"),
multiple = TRUE,
......@@ -86,7 +117,7 @@ output$ui_homo_variance_test <- renderUI({
)
})
## 6. 画图尺寸
## 7. 画图尺寸
hv_plot <- reactive({
list(plot_width = 650,
plot_height = 400 * max(length(input$hv_plots), 1))
......@@ -94,7 +125,7 @@ hv_plot <- reactive({
hv_plot_width <- function() hv_plot()$plot_width
hv_plot_height <- function() hv_plot()$plot_height
## 7. 输出面板
## 8. 输出面板
output$homo_variance_test <- renderUI({
register_print_output("summary_homo_variance_test", ".summary_homo_variance_test")
register_plot_output("plot_homo_variance_test", ".plot_homo_variance_test",
......@@ -102,12 +133,8 @@ output$homo_variance_test <- renderUI({
hv_output_panels <- tabsetPanel(
id = "tabs_homo_variance_test",
tabPanel(title = i18n$t("Summary"),
value = "Summary",
verbatimTextOutput("summary_homo_variance_test")),
tabPanel(title = i18n$t("Plot"),
value = "Plot",
download_link("dlp_homo_variance_test"),
tabPanel(title = i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_homo_variance_test")),
tabPanel(title = i18n$t("Plot"), value = "Plot", download_link("dlp_homo_variance_test"),
plotOutput("plot_homo_variance_test", height = "100%"))
)
......@@ -119,17 +146,34 @@ output$homo_variance_test <- renderUI({
)
})
## 8. 可用性检查
## 9. 可用性检查（强化变量存在性校验）
hv_available <- reactive({
if (not_available(input$hv_var))
return(i18n$t("This analysis requires a numeric variable. If none are\navailable please select another dataset.") %>% suggest_data("demand_uk"))
if (not_available(input$hv_group))
return(i18n$t("Please select a grouping variable."))
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
# 校验数值变量
if (not_available(input$hv_var) || !input$hv_var %in% colnames(current_data)) {
return(i18n$t("Please select a valid numeric variable."))
}
# 校验分组变量
if (not_available(input$hv_group) || !input$hv_group %in% colnames(current_data)) {
return(i18n$t("Please select a valid grouping variable."))
}
# 校验分组变量水平
group_vals <- current_data[[input$hv_group]]
valid_levels <- length(unique(group_vals[!is.na(group_vals)]))
if (valid_levels < 2) {
return(i18n$t("Grouping variable has <2 valid levels. Choose another."))
}
"available"
})
## 9. 计算核心
## 10. 计算核心
.homo_variance_test <- reactive({
req(hv_available() == "available") # 确保通过可用性检查
hvi <- hv_inputs()
hvi$envir <- r_data
do.call(homo_variance_test, hvi)
......@@ -142,33 +186,18 @@ hv_available <- reactive({
.plot_homo_variance_test <- reactive({
if (hv_available() != "available") return(hv_available())
validate(need(input$hv_plots, i18n$t("Nothing to plot. Please select a plot type")))
validate(need(input$hv_plots, i18n$t("Select plot types first")))
withProgress(message = i18n$t("Generating plots"), value = 1,
plot(.homo_variance_test(), plots = input$hv_plots, shiny = TRUE))
})
## 10. Report
homo_variance_test_report <- function() {
if (is.empty(input$hv_var)) return(invisible())
figs <- length(input$hv_plots) > 0
outputs <- if (figs) c("summary", "plot") else "summary"
inp_out <- if (figs) list("", list(plots = input$hv_plots, custom = FALSE)) else list("", "")
update_report(inp_main = clean_args(hv_inputs(), hv_args),
fun_name = "homo_variance_test",
inp_out = inp_out,
outputs = outputs,
figs = figs,
fig.width = hv_plot_width(),
fig.height = hv_plot_height())
}
## 11. 下载 & 截图
download_handler(
id = "dlp_homo_variance_test",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_homo_variance_test"),
type = "png",
caption = i18n$t("Save homogeneity of variance plot"),
caption = i18n$t("Save plot"),
plot = .plot_homo_variance_test,
width = hv_plot_width,
height = hv_plot_height
......
radiant.basics/inst/app/tools/analysis/normality_test_ui.R
View file @ f926635b
......@@ -3,7 +3,7 @@
############################################
## 1. 翻译标签
nt_method <- c("shapiro", "ks", "ad") # 先给 3 个常用方法
nt_method <- c("shapiro", "ks", "ad")
names(nt_method) <- c(i18n$t("Shapiro-Wilk"),
i18n$t("Kolmogorov-Smirnov"),
i18n$t("Anderson-Darling"))
......@@ -21,13 +21,19 @@ nt_args <- as.list(formals(normality_test))
nt_inputs <- reactive({
nt_args$data_filter <- if (input$show_filter) input$data_filter else ""
nt_args$dataset <- input$dataset
for (i in r_drop(names(nt_args))) {
nt_args[[i]] <- input[[paste0("nt_", i)]]
input_key <- paste0("nt_", i)
if (!is.null(input[[input_key]])) {
nt_args[[i]] <- input[[input_key]]
}
}
nt_args$method <- input$nt_method
nt_args
})
## 4. 变量选择（仅 numeric）
## 4. 变量选择
output$ui_nt_var <- renderUI({
isNum <- .get_class() %in% c("integer", "numeric", "ts")
vars <- c("None" = "", varnames()[isNum])
......@@ -45,16 +51,13 @@ output$ui_normality_test <- renderUI({
conditionalPanel(
condition = "input.tabs_normality_test == 'Summary'",
uiOutput("ui_nt_var"),
selectInput(
selectizeInput(
inputId = "nt_method", label = i18n$t("Test method:"),
choices = nt_method,
selected = state_single("nt_method", nt_method, "shapiro"),
multiple = FALSE
),
sliderInput(
"nt_conf_lev", i18n$t("Confidence level:"),
min = 0.85, max = 0.99,
value = state_init("nt_conf_lev", 0.95), step = 0.01
selected = state_multiple("nt_method", nt_method, "shapiro"),
multiple = TRUE,
options = list(placeholder = i18n$t("Select methods"),
plugins = list("remove_button", "drag_drop"))
)
),
conditionalPanel(
......@@ -122,11 +125,13 @@ nt_available <- reactive({
## 9. 计算核心
.normality_test <- reactive({
nti <- nt_inputs()
req(nti$method, nti$var)
nti$envir <- r_data
do.call(normality_test, nti)
})
.summary_normality_test <- reactive({
input$nt_method
if (nt_available() != "available") return(nt_available())
summary(.normality_test())
})
......
radiant.data/DESCRIPTION
View file @ f926635b
Package: radiant.data
Title: Data Menu for Radiant: Business Analytics using R and Shiny
Version: 1.6.7
Date: 2024-10-22
Authors@R: c(
person("Vincent", "Nijs", email = "radiant@rady.ucsd.edu", role = c("aut", "cre")),
person("Niklas", "von Hertzen", email = "niklasvh@gmail.com", role = c("aut"), comment = "html2canvas library")
)
Description: The Radiant Data menu includes interfaces for loading, saving,
viewing, visualizing, summarizing, transforming, and combining data. It also
contains functionality to generate reproducible reports of the analyses
conducted in the application.
Depends:
R (>= 4.3.0),
magrittr (>= 1.5),
ggplot2 (>= 3.4.2),
lubridate (>= 1.7.4),
tidyr (>= 0.8.2),
dplyr (>= 1.1.2)
Imports:
tibble (>= 1.4.2),
rlang (>= 0.4.10),
broom (>= 0.5.2),
car (>= 3.0-0),
knitr (>= 1.20),
markdown (>= 1.7),
rmarkdown(>= 2.22),
shiny (>= 1.8.1),
jsonlite (>= 1.0),
shinyAce (>= 0.4.1),
psych (>= 1.8.4),
DT (>= 0.28),
readr (>= 1.1.1),
readxl (>= 1.0.0),
writexl (>= 0.2),
scales (>= 0.4.0),
curl (>= 2.5),
rstudioapi (>= 0.7),
import (>= 1.1.0),
plotly (>= 4.7.1),
glue (>= 1.3.0),
shinyFiles (>= 0.9.1),
stringi (>= 1.2.4),
randomizr (>= 0.20.0),
patchwork (>= 1.0.0),
bslib (>= 0.5.0),
png,
MASS,
base64enc,
shiny.i18n
Suggests:
arrow (>= 12.0.1),
dbplyr (>= 2.1.1),
DBI (>= 0.7),
RSQLite (>= 2.0),
RPostgres (>= 1.4.4),
webshot (>= 0.5.0),
testthat (>= 2.0.0),
pkgdown (>= 1.1.0)
URL:
https://github.com/radiant-rstats/radiant.data/,
https://radiant-rstats.github.io/radiant.data/,
https://radiant-rstats.github.io/docs/
BugReports: https://github.com/radiant-rstats/radiant.data/issues/
License: AGPL-3 | file LICENSE
LazyData: true
Encoding: UTF-8
Language: en-US
RoxygenNote: 7.3.2
Package: radiant.data
Title: Data Menu for Radiant: Business Analytics using R and Shiny
Version: 1.6.7
Date: 2024-10-22
Authors@R: c(
person("Vincent", "Nijs", email = "radiant@rady.ucsd.edu", role = c("aut", "cre")),
person("Niklas", "von Hertzen", email = "niklasvh@gmail.com", role = c("aut"), comment = "html2canvas library")
)
Description: The Radiant Data menu includes interfaces for loading, saving,
viewing, visualizing, summarizing, transforming, and combining data. It also
contains functionality to generate reproducible reports of the analyses
conducted in the application.
Depends:
R (>= 4.3.0),
magrittr (>= 1.5),
ggplot2 (>= 3.4.2),
lubridate (>= 1.7.4),
tidyr (>= 0.8.2),
dplyr (>= 1.1.2)
Imports:
tibble (>= 1.4.2),
rlang (>= 0.4.10),
broom (>= 0.5.2),
car (>= 3.0-0),
knitr (>= 1.20),
markdown (>= 1.7),
rmarkdown(>= 2.22),
shiny (>= 1.8.1),
jsonlite (>= 1.0),
shinyAce (>= 0.4.1),
psych (>= 1.8.4),
DT (>= 0.28),
readr (>= 1.1.1),
readxl (>= 1.0.0),
writexl (>= 0.2),
scales (>= 0.4.0),
curl (>= 2.5),
rstudioapi (>= 0.7),
import (>= 1.1.0),
plotly (>= 4.7.1),
glue (>= 1.3.0),
shinyFiles (>= 0.9.1),
stringi (>= 1.2.4),
randomizr (>= 0.20.0),
patchwork (>= 1.0.0),
bslib (>= 0.5.0),
png,
MASS,
base64enc,
shinyalert,
shiny.i18n
Suggests:
arrow (>= 12.0.1),
dbplyr (>= 2.1.1),
DBI (>= 0.7),
RSQLite (>= 2.0),
RPostgres (>= 1.4.4),
webshot (>= 0.5.0),
testthat (>= 2.0.0),
pkgdown (>= 1.1.0)
URL:
https://github.com/radiant-rstats/radiant.data/,
https://radiant-rstats.github.io/radiant.data/,
https://radiant-rstats.github.io/docs/
BugReports: https://github.com/radiant-rstats/radiant.data/issues/
License: AGPL-3 | file LICENSE
LazyData: true
Encoding: UTF-8
Language: en-US
RoxygenNote: 7.3.2
radiant.data/inst/app/global.R
View file @ f926635b
......@@ -603,8 +603,7 @@ options(
tabPanel(
actionLink(
"stop_radiant", i18n$t("Stop"),
icon = icon("stop", verify_fa = FALSE),
onclick = "setTimeout(function(){window.close();}, 100);"
icon = icon("stop", verify_fa = FALSE)
)
),
tabPanel(tags$a(
......
radiant.data/inst/app/tools/app/stop.R
View file @ f926635b
#######################################
# Stop menu
#######################################
observeEvent(input$stop_radiant, {
if (isTRUE(getOption("radiant.local"))) stop_radiant()
})
stop_radiant <- function() {
## quit R, unless you are running an interactive session
if (interactive()) {
## flush input and r_data into Rgui or Rstudio
isolate({
LiveInputs <- toList(input)
r_state[names(LiveInputs)] <- LiveInputs
r_state$nav_radiant <- r_info[["nav_radiant"]]
assign("r_state", r_state, envir = .GlobalEnv)
## convert environment to a list and then back to an environment
## again to remove active bindings https://github.com/rstudio/shiny/issues/1905
## using an environment so you can "attach" and access data easily
rem_non_active() ## keep only the active bindings (i.e., data, datalist, etc.)
## to env on stop causes reference problems
assign("r_data", env2list(r_data), envir = .GlobalEnv)
assign("r_info", toList(r_info), envir = .GlobalEnv)
## removing r_sessions and functions defined in global.R
unlink("~/r_figures/", recursive = TRUE)
clean_up_list <- c(
"r_sessions", "help_menu", "make_url_patterns", "import_fs",
"init_data", "navbar_proj", "knit_print.data.frame", "withMathJax",
"Dropbox", "sf_volumes", "GoogleDrive", "bslib_current_version",
"has_bslib_theme", "load_html2canvas"
)
suppressWarnings(
suppressMessages({
res <- try(sapply(clean_up_list, function(x) if (exists(x, envir = .GlobalEnv)) rm(list = x, envir = .GlobalEnv)), silent = TRUE)
rm(res)
})
)
options(radiant.launch_dir = NULL)
options(radiant.project_dir = NULL)
options(radiant.autosave = NULL)
message("\nStopped Radiant. State information is available in the r_state and r_info lists and the r_data environment. Use attach(r_data) to access data loaded into Radiant.\n")
stopApp()
})
} else {
stopApp()
q("no")
}
}
#######################################
# Stop menu
#######################################
observeEvent(input$stop_radiant, {
shinyalert::shinyalert(
title = "确认停止",
text = "停止按钮会将所有容器都关闭！确定停止吗？",
type = "warning",
showCancelButton = TRUE,
confirmButtonCol = "#d33",
confirmButtonText = "确定",
cancelButtonText = "取消",
callbackJS = "function(x){if(x){Shiny.setInputValue('really_stop',Math.random());}}"
)
})
observeEvent(input$really_stop, {
if (isTRUE(getOption("radiant.local"))) stop_radiant()
})
stop_radiant <- function() {
## quit R, unless you are running an interactive session
if (interactive()) {
## flush input and r_data into Rgui or Rstudio
isolate({
LiveInputs <- toList(input)
r_state[names(LiveInputs)] <- LiveInputs
r_state$nav_radiant <- r_info[["nav_radiant"]]
assign("r_state", r_state, envir = .GlobalEnv)
## convert environment to a list and then back to an environment
## again to remove active bindings https://github.com/rstudio/shiny/issues/1905
## using an environment so you can "attach" and access data easily
rem_non_active() ## keep only the active bindings (i.e., data, datalist, etc.)
## to env on stop causes reference problems
assign("r_data", env2list(r_data), envir = .GlobalEnv)
assign("r_info", toList(r_info), envir = .GlobalEnv)
## removing r_sessions and functions defined in global.R
unlink("~/r_figures/", recursive = TRUE)
clean_up_list <- c(
"r_sessions", "help_menu", "make_url_patterns", "import_fs",
"init_data", "navbar_proj", "knit_print.data.frame", "withMathJax",
"Dropbox", "sf_volumes", "GoogleDrive", "bslib_current_version",
"has_bslib_theme", "load_html2canvas"
)
suppressWarnings(
suppressMessages({
res <- try(sapply(clean_up_list, function(x) if (exists(x, envir = .GlobalEnv)) rm(list = x, envir = .GlobalEnv)), silent = TRUE)
rm(res)
})
)
options(radiant.launch_dir = NULL)
options(radiant.project_dir = NULL)
options(radiant.autosave = NULL)
message("\nStopped Radiant. State information is available in the r_state and r_info lists and the r_data environment. Use attach(r_data) to access data loaded into Radiant.\n")
stopApp()
})
} else {
stopApp()
q("no")
}
}
radiant.model/R/cox.R
View file @ f926635b
#' Cox Proportional Hazards Regression (minimal)
#' Cox Proportional Hazards Regression
#'
#' @export
coxp <- function(dataset,
......@@ -13,6 +13,11 @@ coxp <- function(dataset,
rows = NULL,
envir = parent.frame()) {
if (!requireNamespace("survival", quietly = TRUE))
stop("survival package is required but not installed.")
attachNamespace("survival")
on.exit(detach("package:survival"), add = TRUE)
## ---- 公式入口 ----------------------------------------------------------
if (!missing(form)) {
form <- as.formula(format(form))
......@@ -32,6 +37,26 @@ coxp <- function(dataset,
df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset))
dataset <- get_data(dataset, vars, filt = data_filter, arr = arr, rows = rows, envir = envir)
## 状态变量检查与转换
surv_status <- dataset[[status]]
if (!is.numeric(surv_status)) {
## 允许 0/1、FALSE/TRUE、factor(未事件/事件) 等常见编码
if (is.factor(surv_status) || is.character(surv_status)) {
lv <- unique(surv_status)
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"))
}
} else {
if (!all(unique(surv_status) %in% c(0, 1))) {
return("Status variable must contain only 0 and 1." %>% add_class("coxp"))
}
}
## ---- 构造公式 ----------------------------------------------------------
if (missing(form)) {
rhs <- if (length(evar) == 0) "1" else paste(evar, collapse = " + ")
......@@ -46,35 +71,79 @@ coxp <- function(dataset,
model <- survival::coxph(form, data = dataset)
}
## ---- 打包返回 ----------------------------------------------------------
## 失败模型保护
if (inherits(model, "try-error")) {
return("Model estimation failed. Check data separation or collinearity." %>% add_class("coxp"))
}
## 基础摘要信息
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")
## 打包返回
out <- as.list(environment())
out$model <- model
out$df_name <- df_name
out$type <- "survival"
out$check <- check
## 附加对象
out$coef_df <- coef_df
out$n <- n
out$n_event <- n_event
out$concordance <- conc
add_class(out, c("coxp", "model"))
}
#' Summary 占位
#' @export
summary.coxp <- function(object, ...) {
if (is.character(object)) return(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)
invisible(object)
}
#' Predict 占位
#' @export
predict.coxp <- function(object, pred_data = NULL, pred_cmd = "",
dec = 3, envir = parent.frame(), ...) {
if (is.character(object)) return(object)
## 如需生存预测，可返回 linear.predictors 或 survival 曲线
pfun <- function(m, newdata) predict(m, newdata = newdata, type = "lp")
predict_model(object, pfun, "coxp.predict",
pred_data, pred_cmd, dec = dec, envir = envir)
## 构造预测数据框
if (is.null(pred_data)) {
newdata <- envir$.model_frame # 若无新数据，默认用训练集
} else {
newdata <- get_data(pred_data, envir = envir)
}
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
}
#' Print 预测占位
#' @export
print.coxp.predict <- function(x, ..., n = 10) {
print_predict_model(x, ..., n = n, header = "Cox Proportional Hazards")
cat("Cox PH predictions (linear predictor & hazard ratio):\n")
print(head(x, n))
invisible(x)
}
\ No newline at end of file
radiant.model/inst/app/tools/analysis/cox_ui.R
View file @ f926635b
## ========== coxp_ui.R 去错版 ==========
## ========== coxp_ui.R ==========
## 1. 常量 -----------------------------------------------------------------
coxp_show_interactions <- setNames(c("", 2, 3),
......@@ -24,7 +24,6 @@ coxp_plots <- setNames(
)
## 2. 参数收集 -------------------------------------------------------------
## 不再取 formals，全部用空列表占位
coxp_args <- list()
coxp_sum_args <- list()
coxp_plot_args <- list()
......@@ -259,7 +258,7 @@ output$ui_coxp <- renderUI({
selectInput("coxp_plots", i18n$t("Plots:"), choices = coxp_plots,
selected = state_single("coxp_plots", coxp_plots)),
conditionalPanel(
condition = "input.coxp_plots == 'coef' | input.coxp_plots == 'pdp' | input$coxp_plots == 'pred_plot'",
condition = "input.coxp_plots == 'coef' || input.coxp_plots == 'pdp' || input.coxp_plots == 'pred_plot'",
uiOutput("ui_coxp_incl"),
conditionalPanel(
condition = "input.coxp_plots == 'coef'",
......@@ -271,7 +270,7 @@ output$ui_coxp <- renderUI({
)
),
conditionalPanel(
condition = "input.coxp_plots %in% c('correlations','scatter','dashboard','resid_pred')",
condition = "['correlations', 'scatter', 'dashboard', 'resid_pred'].indexOf(input.coxp_plots) !== -1",
uiOutput("ui_coxp_nrobs"),
conditionalPanel(
condition = "input.coxp_plots != 'correlations'",
......@@ -281,9 +280,9 @@ output$ui_coxp <- renderUI({
)
),
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')",
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)
),
......@@ -372,33 +371,117 @@ output$coxp <- renderUI({
})
## 10. 可用性检查 ----------------------------------------------------------
coxp_available <- eventReactive(input$coxp_run, {
if (not_available(input$coxp_time)) {
i18n$t("This analysis requires a time variable of type integer/numeric.") %>% suggest_data("lung")
} else if (not_available(input$coxp_status)) {
i18n$t("Please select a status (event) variable.") %>% suggest_data("lung")
} else if (not_available(input$coxp_evar)) {
i18n$t("Please select one or more explanatory variables.") %>% suggest_data("lung")
} else {
"available"
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")
})
## 11. 模型估计 ------------------------------------------------------------
## 11. 模型估计
.coxp <- eventReactive(input$coxp_run, {
ci <- coxp_inputs()
ci$envir <- r_data
withProgress(message = i18n$t("Estimating Cox model"), value = 1,
do.call(coxph, ci))
cat("---->coxp reactive entered")
# 严格校验变量
ds <- tryCatch({
get_data(input$dataset, vars = c(), envir = r_data) # 先获取完整数据集
}, error = function(e) return(paste("数据集获取失败：", e$message)))
if (is.character(ds)) return(ds) # 数据集不存在，返回错误
# 校验时间变量
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 = ""))
}
# 校验状态变量
if (!input$coxp_status %in% colnames(ds)) {
return(paste("状态变量不存在：数据集中无「", input$coxp_status, "」列", sep = ""))
}
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
# 校验解释变量（存在且非空）
evar_missing <- setdiff(input$coxp_evar, colnames(ds))
if (length(evar_missing) > 0) {
return(paste("解释变量不存在：数据集中无「", paste(evar_missing, collapse = "、"), "」列", sep = ""))
}
# 构建模型并运行
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))))
return(model)
})
## 12. summary / predict / plot --------------------------------------------
.summary_coxp <- reactive({
if (not_pressed(input$coxp_run)) return(i18n$t("** Press the Estimate button to estimate the model **"))
if (coxp_available() != "available") return(coxp_available())
summary(.coxp()$model) # 直接调 survival 的 summary
if (not_pressed(input$coxp_run)) {
return(i18n$t("** 请点击「估计模型」按钮运行分析 **"))
}
# 先检查可用性（提前拦截无效操作）
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, " **"))
}
# 处理有效模型
if (inherits(model_result, "coxph")) {
# 检查是否有系数（避免无系数的空模型）
if (length(coef(model_result)) == 0) {
return(i18n$t("** 未估计出系数：可能存在完全共线性、事件数不足或变量无效 **"))
}
# 输出标准summary
return(summary(model_result))
}
# 其他未知错误
return(i18n$t("** 未知错误：请检查数据集和变量设置 **"))
})
## 确保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())
......
radiant.quickgen/R/quickgen_ai.R
View file @ f926635b
# === 配置 ===
MODELSCOPE_OPENAI_URL <- "https://api-inference.modelscope.cn/v1"
MODELSCOPE_API_KEY <- Sys.getenv("MODELSCOPE_API_KEY", "ms-b2746d72-f897-4faf-8089-89e5e511ed5a")
MODELSCOPE_API_KEY <- Sys.getenv("MODELSCOPE_API_KEY", "ms-6638b00e-57e4-4623-996d-214e375d220f")
MODEL_ID <- "deepseek-ai/DeepSeek-V3.1"
# === 低层封装：单次对话 ===
......
radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
View file @ f926635b
safe_is_empty <- function(x) {
if (is.null(x) || !is.character(x)) return(TRUE)
is.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)
......@@ -73,7 +68,7 @@ qib_add_labs <- function() {
lab_list <- list()
for (l in qib_labs) {
inp <- input[[paste0("qib_labs_", l)]]
if (!safe_is_empty(inp)) lab_list[[l]] <- inp
if (!is.empty(inp)) lab_list[[l]] <- inp
}
lab_list
}
......@@ -407,7 +402,7 @@ output$ui_qib_axes <- renderUI({
} else if (input$qib_type %in% c("bar", "box")) {
ind <- c(1, 3)
}
if (!safe_is_empty(input$qib_facet_row, ".") || !safe_is_empty(input$qib_facet_col, ".")) ind <- c(ind, 4)
if (!is.empty(input$qib_facet_row, ".") || !is.empty(input$qib_facet_col, ".")) ind <- c(ind, 4)
if (input$qib_type == "bar") ind <- c(ind, 6)
checkboxGroupInput(
......@@ -681,7 +676,7 @@ output$ui_quickgen_basic <- renderUI({
})
qib_plot_width <- reactive({
if (safe_is_empty(input$qib_plot_width)) r_info[["plot_width"]] else input$qib_plot_width
if (is.empty(input$qib_plot_width)) r_info[["plot_width"]] else input$qib_plot_width
})
qib_plot_height <- eventReactive(
......@@ -691,7 +686,7 @@ qib_plot_height <- eventReactive(
input$qib_plot_width
},
{
if (safe_is_empty(input$qib_plot_height)) {
if (is.empty(input$qib_plot_height)) {
r_info[["plot_height"]]
} else {
lx <- ifelse(not_available(input$qib_xvar) || isTRUE(input$qib_combx), 1, length(input$qib_xvar))
......@@ -791,49 +786,77 @@ dl_qgb_tab <- function(path) {
}
output$qib_chart <- renderPlot({
req(input$qib_type)
p <- .qib_chart()
if (is.null(p)) return(NULL)
print(p)
}, width = qib_plot_width, height = qib_plot_height, res = 96)
output$qib_chart <- renderPlot(
{
req(input$qib_type)
if (not_available(input$qib_xvar)) {
if (!input$qib_type %in% c("box", "line")) {
return(
plot(
x = 1, type = "n",
main = " ",
axes = FALSE, xlab = "", ylab = "", cex.main = .9
)
)
}
}
.qib_chart() %>%
(function(x) {
if (is.empty(x) || is.character(x)) {
plot(x = 1, type = "n", main = paste0("\n", x), axes = FALSE, xlab = "", ylab = "", cex.main = .9)
} else if (length(x) > 0) {
print(x)
}
})
},
width = qib_plot_width,
height = qib_plot_height,
res = 96
)
.qib_chart <- eventReactive(input$qib_run, {
req(input$qib_type)
if (input$qib_type == "scatter") req(input$qib_nrobs)
## need dependency on ..
req(input$qib_plot_height && input$qib_plot_width)
if (not_available(input$qib_xvar) && !input$qib_type %in% c("box", "line")) {
return(NULL)
}
if (input$qib_type %in% c("scatter", "line", "box", "bar", "surface") && not_available(input$qib_yvar)) {
return(NULL)
}
if (input$qib_type == "box" && !all(input$qib_xvar %in% groupable_vars())) {
return(NULL)
return()
} else if (input$qib_type %in% c("scatter", "line", "box", "bar", "surface") && not_available(input$qib_yvar)) {
return(i18n$t("No Y-variable provided for a plot that requires one"))
} else if (input$qib_type == "box" && !all(input$qib_xvar %in% groupable_vars())) {
return()
}
## 等待 combx / comby 更新
## waiting for comby and/or combx to be updated
if (input$qib_type %in% c("dist", "density")) {
if (isTRUE(input$qib_comby)) return(NULL)
if (length(input$qib_xvar) > 1 && is.null(input$qib_combx)) return(NULL)
if (isTRUE(input$qib_comby)) {
return()
}
if (length(input$qib_xvar) > 1 && is.null(input$qib_combx)) {
return()
}
} else {
if (isTRUE(input$qib_combx)) return(NULL)
if (length(input$qib_yvar) > 1 && is.null(input$qib_comby)) return(NULL)
if (isTRUE(input$qib_combx)) {
return()
}
if (length(input$qib_yvar) > 1 && is.null(input$qib_comby)) {
return()
}
}
#req(!is.null(input$qib_color) || !is.null(input$qib_fill))
qibi <- qib_inputs()
qibi$dataset <- input$dataset
qibi$shiny <- TRUE
qibi$envir <- r_data
qibi$color <- "none"
qibi$fill <- "none"
qibi$dataset <- input$dataset
qibi$shiny <- TRUE
qibi$envir <- r_data
qibi$color <- "none"
qibi$fill <- "none"
qibi$facet_row <- "."
qibi$facet_col <- "."
withProgress(message = i18n$t("Making plot"), value = 1, {
p <- do.call(visualize, qibi)
if (is.character(p)) return(NULL) else p
do.call(visualize, qibi)
})
})
......@@ -852,7 +875,7 @@ observeEvent(input$qgb_store, {
r_data[[dataset]] <- tmp
register(dataset)
updateSelectInput(session, "dataset", selected = input$dataset)
showModal(
modalDialog(
title = i18n$t("Data Stored"),
......@@ -866,6 +889,108 @@ observeEvent(input$qgb_store, {
)
})
# qgb_report <- function() {
# ## get the state of the dt table
# ts <- dt_state("qgb_tab")
# xcmd <- "# summary(result)\ndtab(result"
# if (!is.empty(input$qgb_dec, 3)) {
# xcmd <- paste0(xcmd, ", dec = ", input$qgb_dec)
# }
# if (!is.empty(r_state$qgb_state$length, 10)) {
# xcmd <- paste0(xcmd, ", pageLength = ", r_state$qgb_state$length)
# }
# xcmd <- paste0(xcmd, ", caption = \"\") %>% render()")
# if (!is.empty(input$qgb_name)) {
# dataset <- fix_names(input$qgb_name)
# if (input$qgb_name != dataset) {
# updateTextInput(session, inputId = "qgb_name", value = dataset)
# }
# xcmd <- paste0(xcmd, "\n", dataset, " <- result$tab\nregister(\"", dataset, "\")")
# }
#
# inp_main <- clean_args(qgb_inputs(), qgb_args)
# if (ts$tabsort != "") inp_main <- c(inp_main, tabsort = ts$tabsort)
# if (ts$tabfilt != "") inp_main <- c(inp_main, tabfilt = ts$tabfilt)
# if (is.empty(inp_main$rows)) {
# inp_main$rows <- NULL
# }
# if (is.empty(input$qgb_tab_slice)) {
# inp_main <- c(inp_main, nr = Inf)
# } else {
# inp_main$tabslice <- input$qgb_tab_slice
# }
#
# inp_out <- list(clean_args(qgb_sum_inputs(), qgb_sum_args[-1]))
#
# update_report(
# inp_main = inp_main,
# fun_name = "qgb",
# inp_out = inp_out,
# outputs = c(),
# figs = FALSE,
# xcmd = xcmd
# )
# }
# qib_report <- function() {
# ## resetting hidden elements to default values
# vi <- qib_inputs()
# if (input$qib_type != "dist") {
# vi$bins <- qib_args$bins
# }
# if (input$qib_type %in% c("dist", "density")) {
# vi$yvar <- qib_args$yvar
# }
# if (!input$qib_type %in% c("density", "scatter", "dist") ||
# !("loess" %in% input$qib_check || "density" %in% input$qib_axes || input$qib_type == "density")) {
# vi$smooth <- qib_args$smooth
# }
# if (!input$qib_type %in% c("scatter", "box") && "jitter" %in% input$qib_check) {
# vi$check <- base::setdiff(vi$check, "jitter")
# }
# if (input$qib_type != "scatter") {
# vi$size <- "none"
# vi$nrobs <- NULL
# } else {
# vi$nrobs <- as_integer(vi$nrobs)
# }
# if (!input$qib_type %in% c("scatter", "line", "box")) {
# vi$color <- NULL
# }
# if (!input$qib_type %in% c("bar", "dist", "density", "surface")) {
# vi$fill <- NULL
# }
#
# if (!input$qib_type %in% c("bar", "dist", "box", "density")) {
# vi$fillcol <- "blue"
# }
# if (!input$qib_type %in% c("dist", "density", "box", "scatter", "line")) {
# vi$linecol <- "black"
# }
# if (!input$qib_type %in% c("box", "scatter", "line")) {
# vi$pointcol <- "black"
# }
#
# if (!input$qib_type %in% c("bar", "line", "scatter")) {
# vi$fun <- "mean"
# }
# if (is.empty(input$data_rows)) {
# vi$rows <- NULL
# }
#
# inp_main <- c(clean_args(vi, qib_args), custom = FALSE)
#
# update_report(
# inp_main = inp_main,
# fun_name = "qib_chart",
# outputs = character(0),
# pre_cmd = "",
# figs = TRUE,
# fig.width = qib_plot_width(),
# fig.height = qib_plot_height()
# )
# }
download_handler(
id = "dl_qgb_tab",
fun = dl_qgb_tab,
......@@ -929,7 +1054,7 @@ quickgen_basic_report <- function() {
if (!input$qib_type %in% c("dist", "density", "box", "scatter", "line")) vi$linecol <- "black"
if (!input$qib_type %in% c("box", "scatter", "line")) vi$pointcol <- "black"
if (!input$qib_type %in% c("bar", "line", "scatter")) vi$fun <- "mean"
if (safe_is_empty(input$data_rows)) vi$rows <- NULL
if (is.empty(input$data_rows)) vi$rows <- NULL
inp_main <- c(inp_main, clean_args(vi, qib_args), custom = FALSE)
......@@ -957,6 +1082,35 @@ observeEvent(input$modal_quickgen_basic_screenshot, {
quickgen_basic_report()
removeModal()
})
# observeEvent(input$qgb_report, {
# r_info[["latest_screenshot"]] <- NULL
# qgb_report()
# })
#
# observeEvent(input$qgb_screenshot, {
# r_info[["latest_screenshot"]] <- NULL
# radiant_screenshot_modal("modal_qgb_screenshot")
# })
#
# observeEvent(input$modal_qgb_screenshot, {
# qgb_report()
# removeModal()
# })
#
# observeEvent(input$qib_report, {
# r_info[["latest_screenshot"]] <- NULL
# qib_report()
# })
#
# observeEvent(input$qib_screenshot, {
# r_info[["latest_screenshot"]] <- NULL
# radiant_screenshot_modal("modal_qib_screenshot")
# })
#
# observeEvent(input$modal_qib_screenshot, {
# qib_report()
# removeModal()
# })
# 全选功能
observeEvent(input$qgb_select_all, {
......
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