Skip to content

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

update

parent 45915ece
Hide whitespace changes
Inline Side-by-side
Showing with 1469 additions and 885 deletions
Dockerfile
View file @ 73878daa
......@@ -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
......
notice.txt deleted 100644 → 0
View file @ 45915ece
上传模块
devtools::install_local("/home/wuzekai/radiant/radiant.data", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.basics", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.design", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.model", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.multivariate", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant.quickgen", force = TRUE)
devtools::install_local("/home/wuzekai/radiant/radiant-master", force = TRUE)
清理原文件
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.data
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.basics
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.design
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.model
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.multivariate
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant.quickgen
rm -rf /root/miniconda3/envs/radiant/lib/R/library/radiant-master
启动软件
sudo -i
conda activate radiant
cd /home/wuzekai/radiant
R
options(browser = 'false'); radiant::radiant(host='0.0.0.0', port=8105)
杀掉端口
lsof -i :8105
kill -9 <PID>
\ No newline at end of file
radiant-master/inst/translations/translation_zh.csv
View file @ 73878daa
......@@ -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),计数,
radiant.basics/NAMESPACE
View file @ 73878daa
......@@ -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)
......
radiant.basics/R/time_series.R 0 → 100644
View file @ 73878daa
#' 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
radiant.basics/inst/app/init.R
View file @ 73878daa
......@@ -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")),
)
)
)
radiant.basics/inst/app/tools/analysis/time_series_ui.R 0 → 100644
View file @ 73878daa
###############################
## 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
radiant.basics/man/plot.time_series.Rd 0 → 100644
View file @ 73878daa
% 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
}
radiant.basics/man/summary.time_series.Rd 0 → 100644
View file @ 73878daa
% 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
}
radiant.basics/man/time_series.Rd 0 → 100644
View file @ 73878daa
% 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)
}
radiant.data/inst/app/tools/data/init_load_data.R → radiant.data/inst/app/tools/data/ init_load_data.R
View file @ 73878daa
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) # 在控制台打印详细错误堆栈
})
})
}
}
})
radiant.data/inst/app/tools/data/view_ui.R
View file @ 73878daa
#############################################
# 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()
})
radiant.data/inst/app/www/imgs/icon.png
View replaced file @ 45915ece View file @ 73878daa
radiant.data/inst/app/www/imgs/icon.png

80.6 KB | W: | H:

radiant.data/inst/app/www/imgs/icon.png

1.42 MB | W: | H:

radiant.data/inst/app/www/imgs/icon.png
radiant.data/inst/app/www/imgs/icon.png
radiant.data/inst/app/www/imgs/icon.png
radiant.data/inst/app/www/imgs/icon.png
  • 2-up
  • Swipe
  • Onion skin
radiant.data/inst/app/www/style.css
View file @ 73878daa
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;
}
radiant.model/R/coxp.R
View file @ 73878daa
......@@ -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",
......
radiant.model/R/svm.R
View file @ 73878daa
......@@ -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") +
......
radiant.model/inst/app/tools/analysis/coxp_ui.R
View file @ 73878daa
......@@ -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 --------------------------------------------
......
radiant.model/man/coxp.Rd
View file @ 73878daa
......@@ -9,9 +9,9 @@ coxp(
time,
status,
evar,
form = NULL,
int = "",
check = "",
form,
data_filter = "",
arr = "",
rows = NULL,
......
radiant.model/man/predict.svm.Rd
View file @ 73878daa
......@@ -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)
}
radiant.multivariate/R/hclus.R
View file @ 73878daa
......@@ -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)
......
radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R
View file @ 73878daa
......@@ -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",
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment