From f926635bc641f37c3b36603a0e5f2427caab7a12 Mon Sep 17 00:00:00 2001 From: wuzekai <3025054974@qq.com> Date: Fri, 10 Oct 2025 13:06:50 +0800 Subject: [PATCH] update --- README.md | 4 - notice.txt | 28 ++ .../inst/translations/translation_zh.csv | 7 +- radiant.basics/DESCRIPTION | 82 +++--- radiant.basics/R/homo_variance_test.R | 246 ++++++++++++++---- radiant.basics/R/normality_test.R | 113 ++++++-- .../tools/analysis/homo_variance_test_ui.R | 129 +++++---- .../app/tools/analysis/normality_test_ui.R | 27 +- radiant.data/DESCRIPTION | 139 +++++----- radiant.data/inst/app/global.R | 3 +- radiant.data/inst/app/tools/app/stop.R | 111 ++++---- .../inst/app/tools/data/visualize_ui.R | 164 +++++++++--- radiant.model/R/cox.R | 89 ++++++- .../inst/app/tools/analysis/cox_ui.R | 131 ++++++++-- radiant.quickgen/R/quickgen_ai.R | 2 +- .../app/tools/analysis/quickgen_basic_ui.R | 228 +++++++++++++--- 16 files changed, 1090 insertions(+), 413 deletions(-) delete mode 100644 README.md create mode 100644 notice.txt diff --git a/README.md b/README.md deleted file mode 100644 index 87c0f33..0000000 --- a/README.md +++ /dev/null @@ -1,4 +0,0 @@ -# radiant - -科研统计分析工具 -Statistical Analysis System \ No newline at end of file diff --git a/notice.txt b/notice.txt new file mode 100644 index 0000000..120df68 --- /dev/null +++ b/notice.txt @@ -0,0 +1,28 @@ +上传模块 +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 \ No newline at end of file diff --git a/radiant-master/inst/translations/translation_zh.csv b/radiant-master/inst/translations/translation_zh.csv index f487706..cc4d151 100644 --- a/radiant-master/inst/translations/translation_zh.csv +++ b/radiant-master/inst/translations/translation_zh.csv @@ -1159,9 +1159,9 @@ Edit the generated R code here...,在此处编辑生成的R代码...,quickgen_ai Normality test,正态性检验,init.R Homogeneity of variance test,方差齐性检验,init.R Basics > Normality,基础统计 > 正态性,normality_test_ui.R -Shapiro-Wilk,SW 检验,normality_test_ui.R -Kolmogorov-Smirnov,K-S 检验,normality_test_ui.R -Anderson-Darling,AD 检验,normality_test_ui.R +Shapiro-Wilk,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 diff --git a/radiant.basics/DESCRIPTION b/radiant.basics/DESCRIPTION index 2745654..c1cd2c8 100644 --- a/radiant.basics/DESCRIPTION +++ b/radiant.basics/DESCRIPTION @@ -1,40 +1,42 @@ -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 diff --git a/radiant.basics/R/homo_variance_test.R b/radiant.basics/R/homo_variance_test.R index 30a8aa7..bfc6865 100644 --- a/radiant.basics/R/homo_variance_test.R +++ b/radiant.basics/R/homo_variance_test.R @@ -1,86 +1,224 @@ ############################################ -## 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 + } +} diff --git a/radiant.basics/R/normality_test.R b/radiant.basics/R/normality_test.R index be9e11f..855bf7b 100644 --- a/radiant.basics/R/normality_test.R +++ b/radiant.basics/R/normality_test.R @@ -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)]] <- diff --git a/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R b/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R index 7a400fd..478eeee 100644 --- a/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R +++ b/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R @@ -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 diff --git a/radiant.basics/inst/app/tools/analysis/normality_test_ui.R b/radiant.basics/inst/app/tools/analysis/normality_test_ui.R index b22ad9a..966c520 100644 --- a/radiant.basics/inst/app/tools/analysis/normality_test_ui.R +++ b/radiant.basics/inst/app/tools/analysis/normality_test_ui.R @@ -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()) }) diff --git a/radiant.data/DESCRIPTION b/radiant.data/DESCRIPTION index 8bd5df2..4f411dd 100644 --- a/radiant.data/DESCRIPTION +++ b/radiant.data/DESCRIPTION @@ -1,69 +1,70 @@ -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 diff --git a/radiant.data/inst/app/global.R b/radiant.data/inst/app/global.R index 20c01a1..fbff0d4 100644 --- a/radiant.data/inst/app/global.R +++ b/radiant.data/inst/app/global.R @@ -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( diff --git a/radiant.data/inst/app/tools/app/stop.R b/radiant.data/inst/app/tools/app/stop.R index 7776712..011e27f 100644 --- a/radiant.data/inst/app/tools/app/stop.R +++ b/radiant.data/inst/app/tools/app/stop.R @@ -1,49 +1,62 @@ -####################################### -# 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") + } +} diff --git a/radiant.data/inst/app/tools/data/visualize_ui.R b/radiant.data/inst/app/tools/data/visualize_ui.R index 522ead8..f593bd8 100644 --- a/radiant.data/inst/app/tools/data/visualize_ui.R +++ b/radiant.data/inst/app/tools/data/visualize_ui.R @@ -1,15 +1,11 @@ -############################################# -# 安全封装:避免 is.empty() 报错 -############################################# -safe_is_empty <- function(x) { - if (is.null(x) || !is.character(x)) return(TRUE) - is.empty(x) +is.empty <- function(x, empty = "\\s*") { + if (is.null(x)) return(TRUE) + if (is.atomic(x) && length(x) == 0) return(TRUE) + if (!is.character(x)) return(FALSE) + is_not(x) || + (length(x) == 1 && any(grepl(paste0("^", empty, "$"), x))) } -############################################# -# 其余代码保持不变,仅替换 is.empty() 调用 -############################################# - viz_type <- c( "分布图(dist)" = "dist", "密度图(density)" = "density", "散点图(scatter)" = "scatter", "曲面图(surface)" = "surface", "折线图(line)" = "line", "条形图(bar)" = "bar", "箱线图(box)" = "box" @@ -46,14 +42,17 @@ viz_add_labs <- function() { lab_list <- list() for (l in viz_labs) { inp <- input[[paste0("viz_labs_", l)]] - if (!safe_is_empty(inp)) lab_list[[l]] <- inp + if (!is.empty(inp)) lab_list[[l]] <- inp } lab_list } +## list of function arguments viz_args <- as.list(formals(visualize)) +## list of function inputs selected by user viz_inputs <- reactive({ + ## loop needed because reactive values don't allow single bracket indexing viz_args$data_filter <- if (isTRUE(input$show_filter)) input$data_filter else "" viz_args$arr <- if (isTRUE(input$show_filter)) input$data_arrange else "" viz_args$rows <- if (isTRUE(input$show_filter)) input$data_rows else "" @@ -63,9 +62,16 @@ viz_inputs <- reactive({ for (i in r_drop(names(viz_args), drop = c(i18n$t("dataset"), i18n$t("data_filter"), i18n$t("arr"), i18n$t("rows"), i18n$t("labs")))) { viz_args[[i]] <- input[[paste0("viz_", i)]] } + # isolate({ + # # cat(paste0(names(viz_args), " ", viz_args, collapse = ", "), file = stderr(), "\n") + # cat(paste0(names(viz_args), " = ", viz_args, collapse = ", "), "\n") + # }) viz_args }) +####################################### +# Visualize data +####################################### output$ui_viz_type <- renderUI({ selectInput( inputId = "viz_type", label = i18n$t("Plot-type:"), choices = viz_type, @@ -86,6 +92,7 @@ output$ui_viz_nrobs <- renderUI({ ) }) +## Y - variable output$ui_viz_yvar <- renderUI({ req(input$viz_type) vars <- varying_vars() @@ -95,8 +102,10 @@ output$ui_viz_yvar <- renderUI({ vars <- vars["character" != .get_class()[vars]] } if (input$viz_type %in% c("box", "scatter")) { + ## allow factors in yvars for bar plots vars <- vars["factor" != .get_class()[vars]] } + selectInput( inputId = "viz_yvar", label = i18n$t("Y-variable:"), choices = vars, @@ -105,6 +114,8 @@ output$ui_viz_yvar <- renderUI({ ) }) + +## X - variable output$ui_viz_xvar <- renderUI({ req(input$viz_type) vars <- varying_vars() @@ -112,6 +123,7 @@ output$ui_viz_xvar <- renderUI({ if (input$viz_type == "dist") vars <- vars["date" != .get_class()[vars]] if (input$viz_type == "density") vars <- vars["factor" != .get_class()[vars]] if (input$viz_type %in% c("box", "bar")) vars <- groupable_vars_nonum() + selectInput( inputId = "viz_xvar", label = i18n$t("X-variable:"), choices = vars, selected = state_multiple("viz_xvar", vars, isolate(input$viz_xvar)), @@ -180,6 +192,7 @@ output$ui_viz_color <- renderUI({ } else { vars <- c("None" = "none", varnames()) } + if (isTRUE(input$viz_comby) && length(input$viz_yvar) > 1) vars <- c("None" = "none") selectizeInput( "viz_color", i18n$t("Color:"), vars, @@ -223,6 +236,7 @@ output$ui_viz_axes <- renderUI({ ind <- c(1, 3) } if (input$viz_facet_row != "." || input$viz_facet_col != ".") ind <- c(ind, 4) + # if (input$viz_type == "bar" && input$viz_facet_row == "." && input$viz_facet_col == ".") ind <- c(ind, 6) if (input$viz_type == "bar") ind <- c(ind, 6) checkboxGroupInput( @@ -243,6 +257,7 @@ output$ui_viz_check <- renderUI({ } else { ind <- c() } + if (!input$viz_type %in% c("scatter", "box")) { r_state$viz_check <<- gsub("jitter", "", r_state$viz_check) } @@ -250,6 +265,7 @@ output$ui_viz_check <- renderUI({ r_state$viz_check <<- gsub("line", "", r_state$viz_check) r_state$viz_check <<- gsub("loess", "", r_state$viz_check) } + checkboxGroupInput( "viz_check", NULL, viz_check[ind], selected = state_group("viz_check", ""), @@ -258,11 +274,15 @@ output$ui_viz_check <- renderUI({ }) output$ui_viz_run <- renderUI({ + ## updates when dataset changes req(input$dataset) actionButton("viz_run", i18n$t("Create plot"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") + ## this didn't seem to work quite like the observe below + ## https://stackoverflow.com/questions/43641103/change-color-actionbutton-shiny-r }) output$ui_viz_labs <- renderUI({ + ## updates when dataset changes req(input$dataset) wellPanel( textAreaInput("viz_labs_title", NULL, "", placeholder = i18n$t("Title"), rows = 1), @@ -276,7 +296,10 @@ output$ui_viz_labs <- renderUI({ output$ui_viz_colors <- renderUI({ tagList( conditionalPanel( - condition = "input.viz_type == 'bar' || input.viz_type == 'dist' || input.viz_type == 'box' || input.viz_type == 'density'", + condition = "input.viz_type == 'bar' || + input.viz_type == 'dist' || + input.viz_type == 'box' || + input.viz_type == 'density'", selectInput( "viz_fillcol", i18n$t("Fill color:"), choices = colors(), @@ -284,7 +307,11 @@ output$ui_viz_colors <- renderUI({ ) ), conditionalPanel( - condition = "input.viz_type == 'dist' || input.viz_type == 'density' || input.viz_type == 'box' || input.viz_type == 'scatter' || input.viz_type == 'line'", + condition = "input.viz_type == 'dist' || + input.viz_type == 'density' || + input.viz_type == 'box' || + input.viz_type == 'scatter' || + input.viz_type == 'line'", selectInput( "viz_linecol", i18n$t("Line color:"), choices = colors(), @@ -292,7 +319,9 @@ output$ui_viz_colors <- renderUI({ ) ), conditionalPanel( - condition = "input.viz_type == 'scatter' || input.viz_type == 'line' || input.viz_type == 'box'", + condition = "input.viz_type == 'scatter' || + input.viz_type == 'line' || + input.viz_type == 'box'", selectInput( "viz_pointcol", i18n$t("Point color:"), choices = colors(), @@ -302,6 +331,7 @@ output$ui_viz_colors <- renderUI({ ) }) +## add a spinning refresh icon if the graph needs to be (re)recreated run_refresh( viz_args, "viz", init = c("xvar", "yvar"), label = i18n$t("Create plot"), relabel = i18n$t("Update plot"), @@ -341,11 +371,16 @@ output$ui_Visualize <- renderUI({ uiOutput("ui_viz_facet_row"), uiOutput("ui_viz_facet_col"), conditionalPanel( - condition = "input.viz_type == 'bar' || input.viz_type == 'dist' || input.viz_type == 'density' || input.viz_type == 'surface'", + condition = "input.viz_type == 'bar' || + input.viz_type == 'dist' || + input.viz_type == 'density' || + input.viz_type == 'surface'", uiOutput("ui_viz_fill") ), conditionalPanel( - condition = "input.viz_type == 'scatter' || input.viz_type == 'line' || input.viz_type == 'box'", + condition = "input.viz_type == 'scatter' || + input.viz_type == 'line' || + input.viz_type == 'box'", uiOutput("ui_viz_color") ), conditionalPanel( @@ -353,7 +388,9 @@ output$ui_Visualize <- renderUI({ uiOutput("ui_viz_size") ), conditionalPanel( - condition = "input.viz_type == 'bar' || input.viz_type == 'scatter' || input.viz_type == 'line'", + condition = "input.viz_type == 'bar' || + input.viz_type == 'scatter' || + input.viz_type == 'line'", selectInput( "viz_fun", i18n$t("Function:"), choices = getOption("radiant.functions"), @@ -361,7 +398,10 @@ output$ui_Visualize <- renderUI({ ) ), conditionalPanel( - condition = "input.viz_type == 'scatter' || input.viz_type == 'line' || input.viz_type == 'surface' || input.viz_type == 'box'", + condition = "input.viz_type == 'scatter' || + input.viz_type == 'line' || + input.viz_type == 'surface' || + input.viz_type == 'box'", uiOutput("ui_viz_check") ), uiOutput("ui_viz_axes"), @@ -375,7 +415,9 @@ output$ui_Visualize <- renderUI({ ) ), conditionalPanel( - "input.viz_type == 'density' || input.viz_type == 'dist' && (input.viz_axes && input.viz_axes.indexOf('density')) >= 0 || (input.viz_type == 'scatter' && (input.viz_check && input.viz_check.indexOf('loess') >= 0))", + "input.viz_type == 'density' || + input.viz_type == 'dist' && (input.viz_axes && input.viz_axes.indexOf('density')) >= 0 || + (input.viz_type == 'scatter' && (input.viz_check && input.viz_check.indexOf('loess') >= 0))", sliderInput( "viz_smooth", label = i18n$t("Smooth:"), @@ -448,9 +490,10 @@ output$ui_Visualize <- renderUI({ }) viz_plot_width <- reactive({ - if (safe_is_empty(input$viz_plot_width)) r_info[["plot_width"]] else input$viz_plot_width + if (is.empty(input$viz_plot_width)) r_info[["plot_width"]] else input$viz_plot_width }) +## based on https://stackoverflow.com/a/40182833/1974918 viz_plot_height <- eventReactive( { input$viz_run @@ -458,11 +501,12 @@ viz_plot_height <- eventReactive( input$viz_plot_width }, { - if (safe_is_empty(input$viz_plot_height)) { + if (is.empty(input$viz_plot_height)) { r_info[["plot_height"]] } else { lx <- ifelse(not_available(input$viz_xvar) || isTRUE(input$viz_combx), 1, length(input$viz_xvar)) - ly <- ifelse(not_available(input$viz_yvar) || input$viz_type %in% c("dist", "density") || isTRUE(input$viz_comby), 1, length(input$viz_yvar)) + ly <- ifelse(not_available(input$viz_yvar) || input$viz_type %in% c("dist", "density") || + isTRUE(input$viz_comby), 1, length(input$viz_yvar)) nr <- lx * ly if (nr > 1) { (input$viz_plot_height / 2) * ceiling(nr / 2) @@ -473,38 +517,78 @@ viz_plot_height <- eventReactive( } ) -output$visualize <- renderPlot({ - req(input$viz_type) - p <- .visualize() - if (is.null(p)) return(NULL) - print(p) -}, width = viz_plot_width, height = viz_plot_height, res = 96) +output$visualize <- renderPlot( + { + req(input$viz_type) + if (not_available(input$viz_xvar)) { + if (!input$viz_type %in% c("box", "line")) { + return( + plot( + x = 1, type = "n", + main = i18n$t("Please select variables from the dropdown menus to create a plot"), + axes = FALSE, xlab = "", ylab = "", cex.main = .9 + ) + ) + } + } + .visualize() %>% + (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 = viz_plot_width, + height = viz_plot_height, + res = 96 +) .visualize <- eventReactive(input$viz_run, { req(input$viz_type) if (input$viz_type == "scatter") req(input$viz_nrobs) + + ## need dependency on .. req(input$viz_plot_height && input$viz_plot_width) if (not_available(input$viz_xvar) && !input$viz_type %in% c("box", "line")) { - return(NULL) + return() + } else if (input$viz_type %in% c("scatter", "line", "box", "bar", "surface") && not_available(input$viz_yvar)) { + return(i18n$t("No Y-variable provided for a plot that requires one")) + } else if (input$viz_type == "box" && !all(input$viz_xvar %in% groupable_vars())) { + return() } - if (input$viz_type %in% c("scatter", "line", "box", "bar", "surface") && not_available(input$viz_yvar)) { - return(NULL) + + ## waiting for comby and/or combx to be updated + if (input$viz_type %in% c("dist", "density")) { + if (isTRUE(input$viz_comby)) { + return() + } + if (length(input$viz_xvar) > 1 && is.null(input$viz_combx)) { + return() + } + } else { + if (isTRUE(input$viz_combx)) { + return() + } + if (length(input$viz_yvar) > 1 && is.null(input$viz_comby)) { + return() + } } + req(!is.null(input$viz_color) || !is.null(input$viz_fill)) vizi <- viz_inputs() - vizi$dataset <- input$dataset + vizi$dataset <- input$dataset vizi$shiny <- TRUE vizi$envir <- r_data - withProgress(message = i18n$t("Making plot"), value = 1, { - p <- do.call(visualize, vizi) - if (is.character(p)) return(NULL) - p + do.call(visualize, vizi) }) }) visualize_report <- function() { + ## resetting hidden elements to default values vi <- viz_inputs() if (input$viz_type != "dist") { vi$bins <- viz_args$bins @@ -531,6 +615,7 @@ visualize_report <- function() { if (!input$viz_type %in% c("bar", "dist", "density", "surface")) { vi$fill <- NULL } + if (!input$viz_type %in% c("bar", "dist", "box", "density")) { vi$fillcol <- "blue" } @@ -540,13 +625,16 @@ visualize_report <- function() { if (!input$viz_type %in% c("box", "scatter", "line")) { vi$pointcol <- "black" } + if (!input$viz_type %in% c("bar", "line", "scatter")) { vi$fun <- "mean" } - if (safe_is_empty(input$data_rows)) { + if (is.empty(input$data_rows)) { vi$rows <- NULL } + inp_main <- c(clean_args(vi, viz_args), custom = FALSE) + update_report( inp_main = inp_main, fun_name = "visualize", @@ -582,4 +670,4 @@ observeEvent(input$visualize_screenshot, { observeEvent(input$modal_visualize_screenshot, { visualize_report() removeModal() -}) \ No newline at end of file +}) diff --git a/radiant.model/R/cox.R b/radiant.model/R/cox.R index 8b1c2da..220a9d4 100644 --- a/radiant.model/R/cox.R +++ b/radiant.model/R/cox.R @@ -1,4 +1,4 @@ -#' 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 diff --git a/radiant.model/inst/app/tools/analysis/cox_ui.R b/radiant.model/inst/app/tools/analysis/cox_ui.R index a2cfdfd..c5fa2b7 100644 --- a/radiant.model/inst/app/tools/analysis/cox_ui.R +++ b/radiant.model/inst/app/tools/analysis/cox_ui.R @@ -1,4 +1,4 @@ -## ========== 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()) diff --git a/radiant.quickgen/R/quickgen_ai.R b/radiant.quickgen/R/quickgen_ai.R index 7107e9a..b5c2f75 100644 --- a/radiant.quickgen/R/quickgen_ai.R +++ b/radiant.quickgen/R/quickgen_ai.R @@ -1,6 +1,6 @@ # === 配置 === 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" # === 低层封装:单次对话 === diff --git a/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R b/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R index d033c6d..ed9f114 100644 --- a/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R +++ b/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R @@ -1,8 +1,3 @@ -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, { -- 2.22.0