diff --git a/Dockerfile b/Dockerfile index 74e9602899997237cbd4e6ea12bea8eaa5f233d7..5c1ced96f982366e3ed8cbd1f118df3a5c1400cf 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,8 @@ RUN R -e "remotes::install_local('/srv/shiny-server/radiant.quickgen',dependenci RUN R -e "remotes::install_local('/srv/shiny-server/radiant-master',dependencies=TRUE, type='source', upgrade='never',force=TRUE)" WORKDIR /data -ENV HOST_API_BASE="https://ds.cixincloud.com/data-search-api" +# ENV HOST_API_BASE="https://ds.cixincloud.com/data-search-api" +ENV HOST_API_BASE="http://10.120.120.34:8300/data-search-api" CMD ["R", "-e", "radiant::radiant(host='0.0.0.0', port=3838)"] #sudo -i diff --git a/notice.txt b/notice.txt deleted file mode 100644 index 120df68958038ea43f57e6c9eb11d3061df6c0ea..0000000000000000000000000000000000000000 --- a/notice.txt +++ /dev/null @@ -1,28 +0,0 @@ -上传模块 -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 a0668647379946451b8e03f03aae932cad99f3e8..0c1cafbf0e19e5c6aa31fbff808880bc6e9fe9a1 100644 --- a/radiant-master/inst/translations/translation_zh.csv +++ b/radiant-master/inst/translations/translation_zh.csv @@ -89,7 +89,7 @@ Spearman,斯皮尔曼秩相关,correlation_ui.R Kendall,肯德尔秩相关,correlation_ui.R Calculate correlation,计算相关性,correlation_ui.R Basics > Tables,基础统计 > 表格,correlation_ui.R -Correlation,相关性,"correlation_ui.R,init.R" +Correlation,相关性分析,"correlation_ui.R,init.R" Adjust for {factor} variables,针对 {factor} 变量进行调整,"correlation_ui.R,full_factor_ui.R" Calculate adjusted p.values,计算调整后的 p 值,correlation_ui.R Correlation cutoff:,相关性阈值:,correlation_ui.R @@ -541,8 +541,6 @@ Save factorial design:,保存实验设计：,doe_ui.R Save factors:,保存因素：,doe_ui.R Design factors:,实验因素,doe_ui.R Generated experimental design:,生成的实验设计：,doe.R -Level 1:,水平 1：,doe_ui.R -Level 2:,水平 2：,doe_ui.R Design > DOE,设计 > 实验设计,doe_ui.R Design of Experiments,实验设计,"doe_ui.R,init.R" Variables:,变量：,"randomizer_ui.R, sampling_ui.R,full_factor_ui.R" @@ -1245,3 +1243,29 @@ Data Quality,数据质量, Select plot types,选择图表类型, Select one or more variables,选择一个或多个变量, Missing Value Analysis,缺失值分析, +Select variables to analyze:,选择要分析的变量：, +Missing Heatmap,缺失热图, +Missing Barplot,缺失条形图, +Time Series,时间序列, +Time Series Analysis,时间序列分析, +Moving Average,移动平均（MA）, +Exp. Smoothing,指数平滑（EST）, +Autocorrelation,自相关分析（ACF）, +Interval:,时间间隔：, +MA Window Size:,平均移动窗口大小：, +Forecast Periods:,预测期：, +Basics > Time Series,基础统计 > 时间序列, +Aggregation Method:,聚合方法：, +Please select at least one plot layer.,请至少选择一个图像。, +Original Data,原始数据, +Moving Average Line,移动平均线, +Exp. Smoothing Line,指数平滑线, +ACF Plot,自相关图, +Day,日, +Week,星期, +Month,月, +Quarter,季度, +Year,年, +Mean (Average),均值, +Sum (Total),求和, +Count (Rows),计数, diff --git a/radiant.basics/NAMESPACE b/radiant.basics/NAMESPACE index b3bdc0eba1634a22e7085201f643c6e2ec419a5c..afffa201362b5f1667f5756cd412e96f38521411 100644 --- a/radiant.basics/NAMESPACE +++ b/radiant.basics/NAMESPACE @@ -23,6 +23,7 @@ S3method(plot,prob_tdist) S3method(plot,prob_unif) S3method(plot,single_mean) S3method(plot,single_prop) +S3method(plot,time_series) S3method(print,rcorr) S3method(summary,compare_means) S3method(summary,compare_props) @@ -46,6 +47,7 @@ S3method(summary,prob_tdist) S3method(summary,prob_unif) S3method(summary,single_mean) S3method(summary,single_prop) +S3method(summary,time_series) export(clt) export(compare_means) export(compare_props) @@ -78,6 +80,7 @@ export(run_kw) export(run_norm_test) export(single_mean) export(single_prop) +export(time_series) import(ggplot2) import(radiant.data) import(shiny) diff --git a/radiant.basics/R/time_series.R b/radiant.basics/R/time_series.R new file mode 100644 index 0000000000000000000000000000000000000000..2995e20b543077df7808e4958c4bc6638199a9d4 --- /dev/null +++ b/radiant.basics/R/time_series.R @@ -0,0 +1,257 @@ +#' Time Series Analysis (Smart Aggregation for Date & Numeric) +#' +#' @param dataset Dataset name +#' @param var_num The numeric variable to analyze (Y) +#' @param var_date The time variable (X). Can be Date or Numeric. +#' @param agg_level Aggregation level ("day", "week", "month", "quarter", "year") +#' @param agg_fun Aggregation function ("mean", "sum", "count") +#' @param ma_n Window size for Moving Average +#' @param fc_periods Number of periods to forecast +#' @param methods Vector of methods: "ma", "ets", "acf" +#' @param data_filter Filter expression +#' @param envir Environment +#' +#' @return A list of results +#' @export +time_series <- function(dataset, var_num, var_date = NULL, + agg_level = "month", agg_fun = "mean", + ma_n = 3, fc_periods = 0, methods = c("ma"), + data_filter = "", envir = parent.frame()) { + + # === 1. 数据准备 === + vars <- c(var_num) + if (!is.null(var_date) && var_date != "") vars <- c(vars, var_date) + + df_raw <- get_data(dataset, vars, filt = data_filter, na.rm = TRUE, envir = envir) + + # === 2. 智能聚合逻辑 === + # 检查 X 轴数据类型 + is_date_col <- !is.null(var_date) && var_date != "" && inherits(df_raw[[var_date]], c("Date", "POSIXt")) + is_num_col <- !is.null(var_date) && var_date != "" && is.numeric(df_raw[[var_date]]) + + df <- df_raw # 默认回退 + + if (is_date_col || is_num_col) { + requireNamespace("dplyr") + + if (is_date_col) { + # A. 如果是日期：使用 lubridate 对齐 + requireNamespace("lubridate") + df_raw$ts_group_col <- lubridate::floor_date(df_raw[[var_date]], unit = agg_level) + step_num <- 1 # 仅用于后续判断 + + } else if (is_num_col) { + # B. 如果是数字：执行分箱 (Binning) + # 将 "Month" 映射为 "30个单位", "Week" -> "7个单位" + step_num <- switch(agg_level, + "week" = 7, + "month" = 30, + "quarter" = 90, + "year" = 365, + 1) # default day=1 + + # 核心算法：向下取整分箱 + df_raw$ts_group_col <- floor(df_raw[[var_date]] / step_num) * step_num + } + + # 执行聚合 + df <- df_raw %>% + dplyr::group_by(ts_group_col) %>% + dplyr::summarise( + y_agg = if (agg_fun == "count") dplyr::n() + else if (agg_fun == "sum") sum(.data[[var_num]], na.rm = TRUE) + else mean(.data[[var_num]], na.rm = TRUE) + ) %>% + dplyr::arrange(ts_group_col) %>% + dplyr::rename(!!var_date := ts_group_col, !!var_num := y_agg) %>% + as.data.frame() + + } else { + # 如果没选变量，生成 Index + if (is.null(var_date) || var_date == "") { + var_date <- "Index" + df$Index <- 1:nrow(df) + step_num <- 1 + } + } + + y_val <- df[[var_num]] + res_list <- list() + metrics <- data.frame(Method = character(), RMSE = numeric(), MAE = numeric(), stringsAsFactors = FALSE) + + get_accuracy <- function(actual, fitted, name) { + err <- actual - fitted + c(name, round(sqrt(mean(err^2, na.rm=TRUE)), 3), round(mean(abs(err), na.rm=TRUE), 3)) + } + + # === 3. 计算模块 === + + # --- Moving Average --- + if ("ma" %in% methods) { + # 确保窗口不大于数据长度 + safe_ma_n <- min(ma_n, length(y_val)) + ma_weights <- rep(1/safe_ma_n, safe_ma_n) + df$ma_line <- as.numeric(stats::filter(y_val, ma_weights, sides = 1)) + + valid <- !is.na(df$ma_line) + if (sum(valid) > 0) { + metrics[nrow(metrics)+1,] <- get_accuracy(y_val[valid], df$ma_line[valid], "Moving Average") + } + } + + # --- ETS (Holt-Winters) --- + if ("ets" %in% methods) { + # 尝试根据聚合粒度设定频率 + freq <- 1 + if (is_date_col) { + freq <- switch(agg_level, "month"=12, "quarter"=4, "week"=52, 7) + } else if (is_num_col) { + # 对于数值型，尝试推断周期，默认无季节性 + freq <- 1 + } + + if (length(y_val) < 2 * freq) freq <- 1 + ts_obj <- ts(y_val, frequency = freq) + + ets_model <- tryCatch(HoltWinters(ts_obj), + error = function(e) tryCatch(HoltWinters(ts_obj, gamma=FALSE), error = function(e) NULL)) + + if (!is.null(ets_model)) { + fitted_raw <- as.numeric(ets_model$fitted[, 1]) + pad <- rep(NA, length(y_val) - length(fitted_raw)) + df$ets_line <- c(pad, fitted_raw) + + # 记录参数 + res_list$ets_params <- list(alpha = ets_model$alpha, beta = ets_model$beta, gamma = ets_model$gamma) + + # 记录误差 + metrics[nrow(metrics)+1,] <- get_accuracy(y_val[!is.na(df$ets_line)], df$ets_line[!is.na(df$ets_line)], "Exp. Smoothing") + + # === 预测 (Forecast) === + if (fc_periods > 0) { + fc_out <- predict(ets_model, n.ahead = fc_periods, prediction.interval = TRUE, level = 0.95) + + last_time <- tail(df[[var_date]], 1) + + # 生成未来时间轴 (区分日期和数字) + if (inherits(last_time, "Date") || inherits(last_time, "POSIXt")) { + future_dates <- seq(from = last_time, by = agg_level, length.out = fc_periods + 1)[-1] + } else { + # 对于数字，按 step_num 递增 + # 如果之前判定是数字列，使用之前的 step_num + step <- if(exists("step_num")) step_num else 1 + future_dates <- seq(from = last_time + step, by = step, length.out = fc_periods) + } + + res_list$forecast <- data.frame( + date = future_dates, + fit = as.numeric(fc_out[, "fit"]), + upr = as.numeric(fc_out[, "upr"]), + lwr = as.numeric(fc_out[, "lwr"]) + ) + } + } + } + + # --- ACF --- + if ("acf" %in% methods) { + # 增加 tryCatch 防止数据太少报错 + acf_out <- tryCatch(acf(y_val, plot = FALSE, na.action = na.pass), error = function(e) NULL) + if (!is.null(acf_out)) { + res_list$acf_df <- data.frame(lag = acf_out$lag, acf = acf_out$acf) + } + } + + # === 4. 返回 === + res_list$dataset <- df + res_list$metrics <- metrics + res_list$var_num <- var_num + res_list$var_date <- var_date + res_list$agg_level <- agg_level + res_list$agg_fun <- agg_fun + res_list$methods <- methods + res_list$df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset)) + + as.list(res_list) %>% add_class("time_series") +} + +#' Summary method +#' @export +summary.time_series <- function(object, ...) { + cat("Time Series Analysis\n") + cat("Data :", object$df_name, "\n") + cat("Variable :", object$var_num, "\n") + cat("Time Var :", object$var_date, "\n") + cat("Aggregation:", object$agg_level, "(", object$agg_fun, ")\n\n") + + if (nrow(object$metrics) > 0) { + cat("Model Accuracy (Goodness of Fit):\n") + print(object$metrics, row.names = FALSE) + cat("---\n") + } + + if ("ets" %in% object$methods && !is.null(object$ets_params)) { + p <- object$ets_params + cat("Exp. Smoothing Parameters:\n") + cat(sprintf("Alpha: %.3f, Beta: %.3f, Gamma: %.3f\n", p$alpha, ifelse(is.null(p$beta), 0, p$beta), ifelse(is.null(p$gamma), 0, p$gamma))) + } + + if (!is.null(object$forecast)) { + cat("\nForecast (Next", nrow(object$forecast), "periods):\n") + print(head(object$forecast, 5)) + } +} + +#' Plot method +#' @export +plot.time_series <- function(x, plots = c("original", "ma", "ets"), shiny = FALSE, custom = FALSE, ...) { + + plot_list <- list() + + if (any(c("original", "ma", "ets") %in% plots)) { + + p <- ggplot(x$dataset, aes(x = .data[[x$var_date]], y = .data[[x$var_num]])) + + labs(title = paste("Time Series:", x$var_num), subtitle = paste("Aggregated by", x$agg_level)) + + theme_minimal() + + if ("original" %in% plots) { + p <- p + geom_line(color = "black", alpha = 0.3) + + geom_point(color = "black", alpha = 0.3, size = 1.5) + } + + if ("ma" %in% plots && "ma_line" %in% names(x$dataset)) { + p <- p + geom_line(aes(y = ma_line, color = "Moving Avg"), linewidth = 0.8) + } + + if ("ets" %in% plots && "ets_line" %in% names(x$dataset)) { + p <- p + geom_line(aes(y = ets_line, color = "Exp Smoothing"), linewidth = 0.8) + } + + if ("ets" %in% plots && !is.null(x$forecast)) { + p <- p + + geom_ribbon(data = x$forecast, aes(x = date, ymin = lwr, ymax = upr, y = fit), fill = "red", alpha = 0.15, inherit.aes = FALSE) + + geom_line(data = x$forecast, aes(x = date, y = fit, color = "Forecast"), linetype = "dashed", linewidth = 0.8, inherit.aes = FALSE) + } + + p <- p + scale_color_manual(name = "Legend", + values = c("Moving Avg" = "blue", "Exp Smoothing" = "red", "Forecast" = "red")) + + plot_list[[1]] <- p + } + + if ("acf" %in% plots && "acf" %in% x$methods && !is.null(x$acf_df)) { + ci <- 0.95 + clim <- qnorm((1 + ci)/2) / sqrt(nrow(x$dataset)) + p_acf <- ggplot(x$acf_df, aes(x = lag, y = acf)) + + geom_segment(aes(xend = lag, yend = 0), color = "darkblue", linewidth = 1) + + geom_hline(yintercept = c(clim, -clim), linetype = "dashed", color = "blue") + + geom_hline(yintercept = 0) + + labs(title = "Autocorrelation (ACF)", y = "ACF", x = "Lag") + theme_minimal() + plot_list[[length(plot_list) + 1]] <- p_acf + } + + if (length(plot_list) > 0) { + patchwork::wrap_plots(plot_list, ncol = 1) %>% + (function(obj) if (shiny) obj else print(obj)) + } +} \ No newline at end of file diff --git a/radiant.basics/inst/app/init.R b/radiant.basics/inst/app/init.R index f5a373a6c4b628f87d7f1c26c99b22cab88aa965..c6ff02644e05db89c1e23de3093d4629ebe964ed 100644 --- a/radiant.basics/inst/app/init.R +++ b/radiant.basics/inst/app/init.R @@ -49,7 +49,9 @@ options( "----", i18n$t("Tables"), tabPanel(i18n$t("Goodness of fit"), uiOutput("goodness")), tabPanel(i18n$t("Cross-tabs(Chi-square test, etc)"), uiOutput("cross_tabs")), - tabPanel(i18n$t("Correlation"), uiOutput("correlation")) + tabPanel(i18n$t("Correlation"), uiOutput("correlation")), + "----", i18n$t("Time Series"), + tabPanel(i18n$t("Time Series Analysis"), uiOutput("time_series")), ) ) ) diff --git a/radiant.basics/inst/app/tools/analysis/time_series_ui.R b/radiant.basics/inst/app/tools/analysis/time_series_ui.R new file mode 100644 index 0000000000000000000000000000000000000000..7cba160342a0ccc25ebbd83cdf302adb8df075e5 --- /dev/null +++ b/radiant.basics/inst/app/tools/analysis/time_series_ui.R @@ -0,0 +1,269 @@ +############################### +## Time Series Analysis - ui +## file: time_series_ui.R +############################### + +# --- 1. 定义下拉菜单和选项常量 --- +ts_methods <- c("ma", "ets", "acf") +names(ts_methods) <- c( + i18n$t("Moving Average"), + i18n$t("Exp. Smoothing"), + i18n$t("Autocorrelation") +) + +# 绘图图层选项（统一用方法1） +ts_plot_opts <- c("original", "ma", "ets", "acf") +names(ts_plot_opts) <- c( + i18n$t("Original Data"), + i18n$t("Moving Average Line"), + i18n$t("Exp. Smoothing Line"), + i18n$t("ACF Plot") +) + +# 聚合粒度选项（统一用方法1） +ts_agg_levels <- c("day", "week", "month", "quarter", "year") +names(ts_agg_levels) <- c( + i18n$t("Day"), + i18n$t("Week"), + i18n$t("Month"), + i18n$t("Quarter"), + i18n$t("Year") +) + +# 聚合函数选项（统一用方法1） +ts_agg_funs <- c("mean", "sum", "count") +names(ts_agg_funs) <- c( + i18n$t("Mean (Average)"), + i18n$t("Sum (Total)"), + i18n$t("Count (Rows)") +) + +# --- 2. 初始化参数 --- +# 读取后端 time_series 函数的默认参数 +ts_args <- as.list(formals(time_series)) + +# --- 3. 打包用户输入 (ts_inputs) --- +ts_inputs <- reactive({ + # 处理数据过滤 + ts_args$data_filter <- if (input$show_filter) input$data_filter else "" + ts_args$dataset <- input$dataset + ts_args$envir <- r_data + + # 自动循环匹配 input$ts_xxx 到参数 xxx + for (i in r_drop(names(ts_args))) { + ts_args[[i]] <- input[[paste0("ts_", i)]] + } + ts_args +}) + +# --- 4. 动态 UI 组件定义 --- + +# Y轴变量 (数值型) +output$ui_ts_var_num <- renderUI({ + isNum <- .get_class() %in% c("integer", "numeric", "ts") + vars <- c("None" = "", varnames()[isNum]) + selectInput( + inputId = "ts_var_num", label = i18n$t("Numeric variable:"), + choices = vars, selected = state_single("ts_var_num", vars), multiple = FALSE + ) +}) + +# X轴变量 (日期/时间型/数值型) +output$ui_ts_var_date <- renderUI({ + all_vars <- varnames() + # 自动检测日期类型的变量优先显示 + isDate <- .get_class() %in% c("Date", "POSIXt", "POSIXct") + # 如果有日期变量，默认选中第一个 + def_sel <- if (any(isDate)) all_vars[isDate][1] else "" + + vars <- c("None" = "", all_vars) + selectInput( + inputId = "ts_var_date", label = i18n$t("Time variable:"), + choices = vars, selected = state_single("ts_var_date", vars, def_sel), multiple = FALSE + ) +}) + +# --- 5. 侧边栏主面板 (UI Sidebar) --- +output$ui_time_series <- renderUI({ + req(input$dataset) + tagList( + wellPanel( + # === 基础数据选择 === + uiOutput("ui_ts_var_num"), + uiOutput("ui_ts_var_date"), + + # 改为垂直排列，确保下拉菜单可以正常弹出并被选择 + conditionalPanel( + condition = "input.ts_var_date != ''", + selectInput( + inputId = "ts_agg_level", label = i18n$t("Interval:"), + choices = ts_agg_levels, + selected = state_single("ts_agg_level", ts_agg_levels, "month"), + multiple = FALSE + ), + + selectInput( + inputId = "ts_agg_fun", label = i18n$t("Aggregation Method:"), + choices = ts_agg_funs, + selected = state_single("ts_agg_fun", ts_agg_funs, "mean"), + multiple = FALSE + ) + ), + + conditionalPanel( + condition = "input.tabs_time_series == i18n$t('Summary')", + h6("计算方法:"), + + # 选择计算方法 + checkboxGroupInput( + inputId = "ts_methods", label = NULL, + choices = ts_methods, + selected = state_multiple("ts_methods", ts_methods, c("ma", "ets")) + ), + + # MA 参数设置 + conditionalPanel( + condition = "input.ts_methods.includes('ma')", + numericInput("ts_ma_n", i18n$t("MA Window Size:"), + value = state_init("ts_ma_n", 3), min = 2, step = 1) + ), + + # 预测参数设置 + numericInput( + inputId = "ts_fc_periods", label = i18n$t("Forecast Periods:"), + value = state_init("ts_fc_periods", 0), min = 0, step = 1 + ), + ), + + # === 绘图图层配置 === + conditionalPanel( + condition = "input.tabs_time_series == i18n$t('Plot')", + h6("图像:"), + selectizeInput( + inputId = "ts_plots", label = NULL, + choices = ts_plot_opts, + selected = state_multiple("ts_plots", ts_plot_opts, c("original", "ma", "ets")), + multiple = TRUE, + options = list(placeholder = "Select layers", plugins = list("remove_button", "drag_drop")) + ) + ) + ), + + # 帮助按钮和报告生成按钮 + help_and_report( + modal_title = "Time Series Analysis", + fun_name = "time_series", + help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/time_series.md")) + ) + ) +}) + +# --- 6. 定义图形高度 --- +ts_plot_height <- function() { + # 如果包含 ACF 图，增加高度 + if ("acf" %in% input$ts_plots) 600 else 400 +} + +# --- 7. 注册主界面输出 (Main Panel) --- +output$time_series <- renderUI({ + # 注册打印和绘图输出 + register_print_output("summary_time_series", ".summary_time_series") + register_plot_output("plot_time_series", ".plot_time_series", height_fun = "ts_plot_height") + + # 定义标签页 + ts_output_panels <- tabsetPanel( + id = "tabs_time_series", + tabPanel(i18n$t("Summary"), verbatimTextOutput("summary_time_series")), + tabPanel( + i18n$t("Plot"), + download_link("dlp_time_series"), + plotOutput("plot_time_series", height = "100%") + ) + ) + + # 构建 Radiant 标准 Tab 面板 + stat_tab_panel( + menu = i18n$t("Basics > Time Series"), + tool = i18n$t("Time Series Analysis"), + tool_ui = "ui_time_series", + output_panels = ts_output_panels + ) +}) + +# --- 8. 后端计算逻辑连接 --- + +# 执行计算 +.time_series <- reactive({ + tsi <- ts_inputs() + tsi$envir <- r_data # 确保环境传递正确 + req(tsi$var_num) # 必须选择了变量才执行 + do.call(time_series, tsi) +}) + +# 生成 Summary +.summary_time_series <- reactive({ + summary(.time_series()) +}) + +# 生成 Plot +.plot_time_series <- reactive({ + validate( + need(input$ts_plots, i18n$t("Please select at least one plot layer.")) + ) + withProgress(message = "Generating Plots...", value = 1, { + plot(.time_series(), plots = input$ts_plots, shiny = TRUE) + }) +}) + +# --- 9. 报告生成 (Rmarkdown) --- +time_series_report <- function() { + if (is.empty(input$ts_var_num)) return(invisible()) + + # 判断是否生成图片代码 + if (length(input$ts_plots) == 0) { + figs <- FALSE + outputs <- c("summary") + inp_out <- list("", "") + } else { + figs <- TRUE + outputs <- c("summary", "plot") + inp_out <- list("", list(plots = input$ts_plots, custom = FALSE)) + } + + update_report( + inp_main = clean_args(ts_inputs(), ts_args), + fun_name = "time_series", + outputs = outputs, + figs = figs, + fig.width = 650, + fig.height = ts_plot_height() + ) +} + +# --- 10. 下载处理器 --- +download_handler( + id = "dlp_time_series", + fun = download_handler_plot, + fn = function() paste0(input$dataset, "_time_series"), + type = "png", + caption = "Save time series plot", + plot = .plot_time_series, + width = 650, + height = ts_plot_height +) + +# --- 11. 事件监听 --- +observeEvent(input$time_series_report, { + r_info[["latest_screenshot"]] <- NULL + time_series_report() +}) + +observeEvent(input$time_series_screenshot, { + r_info[["latest_screenshot"]] <- NULL + radiant_screenshot_modal("modal_time_series_screenshot") +}) + +observeEvent(input$modal_time_series_screenshot, { + time_series_report() + removeModal() +}) \ No newline at end of file diff --git a/radiant.basics/inst/app/tools/help/time_series.md b/radiant.basics/inst/app/tools/help/time_series.md new file mode 100644 index 0000000000000000000000000000000000000000..9a6aa23163d651c6faf50373595e2f2c430618ae --- /dev/null +++ b/radiant.basics/inst/app/tools/help/time_series.md @@ -0,0 +1 @@ +xxxxx \ No newline at end of file diff --git a/radiant.basics/man/plot.time_series.Rd b/radiant.basics/man/plot.time_series.Rd new file mode 100644 index 0000000000000000000000000000000000000000..ab0851855baccb5bcfc63276ac12ce0c28cbee59 --- /dev/null +++ b/radiant.basics/man/plot.time_series.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/time_series.R +\name{plot.time_series} +\alias{plot.time_series} +\title{Plot method} +\usage{ +\method{plot}{time_series}(x, plots = c("original", "ma", "ets"), shiny = FALSE, custom = FALSE, ...) +} +\description{ +Plot method +} diff --git a/radiant.basics/man/summary.time_series.Rd b/radiant.basics/man/summary.time_series.Rd new file mode 100644 index 0000000000000000000000000000000000000000..a54bf0127c6a29046b457e03257fcf0240519f19 --- /dev/null +++ b/radiant.basics/man/summary.time_series.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/time_series.R +\name{summary.time_series} +\alias{summary.time_series} +\title{Summary method} +\usage{ +\method{summary}{time_series}(object, ...) +} +\description{ +Summary method +} diff --git a/radiant.basics/man/time_series.Rd b/radiant.basics/man/time_series.Rd new file mode 100644 index 0000000000000000000000000000000000000000..b711bddfcf9e60bfdcee0c0c2c4cb0d9ea817134 --- /dev/null +++ b/radiant.basics/man/time_series.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/time_series.R +\name{time_series} +\alias{time_series} +\title{Time Series Analysis (Smart Aggregation for Date & Numeric)} +\usage{ +time_series( + dataset, + var_num, + var_date = NULL, + agg_level = "month", + agg_fun = "mean", + ma_n = 3, + fc_periods = 0, + methods = c("ma"), + data_filter = "", + envir = parent.frame() +) +} +\arguments{ +\item{dataset}{Dataset name} + +\item{var_num}{The numeric variable to analyze (Y)} + +\item{var_date}{The time variable (X). Can be Date or Numeric.} + +\item{agg_level}{Aggregation level ("day", "week", "month", "quarter", "year")} + +\item{agg_fun}{Aggregation function ("mean", "sum", "count")} + +\item{ma_n}{Window size for Moving Average} + +\item{fc_periods}{Number of periods to forecast} + +\item{methods}{Vector of methods: "ma", "ets", "acf"} + +\item{data_filter}{Filter expression} + +\item{envir}{Environment} +} +\value{ +A list of results +} +\description{ +Time Series Analysis (Smart Aggregation for Date & Numeric) +} diff --git a/radiant.data/inst/app/tools/data/init_load_data.R b/radiant.data/inst/app/tools/data/ init_load_data.R similarity index 92% rename from radiant.data/inst/app/tools/data/init_load_data.R rename to radiant.data/inst/app/tools/data/ init_load_data.R index fd57f81355f922bfe54dcd88b9dc541879ee6e4b..a9f4d6fccc97818ee51cab7dd6864f5ce40c8f20 100644 --- a/radiant.data/inst/app/tools/data/init_load_data.R +++ b/radiant.data/inst/app/tools/data/ init_load_data.R @@ -1,182 +1,185 @@ -library(httr) -library(glue) - -# ------------------------------------------------------------------------- -# 1. CRIC 系统处理函数 -# ------------------------------------------------------------------------- -download_handler_cric <- function(base_url, id, token, dest_file) { - # 注意：这里假设 base_url 结尾没有 /，且 target 开头有 / - target_url <- glue::glue("{base_url}/research-project/generate-project-dataset/{id}") - - response <- httr::POST( - url = target_url, - httr::add_headers(authentication = paste(token)), - httr::write_disk(dest_file, overwrite = TRUE) - ) - return(response) -} - -# ------------------------------------------------------------------------- -# 2. 专病库系统 处理函数 -# ------------------------------------------------------------------------- -# 场景 1: 批量导出患者 (List) -download_handler_disease_batch <- function(base_url, id, token, dest_file) { - # URL 拼接：base_url + /disease-data/... - target_url <- glue::glue("{base_url}/disease-data/export/patient/list") - - # 参数预处理：逗号分隔字符串转向量 - id_list <- strsplit(id, ",")[[1]] - - response <- httr::POST( - url = target_url, - httr::add_headers(Authorization = paste('Bearer ', token)), # 注意空格 - body = id_list, - encode = "json", # 自动将向量转为 JSON 数组 ["id1", "id2"] - httr::write_disk(dest_file, overwrite = TRUE) - ) - return(response) -} - -# 场景 2: 申请单导出 (Case) -download_handler_disease_apply <- function(base_url, id, token, dest_file) { - target_url <- glue::glue("{base_url}/disease-data/data/export/apply/apply/case") - - response <- httr::POST( - url = target_url, - query = list(applyId = id), # 自动拼接到 URL ?applyId=xxx - httr::add_headers(Authorization = paste('Bearer ', token)), - httr::write_disk(dest_file, overwrite = TRUE) - ) - return(response) -} - -# ------------------------------------------------------------------------- -# 系统注册表 -# ------------------------------------------------------------------------- -SYSTEM_REGISTRY <- list( - "cric" = list( - api_base = "https://ds.cixincloud.com/data-search-api", - handler = download_handler_cric, - file_ext = ".xlsx", - sys_description = "大数据检索系统" - ), - - "disease_batch" = list( - api_base = "https://ds.cixincloud.com/disease-api", - handler = download_handler_disease_batch, - file_ext = ".xls",# 注意这里是 xls - sys_description = "专病库系统" - ), - - "disease_apply" = list( - api_base = "https://ds.cixincloud.com/disease-api", - handler = download_handler_disease_apply, - file_ext = ".xlsx", - sys_description = "专病库系统" - ) -) - -# ------------------------------------------------------------------------- -# 主逻辑 (Observer) -# ------------------------------------------------------------------------- -observe({ - # 1. 解析 URL 参数 - query <- parseQueryString(session$clientData$url_search) - - dataset_id <- query[['datasetId']] - token <- query[['token']] - sys_name <- query[['system']] - - # 初始化已加载列表 - if (is.null(session$userData$loaded_datasets)) { - session$userData$loaded_datasets <- c() - } - - # 2. 校验必要参数 - if (!is.null(dataset_id) && !is.null(token) && !is.null(sys_name)) { - - # 3. 防止重复加载 - if (!(dataset_id %in% session$userData$loaded_datasets)) { - - # 4. 获取系统配置 - sys_config <- SYSTEM_REGISTRY[[sys_name]] - - if (is.null(sys_config)) { - showNotification(paste0("配置错误：未知的系统类型 [", sys_config$sys_description, "]"), type = "error", duration = 10) - return() - } - - withProgress(message = paste0('正在连接 [', sys_config$sys_description, ']...'), value = 0.1, { - - tryCatch({ - # 5. 准备临时文件 - # 获取带点的后缀 (如 .xlsx) - file_suffix <- ifelse(is.null(sys_config$file_ext), ".xlsx", sys_config$file_ext) - tmp_file <- tempfile(fileext = file_suffix) - - # [修复点 1] 提前计算不带点的后缀变量 clean_ext，供后续使用 - clean_ext <- gsub("\\.", "", file_suffix) - - incProgress(0.3, detail = "执行下载策略...") - - # 6. 调用 Handler 下载 - response <- sys_config$handler( - base_url = sys_config$api_base, - id = dataset_id, - token = token, - dest_file = tmp_file - ) - - # 7. 检查状态码 - if (httr::status_code(response) != 200) { - err_msg <- tryCatch( - httr::content(response, "text", encoding = "UTF-8"), - error = function(e) "无详细错误信息" - ) - stop(paste0("下载失败 (HTTP ", httr::status_code(response), "): ", err_msg)) - } - - incProgress(0.7, detail = "正在导入 Radiant...") - - # 8. 调用 Radiant 加载函数 - load_user_data( - fname = paste0("data_", dataset_id, file_suffix), - uFile = tmp_file, - ext = clean_ext, # [修复点 2] 使用定义好的变量 - xlsx_header = TRUE, - man_str_as_factor = TRUE - ) - - # 9. 界面联动：自动选中最后一个 Sheet - if (clean_ext %in% c("xlsx", "xls")) { - - # 读取 Sheet 名 -> 清洗 -> 取最后一个 - # 使用 try 包裹 readxl 以防空文件报错 - raw_sheets <- try(readxl::excel_sheets(tmp_file), silent = TRUE) - - if (!inherits(raw_sheets, "try-error") && length(raw_sheets) > 0) { - target_sheet <- head(make.names(raw_sheets), 1) - message(target_sheet) - - # 更新下拉框 - updateSelectInput(session, "dataset", choices = names(r_data), selected = target_sheet) - - # 切换页面 - updateTabsetPanel(session, "nav_radiant", selected = "Data") - updateTabsetPanel(session, "tabs_data", selected = "View") - - # showNotification(paste0("已选中: ", target_sheet), type = "message") - } - } - - # 10. 标记为已加载 - session$userData$loaded_datasets <- c(session$userData$loaded_datasets, dataset_id) - - }, error = function(e) { - showNotification(paste("同步失败:", e$message), type = "error", duration = 15) - print(e) # 在控制台打印详细错误堆栈 - }) - }) - } - } -}) +library(httr) +library(glue) + +# ------------------------------------------------------------------------- +# 1. CRIC 系统处理函数 +# ------------------------------------------------------------------------- +download_handler_cric <- function(base_url, id, token, dest_file) { + # 注意：这里假设 base_url 结尾没有 /，且 target 开头有 / + target_url <- glue::glue("{base_url}/research-project/generate-project-dataset/{id}") + + response <- httr::POST( + url = target_url, + httr::add_headers(authentication = paste(token)), + httr::write_disk(dest_file, overwrite = TRUE) + ) + return(response) +} + +# ------------------------------------------------------------------------- +# 2. 专病库系统 处理函数 +# ------------------------------------------------------------------------- +# 场景 1: 批量导出患者 (List) +download_handler_disease_batch <- function(base_url, id, token, dest_file) { + # URL 拼接：base_url + /disease-data/... + target_url <- glue::glue("{base_url}/disease-data/export/patient/list") + + # 参数预处理：逗号分隔字符串转向量 + id_list <- strsplit(id, ",")[[1]] + + response <- httr::POST( + url = target_url, + httr::add_headers(Authorization = paste('Bearer ', token)), # 注意空格 + body = id_list, + encode = "json", # 自动将向量转为 JSON 数组 ["id1", "id2"] + httr::write_disk(dest_file, overwrite = TRUE) + ) + return(response) +} + +# 场景 2: 申请单导出 (Case) +download_handler_disease_apply <- function(base_url, id, token, dest_file) { + target_url <- glue::glue("{base_url}/disease-data/data/export/apply/apply/case") + + response <- httr::POST( + url = target_url, + query = list(applyId = id), # 自动拼接到 URL ?applyId=xxx + httr::add_headers(Authorization = paste('Bearer ', token)), + httr::write_disk(dest_file, overwrite = TRUE) + ) + return(response) +} + +# ------------------------------------------------------------------------- +# 系统注册表 +# ------------------------------------------------------------------------- +SYSTEM_REGISTRY <- list( + "cric" = list( + # api_base = "https://ds.cixincloud.com/data-search-api", + api_base = "http://10.120.120.34:8300/data-search-api", + handler = download_handler_cric, + file_ext = ".xlsx", + sys_description = "大数据检索系统" + ), + + "disease_batch" = list( + # api_base = "https://ds.cixincloud.com/disease-api", + api_base = "http://10.120.120.34:8300/disease-api", + handler = download_handler_disease_batch, + file_ext = ".xls",# 注意这里是 xls + sys_description = "专病库系统" + ), + + "disease_apply" = list( + # api_base = "https://ds.cixincloud.com/disease-api", + api_base = "http://10.120.120.34:8300/disease-api", + handler = download_handler_disease_apply, + file_ext = ".xlsx", + sys_description = "专病库系统" + ) +) + +# ------------------------------------------------------------------------- +# 主逻辑 (Observer) +# ------------------------------------------------------------------------- +observe({ + # 1. 解析 URL 参数 + query <- parseQueryString(session$clientData$url_search) + + dataset_id <- query[['datasetId']] + token <- query[['token']] + sys_name <- query[['system']] + + # 初始化已加载列表 + if (is.null(session$userData$loaded_datasets)) { + session$userData$loaded_datasets <- c() + } + + # 2. 校验必要参数 + if (!is.null(dataset_id) && !is.null(token) && !is.null(sys_name)) { + + # 3. 防止重复加载 + if (!(dataset_id %in% session$userData$loaded_datasets)) { + + # 4. 获取系统配置 + sys_config <- SYSTEM_REGISTRY[[sys_name]] + + if (is.null(sys_config)) { + showNotification(paste0("配置错误：未知的系统类型 [", sys_config$sys_description, "]"), type = "error", duration = 10) + return() + } + + withProgress(message = paste0('正在连接 [', sys_config$sys_description, ']...'), value = 0.1, { + + tryCatch({ + # 5. 准备临时文件 + # 获取带点的后缀 (如 .xlsx) + file_suffix <- ifelse(is.null(sys_config$file_ext), ".xlsx", sys_config$file_ext) + tmp_file <- tempfile(fileext = file_suffix) + + # [修复点 1] 提前计算不带点的后缀变量 clean_ext，供后续使用 + clean_ext <- gsub("\\.", "", file_suffix) + + incProgress(0.3, detail = "执行下载策略...") + + # 6. 调用 Handler 下载 + response <- sys_config$handler( + base_url = sys_config$api_base, + id = dataset_id, + token = token, + dest_file = tmp_file + ) + + # 7. 检查状态码 + if (httr::status_code(response) != 200) { + err_msg <- tryCatch( + httr::content(response, "text", encoding = "UTF-8"), + error = function(e) "无详细错误信息" + ) + stop(paste0("下载失败 (HTTP ", httr::status_code(response), "): ", err_msg)) + } + + incProgress(0.7, detail = "正在导入 Radiant...") + + # 8. 调用 Radiant 加载函数 + load_user_data( + fname = paste0("data_", dataset_id, file_suffix), + uFile = tmp_file, + ext = clean_ext, # [修复点 2] 使用定义好的变量 + xlsx_header = TRUE, + man_str_as_factor = TRUE + ) + + # 9. 界面联动：自动选中最后一个 Sheet + if (clean_ext %in% c("xlsx", "xls")) { + + # 读取 Sheet 名 -> 清洗 -> 取最后一个 + # 使用 try 包裹 readxl 以防空文件报错 + raw_sheets <- try(readxl::excel_sheets(tmp_file), silent = TRUE) + + if (!inherits(raw_sheets, "try-error") && length(raw_sheets) > 0) { + target_sheet <- head(make.names(raw_sheets), 1) + message(target_sheet) + + # 更新下拉框 + updateSelectInput(session, "dataset", choices = names(r_data), selected = target_sheet) + + # 切换页面 + updateTabsetPanel(session, "nav_radiant", selected = "Data") + updateTabsetPanel(session, "tabs_data", selected = "View") + + # showNotification(paste0("已选中: ", target_sheet), type = "message") + } + } + + # 10. 标记为已加载 + session$userData$loaded_datasets <- c(session$userData$loaded_datasets, dataset_id) + + }, error = function(e) { + showNotification(paste("同步失败:", e$message), type = "error", duration = 15) + print(e) # 在控制台打印详细错误堆栈 + }) + }) + } + } +}) diff --git a/radiant.data/inst/app/tools/data/view_ui.R b/radiant.data/inst/app/tools/data/view_ui.R index 43b340b90807e3f4309dcdb304b3b9aeb15569fb..e1837d95e5c5175680b12369160c6212a14822cc 100644 --- a/radiant.data/inst/app/tools/data/view_ui.R +++ b/radiant.data/inst/app/tools/data/view_ui.R @@ -1,330 +1,330 @@ -############################################# -# View table output of the selected dataset -############################################# -output$ui_view_vars <- renderUI({ - vars <- varnames() - req(available(vars)) - isolate({ - if (not_available(r_state$view_vars)) { - r_state$view_vars <<- NULL - r_state$dataviewer_state <<- list() - r_state$dataviewer_search_columns <<- NULL - } - }) - - selectInput( - "view_vars", i18n$t("Select variables to show:"), - choices = vars, - selected = state_multiple("view_vars", vars, head(vars, 15)), # 默认查看前15行 - multiple = TRUE, - selectize = FALSE, size = min(15, length(vars)) - ) -}) - -output$ui_View <- renderUI({ - tagList( - wellPanel( - actionLink("view_clear", i18n$t("Clear settings"), icon = icon("sync", verify_fa = FALSE), style = "color:black"), - uiOutput("ui_view_vars"), - returnTextAreaInput("view_tab_slice", - label = i18n$t("Table slice (rows):"), - rows = 1, - value = state_init("view_tab_slice"), - placeholder = i18n$t("e.g., 1:5 and press return") - ), - numericInput( - "view_dec", i18n$t("Decimals:"), - value = state_init("view_dec", 2), - min = 0 - ), - tags$table( - tags$td(textInput("view_name", i18n$t("Store filtered data as:"), "", placeholder = i18n$t("Provide data name"))), - tags$td(actionButton("view_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE), class = "btn-success"), class = "top") - ) - ), - help_and_report( - i18n$t("View"), "view", - inclMD(file.path(getOption("radiant.path.data"), "app/tools/help/view.md")) %>% gsub("`", "", .), - lic = "by-sa" - ) - ) -}) - -observeEvent(input$dataviewer_search_columns, { - r_state$dataviewer_search_columns <<- input$dataviewer_search_columns -}) - -observeEvent(input$dataviewer_state, { - r_state$dataviewer_state <<- - if (is.null(input$dataviewer_state)) list() else input$dataviewer_state -}) - -## state_multiple should handle this, but doesn't -## using this observer, however, messes up state settings -# observeEvent(is.null(input$view_vars), { -# if ("view_vars" %in% names(input)) r_state$view_vars <<- NULL -# }) - -observeEvent(input$view_vars, { - if (length(r_state$view_vars) > 0) { - r_state$dataviewer_state <<- list() - r_state$dataviewer_search_columns <<- rep("", length(input$view_vars)) - } - r_state$view_vars <<- input$view_vars -}) - -observeEvent(input$view_clear, { - r_state$dataviewer_state <<- list() - r_state$dataviewer_search_columns <<- rep("", length(input$view_vars)) - r_state$view_vars <<- input$view_vars - updateCheckboxInput(session = session, inputId = "show_filter", value = FALSE) -}) - -output$dataviewer <- DT::renderDataTable( - { - input$view_clear - req(available(input$view_vars)) - dat <- select_at(.get_data(), .vars = input$view_vars) - - style <- if (exists("bslib_current_version") && "4" %in% bslib_current_version()) "bootstrap4" else "bootstrap" - - search <- r_state$dataviewer_state$search$search - if (is.null(search)) search <- "" - fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top") - - isBigFct <- sapply(dat, function(x) is.factor(x) && length(levels(x)) > 1000) - if (sum(isBigFct) > 0) { - dat[, isBigFct] <- select(dat, which(isBigFct)) %>% mutate_all(as.character) - } - - ## for rounding - isInt <- sapply(dat, function(x) is.integer(x)) - isDbl <- sapply(dat, is_double) - dec <- input$view_dec %>% - (function(x) ifelse(is.empty(x) || x < 0, 3, round(x, 0))) - - caption <- if (is.empty(input$view_tab_slice)) NULL else htmltools::tags$caption(glue(i18n$t("Table slice {input$view_tab_slice} will be applied on Download, Store, or Report"))) - - withProgress( - message = i18n$t("Generating view table"), value = 1, - DT::datatable( - dat, - filter = fbox, - selection = "none", - rownames = FALSE, - ## must use fillContainer = FALSE to address - ## see https://github.com/rstudio/DT/issues/367 - ## https://github.com/rstudio/DT/issues/379 - fillContainer = FALSE, - ## only works with client-side processing - # extension = "KeyTable", - escape = FALSE, - # editable = TRUE, - style = style, - options = list( - stateSave = TRUE, ## maintains state - searchCols = lapply(r_state$dataviewer_search_columns, function(x) list(search = x)), - search = list(search = search, regex = TRUE), - order = { - if (is.null(r_state$dataviewer_state$order)) { - list() - } else { - r_state$dataviewer_state$order - } - }, - columnDefs = list( - list(orderSequence = c("desc", "asc"), targets = "_all"), - list(className = "dt-center", targets = "_all") - ), - autoWidth = TRUE, - processing = isTRUE(fbox == "none"), - pageLength = { - if (is.null(r_state$dataviewer_state$length)) 10 else r_state$dataviewer_state$length - }, - lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", i18n$t("All"))) - ), - caption = caption, - ## https://github.com/rstudio/DT/issues/146#issuecomment-534319155 - callback = DT::JS('$(window).on("unload", function() { table.state.clear(); }); ') - ) %>% - (function(x) if (sum(isDbl) > 0) DT::formatRound(x, names(isDbl)[isDbl], dec) else x) %>% - (function(x) if (sum(isInt) > 0) DT::formatRound(x, names(isInt)[isInt], 0) else x) - ) - }, - server = TRUE -) - -observeEvent(input$view_store, { - req(input$view_name) - data_filter <- if (input$show_filter) input$data_filter else "" - data_arrange <- if (input$show_filter) input$data_arrange else "" - data_rows <- if (input$show_filter) input$data_rows else "" - - dataset <- fix_names(input$view_name) - if (input$view_name != dataset) { - updateTextInput(session, inputId = "view_name", value = dataset) - } - - r_data[[dataset]] <- get_data( - input$dataset, - vars = input$view_vars, filt = data_filter, arr = data_arrange, - rows = data_rows, data_view_rows = input$dataviewer_rows_all, - na.rm = FALSE, envir = r_data - ) %>% - (function(x) if (is.empty(input$view_tab_slice)) x else slice_data(x, input$view_tab_slice)) - register(dataset) - updateSelectInput(session = session, inputId = "dataset", selected = input$dataset) - - if (input$dataset != dataset) { - ## See https://shiny.posit.co/reference/shiny/latest/modalDialog.html - showModal( - modalDialog( - title = i18n$t("Data Stored"), - span( - paste0(i18n$t("Dataset '"), dataset, i18n$t("' was successfully added to - the datasets dropdown. Add code to Report > Rmd or - Report > R to (re)create the dataset by clicking the report i - con on the bottom left of your screen.")) - ), - footer = modalButton(i18n$t("OK")), - size = "m", - easyClose = TRUE - ) - ) - } -}) - -dl_view_tab <- function(file) { - data_filter <- if (input$show_filter) input$data_filter else "" - data_arrange <- if (input$show_filter) input$data_arrange else "" - data_rows <- if (input$show_filter) input$data_rows else "" - get_data( - input$dataset, - vars = input$view_vars, - filt = data_filter, - arr = data_arrange, - rows = data_rows, - data_view_rows = input$dataviewer_rows_all, - na.rm = FALSE, - envir = r_data - ) %>% - (function(x) if (is.empty(input$view_tab_slice)) x else slice_data(x, input$view_tab_slice)) %>% - write.csv(file, row.names = FALSE) -} - -download_handler( - id = "dl_view_tab", - fun = dl_view_tab, - fn = function() { - ifelse(is.empty(input$view_name), paste0(input$dataset, i18n$t("_view")), input$view_name) - } -) - -.dataviewer <- reactive({ - list(tab = .get_data()[1, ]) -}) - -.viewcmd <- function(mess = "") { - ## get the state of the dt table - ts <- dt_state("dataviewer", vars = input$view_vars) - - if (is.empty(input$view_name)) { - dataset <- NULL - } else { - dataset <- fix_names(input$view_name) - if (input$view_name != dataset) { - updateTextInput(session, inputId = "view_name", value = dataset) - } - } - - cmd <- "" - - ## shorten list of variales if possible - vars <- input$view_vars - cn <- colnames(.dataviewer()$tab) - ind <- which(cn %in% vars) - - if (length(vars) == length(cn)) { - vars <- paste0(head(vars, 1), ":", tail(vars, 1)) - } else if ((max(ind) - min(ind) + 1) == length(vars)) { - vars <- paste0(cn[min(ind)], ":", cn[max(ind)]) - } else if (length(vars) > (length(cn) / 2)) { - vars <- paste0("-", base::setdiff(cn, vars), collapse = ", ") - } else { - vars <- paste0(vars, collapse = ", ") - } - - if (is.empty(dataset)) { - xcmd <- paste0(i18n$t(" dtab(")) - } else { - xcmd <- paste0(i18n$t("dtab("), dataset, ", ") - } - if (!is.empty(input$view_dec, 3)) { - xcmd <- paste0(xcmd, i18n$t("dec = "), input$view_dec, ", ") - } - if (!is.empty(r_state$dataviewer_state$length, 10)) { - xcmd <- paste0(xcmd, i18n$t("pageLength = "), r_state$dataviewer_state$length, ", ") - } - - ## create the command to filter and sort the data - if (is.empty(dataset)) { - cmd <- paste0(cmd, i18n$t("## filter and sort the dataset\n"), input$dataset) - } else { - cmd <- paste0(cmd, i18n$t("## filter and sort the dataset\n"), dataset, " <- ", input$dataset) - } - if (input$show_filter && !is.empty(input$data_filter)) { - cmd <- paste0(cmd, " %>%\n ", i18n$t("filter("), input$data_filter, ")") - } - if (input$show_filter && !is.empty(input$data_arrange)) { - cmd <- paste0(cmd, " %>%\n ", i18n$t("arrange("), make_arrange_cmd(input$data_arrange)) - } - if (input$show_filter && !is.empty(input$data_rows)) { - cmd <- paste0(cmd, " %>%\n ", i18n$t("slice("), input$data_rows, ")") - } - if (!is.empty(ts$search)) { - cmd <- paste0(cmd, " %>%\n filter(search_data(., \"", ts$search, "\"))") - } - if (!is.empty(ts$tabfilt)) { - cmd <- paste0(cmd, " %>%\n ", i18n$t("filter("), ts$tabfilt, ")") - } - if (!is.empty(ts$tabsort)) { - cmd <- paste0(cmd, " %>%\n ", i18n$t("arrange("), ts$tabsort, ")") - } - if (!is.empty(input$view_tab_slice)) { - cmd <- paste0(cmd, " %>%\n slice(", input$view_tab_slice, ")") - xcmd <- paste0(xcmd, i18n$t("caption = \"\") %>%\n render()")) - } else { - xcmd <- paste0(xcmd, i18n$t("caption = \"\", nr = 100) %>%\n render()")) - } - ## moved `select` to the end so filters can use variables - ## not selected for the final dataset - if (is.empty(dataset)) { - paste0(cmd, " %>%\n ", i18n$t("select("), vars, i18n$t(") %>%\n droplevels() %>%")) %>% - paste0("\n", xcmd) - } else { - ret <- paste0(cmd, " %>%\n ", i18n$t("select("), vars, i18n$t(") %>% droplevels()")) - if (dataset != input$dataset) { - ret <- paste0(ret, "\n", i18n$t("register(\""), dataset, "\", \"", input$dataset, "\")\n", xcmd) - } - ret - } -} - -view_report <- function() { - update_report(cmd = .viewcmd(), outputs = NULL, figs = FALSE) -} - -observeEvent(input$view_report, { - r_info[["latest_screenshot"]] <- NULL - view_report() -}) - -observeEvent(input$view_screenshot, { - r_info[["latest_screenshot"]] <- NULL - radiant_screenshot_modal("modal_view_screenshot") -}) - -observeEvent(input$modal_view_screenshot, { - view_report() - removeModal() -}) +############################################# +# View table output of the selected dataset +############################################# +output$ui_view_vars <- renderUI({ + vars <- varnames() + req(available(vars)) + isolate({ + if (not_available(r_state$view_vars)) { + r_state$view_vars <<- NULL + r_state$dataviewer_state <<- list() + r_state$dataviewer_search_columns <<- NULL + } + }) + + selectInput( + "view_vars", i18n$t("Select variables to show:"), + choices = vars, + selected = state_multiple("view_vars", vars, head(vars, 15)), # 默认查看前15行 + multiple = TRUE, + selectize = FALSE, size = min(15, length(vars)) + ) +}) + +output$ui_View <- renderUI({ + tagList( + wellPanel( + actionLink("view_clear", i18n$t("Clear settings"), icon = icon("sync", verify_fa = FALSE), style = "color:black"), + uiOutput("ui_view_vars"), + returnTextAreaInput("view_tab_slice", + label = i18n$t("Table slice (rows):"), + rows = 1, + value = state_init("view_tab_slice"), + placeholder = i18n$t("e.g., 1:5 and press return") + ), + numericInput( + "view_dec", i18n$t("Decimals:"), + value = state_init("view_dec", 2), + min = 0 + ), + tags$table( + tags$td(textInput("view_name", i18n$t("Store filtered data as:"), "", placeholder = i18n$t("Provide data name"))), + tags$td(actionButton("view_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE), class = "btn-success"), class = "top") + ) + ), + help_and_report( + i18n$t("View"), "view", + inclMD(file.path(getOption("radiant.path.data"), "app/tools/help/view.md")) %>% gsub("`", "", .), + lic = "by-sa" + ) + ) +}) + +observeEvent(input$dataviewer_search_columns, { + r_state$dataviewer_search_columns <<- input$dataviewer_search_columns +}) + +observeEvent(input$dataviewer_state, { + r_state$dataviewer_state <<- + if (is.null(input$dataviewer_state)) list() else input$dataviewer_state +}) + +## state_multiple should handle this, but doesn't +## using this observer, however, messes up state settings +# observeEvent(is.null(input$view_vars), { +# if ("view_vars" %in% names(input)) r_state$view_vars <<- NULL +# }) + +observeEvent(input$view_vars, { + if (length(r_state$view_vars) > 0) { + r_state$dataviewer_state <<- list() + r_state$dataviewer_search_columns <<- rep("", length(input$view_vars)) + } + r_state$view_vars <<- input$view_vars +}) + +observeEvent(input$view_clear, { + r_state$dataviewer_state <<- list() + r_state$dataviewer_search_columns <<- rep("", length(input$view_vars)) + r_state$view_vars <<- input$view_vars + updateCheckboxInput(session = session, inputId = "show_filter", value = FALSE) +}) + +output$dataviewer <- DT::renderDataTable( + { + input$view_clear + req(available(input$view_vars)) + dat <- select_at(.get_data(), .vars = input$view_vars) + + style <- if (exists("bslib_current_version") && "4" %in% bslib_current_version()) "bootstrap4" else "bootstrap" + + search <- r_state$dataviewer_state$search$search + if (is.null(search)) search <- "" + fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top") + + isBigFct <- sapply(dat, function(x) is.factor(x) && length(levels(x)) > 1000) + if (sum(isBigFct) > 0) { + dat[, isBigFct] <- select(dat, which(isBigFct)) %>% mutate_all(as.character) + } + + ## for rounding + isInt <- sapply(dat, function(x) is.integer(x)) + isDbl <- sapply(dat, is_double) + dec <- input$view_dec %>% + (function(x) ifelse(is.empty(x) || x < 0, 3, round(x, 0))) + + caption <- if (is.empty(input$view_tab_slice)) NULL else htmltools::tags$caption(glue(i18n$t("Table slice {input$view_tab_slice} will be applied on Download, Store, or Report"))) + + withProgress( + message = i18n$t("Generating view table"), value = 1, + DT::datatable( + dat, + filter = fbox, + selection = "none", + rownames = FALSE, + ## must use fillContainer = FALSE to address + ## see https://github.com/rstudio/DT/issues/367 + ## https://github.com/rstudio/DT/issues/379 + fillContainer = FALSE, + ## only works with client-side processing + # extension = "KeyTable", + escape = FALSE, + # editable = TRUE, + style = style, + options = list( + stateSave = TRUE, ## maintains state + searchCols = lapply(r_state$dataviewer_search_columns, function(x) list(search = x)), + search = list(search = search, regex = TRUE), + order = { + if (is.null(r_state$dataviewer_state$order)) { + list() + } else { + r_state$dataviewer_state$order + } + }, + columnDefs = list( + list(orderSequence = c("desc", "asc"), targets = "_all"), + list(className = "dt-center", targets = "_all") + ), + autoWidth = TRUE, + processing = isTRUE(fbox == "none"), + pageLength = { + if (is.null(r_state$dataviewer_state$length)) 10 else r_state$dataviewer_state$length + }, + lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", i18n$t("All"))) + ), + caption = caption, + ## https://github.com/rstudio/DT/issues/146#issuecomment-534319155 + callback = DT::JS('$(window).on("unload", function() { table.state.clear(); }); ') + ) %>% + (function(x) if (sum(isDbl) > 0) DT::formatRound(x, names(isDbl)[isDbl], dec) else x) %>% + (function(x) if (sum(isInt) > 0) DT::formatRound(x, names(isInt)[isInt], 0) else x) + ) + }, + server = TRUE +) + +observeEvent(input$view_store, { + req(input$view_name) + data_filter <- if (input$show_filter) input$data_filter else "" + data_arrange <- if (input$show_filter) input$data_arrange else "" + data_rows <- if (input$show_filter) input$data_rows else "" + + dataset <- fix_names(input$view_name) + if (input$view_name != dataset) { + updateTextInput(session, inputId = "view_name", value = dataset) + } + + r_data[[dataset]] <- get_data( + input$dataset, + vars = input$view_vars, filt = data_filter, arr = data_arrange, + rows = data_rows, data_view_rows = input$dataviewer_rows_all, + na.rm = FALSE, envir = r_data + ) %>% + (function(x) if (is.empty(input$view_tab_slice)) x else slice_data(x, input$view_tab_slice)) + register(dataset) + updateSelectInput(session = session, inputId = "dataset", selected = input$dataset) + + if (input$dataset != dataset) { + ## See https://shiny.posit.co/reference/shiny/latest/modalDialog.html + showModal( + modalDialog( + title = i18n$t("Data Stored"), + span( + paste0(i18n$t("Dataset '"), dataset, i18n$t("' was successfully added to + the datasets dropdown. Add code to Report > Rmd or + Report > R to (re)create the dataset by clicking the report i + con on the bottom left of your screen.")) + ), + footer = modalButton(i18n$t("OK")), + size = "m", + easyClose = TRUE + ) + ) + } +}) + +dl_view_tab <- function(file) { + data_filter <- if (input$show_filter) input$data_filter else "" + data_arrange <- if (input$show_filter) input$data_arrange else "" + data_rows <- if (input$show_filter) input$data_rows else "" + get_data( + input$dataset, + vars = input$view_vars, + filt = data_filter, + arr = data_arrange, + rows = data_rows, + data_view_rows = input$dataviewer_rows_all, + na.rm = FALSE, + envir = r_data + ) %>% + (function(x) if (is.empty(input$view_tab_slice)) x else slice_data(x, input$view_tab_slice)) %>% + write.csv(file, row.names = FALSE) +} + +download_handler( + id = "dl_view_tab", + fun = dl_view_tab, + fn = function() { + ifelse(is.empty(input$view_name), paste0(input$dataset, i18n$t("_view")), input$view_name) + } +) + +.dataviewer <- reactive({ + list(tab = .get_data()[1, ]) +}) + +.viewcmd <- function(mess = "") { + ## get the state of the dt table + ts <- dt_state("dataviewer", vars = input$view_vars) + + if (is.empty(input$view_name)) { + dataset <- NULL + } else { + dataset <- fix_names(input$view_name) + if (input$view_name != dataset) { + updateTextInput(session, inputId = "view_name", value = dataset) + } + } + + cmd <- "" + + ## shorten list of variales if possible + vars <- input$view_vars + cn <- colnames(.dataviewer()$tab) + ind <- which(cn %in% vars) + + if (length(vars) == length(cn)) { + vars <- paste0(head(vars, 1), ":", tail(vars, 1)) + } else if ((max(ind) - min(ind) + 1) == length(vars)) { + vars <- paste0(cn[min(ind)], ":", cn[max(ind)]) + } else if (length(vars) > (length(cn) / 2)) { + vars <- paste0("-", base::setdiff(cn, vars), collapse = ", ") + } else { + vars <- paste0(vars, collapse = ", ") + } + + if (is.empty(dataset)) { + xcmd <- paste0(i18n$t(" dtab(")) + } else { + xcmd <- paste0(i18n$t("dtab("), dataset, ", ") + } + if (!is.empty(input$view_dec, 3)) { + xcmd <- paste0(xcmd, i18n$t("dec = "), input$view_dec, ", ") + } + if (!is.empty(r_state$dataviewer_state$length, 10)) { + xcmd <- paste0(xcmd, i18n$t("pageLength = "), r_state$dataviewer_state$length, ", ") + } + + ## create the command to filter and sort the data + if (is.empty(dataset)) { + cmd <- paste0(cmd, i18n$t("## filter and sort the dataset\n"), input$dataset) + } else { + cmd <- paste0(cmd, i18n$t("## filter and sort the dataset\n"), dataset, " <- ", input$dataset) + } + if (input$show_filter && !is.empty(input$data_filter)) { + cmd <- paste0(cmd, " %>%\n ", i18n$t("filter("), input$data_filter, ")") + } + if (input$show_filter && !is.empty(input$data_arrange)) { + cmd <- paste0(cmd, " %>%\n ", i18n$t("arrange("), make_arrange_cmd(input$data_arrange)) + } + if (input$show_filter && !is.empty(input$data_rows)) { + cmd <- paste0(cmd, " %>%\n ", i18n$t("slice("), input$data_rows, ")") + } + if (!is.empty(ts$search)) { + cmd <- paste0(cmd, " %>%\n filter(search_data(., \"", ts$search, "\"))") + } + if (!is.empty(ts$tabfilt)) { + cmd <- paste0(cmd, " %>%\n ", i18n$t("filter("), ts$tabfilt, ")") + } + if (!is.empty(ts$tabsort)) { + cmd <- paste0(cmd, " %>%\n ", i18n$t("arrange("), ts$tabsort, ")") + } + if (!is.empty(input$view_tab_slice)) { + cmd <- paste0(cmd, " %>%\n slice(", input$view_tab_slice, ")") + xcmd <- paste0(xcmd, i18n$t("caption = \"\") %>%\n render()")) + } else { + xcmd <- paste0(xcmd, i18n$t("caption = \"\", nr = 100) %>%\n render()")) + } + ## moved `select` to the end so filters can use variables + ## not selected for the final dataset + if (is.empty(dataset)) { + paste0(cmd, " %>%\n ", i18n$t("select("), vars, i18n$t(") %>%\n droplevels() %>%")) %>% + paste0("\n", xcmd) + } else { + ret <- paste0(cmd, " %>%\n ", i18n$t("select("), vars, i18n$t(") %>% droplevels()")) + if (dataset != input$dataset) { + ret <- paste0(ret, "\n", i18n$t("register(\""), dataset, "\", \"", input$dataset, "\")\n", xcmd) + } + ret + } +} + +view_report <- function() { + update_report(cmd = .viewcmd(), outputs = NULL, figs = FALSE) +} + +observeEvent(input$view_report, { + r_info[["latest_screenshot"]] <- NULL + view_report() +}) + +observeEvent(input$view_screenshot, { + r_info[["latest_screenshot"]] <- NULL + radiant_screenshot_modal("modal_view_screenshot") +}) + +observeEvent(input$modal_view_screenshot, { + view_report() + removeModal() +}) diff --git a/radiant.data/inst/app/www/imgs/icon.png b/radiant.data/inst/app/www/imgs/icon.png index e27a5d7ce9c4d0db2495b75f7fd8b4bd091921a7..ec56584a7b28f93bffc546acf11e95ad8d344bed 100644 Binary files a/radiant.data/inst/app/www/imgs/icon.png and b/radiant.data/inst/app/www/imgs/icon.png differ diff --git a/radiant.data/inst/app/www/style.css b/radiant.data/inst/app/www/style.css index 1c56c22d47da9e5eed5692c931e4bc2e92342778..df1eaa990dfcf5d3396201555386ced6674901a6 100644 --- a/radiant.data/inst/app/www/style.css +++ b/radiant.data/inst/app/www/style.css @@ -1,257 +1,257 @@ -ul, -ol { - padding-left: 18px; -} - -#viz_details_main+span, -#viz_details_labels+span, -#viz_details_style+span { - font-weight: bold; -} - -.table { - width: auto; -} - -.btn { - overflow: hidden; - white-space: nowrap; - text-overflow: ellipsis; -} - -.snippet th, -.snippet td { - text-align: center; -} - -table.dataTable tfoot td, -table.dataTable thead td { - padding: 0 0 0 0; -} - -td.top { - padding-top: 33px; -} - -td.top_small { - padding-top: 5px; -} - -td.top_mini { - padding-top: 1px; -} - -.well { - padding: 7px; - margin-bottom: 5px; -} - -.col-sm-4 { - max-width: 315px; -} - -.checkbox { - margin-top: 0; - margin-bottom: 0; -} - -.form-group { - margin-top: 0; - margin-bottom: 0; -} - -.radio-inline+.radio-inline, -.checkbox-inline+.checkbox-inline { - margin-left: 0; - margin-right: 5px; -} - -.radio-inline, -.checkbox-inline { - margin-right: 5px; -} - -.help-modal-dialog { - padding-top: 80px; -} - -.modal-sm { - padding-top: 80px; - width: 600px; -} - -.help-modal-body { - max-height: 600px; - overflow-y: auto; -} - -.modal-title { - display: inline-block; - line-height: 1; - margin-top: 0; - margin-bottom: 0; -} - -img { - max-width: 85% !important; - height: auto; -} - -/* based on https://stackoverflow.com/a/30338814/1974918*/ -pre { - overflow: auto; - white-space: pre; - word-wrap: normal; - /*background-color: #ffffff;*/ -} - -code, -pre code { - overflow: auto; - white-space: pre; - word-wrap: normal; -} - -#state_download { - font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; - font-size: 16px; - color: black; -} - -/* allow all textareas and multiple-select inputs to resize vertically */ -/* have to set overflow to make resize work on Safari */ -/* based on https://css-tricks.com/almanac/properties/r/resize/ */ -textarea, -select { - resize: vertical; - overflow: auto; - max-width: 100%; -} - -.alignleft { - float: left; -} - -.alignright { - float: right; -} - -.aligncenter { - margin-left: 42%; -} - -.color_bar { - background-color: blue; -} - -/* from: https://github.com/swarm-lab/editR/blob/master/inst/app/www/editR.css */ -#rmd_edit, -#r_edit { - position: absolute; - top: 100px; - bottom: 0; - left: 0; - right: 50%; - padding-right: 10px; - margin-top: 1rem; -} - -/* from: https://github.com/swarm-lab/editR/blob/master/inst/app/www/editR.css */ -#rmd_knitted, -#r_knitted { - position: absolute; - top: 100px; - bottom: 0; - left: 50%; - right: 0; - padding-left: 10px; - overflow-y: scroll; - margin-top: 1rem; -} - -/* Needed in combination with navbarPage with fixed-top */ -/* based on https://stackoverflow.com/a/19231861/1974918 */ -body { - padding-top: 42px; -} - -.navbar { - margin-bottom: 5px; - background-color: black; -} - -.navbar .nav>li>a { - padding-left: 7px; - padding-right: 8px; -} - -.nav-tabs { - margin-bottom: 10px; -} - -.dropdown-menu { - max-height: 90vh; - overflow-y: auto; -} - -@media (max-width: 1000px) { - .navbar-header { - float: none; - } - - .navbar-left, - .navbar-right { - float: none !important; - } - - .navbar-toggle { - display: block; - } - - .navbar-collapse { - border-top: 1px solid transparent; - box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1); - } - - .navbar-fixed-top { - top: 0; - border-width: 0 0 1px; - } - - .navbar-collapse.collapse { - display: none !important; - } - - .navbar-nav { - float: none !important; - margin-top: 7.5px; - } - - .navbar-nav>li { - float: none; - } - - .navbar-nav>li>a { - padding-top: 10px; - padding-bottom: 10px; - } - - .collapse.in { - display: block !important; - } -} - -/* border radius same as other buttons in shiny */ -.btn-file-solitary { - border-radius: 4px !important; -} - -/* likely due to bootstrap css, font set to white */ -/* with dark themes against a white background */ -/* see https://github.com/ajaxorg/ace/issues/3071 */ -.ace_replace_form, -.ace_search_field, -.ace_replacebtn, -.ace_searchbtn { - color: black; -} +ul, +ol { + padding-left: 18px; +} + +#viz_details_main+span, +#viz_details_labels+span, +#viz_details_style+span { + font-weight: bold; +} + +.table { + width: auto; +} + +.btn { + overflow: hidden; + white-space: nowrap; + text-overflow: ellipsis; +} + +.snippet th, +.snippet td { + text-align: center; +} + +table.dataTable tfoot td, +table.dataTable thead td { + padding: 0 0 0 0; +} + +td.top { + padding-top: 33px; +} + +td.top_small { + padding-top: 5px; +} + +td.top_mini { + padding-top: 1px; +} + +.well { + padding: 7px; + margin-bottom: 5px; +} + +.col-sm-4 { + max-width: 315px; +} + +.checkbox { + margin-top: 0; + margin-bottom: 0; +} + +.form-group { + margin-top: 0; + margin-bottom: 0; +} + +.radio-inline+.radio-inline, +.checkbox-inline+.checkbox-inline { + margin-left: 0; + margin-right: 5px; +} + +.radio-inline, +.checkbox-inline { + margin-right: 5px; +} + +.help-modal-dialog { + padding-top: 80px; +} + +.modal-sm { + padding-top: 80px; + width: 600px; +} + +.help-modal-body { + max-height: 600px; + overflow-y: auto; +} + +.modal-title { + display: inline-block; + line-height: 1; + margin-top: 0; + margin-bottom: 0; +} + +img { + max-width: 85% !important; + height: auto; +} + +/* based on https://stackoverflow.com/a/30338814/1974918*/ +pre { + overflow: auto; + white-space: pre; + word-wrap: normal; + /*background-color: #ffffff;*/ +} + +code, +pre code { + overflow: auto; + white-space: pre; + word-wrap: normal; +} + +#state_download { + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-size: 16px; + color: black; +} + +/* allow all textareas and multiple-select inputs to resize vertically */ +/* have to set overflow to make resize work on Safari */ +/* based on https://css-tricks.com/almanac/properties/r/resize/ */ +textarea, +select { + resize: vertical; + overflow: auto; + max-width: 100%; +} + +.alignleft { + float: left; +} + +.alignright { + float: right; +} + +.aligncenter { + margin-left: 42%; +} + +.color_bar { + background-color: blue; +} + +/* from: https://github.com/swarm-lab/editR/blob/master/inst/app/www/editR.css */ +#rmd_edit, +#r_edit { + position: absolute; + top: 100px; + bottom: 0; + left: 0; + right: 50%; + padding-right: 10px; + margin-top: 1rem; +} + +/* from: https://github.com/swarm-lab/editR/blob/master/inst/app/www/editR.css */ +#rmd_knitted, +#r_knitted { + position: absolute; + top: 100px; + bottom: 0; + left: 50%; + right: 0; + padding-left: 10px; + overflow-y: scroll; + margin-top: 1rem; +} + +/* Needed in combination with navbarPage with fixed-top */ +/* based on https://stackoverflow.com/a/19231861/1974918 */ +body { + padding-top: 42px; +} + +.navbar { + margin-bottom: 5px; + background-color: #325aa5 !important; +} + +.navbar .nav>li>a { + padding-left: 7px; + padding-right: 8px; +} + +.nav-tabs { + margin-bottom: 10px; +} + +.dropdown-menu { + max-height: 90vh; + overflow-y: auto; +} + +@media (max-width: 1000px) { + .navbar-header { + float: none; + } + + .navbar-left, + .navbar-right { + float: none !important; + } + + .navbar-toggle { + display: block; + } + + .navbar-collapse { + border-top: 1px solid transparent; + box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1); + } + + .navbar-fixed-top { + top: 0; + border-width: 0 0 1px; + } + + .navbar-collapse.collapse { + display: none !important; + } + + .navbar-nav { + float: none !important; + margin-top: 7.5px; + } + + .navbar-nav>li { + float: none; + } + + .navbar-nav>li>a { + padding-top: 10px; + padding-bottom: 10px; + } + + .collapse.in { + display: block !important; + } +} + +/* border radius same as other buttons in shiny */ +.btn-file-solitary { + border-radius: 4px !important; +} + +/* likely due to bootstrap css, font set to white */ +/* with dark themes against a white background */ +/* see https://github.com/ajaxorg/ace/issues/3071 */ +.ace_replace_form, +.ace_search_field, +.ace_replacebtn, +.ace_searchbtn { + color: black; +} diff --git a/radiant.model/R/coxp.R b/radiant.model/R/coxp.R index 4b010a9a062632a1b91f9c533e35a8449f803235..06f1b2d874a606f2b9f58da79df0430d82db4d89 100644 --- a/radiant.model/R/coxp.R +++ b/radiant.model/R/coxp.R @@ -5,9 +5,9 @@ coxp <- function(dataset, time, status, evar, + form = NULL, int = "", check = "", - form, data_filter = "", arr = "", rows = NULL, @@ -35,6 +35,32 @@ 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) + if (!time %in% colnames(dataset)) + return("时间变量不存在于数据集中" %>% add_class("coxp")) + if (!is.numeric(dataset[[time]])) + return("时间变量必须是数值型" %>% add_class("coxp")) + + if (!status %in% colnames(dataset)) + return("状态变量不存在于数据集中" %>% add_class("coxp")) + + surv_vec <- dataset[[status]] + if (is.factor(surv_vec) || is.character(surv_vec)) { + lev <- unique(surv_vec) + if (length(lev) != 2) + return("状态变量必须是二分类（两个水平）" %>% add_class("coxp")) + dataset[[status]] <- as.numeric(factor(surv_vec, levels = lev)) - 1L + } else if (!all(unique(surv_vec) %in% c(0, 1))) { + return("状态变量必须只包含 0 和 1" %>% add_class("coxp")) + } + + n_event <- sum(dataset[[status]]) + if (n_event < 1) + return("数据中未发生任何事件（status = 1）" %>% add_class("coxp")) + + evar_missing <- setdiff(evar, colnames(dataset)) + if (length(evar_missing) > 0) + return(paste("解释变量不存在：", paste(evar_missing, collapse = ", ")) %>% add_class("coxp")) + ## 状态变量检查与转换 surv_status <- dataset[[status]] if (!is.numeric(surv_status)) { @@ -175,14 +201,25 @@ predict.coxp <- function(object, pred_data = NULL, pred_cmd = "", if (is.null(pred_data)) { newdata <- envir$.model_frame %||% object$model$model } else { - # 获取预测数据集 - newdata <- get_data(pred_data, vars = NULL, envir = envir) + model_vars <- all.vars(object$model$terms) + model_evar <- object$evar - # 变量存在性校验 - model_evar <- object$evar - pred_cols <- colnames(newdata) - missing_vars <- setdiff(model_evar, pred_cols) + # ========== 提前校验 ========== + # 先获取预测数据集的所有列 + pred_data_all <- get_data(pred_data, vars = NULL, envir = envir) + pred_cols <- colnames(pred_data_all) + # 检查模型变量是否都在预测数据中 + missing_vars <- setdiff(model_vars, pred_cols) + if (length(missing_vars) > 0) { + return(paste0( + "All variables in the model must also be in the prediction data\n", + "Variables in the model: ", paste(model_vars, collapse = ", "), "\n", + "Variables not available in prediction data: ", paste(missing_vars, collapse = ", ") + ) %>% add_class("coxp.predict")) + } + newdata <- get_data(pred_data, vars = model_vars, envir = envir) + missing_vars <- setdiff(model_evar, pred_cols) if (length(missing_vars) > 0) { return(paste0( "All variables in the model must also be in the prediction data\n", diff --git a/radiant.model/R/svm.R b/radiant.model/R/svm.R index 0f76f09c09a7fa8f19255b73ec722c3c174e2f78..7d5c22b72a47d6d69ce0ec51492d24c34e7cff45 100644 --- a/radiant.model/R/svm.R +++ b/radiant.model/R/svm.R @@ -738,7 +738,7 @@ varimp <- function(object, rvar = NULL, lev = NULL, data = NULL, seed = 1234, np #' @export svm_vip_plot <- function(object, size, custom) { - tryCatch({ + p <- tryCatch({ vi_scores <- varimp( object, rvar = object$rvar, @@ -752,14 +752,14 @@ svm_vip_plot <- function(object, size, custom) { # 检查数据有效性 if (nrow(vi_scores) == 0 || all(is.na(vi_scores$Importance))) { - p <- ggplot() + + ggplot() + annotate("text", x = 0.5, y = 0.5, label = "Could not compute variable importance\n(check model/data)", size = 5, color = "red") + theme_void() } else { # 创建条形图 - p <- ggplot(vi_scores, aes(x = reorder(Variable, Importance), y = Importance)) + + ggplot(vi_scores, aes(x = reorder(Variable, Importance), y = Importance)) + geom_col(fill = "#377eb8") + coord_flip() + labs( @@ -777,7 +777,7 @@ svm_vip_plot <- function(object, size, custom) { ) } }, error = function(e) { - p <- ggplot() + + ggplot() + annotate("text", x = 0.5, y = 0.5, label = paste("Error calculating importance:\n", e$message), size = 4, color = "red") + diff --git a/radiant.model/inst/app/tools/analysis/coxp_ui.R b/radiant.model/inst/app/tools/analysis/coxp_ui.R index 83d02f1ff0ef2cf4aaf90668f4b91fd3a362a7d6..31b9ff14f662be83fd4a51a59a978000f91b4d28 100644 --- a/radiant.model/inst/app/tools/analysis/coxp_ui.R +++ b/radiant.model/inst/app/tools/analysis/coxp_ui.R @@ -27,16 +27,15 @@ coxp_inputs <- reactive({ args$arr <- if (input$show_filter) input$data_arrange else "" args$rows <- if (input$show_filter) input$data_rows else "" args$dataset <- input$dataset - ## 其余参数手动映射 - for (i in r_drop(names(args))) { - args[[i]] <- input[[paste0("coxp_", i)]] - } + args$time <- input$coxp_time + args$status <- input$coxp_status + args$evar <- input$coxp_evar args }) coxp_plot_inputs <- reactive({ args <- list() - + # 传递用户设置的置信水平 args$conf_lev <- input$coxp_conf_lev %||% 0.95 @@ -309,63 +308,11 @@ coxp_available <- reactive({ ## 10. 模型估计 .coxp <- eventReactive(input$coxp_run, { - ds <- tryCatch( - get_data(input$dataset, vars = c(), envir = r_data), - error = function(e) return(paste("数据集获取失败：", e$message)) - ) - if (is.character(ds)) return(ds %>% add_class("coxp")) - - time_var <- input$coxp_time - if (!time_var %in% colnames(ds)) - return("时间变量不存在于数据集中" %>% add_class("coxp")) - if (!is.numeric(ds[[time_var]])) - return("时间变量必须是数值型" %>% add_class("coxp")) - - status_var <- input$coxp_status - if (!status_var %in% colnames(ds)) - return("状态变量不存在于数据集中" %>% add_class("coxp")) - - surv_vec <- ds[[status_var]] - if (is.factor(surv_vec) || is.character(surv_vec)) { - lev <- unique(surv_vec) - if (length(lev) != 2) - return("状态变量必须是二分类（两个水平）" %>% add_class("coxp")) - ds[[status_var]] <- as.numeric(factor(surv_vec, levels = lev)) - 1L - } else if (!all(unique(surv_vec) %in% c(0, 1))) { - return("状态变量必须只包含 0 和 1" %>% add_class("coxp")) - } - n_event <- sum(ds[[status_var]]) - if (n_event < 1) - return("数据中未发生任何事件（status = 1）" %>% add_class("coxp")) - - evar_missing <- setdiff(input$coxp_evar, colnames(ds)) - if (length(evar_missing) > 0) - return(paste("解释变量不存在：", paste(evar_missing, collapse = ", ")) %>% add_class("coxp")) - - rhs <- if (length(input$coxp_evar) > 0) { - paste(input$coxp_evar, collapse = " + ") - } else { - "1" - } - form <- as.formula(paste0("Surv(", time_var, ", ", status_var, ") ~ ", rhs)) - - model <- tryCatch( - survival::coxph(form, data = ds), - error = function(e) return(paste("coxph 模型失败：", e$message)) - ) - if (is.character(model)) - return(model %>% add_class("coxp")) - - coxp( - dataset = input$dataset, - time = time_var, - status = status_var, - evar = input$coxp_evar, - data_filter = if (input$show_filter) input$data_filter else "", - arr = if (input$show_filter) input$data_arrange else "", - rows = if (input$show_filter) input$data_rows else NULL, - envir = r_data - ) + coxpi <- coxp_inputs() + coxpi$envir <- r_data + withProgress(message = i18n$t("Estimating model"), value = 1, { + do.call(coxp, coxpi) + }) }) ## 11. summary / predict / plot -------------------------------------------- diff --git a/radiant.model/man/coxp.Rd b/radiant.model/man/coxp.Rd index 286df53190a3027fac1a39e43e75680b2fafd5b3..e203ee0ac3a034dbe24167219ee1f1f6755a7ec1 100644 --- a/radiant.model/man/coxp.Rd +++ b/radiant.model/man/coxp.Rd @@ -9,9 +9,9 @@ coxp( time, status, evar, + form = NULL, int = "", check = "", - form, data_filter = "", arr = "", rows = NULL, diff --git a/radiant.model/man/predict.svm.Rd b/radiant.model/man/predict.svm.Rd index 0db202c85349994fa0fb9f9e01ccbe08a1949b6b..aa0b0248d645fd09520f8064cb6aa8c113564bb3 100644 --- a/radiant.model/man/predict.svm.Rd +++ b/radiant.model/man/predict.svm.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/svm.R \name{predict.svm} \alias{predict.svm} -\title{Predict method for SVM model} +\title{Predict method for SVM model (FIXED VERSION)} \usage{ \method{predict}{svm}( object, @@ -14,5 +14,5 @@ ) } \description{ -Predict method for SVM model +Predict method for SVM model (FIXED VERSION) } diff --git a/radiant.multivariate/R/hclus.R b/radiant.multivariate/R/hclus.R index 4d4ba7962e303e59ff047a865d14f44811909a36..9cda7103425c449caad1af9877a19917c9f529c9 100644 --- a/radiant.multivariate/R/hclus.R +++ b/radiant.multivariate/R/hclus.R @@ -37,11 +37,6 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian", add_class("hclus")) } - anyCategorical <- sapply(dataset, function(x) is.numeric(x)) == FALSE - ## in case : is used - if (length(vars) < ncol(dataset)) vars <- colnames(dataset) - if (any(anyCategorical) && distance != "gower") distance <- "gower" - if (labels != "none") { if (length(unique(dataset[[1]])) == nrow(dataset)) { rownames(dataset) <- dataset[[1]] @@ -52,6 +47,11 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian", dataset <- select(dataset, -1) } + anyCategorical <- sapply(dataset, function(x) is.numeric(x)) == FALSE + ## in case : is used + if (length(vars) < ncol(dataset)) vars <- colnames(dataset) + if (any(anyCategorical) && distance != "gower") distance <- "gower" + if (standardize) { dataset <- mutate_if(dataset, is.numeric, ~ as.vector(scale(.))) } @@ -59,7 +59,7 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian", if (distance == "sq.euclidian") { d <- dist(dataset, method = "euclidean")^2 } else if (distance == "gower") { - d <- sapply(1:nrow(dataset), function(i) gower::gower_dist(dataset[i, ], dataset)) %>% + d <- sapply(1:nrow(dataset), function(i) gower::gower_dist(dataset[i, , drop = FALSE], dataset)) %>% as.dist() } else { d <- dist(dataset, method = distance) diff --git a/radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R b/radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R index d1c7bbee48aed783add20bab4d60e285e72c5c48..4a40c82656f2b29d751250b7ae3fe2004f35e1a7 100644 --- a/radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R +++ b/radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R @@ -49,7 +49,7 @@ output$chat_history_area <- renderUI({ return(create_no_data_ui()) } - dify_base_url <- "http://122.112.232.121:8079/chat/pmo9kEMGQVAdv8YR" + dify_base_url <- "http://10.120.120.35/chat/pmo9kEMGQVAdv8YR" dify_url <- paste0( dify_base_url, "?showSidebar=true",