Commit 078f95fa authored by wuzekai's avatar wuzekai

update

parent 896921db
......@@ -7,6 +7,7 @@ S3method(plot,correlation)
S3method(plot,cross_tabs)
S3method(plot,goodness)
S3method(plot,homo_variance_test)
S3method(plot,mda)
S3method(plot,normality_test)
S3method(plot,prob_binom)
S3method(plot,prob_chisq)
......@@ -27,6 +28,7 @@ S3method(summary,correlation)
S3method(summary,cross_tabs)
S3method(summary,goodness)
S3method(summary,homo_variance_test)
S3method(summary,mda)
S3method(summary,normality_test)
S3method(summary,prob_binom)
S3method(summary,prob_chisq)
......@@ -48,6 +50,7 @@ export(correlation)
export(cross_tabs)
export(goodness)
export(homo_variance_test)
export(mda)
export(normality_test)
export(prob_binom)
export(prob_chisq)
......
############################################
## Multigroup Difference Analysis (ANOVA/Kruskal-Wallis)
############################################
#' @export
mda <- function(dataset,
var,
group,
normality_type = c("overall", "by_group"),
data_filter = "",
envir = parent.frame()) {
# 1. 基础参数处理
normality_type <- match.arg(normality_type, choices = c("overall", "by_group"))
df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset))
# 2. 数据提取:只保留“因变量+分组变量”
dataset <- get_data(
dataset,
vars = c(var, group), # 强制只取2个核心变量,剔除冗余列
filt = data_filter,
na.rm = FALSE, # 先不删缺失值,后续统一过滤
envir = envir
)
# 3. 数据校验
if (!var %in% colnames(dataset)) {
stop(paste("因变量", var, "未在数据集中找到!"), call. = FALSE)
}
if (!group %in% colnames(dataset)) {
stop(paste("分组变量", group, "未在数据集中找到!"), call. = FALSE)
}
if (!is.numeric(dataset[[var]])) {
stop(paste("因变量", var, "必须是数值型(当前类型:", class(dataset[[var]]), ")!"), call. = FALSE)
}
# 4. 有效样本过滤:剔除任一变量缺失的样本
valid_indices <- !is.na(dataset[[var]]) & !is.na(dataset[[group]])
valid_data <- dataset[valid_indices, ] # 仅保留有效样本的2列数据
if (nrow(valid_data) == 0) {
stop("无有效样本(所有样本的因变量/分组变量存在缺失值)!", call. = FALSE)
}
# 5. 分组变量处理:强制转因子+校验水平
valid_data[[group]] <- as.factor(valid_data[[group]]) # 强制转因子,避免字符型干扰
valid_levels <- length(levels(valid_data[[group]])) # 用levels()确保因子水平正确
if (valid_levels < 2) {
stop(paste("分组变量有效水平不足2个(当前水平数:", valid_levels, "),无法执行检验!"), call. = FALSE)
}
# 6. 检验计算:调用辅助函数
homo_res <- run_homo_test(valid_data, var, group) # 方差齐性检验
norm_res <- run_norm_test(valid_data, var, group, normality_type) # 正态性检验
# 7. 绘图数据准备
plot_obj <- list(
norm = list(
data = valid_data[[var]],
group_data = if (normality_type == "by_group") {
# 把命名向量转为无命名列表,避免asJSON警告
lapply(split(valid_data[[var]], valid_data[[group]]), function(x) x)
} else NULL,
var = var,
group = group,
type = normality_type
),
homo = list(
data = valid_data,
var = var,
group = group
)
)
# 8. 结果打包:对齐单独检验的输出结构
out <- structure(
list(
df_name = df_name,
var = var,
group = group,
normality_type = normality_type,
data_filter = if (data_filter == "") "None" else data_filter,
valid_n = nrow(valid_data), # 有效样本量
homo_res = homo_res, # 方差齐性检验结果
norm_res = norm_res, # 正态性检验结果
plot_obj = plot_obj
),
class = "mda"
)
out
}
# ------------------------------
# 辅助函数1:方差齐性检验
# ------------------------------
run_homo_test <- function(valid_data, var, group) {
x <- valid_data[[var]]
g <- valid_data[[group]]
res <- tibble::tibble(Test = character(), Statistic = numeric(), p.value = numeric())
# 1. Levene检验
if (requireNamespace("car", quietly = TRUE)) {
tmp <- tryCatch(
expr = car::leveneTest(x ~ g),
error = function(e) {
message(paste("Levene检验执行失败:", e$message))
return(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]))
}
} else {
res <- tibble::add_row(res,
Test = "Levene",
Statistic = NA_real_,
p.value = NA_real_)
message("提示:需安装car包以运行Levene检验")
}
# 2. Bartlett检验
tmp <- tryCatch(
expr = stats::bartlett.test(x, g),
error = function(e) {
message(paste("Bartlett检验执行失败:", e$message))
return(NULL)
}
)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Test = "Bartlett",
Statistic = as.numeric(tmp$statistic),
p.value = as.numeric(tmp$p.value))
} else {
res <- tibble::add_row(res,
Test = "Bartlett",
Statistic = NA_real_,
p.value = NA_real_)
}
# 3. Fligner检验
tmp <- tryCatch(
expr = stats::fligner.test(x, g),
error = function(e) {
message(paste("Fligner检验执行失败:", e$message))
return(NULL)
}
)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Test = "Fligner",
Statistic = as.numeric(tmp$statistic),
p.value = as.numeric(tmp$p.value))
} else {
res <- tibble::add_row(res,
Test = "Fligner",
Statistic = NA_real_,
p.value = NA_real_)
}
res
}
# ------------------------------
# 辅助函数2:正态性检验
# ------------------------------
run_norm_test <- function(valid_data, var, group, normality_type) {
x <- valid_data[[var]]
g <- valid_data[[group]]
res <- tibble::tibble(Group = character(), Test = character(), Statistic = numeric(), p.value = numeric())
# 1. 整体正态性检验
if (normality_type == "overall") {
res <- dplyr::bind_rows(res, get_single_norm(x, group_label = "Overall"))
}
# 2. 按分组正态性检验
if (normality_type == "by_group") {
for (level in levels(g)) {
group_x <- x[g == level]
res <- dplyr::bind_rows(res, get_single_norm(group_x, group_label = level))
}
}
res
}
# ------------------------------
# 辅助函数3:单组正态性检验
# ------------------------------
get_single_norm <- function(x, group_label) {
res <- tibble::tibble(Group = group_label, Test = character(), Statistic = numeric(), p.value = numeric())
n <- length(x)
# 1. Shapiro-Wilk检验
if (n >= 3 && n <= 5000) {
tmp <- tryCatch(
expr = stats::shapiro.test(x),
error = function(e) {
message(paste("Shapiro-Wilk检验(", group_label, ")失败:", e$message, sep = ""))
return(NULL)
}
)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Group = group_label,
Test = "Shapiro-Wilk",
Statistic = tmp$statistic,
p.value = tmp$p.value)
}
} else {
res <- tibble::add_row(res,
Group = group_label,
Test = "Shapiro-Wilk",
Statistic = NA_real_,
p.value = NA_real_)
message(paste("Shapiro-Wilk检验(", group_label, ")跳过:样本量需3-5000(当前n=", n, ")", sep = ""))
}
# 2. Lilliefors-KS检验
if (requireNamespace("nortest", quietly = TRUE)) {
tmp <- tryCatch(
expr = nortest::lillie.test(x),
error = function(e) {
message(paste("Lilliefors-KS检验(", group_label, ")失败:", e$message, sep = ""))
return(NULL)
}
)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Group = group_label,
Test = "Lilliefors-KS",
Statistic = tmp$statistic,
p.value = tmp$p.value)
} else {
res <- tibble::add_row(res,
Group = group_label,
Test = "Lilliefors-KS",
Statistic = NA_real_,
p.value = NA_real_)
}
} else {
res <- tibble::add_row(res,
Group = group_label,
Test = "Lilliefors-KS",
Statistic = NA_real_,
p.value = NA_real_)
message("提示:需安装nortest包以运行KS/AD检验")
}
# 3. Anderson-Darling检验
if (requireNamespace("nortest", quietly = TRUE)) {
tmp <- tryCatch(
expr = nortest::ad.test(x),
error = function(e) {
message(paste("Anderson-Darling检验(", group_label, ")失败:", e$message, sep = ""))
return(NULL)
}
)
if (!is.null(tmp)) {
res <- tibble::add_row(res,
Group = group_label,
Test = "Anderson-Darling",
Statistic = tmp$statistic,
p.value = tmp$p.value)
} else {
res <- tibble::add_row(res,
Group = group_label,
Test = "Anderson-Darling",
Statistic = NA_real_,
p.value = NA_real_)
}
} else {
res <- tibble::add_row(res,
Group = group_label,
Test = "Anderson-Darling",
Statistic = NA_real_,
p.value = NA_real_)
}
res
}
# ------------------------------
# Summary方法
# ------------------------------
#' @export
summary.mda <- function(object, dec = 3, ...) {
# 1. 基础信息
cat("Multigroup Difference Analysis (ANOVA/KW)\n")
cat("Data :", object$df_name, "\n")
cat("Dependent var:", object$var, "(numeric)\n")
cat("Group var :", object$group, "(factor,", length(levels(object$plot_obj$homo$data[[object$group]])), "levels)\n")
cat("Normality test:", object$normality_type, "\n")
cat("Valid samples:", object$valid_n, "\n\n")
# 2. 正态性检验结果
cat("=== 1. Normality Test Results ===\n")
if (nrow(object$norm_res) == 0) {
cat(" No valid normality test results.\n\n")
} else {
norm_formatted <- object$norm_res %>%
dplyr::mutate(
Statistic = as.character(round(Statistic, dec)), # 转为字符型,统一类型
p.value = dplyr::case_when(
is.na(p.value) ~ "",
p.value < 0.001 ~ "<0.001",
p.value < 0.01 ~ as.character(round(p.value, 3)), # 数值转字符
TRUE ~ as.character(round(p.value, 4)) # 数值转字符
)
) %>%
as.data.frame(stringsAsFactors = FALSE)
print(norm_formatted, row.names = FALSE, right = FALSE)
cat("\n")
}
# 3. 方差齐性检验结果
cat("=== 2. Homogeneity of Variance Results ===\n")
if (nrow(object$homo_res) == 0) {
cat(" No valid homogeneity test results.\n\n")
} else {
homo_formatted <- object$homo_res %>%
dplyr::mutate(
Statistic = as.character(round(Statistic, dec)), # 转为字符型,统一类型
p.value = dplyr::case_when(
is.na(p.value) ~ "",
p.value < 0.001 ~ "<0.001",
p.value < 0.01 ~ as.character(round(p.value, 3)), # 数值转字符
TRUE ~ as.character(round(p.value, 4)) # 数值转字符
)
) %>%
as.data.frame(stringsAsFactors = FALSE)
print(homo_formatted, row.names = FALSE, right = FALSE)
cat("\n")
}
# 4. 结论提示
cat("=== 3. Interpretation Tips ===\n")
cat("• 正态性:p ≥ 0.05 → 满足正态性假设\n")
cat("• 方差齐性:p ≥ 0.05 → 满足方差齐性假设\n")
cat("• 若同时满足这两个假设 → 使用方差分析(ANOVA)\n")
cat("• 若任一假设不满足 → 使用Kruskal-Wallis检验\n")
invisible(object)
}
# ------------------------------
# Plot方法
# ------------------------------
#' @export
plot.mda <- function(x,
plots = c("norm_qq", "norm_hist", "homo_box"),
shiny = FALSE, custom = FALSE, ...) {
# 1. 基础校验
if (length(plots) == 0) {
return(ggplot2::ggplot() +
ggplot2::annotate("text", x = 1, y = 1, label = i18n$t("No plots selected")) +
ggplot2::theme_void())
}
plot_list <- list()
var_name <- x$var
group_name <- x$group
# 2. 正态性检验图表
# 2.1 Q-Q图
if ("norm_qq" %in% plots) {
if (x$normality_type == "overall") {
p <- ggplot2::ggplot(data.frame(y = x$plot_obj$norm$data), ggplot2::aes(sample = y)) +
ggplot2::stat_qq(color = "#2E86AB", size = 1) +
ggplot2::stat_qq_line(color = "#A23B72", linetype = "dashed") +
ggplot2::labs(x = "Theoretical Quantiles",
y = paste("Empirical Quantiles (", var_name, ")", sep = ""),
title = "Normality: Q-Q Plot (Overall)") +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12))
plot_list[["norm_qq"]] <- p
} else {
# 按分组画QQ图
group_data <- x$plot_obj$norm$group_data
for (level in names(group_data)) {
p <- ggplot2::ggplot(data.frame(y = group_data[[level]]), ggplot2::aes(sample = y)) +
ggplot2::stat_qq(color = "#2E86AB", size = 1) +
ggplot2::stat_qq_line(color = "#A23B72", linetype = "dashed") +
ggplot2::labs(x = "Theoretical Quantiles",
y = paste("Empirical Quantiles (", var_name, ")", sep = ""),
title = paste("Normality: Q-Q Plot (", level, ")", sep = "")) +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12))
plot_list[[paste("norm_qq_", level, sep = "")]] <- p
}
}
}
# 2.2 直方图
if ("norm_hist" %in% plots) {
if (x$normality_type == "overall") {
p <- ggplot2::ggplot(data.frame(y = x$plot_obj$norm$data), ggplot2::aes(x = y)) +
ggplot2::geom_histogram(fill = "#F18F01", alpha = 0.7, bins = 30) +
ggplot2::labs(x = var_name, y = "Count",
title = "Normality: Histogram (Overall)") +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12))
plot_list[["norm_hist"]] <- p
} else {
# 按分组画直方图
group_data <- x$plot_obj$norm$group_data
for (level in names(group_data)) {
p <- ggplot2::ggplot(data.frame(y = group_data[[level]]), ggplot2::aes(x = y)) +
ggplot2::geom_histogram(fill = "#F18F01", alpha = 0.7, bins = 30) +
ggplot2::labs(x = var_name, y = "Count",
title = paste("Normality: Histogram (", level, ")", sep = "")) +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12))
plot_list[[paste("norm_hist_", level, sep = "")]] <- p
}
}
}
# 3. 方差齐性检验图表
if ("homo_box" %in% plots) {
p <- ggplot2::ggplot(x$plot_obj$homo$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::scale_fill_brewer(palette = "Set2") +
ggplot2::labs(x = group_name, y = var_name,
title = "Homogeneity: Boxplot by Group") +
ggplot2::theme_minimal() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 12))
plot_list[["homo_box"]] <- p
}
# 4. 组合图表
combined_plot <- patchwork::wrap_plots(plot_list, ncol = 1, guides = "collect")
# 5. 输出
if (shiny) {
print(combined_plot)
return(invisible(combined_plot))
} else {
return(combined_plot)
}
}
......@@ -4,6 +4,8 @@ r_url_list[["Single mean"]] <-
list("tabs_single_mean" = list("Summary" = "basics/single-mean/", "Plot" = "basics/single-mean/plot/"))
r_url_list[["Compare means(t-test/Wilcoxon rank-sum test)"]] <-
list("tabs_compare_means" = list("Summary" = "basics/compare-means/", "Plot" = "basics/compare-means/plot/"))
r_url_list[["Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"]] <-
list("tabs_mda" = list("Summary" = "basics/mda/", "Plot" = "basics/mda/plot/"))
r_url_list[["Single proportion"]] <-
list("tabs_single_prop" = list("Summary" = "basics/single-prop/", "Plot" = "basics/single-prop/plot/"))
r_url_list[["Compare proportions"]] <-
......@@ -35,8 +37,9 @@ options(
"----", i18n$t("Means"),
tabPanel(i18n$t("Single mean"), uiOutput("single_mean")),
tabPanel(i18n$t("Compare means(t-test/Wilcoxon rank-sum test)"), uiOutput("compare_means")),
tabPanel(i18n$t("Normality test"),uiOutput("normality_test")),
tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")),
#tabPanel(i18n$t("Normality test"),uiOutput("normality_test")),
#tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")),
tabPanel(i18n$t("Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"),uiOutput("mda")),
"----", i18n$t("Proportions"),
tabPanel(i18n$t("Single proportion"), uiOutput("single_prop")),
tabPanel(i18n$t("Compare proportions"), uiOutput("compare_props")),
......
############################################
## Multigroup Difference Analysis (ANOVA/KW) - UI
## 对齐单独检验的UI设计:简洁+严格校验+统一风格
############################################
## 1. 翻译标签(对齐单独检验的i18n逻辑,保持术语一致)
mda_norm_type <- c("overall", "by_group")
names(mda_norm_type) <- c(i18n$t("Overall (Whole variable)"),
i18n$t("By Group (Each level separately)"))
mda_plots <- c("norm_qq", "norm_hist", "homo_box")
names(mda_plots) <- c(i18n$t("Normality: Q-Q Plot"),
i18n$t("Normality: Histogram"),
i18n$t("Homogeneity: Boxplot by Group"))
## 2. 函数形参
mda_args <- as.list(formals(mda))
mda_args <- mda_args[names(mda_args) %in% c("dataset", "var", "group", "normality_type", "data_filter")]
## 3. 输入收集
mda_inputs <- reactive({
req(input$dataset)
# 基础参数
inputs <- list(
dataset = input$dataset,
var = input$mda_var,
group = input$mda_group,
normality_type = input$mda_normality_type,
data_filter = if (input$show_filter) input$data_filter else "None",
envir = r_data
)
# 校验参数完整性
for (arg in names(mda_args)) {
if (is.null(inputs[[arg]])) inputs[[arg]] <- mda_args[[arg]]
}
inputs
})
## 4. 因变量选择
output$ui_mda_var <- renderUI({
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
is_num <- sapply(current_data, function(col) is.numeric(col) || is.ts(col))
num_vars <- names(is_num)[is_num]
if (length(num_vars) == 0) {
return(div(class = "alert alert-warning", i18n$t("No numeric variables in dataset. Please select another dataset.")))
}
# 提取变量类型并组合标签
var_types <- sapply(current_data[, num_vars, drop = FALSE], function(col) class(col)[1])
choices <- setNames(nm = paste0(num_vars, " {", var_types, "}"), object = num_vars)
selectInput(
inputId = "mda_var",
label = i18n$t("Dependent variable:"),
choices = c("None" = "", choices),
selected = state_single("mda_var", num_vars),
multiple = FALSE
)
})
## 5. 分组变量选择
output$ui_mda_group <- renderUI({
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
is_group <- sapply(current_data, function(col) is.factor(col) || is.character(col))
group_candidates <- names(is_group)[is_group]
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).")))
}
#提取变量类型并组合标签
group_types <- sapply(current_data[, valid_groups, drop = FALSE], function(col) class(col)[1])
choices <- setNames(nm = paste0(valid_groups, " {", group_types, "}"), object = valid_groups)
selectInput(
inputId = "mda_group",
label = i18n$t("Grouping variable:"),
choices = choices,
selected = state_single("mda_group", valid_groups),
multiple = FALSE
)
})
## 6. 正态性检验类型选择
output$ui_mda_normality_type <- renderUI({
selectInput(
inputId = "mda_normality_type",
label = i18n$t("Normality test:"),
choices = mda_norm_type,
selected = state_single("mda_normality_type", mda_norm_type, "overall"),
multiple = FALSE
)
})
## 7. 主UI
output$ui_mda <- renderUI({
req(input$dataset)
tagList(
wellPanel(
# Summary标签页
conditionalPanel(
condition = "input.tabs_mda == 'Summary'",
uiOutput("ui_mda_var"),
uiOutput("ui_mda_group"),
uiOutput("ui_mda_normality_type")
),
# Plot标签页
conditionalPanel(
condition = "input.tabs_mda == 'Plot'",
selectizeInput(
inputId = "mda_plots",
label = i18n$t("Select plots:"),
choices = mda_plots,
selected = state_multiple("mda_plots", mda_plots, "norm_qq"), # 默认选QQ图
multiple = TRUE,
options = list(
placeholder = i18n$t("Select plot types"),
plugins = list("remove_button", "drag_drop")
)
)
)
),
# 帮助与报告
help_and_report(
modal_title = i18n$t("Multigroup Difference Analysis (ANOVA/KW)"),
fun_name = "mda",
help_file = inclMD(file.path(getOption("radiant.path.basics"),
"app/tools/help/mda.md"))
)
)
})
## 8. 图表尺寸
mda_plot_dims <- reactive({
req(.mda())
plot_count <- length(input$mda_plots)
group_count <- if (.mda()$normality_type == "by_group") {
length(levels(.mda()$plot_obj$homo$data[[.mda()$group]]))
} else {
1
}
base_subplot_height_px <- 350
total_height_px <- base_subplot_height_px * plot_count * group_count
total_height_px <- min(total_height_px, 2000)
total_height_px <- max(total_height_px, 400)
list(
width = 700,
height = total_height_px
)
})
mda_plot_width <- function() mda_plot_dims()$width
mda_plot_height <- function() mda_plot_dims()$height
## 9. 输出面板
output$mda <- renderUI({
# 注册输出
register_print_output("summary_mda", ".summary_mda")
register_plot_output("plot_mda", ".plot_mda",
height_fun = "mda_plot_height")
# 标签页
mda_panels <- tabsetPanel(
id = "tabs_mda",
tabPanel(
title = i18n$t("Summary"),
value = "Summary",
verbatimTextOutput("summary_mda", placeholder = TRUE)
),
tabPanel(
title = i18n$t("Plot"),
value = "Plot",
download_link("dlp_mda"), # 下载按钮
plotOutput("plot_mda", height = "100%"),
style = "margin-top: 10px;"
)
)
# 整合到Radiant标准面板
stat_tab_panel(
menu = i18n$t("Basics > Means"),
tool = i18n$t("Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"),
tool_ui = "ui_mda",
output_panels = mda_panels
)
})
## 10. 可用性检验
mda_available <- reactive({
req(input$dataset)
current_data <- get_data(input$dataset, envir = r_data)
# 1. 校验因变量
if (not_available(input$mda_var) || !input$mda_var %in% colnames(current_data)) {
return(i18n$t("Please select a valid numeric dependent variable."))
}
# 2. 校验分组变量
if (not_available(input$mda_group) || !input$mda_group %in% colnames(current_data)) {
return(i18n$t("Please select a valid grouping variable."))
}
# 3. 校验分组变量水平
group_vals <- current_data[[input$mda_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."))
}
# 4. 校验有效样本
valid_n <- sum(!is.na(current_data[[input$mda_var]]) & !is.na(current_data[[input$mda_group]]))
if (valid_n < 5) { # 最小样本量校验
return(i18n$t(paste("Valid samples are too few (n=", valid_n, "). Need at least 5.", sep = "")))
}
"available" # 所有校验通过
})
## 11. 计算核心
.mda <- reactive({
req(mda_available() == "available")
do.call(mda, mda_inputs())
})
.summary_mda <- reactive({
req(mda_available() == "available")
summary(.mda())
})
.plot_mda <- reactive({
req(mda_available() == "available")
validate(need(input$mda_plots, i18n$t("Please select at least one plot type first.")))
# 进度提示
withProgress(message = i18n$t("Generating plots..."), value = 0.5, {
p <- plot(.mda(), plots = input$mda_plots, shiny = TRUE)
setProgress(value = 1)
})
p
})
## 12. 下载与截图
# 图表下载
download_handler(
id = "dlp_mda",
fun = function(file) {
# 1. 校验图表对象
plot_obj <- .plot_mda()
width_in <- mda_plot_width() / 96
height_in <- mda_plot_height() / 96
ggsave(
filename = file,
plot = plot_obj,
width = width_in,
height = height_in,
device = "png",
dpi = 300,
limitsize = FALSE,
bg = "white"
)
},
fn = function() paste0(input$dataset, "_mda_plots"),
type = "png",
caption = i18n$t("Save plots")
)
# 报告生成
mda_report <- function() {
req(mda_available() == "available")
figs <- length(input$mda_plots) > 0
# 报告结构
update_report(
inp_main = clean_args(mda_inputs(), mda_args),
fun_name = "mda",
inp_out = if (figs) list("", list(plots = input$mda_plots)) else list(""),
outputs = if (figs) c("summary", "plot") else "summary",
figs = figs,
fig.width = mda_plot_width(),
fig.height = mda_plot_height()
)
}
# 截图功能
observeEvent(input$mda_report, {
r_info[["latest_screenshot"]] <- NULL
mda_report()
})
observeEvent(input$mda_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_mda_screenshot")
})
observeEvent(input$modal_mda_screenshot, {
mda_report()
removeModal()
})
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