Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
R
Radiant
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Boards
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
wuzekai
Radiant
Commits
73878daa
Commit
73878daa
authored
Jul 21, 2026
by
wuzekai
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
update
parent
45915ece
Changes
22
Show whitespace changes
Inline
Side-by-side
Showing
22 changed files
with
1469 additions
and
885 deletions
+1469
-885
Dockerfile
Dockerfile
+2
-1
notice.txt
notice.txt
+0
-28
translation_zh.csv
radiant-master/inst/translations/translation_zh.csv
+27
-3
NAMESPACE
radiant.basics/NAMESPACE
+3
-0
time_series.R
radiant.basics/R/time_series.R
+257
-0
init.R
radiant.basics/inst/app/init.R
+3
-1
time_series_ui.R
radiant.basics/inst/app/tools/analysis/time_series_ui.R
+269
-0
time_series.md
radiant.basics/inst/app/tools/help/time_series.md
+1
-0
plot.time_series.Rd
radiant.basics/man/plot.time_series.Rd
+11
-0
summary.time_series.Rd
radiant.basics/man/summary.time_series.Rd
+11
-0
time_series.Rd
radiant.basics/man/time_series.Rd
+46
-0
init_load_data.R
radiant.data/inst/app/tools/data/ init_load_data.R
+185
-182
view_ui.R
radiant.data/inst/app/tools/data/view_ui.R
+330
-330
icon.png
radiant.data/inst/app/www/imgs/icon.png
+0
-0
style.css
radiant.data/inst/app/www/style.css
+257
-257
coxp.R
radiant.model/R/coxp.R
+44
-7
svm.R
radiant.model/R/svm.R
+4
-4
coxp_ui.R
radiant.model/inst/app/tools/analysis/coxp_ui.R
+9
-62
coxp.Rd
radiant.model/man/coxp.Rd
+1
-1
predict.svm.Rd
radiant.model/man/predict.svm.Rd
+2
-2
hclus.R
radiant.multivariate/R/hclus.R
+6
-6
quickgen_chat_ui.R
radiant.quickgen/inst/app/tools/analysis/quickgen_chat_ui.R
+1
-1
No files found.
Dockerfile
View file @
73878daa
...
@@ -23,7 +23,8 @@ RUN R -e "remotes::install_local('/srv/shiny-server/radiant.quickgen',dependenci
...
@@ -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)"
RUN
R
-e
"remotes::install_local('/srv/shiny-server/radiant-master',dependencies=TRUE, type='source', upgrade='never',force=TRUE)"
WORKDIR
/data
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)"]
CMD
["R", "-e", "radiant::radiant(host='0.0.0.0', port=3838)"]
#sudo -i
#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
...
@@ -89,7 +89,7 @@ Spearman,斯皮尔曼秩相关,correlation_ui.R
Kendall,肯德尔秩相关,correlation_ui.R
Kendall,肯德尔秩相关,correlation_ui.R
Calculate correlation,计算相关性,correlation_ui.R
Calculate correlation,计算相关性,correlation_ui.R
Basics > Tables,基础统计 > 表格,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"
Adjust for {factor} variables,针对 {factor} 变量进行调整,"correlation_ui.R,full_factor_ui.R"
Calculate adjusted p.values,计算调整后的 p 值,correlation_ui.R
Calculate adjusted p.values,计算调整后的 p 值,correlation_ui.R
Correlation cutoff:,相关性阈值:,correlation_ui.R
Correlation cutoff:,相关性阈值:,correlation_ui.R
...
@@ -541,8 +541,6 @@ Save factorial design:,保存实验设计:,doe_ui.R
...
@@ -541,8 +541,6 @@ Save factorial design:,保存实验设计:,doe_ui.R
Save factors:,保存因素:,doe_ui.R
Save factors:,保存因素:,doe_ui.R
Design factors:,实验因素,doe_ui.R
Design factors:,实验因素,doe_ui.R
Generated experimental design:,生成的实验设计:,doe.R
Generated experimental design:,生成的实验设计:,doe.R
Level 1:,水平 1:,doe_ui.R
Level 2:,水平 2:,doe_ui.R
Design > DOE,设计 > 实验设计,doe_ui.R
Design > DOE,设计 > 实验设计,doe_ui.R
Design of Experiments,实验设计,"doe_ui.R,init.R"
Design of Experiments,实验设计,"doe_ui.R,init.R"
Variables:,变量:,"randomizer_ui.R, sampling_ui.R,full_factor_ui.R"
Variables:,变量:,"randomizer_ui.R, sampling_ui.R,full_factor_ui.R"
...
@@ -1245,3 +1243,29 @@ Data Quality,数据质量,
...
@@ -1245,3 +1243,29 @@ Data Quality,数据质量,
Select plot types,选择图表类型,
Select plot types,选择图表类型,
Select one or more variables,选择一个或多个变量,
Select one or more variables,选择一个或多个变量,
Missing Value Analysis,缺失值分析,
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)
...
@@ -23,6 +23,7 @@ S3method(plot,prob_tdist)
S3method(plot,prob_unif)
S3method(plot,prob_unif)
S3method(plot,single_mean)
S3method(plot,single_mean)
S3method(plot,single_prop)
S3method(plot,single_prop)
S3method(plot,time_series)
S3method(print,rcorr)
S3method(print,rcorr)
S3method(summary,compare_means)
S3method(summary,compare_means)
S3method(summary,compare_props)
S3method(summary,compare_props)
...
@@ -46,6 +47,7 @@ S3method(summary,prob_tdist)
...
@@ -46,6 +47,7 @@ S3method(summary,prob_tdist)
S3method(summary,prob_unif)
S3method(summary,prob_unif)
S3method(summary,single_mean)
S3method(summary,single_mean)
S3method(summary,single_prop)
S3method(summary,single_prop)
S3method(summary,time_series)
export(clt)
export(clt)
export(compare_means)
export(compare_means)
export(compare_props)
export(compare_props)
...
@@ -78,6 +80,7 @@ export(run_kw)
...
@@ -78,6 +80,7 @@ export(run_kw)
export(run_norm_test)
export(run_norm_test)
export(single_mean)
export(single_mean)
export(single_prop)
export(single_prop)
export(time_series)
import(ggplot2)
import(ggplot2)
import(radiant.data)
import(radiant.data)
import(shiny)
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(
...
@@ -49,7 +49,9 @@ options(
"----"
,
i
18
n
$
t
(
"Tables"
),
"----"
,
i
18
n
$
t
(
"Tables"
),
tabPanel
(
i
18
n
$
t
(
"Goodness of fit"
),
uiOutput
(
"goodness"
)),
tabPanel
(
i
18
n
$
t
(
"Goodness of fit"
),
uiOutput
(
"goodness"
)),
tabPanel
(
i
18
n
$
t
(
"Cross-tabs(Chi-square test, etc)"
),
uiOutput
(
"cross_tabs"
)),
tabPanel
(
i
18
n
$
t
(
"Cross-tabs(Chi-square test, etc)"
),
uiOutput
(
"cross_tabs"
)),
tabPanel
(
i
18
n
$
t
(
"Correlation"
),
uiOutput
(
"correlation"
))
tabPanel
(
i
18
n
$
t
(
"Correlation"
),
uiOutput
(
"correlation"
)),
"----"
,
i
18
n
$
t
(
"Time Series"
),
tabPanel
(
i
18
n
$
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
(
i
18
n
$
t
(
"Moving Average"
),
i
18
n
$
t
(
"Exp. Smoothing"
),
i
18
n
$
t
(
"Autocorrelation"
)
)
# 绘图图层选项(统一用方法1)
ts_plot_opts
<-
c
(
"original"
,
"ma"
,
"ets"
,
"acf"
)
names
(
ts_plot_opts
)
<-
c
(
i
18
n
$
t
(
"Original Data"
),
i
18
n
$
t
(
"Moving Average Line"
),
i
18
n
$
t
(
"Exp. Smoothing Line"
),
i
18
n
$
t
(
"ACF Plot"
)
)
# 聚合粒度选项(统一用方法1)
ts_agg_levels
<-
c
(
"day"
,
"week"
,
"month"
,
"quarter"
,
"year"
)
names
(
ts_agg_levels
)
<-
c
(
i
18
n
$
t
(
"Day"
),
i
18
n
$
t
(
"Week"
),
i
18
n
$
t
(
"Month"
),
i
18
n
$
t
(
"Quarter"
),
i
18
n
$
t
(
"Year"
)
)
# 聚合函数选项(统一用方法1)
ts_agg_funs
<-
c
(
"mean"
,
"sum"
,
"count"
)
names
(
ts_agg_funs
)
<-
c
(
i
18
n
$
t
(
"Mean (Average)"
),
i
18
n
$
t
(
"Sum (Total)"
),
i
18
n
$
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
=
i
18
n
$
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
=
i
18
n
$
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
=
i
18
n
$
t
(
"Interval:"
),
choices
=
ts_agg_levels
,
selected
=
state_single
(
"ts_agg_level"
,
ts_agg_levels
,
"month"
),
multiple
=
FALSE
),
selectInput
(
inputId
=
"ts_agg_fun"
,
label
=
i
18
n
$
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')"
,
h
6
(
"计算方法:"
),
# 选择计算方法
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"
,
i
18
n
$
t
(
"MA Window Size:"
),
value
=
state_init
(
"ts_ma_n"
,
3
),
min
=
2
,
step
=
1
)
),
# 预测参数设置
numericInput
(
inputId
=
"ts_fc_periods"
,
label
=
i
18
n
$
t
(
"Forecast Periods:"
),
value
=
state_init
(
"ts_fc_periods"
,
0
),
min
=
0
,
step
=
1
),
),
# === 绘图图层配置 ===
conditionalPanel
(
condition
=
"input.tabs_time_series == i18n$t('Plot')"
,
h
6
(
"图像:"
),
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
(
i
18
n
$
t
(
"Summary"
),
verbatimTextOutput
(
"summary_time_series"
)),
tabPanel
(
i
18
n
$
t
(
"Plot"
),
download_link
(
"dlp_time_series"
),
plotOutput
(
"plot_time_series"
,
height
=
"100%"
)
)
)
# 构建 Radiant 标准 Tab 面板
stat_tab_panel
(
menu
=
i
18
n
$
t
(
"Basics > Time Series"
),
tool
=
i
18
n
$
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
,
i
18
n
$
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/inst/app/tools/help/time_series.md
0 → 100644
View file @
73878daa
xxxxx
\ 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
...
@@ -55,21 +55,24 @@ download_handler_disease_apply <- function(base_url, id, token, dest_file) {
...
@@ -55,21 +55,24 @@ download_handler_disease_apply <- function(base_url, id, token, dest_file) {
# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
SYSTEM_REGISTRY
<-
list
(
SYSTEM_REGISTRY
<-
list
(
"cric"
=
list
(
"cric"
=
list
(
api_base
=
"https://ds.cixincloud.com/data-search-api"
,
# api_base = "https://ds.cixincloud.com/data-search-api",
api_base
=
"http://10.120.120.34:8300/data-search-api"
,
handler
=
download_handler_cric
,
handler
=
download_handler_cric
,
file_ext
=
".xlsx"
,
file_ext
=
".xlsx"
,
sys_description
=
"大数据检索系统"
sys_description
=
"大数据检索系统"
),
),
"disease_batch"
=
list
(
"disease_batch"
=
list
(
api_base
=
"https://ds.cixincloud.com/disease-api"
,
# api_base = "https://ds.cixincloud.com/disease-api",
api_base
=
"http://10.120.120.34:8300/disease-api"
,
handler
=
download_handler_disease_batch
,
handler
=
download_handler_disease_batch
,
file_ext
=
".xls"
,
# 注意这里是 xls
file_ext
=
".xls"
,
# 注意这里是 xls
sys_description
=
"专病库系统"
sys_description
=
"专病库系统"
),
),
"disease_apply"
=
list
(
"disease_apply"
=
list
(
api_base
=
"https://ds.cixincloud.com/disease-api"
,
# api_base = "https://ds.cixincloud.com/disease-api",
api_base
=
"http://10.120.120.34:8300/disease-api"
,
handler
=
download_handler_disease_apply
,
handler
=
download_handler_disease_apply
,
file_ext
=
".xlsx"
,
file_ext
=
".xlsx"
,
sys_description
=
"专病库系统"
sys_description
=
"专病库系统"
...
...
radiant.data/inst/app/tools/data/view_ui.R
View file @
73878daa
radiant.data/inst/app/www/imgs/icon.png
View replaced file @
45915ece
View file @
73878daa
This diff is collapsed.
Click to expand it.
radiant.data/inst/app/www/style.css
View file @
73878daa
...
@@ -177,7 +177,7 @@ body {
...
@@ -177,7 +177,7 @@ body {
.navbar
{
.navbar
{
margin-bottom
:
5px
;
margin-bottom
:
5px
;
background-color
:
black
;
background-color
:
#325aa5
!important
;
}
}
.navbar
.nav
>
li
>
a
{
.navbar
.nav
>
li
>
a
{
...
...
radiant.model/R/coxp.R
View file @
73878daa
...
@@ -5,9 +5,9 @@ coxp <- function(dataset,
...
@@ -5,9 +5,9 @@ coxp <- function(dataset,
time
,
time
,
status
,
status
,
evar
,
evar
,
form
=
NULL
,
int
=
""
,
int
=
""
,
check
=
""
,
check
=
""
,
form
,
data_filter
=
""
,
data_filter
=
""
,
arr
=
""
,
arr
=
""
,
rows
=
NULL
,
rows
=
NULL
,
...
@@ -35,6 +35,32 @@ coxp <- function(dataset,
...
@@ -35,6 +35,32 @@ coxp <- function(dataset,
df_name
<-
if
(
is_string
(
dataset
))
dataset
else
deparse
(
substitute
(
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
)
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
]]
surv_status
<-
dataset
[[
status
]]
if
(
!
is.numeric
(
surv_status
))
{
if
(
!
is.numeric
(
surv_status
))
{
...
@@ -175,14 +201,25 @@ predict.coxp <- function(object, pred_data = NULL, pred_cmd = "",
...
@@ -175,14 +201,25 @@ predict.coxp <- function(object, pred_data = NULL, pred_cmd = "",
if
(
is.null
(
pred_data
))
{
if
(
is.null
(
pred_data
))
{
newdata
<-
envir
$
.model_frame
%||%
object
$
model
$
model
newdata
<-
envir
$
.model_frame
%||%
object
$
model
$
model
}
else
{
}
else
{
# 获取预测数据集
model_vars
<-
all.vars
(
object
$
model
$
terms
)
newdata
<-
get_data
(
pred_data
,
vars
=
NULL
,
envir
=
envir
)
# 变量存在性校验
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
)
{
if
(
length
(
missing_vars
)
>
0
)
{
return
(
paste0
(
return
(
paste0
(
"All variables in the model must also be in the prediction data\n"
,
"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
...
@@ -738,7 +738,7 @@ varimp <- function(object, rvar = NULL, lev = NULL, data = NULL, seed = 1234, np
#' @export
#' @export
svm_vip_plot
<-
function
(
object
,
size
,
custom
)
{
svm_vip_plot
<-
function
(
object
,
size
,
custom
)
{
tryCatch
({
p
<-
tryCatch
({
vi_scores
<-
varimp
(
vi_scores
<-
varimp
(
object
,
object
,
rvar
=
object
$
rvar
,
rvar
=
object
$
rvar
,
...
@@ -752,14 +752,14 @@ svm_vip_plot <- function(object, size, custom) {
...
@@ -752,14 +752,14 @@ svm_vip_plot <- function(object, size, custom) {
# 检查数据有效性
# 检查数据有效性
if
(
nrow
(
vi_scores
)
==
0
||
all
(
is.na
(
vi_scores
$
Importance
)))
{
if
(
nrow
(
vi_scores
)
==
0
||
all
(
is.na
(
vi_scores
$
Importance
)))
{
p
<-
ggplot
()
+
ggplot
()
+
annotate
(
"text"
,
x
=
0.5
,
y
=
0.5
,
annotate
(
"text"
,
x
=
0.5
,
y
=
0.5
,
label
=
"Could not compute variable importance\n(check model/data)"
,
label
=
"Could not compute variable importance\n(check model/data)"
,
size
=
5
,
color
=
"red"
)
+
size
=
5
,
color
=
"red"
)
+
theme_void
()
theme_void
()
}
else
{
}
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"
)
+
geom_col
(
fill
=
"#377eb8"
)
+
coord_flip
()
+
coord_flip
()
+
labs
(
labs
(
...
@@ -777,7 +777,7 @@ svm_vip_plot <- function(object, size, custom) {
...
@@ -777,7 +777,7 @@ svm_vip_plot <- function(object, size, custom) {
)
)
}
}
},
error
=
function
(
e
)
{
},
error
=
function
(
e
)
{
p
<-
ggplot
()
+
ggplot
()
+
annotate
(
"text"
,
x
=
0.5
,
y
=
0.5
,
annotate
(
"text"
,
x
=
0.5
,
y
=
0.5
,
label
=
paste
(
"Error calculating importance:\n"
,
e
$
message
),
label
=
paste
(
"Error calculating importance:\n"
,
e
$
message
),
size
=
4
,
color
=
"red"
)
+
size
=
4
,
color
=
"red"
)
+
...
...
radiant.model/inst/app/tools/analysis/coxp_ui.R
View file @
73878daa
...
@@ -27,10 +27,9 @@ coxp_inputs <- reactive({
...
@@ -27,10 +27,9 @@ coxp_inputs <- reactive({
args
$
arr
<-
if
(
input
$
show_filter
)
input
$
data_arrange
else
""
args
$
arr
<-
if
(
input
$
show_filter
)
input
$
data_arrange
else
""
args
$
rows
<-
if
(
input
$
show_filter
)
input
$
data_rows
else
""
args
$
rows
<-
if
(
input
$
show_filter
)
input
$
data_rows
else
""
args
$
dataset
<-
input
$
dataset
args
$
dataset
<-
input
$
dataset
## 其余参数手动映射
args
$
time
<-
input
$
coxp_time
for
(
i
in
r_drop
(
names
(
args
)))
{
args
$
status
<-
input
$
coxp_status
args
[[
i
]]
<-
input
[[
paste0
(
"coxp_"
,
i
)]]
args
$
evar
<-
input
$
coxp_evar
}
args
args
})
})
...
@@ -309,63 +308,11 @@ coxp_available <- reactive({
...
@@ -309,63 +308,11 @@ coxp_available <- reactive({
## 10. 模型估计
## 10. 模型估计
.coxp
<-
eventReactive
(
input
$
coxp_run
,
{
.coxp
<-
eventReactive
(
input
$
coxp_run
,
{
ds
<-
tryCatch
(
coxpi
<-
coxp_inputs
()
get_data
(
input
$
dataset
,
vars
=
c
(),
envir
=
r_data
),
coxpi
$
envir
<-
r_data
error
=
function
(
e
)
return
(
paste
(
"数据集获取失败:"
,
e
$
message
))
withProgress
(
message
=
i
18
n
$
t
(
"Estimating model"
),
value
=
1
,
{
)
do.call
(
coxp
,
coxpi
)
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
)
})
})
## 11. summary / predict / plot --------------------------------------------
## 11. summary / predict / plot --------------------------------------------
...
...
radiant.model/man/coxp.Rd
View file @
73878daa
...
@@ -9,9 +9,9 @@ coxp(
...
@@ -9,9 +9,9 @@ coxp(
time,
time,
status,
status,
evar,
evar,
form = NULL,
int = "",
int = "",
check = "",
check = "",
form,
data_filter = "",
data_filter = "",
arr = "",
arr = "",
rows = NULL,
rows = NULL,
...
...
radiant.model/man/predict.svm.Rd
View file @
73878daa
...
@@ -2,7 +2,7 @@
...
@@ -2,7 +2,7 @@
% Please edit documentation in R/svm.R
% Please edit documentation in R/svm.R
\name{predict.svm}
\name{predict.svm}
\alias{predict.svm}
\alias{predict.svm}
\title{Predict method for SVM model}
\title{Predict method for SVM model
(FIXED VERSION)
}
\usage{
\usage{
\method{predict}{svm}(
\method{predict}{svm}(
object,
object,
...
@@ -14,5 +14,5 @@
...
@@ -14,5 +14,5 @@
)
)
}
}
\description{
\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",
...
@@ -37,11 +37,6 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian",
add_class
(
"hclus"
))
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
(
labels
!=
"none"
)
{
if
(
length
(
unique
(
dataset
[[
1
]]))
==
nrow
(
dataset
))
{
if
(
length
(
unique
(
dataset
[[
1
]]))
==
nrow
(
dataset
))
{
rownames
(
dataset
)
<-
dataset
[[
1
]]
rownames
(
dataset
)
<-
dataset
[[
1
]]
...
@@ -52,6 +47,11 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian",
...
@@ -52,6 +47,11 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian",
dataset
<-
select
(
dataset
,
-1
)
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
)
{
if
(
standardize
)
{
dataset
<-
mutate_if
(
dataset
,
is.numeric
,
~
as.vector
(
scale
(
.
)))
dataset
<-
mutate_if
(
dataset
,
is.numeric
,
~
as.vector
(
scale
(
.
)))
}
}
...
@@ -59,7 +59,7 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian",
...
@@ -59,7 +59,7 @@ hclus <- function(dataset, vars, labels = "none", distance = "sq.euclidian",
if
(
distance
==
"sq.euclidian"
)
{
if
(
distance
==
"sq.euclidian"
)
{
d
<-
dist
(
dataset
,
method
=
"euclidean"
)
^
2
d
<-
dist
(
dataset
,
method
=
"euclidean"
)
^
2
}
else
if
(
distance
==
"gower"
)
{
}
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
()
as.dist
()
}
else
{
}
else
{
d
<-
dist
(
dataset
,
method
=
distance
)
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({
...
@@ -49,7 +49,7 @@ output$chat_history_area <- renderUI({
return
(
create_no_data_ui
())
return
(
create_no_data_ui
())
}
}
dify_base_url
<-
"http://1
22.112.232.121:8079
/chat/pmo9kEMGQVAdv8YR"
dify_base_url
<-
"http://1
0.120.120.35
/chat/pmo9kEMGQVAdv8YR"
dify_url
<-
paste0
(
dify_url
<-
paste0
(
dify_base_url
,
dify_base_url
,
"?showSidebar=true"
,
"?showSidebar=true"
,
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment