Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Submit feedback
Contribute to GitLab
Sign in
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
ad60c0cf
Commit
ad60c0cf
authored
Oct 13, 2025
by
wuzekai
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
update
parent
f926635b
Changes
8
Show whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
603 additions
and
286 deletions
+603
-286
server.R
radiant-master/inst/app/server.R
+2
-2
translation_zh.csv
radiant-master/inst/translations/translation_zh.csv
+3
-3
homo_variance_test.md
radiant.basics/inst/app/tools/help/homo_variance_test.md
+19
-0
normality_test.md
radiant.basics/inst/app/tools/help/normality_test.md
+19
-0
stop.R
radiant.data/inst/app/tools/app/stop.R
+1
-1
cox.R
radiant.model/R/cox.R
+316
-30
cox_ui.R
radiant.model/inst/app/tools/analysis/cox_ui.R
+234
-249
quickgen_basic_ui.R
radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
+9
-1
No files found.
radiant-master/inst/app/server.R
View file @
ad60c0cf
...
@@ -55,7 +55,7 @@ shinyServer(function(input, output, session) {
...
@@ -55,7 +55,7 @@ shinyServer(function(input, output, session) {
sidebarLayout
(
sidebarLayout
(
sidebarPanel
(
sidebarPanel
(
help_data_panel
,
help_data_panel
,
help_quickgen_panel
,
# 添加 quickgen 的 help 面板
help_quickgen_panel
,
help_design_panel
,
help_design_panel
,
help_basics_panel
,
help_basics_panel
,
help_model_panel
,
help_model_panel
,
...
@@ -66,7 +66,7 @@ shinyServer(function(input, output, session) {
...
@@ -66,7 +66,7 @@ shinyServer(function(input, output, session) {
mainPanel
(
mainPanel
(
HTML
(
paste0
(
"<h2>Select help files to show and search</h2><hr>"
)),
HTML
(
paste0
(
"<h2>Select help files to show and search</h2><hr>"
)),
htmlOutput
(
"help_data"
),
htmlOutput
(
"help_data"
),
htmlOutput
(
"help_quickgen"
),
# 添加 quickgen 的 help 输出
htmlOutput
(
"help_quickgen"
),
htmlOutput
(
"help_design"
),
htmlOutput
(
"help_design"
),
htmlOutput
(
"help_basics"
),
htmlOutput
(
"help_basics"
),
htmlOutput
(
"help_model"
),
htmlOutput
(
"help_model"
),
...
...
radiant-master/inst/translations/translation_zh.csv
View file @
ad60c0cf
...
@@ -1159,9 +1159,9 @@ Edit the generated R code here...,在此处编辑生成的R代码...,quickgen_ai
...
@@ -1159,9 +1159,9 @@ Edit the generated R code here...,在此处编辑生成的R代码...,quickgen_ai
Normality test,正态性检验,init.R
Normality test,正态性检验,init.R
Homogeneity of variance test,方差齐性检验,init.R
Homogeneity of variance test,方差齐性检验,init.R
Basics > Normality,基础统计 > 正态性,normality_test_ui.R
Basics > Normality,基础统计 > 正态性,normality_test_ui.R
Shapiro-Wilk,
SW
检验,normality_test_ui.R
Shapiro-Wilk,
夏皮罗-威尔克
检验,normality_test_ui.R
Kolmogorov-Smirnov,
K-S
检验,normality_test_ui.R
Kolmogorov-Smirnov,
柯尔莫哥洛夫-斯米尔诺夫
检验,normality_test_ui.R
Anderson-Darling,
AD
检验,normality_test_ui.R
Anderson-Darling,
安德森-达林
检验,normality_test_ui.R
Basics > Homogeneity,基础统计 > 方差齐性,homo_variance_test_ui.R
Basics > Homogeneity,基础统计 > 方差齐性,homo_variance_test_ui.R
Grouping variable:,分组变量:,homo_variance_test_ui.R
Grouping variable:,分组变量:,homo_variance_test_ui.R
Test method:,检验方法:,homo_variance_test_ui.R
Test method:,检验方法:,homo_variance_test_ui.R
...
...
radiant.basics/inst/app/tools/help/homo_variance_test.md
View file @
ad60c0cf
> 方差齐性检验
基于 Levene(莱文检验)、Bartlett(巴特利特检验)、Fligner(弗林格检验)等方差齐性检验方法,对多组数据的总体方差是否相等进行统计推断,为后续其他需要方差齐性假设的参数检验提供适用前提与决策依据。
## Levene(莱文检验)
Levene 检验把每组原始数据先转换成与组内中心距离的绝对值,再对这些绝对偏差做单因素方差分析,只要组间平均偏离程度差异显著,就推断方差不齐;由于使用了离差绝对值,它对偏离正态分布、存在厚尾或异常值的情况非常稳健,样本量不等、分布偏斜时依然能保持较好的检验效能,因此在实验设计和生物统计中被广泛当作默认的方差齐性判断工具。
## Bartlett(巴特利特检验)
Bartlett 检验直接比较各组样本方差的大小,通过计算方差加权平均与几何平均之间的差距来度量齐性,差距越大越倾向拒绝方差齐性假设;它在数据确实来自正态总体时具有最高的检验功效,能够最早发现微小的方差差异,但只要总体稍偏离正态,尤其是出现偏斜或异常值时,容易错误地夸大差异,导致假阳性率升高,因此更适合在已确认正态性的前提下使用。
## Fligner(弗林格检验)
Fligner 检验把每组观测值转换为整体秩次,再对这些秩离差进行类似 Levene 的方差分析,由于整个过程只依赖秩的大小而不涉及具体数值,它对分布形态几乎没有任何要求,即使在严重偏斜、多峰或含有极端值的情况下也能维持稳定的显著性水平,适用于完全不确定分布形状、希望获得稳健结论的探索性分析,但相应地其检测微小方差差异的灵敏度略低于 Bartlett 和 Levene。
\ No newline at end of file
radiant.basics/inst/app/tools/help/normality_test.md
View file @
ad60c0cf
> 正态性检验
基于 Shapiro-Wilk(夏皮罗-威尔克检验)、Kolmogorov-Smirnov(柯尔莫哥洛夫-斯米尔诺夫检验)、Anderson-Darling(安德森-达林检验)等正态性检验方法,对样本数据是否服从正态分布进行统计推断,为后续参数检验或建模方法的选择提供前提依据。
## Shapiro-Wilk(夏皮罗-威尔克检验)
Shapiro-Wilk 检验的核心思路是把样本按大小排序后,用一套专门系数去衡量这些次序统计量与理论正态分位点之间的线性相关程度。如果散点几乎落在一条直线上,就说明数据和正态分布非常吻合;只要出现轻微偏斜、厚尾或者一两个异常值,直线就会弯曲,检验统计量迅速下降,从而在小样本环境下也能高效地捕捉到非正态信号。由于它对各种常见偏离模式都很敏感,学术界普遍把它视为样本量不超过五十时的首选正态性判别工具。
## Kolmogorov-Smirnov(柯尔莫哥洛夫-斯米尔诺夫检验)
Kolmogorov-Smirnov 检验通过把样本的经验分布函数与一条完全确定参数的正态分布曲线全程重叠,寻找两者在垂直方向上的最大差距来判断拟合优劣。这个最大距离越大,说明样本整体越不像正态。其优点在于概念直观、可以一眼看出差异出现在哪个区间,并且不仅限于正态性,还能推广到任意两个分布之间的比较;不过当分布参数需要从样本估计时,必须使用 Lilliefors 修正临界值,否则容易过于宽松,而且它的注意力主要集中在分布中部,对两端的偏离相对迟钝,因此在尾部存在异常值或轻微双峰的情况下,检验功效会低于其他专门针对正态性的方法。
## Anderson-Darling(安德森-达林检验)
Anderson-Darling 检验同样对比经验分布与理论正态曲线,但在计算整体差异时给尾部施加了更高的权重,使得分布两端即使只有轻微偏离也会被迅速放大。这种设计让它对偏斜、双峰、厚尾以及个别极端值极其敏感,特别适合需要重点监控尾部行为的场景,例如质量管理和金融风险评估。由于统计量对异常值反应强烈,在实际应用中建议先对数据进行异常值检查;当样本量处于二十到两百之间时,它在常见正态性检验中通常拥有最高的检验力,能够最早发现隐蔽的非正态特征。
\ No newline at end of file
radiant.data/inst/app/tools/app/stop.R
View file @
ad60c0cf
...
@@ -4,7 +4,7 @@
...
@@ -4,7 +4,7 @@
observeEvent
(
input
$
stop_radiant
,
{
observeEvent
(
input
$
stop_radiant
,
{
shinyalert
::
shinyalert
(
shinyalert
::
shinyalert
(
title
=
"确认停止"
,
title
=
"确认停止"
,
text
=
"停止按钮会将所有
容器
都关闭!确定停止吗?"
,
text
=
"停止按钮会将所有
页面
都关闭!确定停止吗?"
,
type
=
"warning"
,
type
=
"warning"
,
showCancelButton
=
TRUE
,
showCancelButton
=
TRUE
,
confirmButtonCol
=
"#d33"
,
confirmButtonCol
=
"#d33"
,
...
...
radiant.model/R/cox.R
View file @
ad60c0cf
...
@@ -46,7 +46,6 @@ coxp <- function(dataset,
...
@@ -46,7 +46,6 @@ coxp <- function(dataset,
if
(
length
(
lv
)
!=
2
)
{
if
(
length
(
lv
)
!=
2
)
{
return
(
"Status variable must be binary (0/1 or two levels)."
%>%
add_class
(
"coxp"
))
return
(
"Status variable must be binary (0/1 or two levels)."
%>%
add_class
(
"coxp"
))
}
}
## 统一成 0/1:按字母顺序或因子水平,第二个水平当作“事件=1”
dataset
[[
status
]]
<-
as.numeric
(
factor
(
surv_status
,
levels
=
lv
))
-
1L
dataset
[[
status
]]
<-
as.numeric
(
factor
(
surv_status
,
levels
=
lv
))
-
1L
}
else
{
}
else
{
return
(
"Status variable must be numeric 0/1 or binary factor."
%>%
add_class
(
"coxp"
))
return
(
"Status variable must be numeric 0/1 or binary factor."
%>%
add_class
(
"coxp"
))
...
@@ -57,14 +56,12 @@ coxp <- function(dataset,
...
@@ -57,14 +56,12 @@ coxp <- function(dataset,
}
}
}
}
## ---- 构造公式 ----------------------------------------------------------
if
(
missing
(
form
))
{
if
(
missing
(
form
))
{
rhs
<-
if
(
length
(
evar
)
==
0
)
"1"
else
paste
(
evar
,
collapse
=
" + "
)
rhs
<-
if
(
length
(
evar
)
==
0
)
"1"
else
paste
(
evar
,
collapse
=
" + "
)
if
(
!
is.empty
(
int
))
rhs
<-
paste
(
rhs
,
paste
(
int
,
collapse
=
" + "
),
sep
=
" + "
)
if
(
!
is.empty
(
int
))
rhs
<-
paste
(
rhs
,
paste
(
int
,
collapse
=
" + "
),
sep
=
" + "
)
form
<-
as.formula
(
paste
(
"Surv("
,
time
,
", "
,
status
,
") ~ "
,
rhs
))
form
<-
as.formula
(
paste
(
"Surv("
,
time
,
", "
,
status
,
") ~ "
,
rhs
))
}
}
## ---- 模型估计 ----------------------------------------------------------
if
(
"robust"
%in%
check
)
{
if
(
"robust"
%in%
check
)
{
model
<-
survival
::
coxph
(
form
,
data
=
dataset
,
robust
=
TRUE
)
model
<-
survival
::
coxph
(
form
,
data
=
dataset
,
robust
=
TRUE
)
}
else
{
}
else
{
...
@@ -80,12 +77,14 @@ coxp <- function(dataset,
...
@@ -80,12 +77,14 @@ coxp <- function(dataset,
coef_df
<-
broom
::
tidy
(
model
,
conf.int
=
TRUE
)
# 系数、HR、CI、p
coef_df
<-
broom
::
tidy
(
model
,
conf.int
=
TRUE
)
# 系数、HR、CI、p
n
<-
nrow
(
dataset
)
# 样本量
n
<-
nrow
(
dataset
)
# 样本量
n_event
<-
sum
(
dataset
[[
status
]])
# 事件数
n_event
<-
sum
(
dataset
[[
status
]])
# 事件数
conc
<-
survival
::
survConcordance.fit
(
y
=
Surv
(
dataset
[[
time
]],
dataset
[[
status
]]),
conc
<-
tryCatch
(
x
=
predict
(
model
,
type
=
"lp"
))
$
concordance
survival
::
concordancefit
(
y
=
Surv
(
dataset
[[
time
]],
dataset
[[
status
]]),
cat
(
"coef:"
,
length
(
coef
(
model
)),
" n="
,
nrow
(
dataset
),
x
=
predict
(
model
,
type
=
"lp"
),
" events="
,
sum
(
dataset
[[
status
]]),
"\n"
)
data
=
dataset
)
$
concordance
,
error
=
function
(
e
)
NA
)
## 打包返回
## 打包返回
out
<-
as.list
(
environment
())
out
<-
as.list
(
environment
())
out
$
model
<-
model
out
$
model
<-
model
...
@@ -101,49 +100,336 @@ coxp <- function(dataset,
...
@@ -101,49 +100,336 @@ coxp <- function(dataset,
}
}
#' @export
#' @export
summary.coxp
<-
function
(
object
,
...
)
{
summary.coxp
<-
function
(
object
,
dec
=
3
,
...
)
{
if
(
is.character
(
object
))
return
(
object
)
if
(
is.character
(
object
))
{
# 检查模型对象有效性
cat
(
object
,
"\n"
)
return
(
invisible
(
object
))
}
if
(
!
inherits
(
object
$
model
,
"coxph"
))
{
if
(
!
inherits
(
object
$
model
,
"coxph"
))
{
cat
(
"** Invalid Cox model object. **\n"
)
cat
(
"** Invalid Cox model object. **\n"
)
return
(
invisible
(
object
))
return
(
invisible
(
object
))
}
}
# 输出基础信息
cat
(
"Cox Proportional Hazards\n"
)
## 基础模型信息
cat
(
"Data:"
,
object
$
df_name
,
" N="
,
object
$
n
,
" Events="
,
object
$
n_event
,
"\n"
)
cat
(
"Cox Proportional Hazards Regression\n"
)
cat
(
"Concordance="
,
round
(
object
$
concordance
,
3
),
"\n\n"
)
cat
(
"Data:"
,
object
$
df_name
,
"\n"
)
# 输出模型summary
if
(
!
is.empty
(
object
$
data_filter
))
{
summary
(
object
$
model
)
cat
(
"Filter:"
,
gsub
(
"\\n"
,
""
,
object
$
data_filter
),
"\n"
)
}
if
(
!
is.empty
(
object
$
arr
))
{
cat
(
"Arrange:"
,
gsub
(
"\\n"
,
""
,
object
$
arr
),
"\n"
)
}
if
(
!
is.empty
(
object
$
rows
))
{
cat
(
"Slice:"
,
gsub
(
"\\n"
,
""
,
object
$
rows
),
"\n"
)
}
cat
(
"Time variable :"
,
object
$
time
,
"\n"
)
cat
(
"Status variable :"
,
object
$
status
,
"\n"
)
cat
(
"Explanatory vars:"
,
paste
(
object
$
evar
,
collapse
=
", "
),
"\n"
)
cat
(
"N ="
,
object
$
n
,
", Events ="
,
object
$
n_event
,
"\n"
)
cat
(
"Concordance ="
,
sprintf
(
"%.3f"
,
object
$
concordance
),
"\n\n"
)
## 系数表
coef_df
<-
object
$
coef_df
coef_df
$
sig_star
<-
sig_stars
(
coef_df
$
p.value
)
%>%
format
(
justify
=
"left"
)
coef_df
$
label
<-
rownames
(
coef_df
)
## 格式化输出
coeff
<-
coef_df
%>%
mutate
(
HR
=
sprintf
(
"%.3f"
,
exp
(
estimate
)),
`HR.low`
=
sprintf
(
"%.3f"
,
exp
(
conf.low
)),
`HR.high`
=
sprintf
(
"%.3f"
,
exp
(
conf.high
)),
coef
=
sprintf
(
"%.3f"
,
estimate
),
se
=
sprintf
(
"%.3f"
,
std.error
),
z
=
sprintf
(
"%.3f"
,
statistic
),
p
=
ifelse
(
p.value
<
.001
,
"< .001"
,
sprintf
(
"%.3f"
,
p.value
))
)
%>%
select
(
label
,
coef
,
se
,
z
,
p
,
sig_star
,
HR
,
HR.low
,
HR.high
)
colnames
(
coeff
)
<-
c
(
" "
,
"Coef"
,
"SE"
,
"z"
,
"p"
,
" "
,
"HR"
,
"HR.lower"
,
"HR.upper"
)
print.data.frame
(
coeff
,
row.names
=
FALSE
)
cat
(
"\nSignif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1\n\n"
)
## 模型检验
sm
<-
summary
(
object
$
model
)
cat
(
"Likelihood ratio test ="
,
sprintf
(
"%.2f"
,
sm
$
logtest
[
1
]),
"on"
,
sm
$
logtest
[
2
],
"df, p ="
,
ifelse
(
sm
$
logtest
[
3
]
<
.0001
,
"< .0001"
,
sprintf
(
"%.4f"
,
sm
$
logtest
[
3
])),
"\n"
)
cat
(
"Wald test ="
,
sprintf
(
"%.2f"
,
sm
$
waldtest
[
1
]),
"on"
,
sm
$
waldtest
[
2
],
"df, p ="
,
ifelse
(
sm
$
waldtest
[
3
]
<
.0001
,
"< .0001"
,
sprintf
(
"%.4f"
,
sm
$
waldtest
[
3
])),
"\n"
)
cat
(
"Score (logrank) test ="
,
sprintf
(
"%.2f"
,
sm
$
sctest
[
1
]),
"on"
,
sm
$
sctest
[
2
],
"df, p ="
,
ifelse
(
sm
$
sctest
[
3
]
<
.0001
,
"< .0001"
,
sprintf
(
"%.4f"
,
sm
$
sctest
[
3
])),
"\n"
)
invisible
(
object
)
invisible
(
object
)
}
}
#' @export
#' @export
predict.coxp
<-
function
(
object
,
pred_data
=
NULL
,
pred_cmd
=
""
,
predict.coxp
<-
function
(
object
,
pred_data
=
NULL
,
pred_cmd
=
""
,
dec
=
3
,
envir
=
parent.frame
(),
...
)
{
conf_lev
=
0.95
,
dec
=
3
,
envir
=
parent.frame
(),
...
)
{
if
(
is.character
(
object
))
return
(
object
)
if
(
is.character
(
object
))
return
(
object
)
#
# 构造预测数据框
#
1. 构造预测数据
if
(
is.null
(
pred_data
))
{
if
(
is.null
(
pred_data
))
{
newdata
<-
envir
$
.model_frame
# 若无新数据,默认用训练集
newdata
<-
envir
$
.model_frame
%||%
object
$
model
$
model
}
else
{
}
else
{
newdata
<-
get_data
(
pred_data
,
envir
=
envir
)
# 获取预测数据集(只取模型需要的变量,但先全取以便校验)
newdata
<-
get_data
(
pred_data
,
vars
=
NULL
,
envir
=
envir
)
# 变量存在性校验
model_evar
<-
object
$
evar
# 模型使用的解释变量
pred_cols
<-
colnames
(
newdata
)
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"
,
"Variables in the model: "
,
paste
(
model_evar
,
collapse
=
", "
),
"\n"
,
"Variables not available in prediction data: "
,
paste
(
missing_vars
,
collapse
=
", "
)
)
%>%
add_class
(
"coxp.predict"
))
}
newdata
<-
newdata
[,
model_evar
,
drop
=
FALSE
]
}
}
# 2. 应用 pred_cmd
if
(
!
is.empty
(
pred_cmd
))
{
if
(
!
is.empty
(
pred_cmd
))
{
newdata
<-
modify_data
(
newdata
,
pred_cmd
,
envir
=
envir
)
newdata
<-
modify_data
(
newdata
,
pred_cmd
,
envir
=
envir
)
}
}
## 线性预测值 + HR
# 3. 过滤全NA的列
lp
<-
predict
(
object
$
model
,
newdata
=
newdata
,
type
=
"lp"
)
newdata
<-
newdata
[,
colSums
(
is.na
(
newdata
))
!=
nrow
(
newdata
),
drop
=
FALSE
]
hr
<-
exp
(
lp
)
if
(
ncol
(
newdata
)
==
0
&&
length
(
object
$
evar
)
>
0
)
{
res
<-
data.frame
(
lp
=
round
(
lp
,
dec
),
hr
=
round
(
hr
,
dec
))
return
(
paste
(
"预测数据中无有效解释变量列(需包含:"
,
paste
(
object
$
evar
,
collapse
=
", "
),
")"
)
%>%
add_class
(
"coxp.predict"
))
attr
(
res
,
"pred_type"
)
<-
"linear predictor & hazard ratio"
}
res
# 4. 核心预测计算
pred_cox
<-
predict
(
object
$
model
,
newdata
=
newdata
,
type
=
"lp"
,
se.fit
=
TRUE
)
z_val
<-
qnorm
((
1
+
conf_lev
)
/
2
)
lp_lower
<-
pred_cox
$
fit
-
z_val
*
pred_cox
$
se.fit
lp_upper
<-
pred_cox
$
fit
+
z_val
*
pred_cox
$
se.fit
hr
<-
exp
(
pred_cox
$
fit
)
hr_lower
<-
exp
(
lp_lower
)
hr_upper
<-
exp
(
lp_upper
)
# 5. 构建结果数据框
pred_result
<-
data.frame
(
lp
=
round
(
pred_cox
$
fit
,
dec
),
HR
=
round
(
hr
,
dec
),
lp_lower
=
round
(
lp_lower
,
dec
),
lp_upper
=
round
(
lp_upper
,
dec
),
HR_lower
=
round
(
hr_lower
,
dec
),
HR_upper
=
round
(
hr_upper
,
dec
),
check.names
=
FALSE
,
stringsAsFactors
=
FALSE
)
pred_full
<-
cbind
(
newdata
,
pred_result
)
# 6. 添加元信息
pred_full
<-
pred_full
%>%
radiant.data
::
set_attr
(
"radiant_df_name"
,
object
$
df_name
)
%>%
radiant.data
::
set_attr
(
"radiant_time"
,
object
$
time
)
%>%
radiant.data
::
set_attr
(
"radiant_status"
,
object
$
status
)
%>%
radiant.data
::
set_attr
(
"radiant_evar_actual"
,
colnames
(
newdata
))
%>%
radiant.data
::
set_attr
(
"radiant_conf_lev"
,
conf_lev
)
%>%
radiant.data
::
set_attr
(
"radiant_dec"
,
dec
)
%>%
add_class
(
c
(
"coxp.predict"
,
"model.predict"
))
return
(
pred_full
)
}
}
#' @export
#' @export
print.coxp.predict
<-
function
(
x
,
...
,
n
=
10
)
{
print.coxp.predict
<-
function
(
x
,
...
,
n
=
10
)
{
cat
(
"Cox PH predictions (linear predictor & hazard ratio):\n"
)
if
(
is.character
(
x
))
{
print
(
head
(
x
,
n
))
cat
(
x
,
"\n"
)
return
(
invisible
(
x
))
}
# 转为数据框
x_df
<-
as.data.frame
(
x
,
stringsAsFactors
=
FALSE
)
df_name
<-
attr
(
x_df
,
"radiant_df_name"
)
%||%
"Unknown"
time_var
<-
attr
(
x_df
,
"radiant_time"
)
%||%
"Unknown"
status_var
<-
attr
(
x_df
,
"radiant_status"
)
%||%
"Unknown"
conf_lev
<-
attr
(
x_df
,
"radiant_conf_lev"
)
%||%
0.95
dec
<-
attr
(
x_df
,
"radiant_dec"
)
%||%
3
ci_perc
<-
paste0
(
c
(
round
((
1
-
conf_lev
)
/
2
*
100
,
1
),
round
((
1
+
conf_lev
)
/
2
*
100
,
1
)),
"%"
)
total_cols
<-
ncol
(
x_df
)
result_count
<-
6
if
(
total_cols
<
result_count
)
{
cat
(
"Error: Not enough columns for prediction results (need at least 6 result columns).\n"
)
return
(
invisible
(
x
))
}
evar_count_actual
<-
total_cols
-
result_count
evar_cols_actual
<-
colnames
(
x_df
)[
1
:
evar_count_actual
]
new_result_names
<-
c
(
"lp"
,
"HR"
,
ci_perc
[
1
],
ci_perc
[
2
],
paste0
(
"HR_"
,
ci_perc
[
1
]),
paste0
(
"HR_"
,
ci_perc
[
2
])
)
# 拼接完整列名向量
new_colnames
<-
c
(
evar_cols_actual
,
new_result_names
)
# 最终校验
if
(
length
(
new_colnames
)
!=
total_cols
)
{
cat
(
"Error: Column name length mismatch.\n"
)
cat
(
"Total columns:"
,
total_cols
,
"\n"
)
cat
(
"Constructed names:"
,
length
(
new_colnames
),
"\n"
)
cat
(
"evar_cols_actual:"
,
paste
(
evar_cols_actual
,
collapse
=
", "
),
"\n"
)
cat
(
"new_result_names:"
,
paste
(
new_result_names
,
collapse
=
", "
),
"\n"
)
return
(
invisible
(
x
))
}
# 应用新列名
colnames
(
x_df
)
<-
new_colnames
cat
(
"Cox Proportional Hazards Regression\n"
)
cat
(
"Data :"
,
df_name
,
"\n"
)
cat
(
"Time variable :"
,
time_var
,
"\n"
)
cat
(
"Status variable :"
,
status_var
,
"\n"
)
cat
(
"Explanatory variables:"
,
if
(
length
(
evar_cols_actual
)
>
0
)
paste
(
evar_cols_actual
,
collapse
=
", "
)
else
"None"
,
"\n"
)
cat
(
"Confidence level :"
,
paste0
(
conf_lev
*
100
,
"%"
),
"\n"
)
cat
(
"Total columns :"
,
total_cols
,
"(Explanatory:"
,
evar_count_actual
,
", Result:"
,
result_count
,
")\n"
)
total_rows
<-
nrow
(
x_df
)
if
(
n
==
-1
||
total_rows
<=
n
)
{
cat
(
"Rows shown :"
,
total_rows
,
"of"
,
total_rows
,
"\n"
)
out_df
<-
x_df
}
else
{
cat
(
"Rows shown :"
,
n
,
"of"
,
total_rows
,
"\n"
)
out_df
<-
head
(
x_df
,
n
)
}
cat
(
"\n"
)
# 格式化数值列
numeric_cols
<-
(
evar_count_actual
+
1
)
:
total_cols
if
(
length
(
numeric_cols
)
>
0
)
{
out_df
[,
numeric_cols
]
<-
lapply
(
out_df
[,
numeric_cols
,
drop
=
FALSE
],
function
(
col
)
{
sprintf
(
paste0
(
"%."
,
dec
,
"f"
),
as.numeric
(
col
))
})
}
print
(
out_df
,
row.names
=
FALSE
)
invisible
(
x
)
invisible
(
x
)
}
}
#' @export
store.coxp.predict
<-
function
(
dataset
,
object
,
name
=
"hr"
,
...
)
{
if
(
is.empty
(
name
))
name
<-
"hr"
name
<-
unlist
(
strsplit
(
name
,
"(\\s*,\\s*|\\s*;\\s*|\\s+)"
))
%>%
gsub
(
"\\s"
,
""
,
.
)
%>%
.
[
1
]
pred_col
<-
"HR"
if
(
!
pred_col
%in%
colnames
(
object
))
{
stop
(
"Prediction column 'HR' not found in prediction object."
)
}
pred_df
<-
object
[,
pred_col
,
drop
=
FALSE
]
colnames
(
pred_df
)
<-
name
evar_actual
<-
attr
(
object
,
"radiant_evar_actual"
)
%||%
attr
(
object
,
"radiant_evar"
)
%||%
character
(
0
)
indr
<-
indexr
(
dataset
,
vars
=
evar_actual
,
filt
=
""
,
rows
=
NULL
,
cmd
=
attr
(
object
,
"radiant_pred_cmd"
))
out_df
<-
as.data.frame
(
matrix
(
NA
,
nrow
=
nrow
(
dataset
),
ncol
=
1
),
stringsAsFactors
=
FALSE
)
out_df
[
indr
$
ind
,
1
]
<-
pred_df
[[
1
]]
colnames
(
out_df
)
<-
name
dataset
[,
name
]
<-
out_df
dataset
}
#' @export
plot.coxp
<-
function
(
x
,
plots
=
"none"
,
incl
=
NULL
,
incl_int
=
NULL
,
conf_lev
=
0.95
,
intercept
=
FALSE
,
shiny
=
FALSE
,
custom
=
FALSE
,
...
)
{
if
(
is.character
(
x
))
return
(
x
)
if
(
is.empty
(
plots
)
||
plots
==
"none"
)
return
(
invisible
())
plot_list
<-
list
()
if
(
"coef"
%in%
plots
)
{
# 提取系数和 CI
coef_df
<-
broom
::
tidy
(
x
$
model
,
conf.int
=
TRUE
,
conf.level
=
conf_lev
)
coef_df
$
hr
<-
exp
(
coef_df
$
estimate
)
coef_df
$
hr_low
<-
exp
(
coef_df
$
conf.low
)
coef_df
$
hr_high
<-
exp
(
coef_df
$
conf.high
)
coef_df
$
term
<-
coef_df
$
term
if
(
!
intercept
)
{
coef_df
<-
coef_df
[
!
grepl
(
"Intercept"
,
coef_df
$
term
),
]
}
if
(
length
(
incl
)
>
0
)
{
incl_regex
<-
paste0
(
"^("
,
paste
(
incl
,
collapse
=
"|"
),
")"
)
coef_df
<-
coef_df
[
grepl
(
incl_regex
,
coef_df
$
term
),
]
}
if
(
nrow
(
coef_df
)
==
0
)
{
plot_list
[[
"coef"
]]
<-
"** No coefficients to plot **"
}
else
{
p
<-
ggplot
(
coef_df
,
aes
(
x
=
term
,
y
=
hr
,
ymin
=
hr_low
,
ymax
=
hr_high
))
+
geom_pointrange
()
+
geom_hline
(
yintercept
=
1
,
linetype
=
"dashed"
,
color
=
"red"
)
+
scale_x_discrete
(
limits
=
rev
)
+
coord_flip
()
+
labs
(
x
=
""
,
y
=
"Hazard Ratio (HR)"
,
title
=
"Coefficient Plot (HR)"
)
plot_list
[[
"coef"
]]
<-
p
}
}
if
(
"dist"
%in%
plots
)
{
data
<-
x
$
model
$
model
vars
<-
c
(
x
$
time
,
x
$
status
,
x
$
evar
)
for
(
v
in
vars
)
{
if
(
v
%in%
colnames
(
data
))
{
p
<-
visualize
(
data
,
xvar
=
v
,
bins
=
30
,
custom
=
TRUE
)
plot_list
[[
paste0
(
"dist_"
,
v
)]]
<-
p
}
}
}
if
(
"vip"
%in%
plots
)
{
coef_df
<-
broom
::
tidy
(
x
$
model
)
coef_df
$
Importance
<-
abs
(
coef_df
$
estimate
)
coef_df
<-
coef_df
[
order
(
coef_df
$
Importance
,
decreasing
=
TRUE
),
]
p
<-
visualize
(
coef_df
,
xvar
=
"term"
,
yvar
=
"Importance"
,
type
=
"bar"
,
custom
=
TRUE
)
+
coord_flip
()
+
labs
(
title
=
"Variable Importance (|coef|)"
)
plot_list
[[
"vip"
]]
<-
p
}
if
(
"pdp"
%in%
plots
||
"pred_plot"
%in%
plots
)
{
plot_list
[[
"pdp"
]]
<-
"** PDP not yet implemented for Cox **"
}
if
(
"influence"
%in%
plots
)
{
plot_list
[[
"influence"
]]
<-
"** Influence plot not yet implemented **"
}
# 输出
if
(
length
(
plot_list
)
==
0
)
return
(
invisible
())
if
(
custom
)
{
if
(
length
(
plot_list
)
==
1
)
return
(
plot_list
[[
1
]])
else
return
(
plot_list
)
}
else
{
patchwork
::
wrap_plots
(
plot_list
,
ncol
=
2
)
%>%
(
function
(
x
)
if
(
isTRUE
(
shiny
))
x
else
print
(
x
))
}
}
\ No newline at end of file
radiant.model/inst/app/tools/analysis/cox_ui.R
View file @
ad60c0cf
## ========== coxp_ui.R ==========
## ========== coxp_ui.R ==========
## 1. 常量 -----------------------------------------------------------------
## 1. 常量 -----------------------------------------------------------------
coxp_show_interactions
<-
setNames
(
c
(
""
,
2
,
3
),
c
(
i
18
n
$
t
(
"None"
),
i
18
n
$
t
(
"2-way"
),
i
18
n
$
t
(
"3-way"
)))
coxp_predict
<-
setNames
(
c
(
"none"
,
"data"
,
"cmd"
,
"datacmd"
),
coxp_predict
<-
setNames
(
c
(
"none"
,
"data"
,
"cmd"
,
"datacmd"
),
c
(
i
18
n
$
t
(
"None"
),
i
18
n
$
t
(
"Data"
),
i
18
n
$
t
(
"Command"
),
i
18
n
$
t
(
"Data & Command"
)))
c
(
i
18
n
$
t
(
"None"
),
i
18
n
$
t
(
"Data"
),
i
18
n
$
t
(
"Command"
),
i
18
n
$
t
(
"Data & Command"
)))
coxp_check
<-
setNames
(
c
(
"robust"
),
c
(
i
18
n
$
t
(
"Robust"
)))
coxp_sum_check
<-
setNames
(
c
(
"rmse"
,
"confint"
),
c
(
i
18
n
$
t
(
"RMSE"
),
i
18
n
$
t
(
"Confidence intervals"
)))
coxp_lines
<-
setNames
(
c
(
"line"
,
"loess"
,
"jitter"
),
coxp_lines
<-
setNames
(
c
(
"line"
,
"loess"
,
"jitter"
),
c
(
i
18
n
$
t
(
"Line"
),
i
18
n
$
t
(
"Loess"
),
i
18
n
$
t
(
"Jitter"
)))
c
(
i
18
n
$
t
(
"Line"
),
i
18
n
$
t
(
"Loess"
),
i
18
n
$
t
(
"Jitter"
)))
coxp_plots
<-
setNames
(
coxp_plots
<-
setNames
(
c
(
"none"
,
"dist"
,
"
correlations"
,
"scatter"
,
"vip"
,
"pred_plot"
,
"pdp"
,
"dashboard"
,
"resid_pred
"
,
"coef"
,
"influence"
),
c
(
"none"
,
"dist"
,
"
vip"
,
"pred_plot"
,
"pdp
"
,
"coef"
,
"influence"
),
c
(
i
18
n
$
t
(
"None"
),
i
18
n
$
t
(
"Distribution"
),
i
18
n
$
t
(
"Correlations"
),
c
(
i
18
n
$
t
(
"None"
),
i
18
n
$
t
(
"Distribution"
),
i
18
n
$
t
(
"
Scatter"
),
i
18
n
$
t
(
"
Permutation Importance"
),
i
18
n
$
t
(
"Prediction plots"
),
i
18
n
$
t
(
"Permutation Importance"
),
i
18
n
$
t
(
"Prediction plots"
),
i
18
n
$
t
(
"Partial Dependence"
),
i
18
n
$
t
(
"
Dashboard"
),
i
18
n
$
t
(
"Residual vs explanatory"
),
i
18
n
$
t
(
"Partial Dependence"
),
i
18
n
$
t
(
"
Coefficient plot"
),
i
18
n
$
t
(
"
Coefficient plot"
),
i
18
n
$
t
(
"
Influential observations"
))
i
18
n
$
t
(
"Influential observations"
))
)
)
## 2. 参数收集 -------------------------------------------------------------
## 2. 参数收集 -------------------------------------------------------------
coxp_args
<-
list
()
coxp_args
<-
list
()
coxp_sum_args
<-
list
()
coxp_plot_args
<-
list
()
coxp_plot_args
<-
list
()
coxp_pred_args
<-
list
()
coxp_pred_args
<-
list
()
coxp_pred_plot_args
<-
list
()
## 输入收集 reactive
## 输入收集 reactive
coxp_inputs
<-
reactive
({
coxp_inputs
<-
reactive
({
...
@@ -44,17 +35,14 @@ coxp_inputs <- reactive({
...
@@ -44,17 +35,14 @@ coxp_inputs <- reactive({
args
args
})
})
coxp_sum_inputs
<-
reactive
({
args
<-
coxp_sum_args
for
(
i
in
names
(
args
))
args
[[
i
]]
<-
input
[[
paste0
(
"coxp_"
,
i
)]]
args
})
coxp_plot_inputs
<-
reactive
({
list
()
})
coxp_plot_inputs
<-
reactive
({
list
()
})
coxp_pred_inputs
<-
reactive
({
coxp_pred_inputs
<-
reactive
({
args
<-
coxp_pred_args
args
<-
coxp_pred_args
# 收集所有预测参数(含新增的coxp_conf_lev)
for
(
i
in
names
(
args
))
args
[[
i
]]
<-
input
[[
paste0
(
"coxp_"
,
i
)]]
for
(
i
in
names
(
args
))
args
[[
i
]]
<-
input
[[
paste0
(
"coxp_"
,
i
)]]
# 处理预测数据/命令(保留原有逻辑)
args
$
pred_cmd
<-
""
args
$
pred_cmd
<-
""
args
$
pred_data
<-
""
args
$
pred_data
<-
""
if
(
input
$
coxp_predict
==
"cmd"
)
{
if
(
input
$
coxp_predict
==
"cmd"
)
{
...
@@ -67,10 +55,12 @@ coxp_pred_inputs <- reactive({
...
@@ -67,10 +55,12 @@ coxp_pred_inputs <- reactive({
gsub
(
";\\s+"
,
";"
,
.
)
%>%
gsub
(
"\""
,
"\'"
,
.
)
gsub
(
";\\s+"
,
";"
,
.
)
%>%
gsub
(
"\""
,
"\'"
,
.
)
args
$
pred_data
<-
input
$
coxp_pred_data
args
$
pred_data
<-
input
$
coxp_pred_data
}
}
args
})
coxp_pred_plot_inputs
<-
reactive
({
list
()
})
args
$
conf_lev
<-
input
$
coxp_conf_lev
%||%
0.95
args
$
dec
<-
3
return
(
args
)
})
## 3. 变量选择 UI ----------------------------------------------------------
## 3. 变量选择 UI ----------------------------------------------------------
output
$
ui_coxp_time
<-
renderUI
({
output
$
ui_coxp_time
<-
renderUI
({
...
@@ -131,52 +121,12 @@ output$ui_coxp_incl_int <- renderUI({
...
@@ -131,52 +121,12 @@ output$ui_coxp_incl_int <- renderUI({
)
)
})
})
output
$
ui_coxp_test_var
<-
renderUI
({
## 5. 预测 / 绘图 / 刷新按钮 ----------------------------------------------
req
(
available
(
input
$
coxp_evar
))
vars
<-
input
$
coxp_evar
if
(
!
is.null
(
input
$
coxp_int
))
vars
<-
c
(
vars
,
input
$
coxp_int
)
selectizeInput
(
"coxp_test_var"
,
i
18
n
$
t
(
"Variables to test:"
),
choices
=
vars
,
selected
=
state_multiple
(
"coxp_test_var"
,
vars
),
multiple
=
TRUE
,
options
=
list
(
placeholder
=
i
18
n
$
t
(
"None"
),
plugins
=
list
(
"remove_button"
)))
})
## 5. 交互选择 ------------------------------------------------------------
output
$
ui_coxp_show_interactions
<-
renderUI
({
vars
<-
input
$
coxp_evar
isNum
<-
.get_class
()
%in%
c
(
"integer"
,
"numeric"
,
"ts"
)
if
(
any
(
vars
%in%
varnames
()[
isNum
]))
{
choices
<-
coxp_show_interactions
[
1
:
3
]
}
else
{
choices
<-
coxp_show_interactions
[
1
:
max
(
min
(
3
,
length
(
input
$
coxp_evar
)),
1
)]
}
radioButtons
(
"coxp_show_interactions"
,
i
18
n
$
t
(
"Interactions:"
),
choices
=
choices
,
selected
=
state_init
(
"coxp_show_interactions"
),
inline
=
TRUE
)
})
output
$
ui_coxp_int
<-
renderUI
({
choices
<-
character
(
0
)
if
(
is.empty
(
input
$
coxp_show_interactions
))
return
()
vars
<-
input
$
coxp_evar
if
(
not_available
(
vars
))
return
()
isNum
<-
intersect
(
vars
,
varnames
()[
.get_class
()
%in%
c
(
"integer"
,
"numeric"
,
"ts"
)])
if
(
length
(
isNum
)
>
0
)
choices
<-
qterms
(
isNum
,
input
$
coxp_show_interactions
)
if
(
length
(
vars
)
>
1
)
choices
<-
c
(
choices
,
iterms
(
vars
,
input
$
coxp_show_interactions
))
if
(
length
(
choices
)
==
0
)
return
()
selectInput
(
"coxp_int"
,
label
=
NULL
,
choices
=
choices
,
selected
=
state_init
(
"coxp_int"
),
multiple
=
TRUE
,
size
=
min
(
8
,
length
(
choices
)),
selectize
=
FALSE
)
})
## 6. 预测 / 绘图 / 刷新按钮 ----------------------------------------------
observeEvent
(
input
$
dataset
,
{
observeEvent
(
input
$
dataset
,
{
updateSelectInput
(
session
,
"coxp_predict"
,
selected
=
"none"
)
updateSelectInput
(
session
,
"coxp_predict"
,
selected
=
"none"
)
updateSelectInput
(
session
,
"coxp_plots"
,
selected
=
"none"
)
updateSelectInput
(
session
,
"coxp_plots"
,
selected
=
"none"
)
})
})
output
$
ui_coxp_predict_plot
<-
renderUI
({
predict_plot_controls
(
"coxp"
)
})
output
$
ui_coxp_nrobs
<-
renderUI
({
output
$
ui_coxp_nrobs
<-
renderUI
({
nrobs
<-
nrow
(
.get_data
())
nrobs
<-
nrow
(
.get_data
())
choices
<-
c
(
"1,000"
=
1000
,
"5,000"
=
5000
,
"10,000"
=
10000
,
"All"
=
-1
)
%>%
.
[
.
<
nrobs
]
choices
<-
c
(
"1,000"
=
1000
,
"5,000"
=
5000
,
"10,000"
=
10000
,
"All"
=
-1
)
%>%
.
[
.
<
nrobs
]
...
@@ -184,14 +134,9 @@ output$ui_coxp_nrobs <- renderUI({
...
@@ -184,14 +134,9 @@ output$ui_coxp_nrobs <- renderUI({
choices
=
choices
,
selected
=
state_single
(
"coxp_nrobs"
,
choices
,
1000
))
choices
=
choices
,
selected
=
state_single
(
"coxp_nrobs"
,
choices
,
1000
))
})
})
output
$
ui_coxp_store_res_name
<-
renderUI
({
req
(
input
$
dataset
)
textInput
(
"coxp_store_res_name"
,
i
18
n
$
t
(
"Store residuals:"
),
""
,
placeholder
=
i
18
n
$
t
(
"Provide variable name"
))
})
run_refresh
(
coxp_args
,
"coxp"
,
tabs
=
"tabs_coxp"
,
label
=
i
18
n
$
t
(
"Estimate model"
),
relabel
=
i
18
n
$
t
(
"Re-estimate model"
))
run_refresh
(
coxp_args
,
"coxp"
,
tabs
=
"tabs_coxp"
,
label
=
i
18
n
$
t
(
"Estimate model"
),
relabel
=
i
18
n
$
t
(
"Re-estimate model"
))
##
7
. 主 UI ----------------------------------------------------------------
##
6
. 主 UI ----------------------------------------------------------------
output
$
ui_coxp
<-
renderUI
({
output
$
ui_coxp
<-
renderUI
({
req
(
input
$
dataset
)
req
(
input
$
dataset
)
tagList
(
tagList
(
...
@@ -206,20 +151,7 @@ output$ui_coxp <- renderUI({
...
@@ -206,20 +151,7 @@ output$ui_coxp <- renderUI({
condition
=
"input.tabs_coxp == 'Summary'"
,
condition
=
"input.tabs_coxp == 'Summary'"
,
uiOutput
(
"ui_coxp_time"
),
uiOutput
(
"ui_coxp_time"
),
uiOutput
(
"ui_coxp_status"
),
uiOutput
(
"ui_coxp_status"
),
uiOutput
(
"ui_coxp_evar"
),
uiOutput
(
"ui_coxp_evar"
)
conditionalPanel
(
condition
=
"input.coxp_evar != null"
,
uiOutput
(
"ui_coxp_show_interactions"
),
conditionalPanel
(
condition
=
"input.coxp_show_interactions != ''"
,
uiOutput
(
"ui_coxp_int"
)
),
uiOutput
(
"ui_coxp_test_var"
),
checkboxGroupInput
(
"coxp_check"
,
NULL
,
coxp_check
,
selected
=
state_group
(
"coxp_check"
),
inline
=
TRUE
),
checkboxGroupInput
(
"coxp_sum_check"
,
NULL
,
coxp_sum_check
,
selected
=
state_group
(
"coxp_sum_check"
),
inline
=
TRUE
)
)
),
),
conditionalPanel
(
conditionalPanel
(
condition
=
"input.tabs_coxp == 'Predict'"
,
condition
=
"input.tabs_coxp == 'Predict'"
,
...
@@ -238,17 +170,15 @@ output$ui_coxp <- renderUI({
...
@@ -238,17 +170,15 @@ output$ui_coxp <- renderUI({
placeholder
=
i
18
n
$
t
(
"Type a formula to set values for model variables (e.g., age = 60; sex = 'Male') and press return"
))
placeholder
=
i
18
n
$
t
(
"Type a formula to set values for model variables (e.g., age = 60; sex = 'Male') and press return"
))
),
),
conditionalPanel
(
conditionalPanel
(
condition
=
"input.coxp_predict != 'none'"
,
"input.coxp_predict != 'none'"
,
checkboxInput
(
"coxp_pred_plot"
,
i
18
n
$
t
(
"Plot predictions"
),
state_init
(
"coxp_pred_plot"
,
FALSE
)),
sliderInput
(
"coxp_conf_lev"
,
i
18
n
$
t
(
"Confidence level:"
),
conditionalPanel
(
min
=
0.80
,
max
=
0.99
,
value
=
state_init
(
"coxp_conf_lev"
,
0.95
),
"input.coxp_pred_plot == true"
,
step
=
0.01
)
uiOutput
(
"ui_coxp_predict_plot"
)
)
),
),
conditionalPanel
(
conditionalPanel
(
"input.coxp_predict == 'data' | input.coxp_predict == 'datacmd'"
,
"input.coxp_predict == 'data' | input.coxp_predict == 'datacmd'"
,
tags
$
table
(
tags
$
table
(
tags
$
td
(
textInput
(
"coxp_store_pred_name"
,
i
18
n
$
t
(
"Store predictions:"
),
state_init
(
"coxp_store_pred_name"
,
"
pred_coxp
"
))),
tags
$
td
(
textInput
(
"coxp_store_pred_name"
,
i
18
n
$
t
(
"Store predictions:"
),
state_init
(
"coxp_store_pred_name"
,
"
cox_hr
"
))),
tags
$
td
(
actionButton
(
"coxp_store_pred"
,
i
18
n
$
t
(
"Store"
),
icon
=
icon
(
"plus"
,
verify_fa
=
FALSE
)),
class
=
"top"
)
tags
$
td
(
actionButton
(
"coxp_store_pred"
,
i
18
n
$
t
(
"Store"
),
icon
=
icon
(
"plus"
,
verify_fa
=
FALSE
)),
class
=
"top"
)
)
)
)
)
...
@@ -268,29 +198,6 @@ output$ui_coxp <- renderUI({
...
@@ -268,29 +198,6 @@ output$ui_coxp <- renderUI({
condition
=
"input.coxp_plots == 'pdp' | input.coxp_plots == 'pred_plot'"
,
condition
=
"input.coxp_plots == 'pdp' | input.coxp_plots == 'pred_plot'"
,
uiOutput
(
"ui_coxp_incl_int"
)
uiOutput
(
"ui_coxp_incl_int"
)
)
)
),
conditionalPanel
(
condition
=
"['correlations', 'scatter', 'dashboard', 'resid_pred'].indexOf(input.coxp_plots) !== -1"
,
uiOutput
(
"ui_coxp_nrobs"
),
conditionalPanel
(
condition
=
"input.coxp_plots != 'correlations'"
,
checkboxGroupInput
(
"coxp_lines"
,
NULL
,
coxp_lines
,
selected
=
state_group
(
"coxp_lines"
),
inline
=
TRUE
)
)
)
),
conditionalPanel
(
condition
=
"(input.tabs_coxp == 'Summary' && input.coxp_sum_check != undefined && input.coxp_sum_check.indexOf('confint') >= 0) ||
(input.tabs_coxp == 'Predict' && input.coxp_predict != 'none') ||
(input.tabs_coxp == 'Plot' && input.coxp_plots == 'coef')"
,
sliderInput
(
"coxp_conf_lev"
,
i
18
n
$
t
(
"Confidence level:"
),
min
=
0.80
,
max
=
0.99
,
value
=
state_init
(
"coxp_conf_lev"
,
.95
),
step
=
0.01
)
),
conditionalPanel
(
condition
=
"input.tabs_coxp == 'Summary'"
,
tags
$
table
(
tags
$
td
(
uiOutput
(
"ui_coxp_store_res_name"
)),
tags
$
td
(
actionButton
(
"coxp_store_res"
,
i
18
n
$
t
(
"Store"
),
icon
=
icon
(
"plus"
,
verify_fa
=
FALSE
)),
class
=
"top"
)
)
)
)
)
),
),
...
@@ -302,7 +209,7 @@ output$ui_coxp <- renderUI({
...
@@ -302,7 +209,7 @@ output$ui_coxp <- renderUI({
)
)
})
})
##
8
. 绘图尺寸 ------------------------------------------------------------
##
7
. 绘图尺寸 ------------------------------------------------------------
coxp_plot
<-
reactive
({
coxp_plot
<-
reactive
({
if
(
coxp_available
()
!=
"available"
)
return
()
if
(
coxp_available
()
!=
"available"
)
return
()
if
(
is.empty
(
input
$
coxp_plots
,
"none"
))
return
()
if
(
is.empty
(
input
$
coxp_plots
,
"none"
))
return
()
...
@@ -337,13 +244,11 @@ coxp_plot <- reactive({
...
@@ -337,13 +244,11 @@ coxp_plot <- reactive({
coxp_plot_width
<-
function
()
coxp_plot
()
%>%
(
function
(
x
)
if
(
is.list
(
x
))
x
$
plot_width
else
650
)
coxp_plot_width
<-
function
()
coxp_plot
()
%>%
(
function
(
x
)
if
(
is.list
(
x
))
x
$
plot_width
else
650
)
coxp_plot_height
<-
function
()
coxp_plot
()
%>%
(
function
(
x
)
if
(
is.list
(
x
))
x
$
plot_height
else
500
)
coxp_plot_height
<-
function
()
coxp_plot
()
%>%
(
function
(
x
)
if
(
is.list
(
x
))
x
$
plot_height
else
500
)
coxp_pred_plot_height
<-
function
()
if
(
input
$
coxp_pred_plot
)
500
else
1
##
9
. 输出注册 -------------------------------------------------------------
##
8
. 输出注册 -------------------------------------------------------------
output
$
coxp
<-
renderUI
({
output
$
coxp
<-
renderUI
({
register_print_output
(
"summary_coxp"
,
".summary_coxp"
)
register_print_output
(
"summary_coxp"
,
".summary_coxp"
)
register_print_output
(
"predict_coxp"
,
".predict_print_coxp"
)
register_print_output
(
"predict_coxp"
,
".predict_print_coxp"
)
register_plot_output
(
"predict_plot_coxp"
,
".predict_plot_coxp"
,
height_fun
=
"coxp_pred_plot_height"
)
register_plot_output
(
"plot_coxp"
,
".plot_coxp"
,
height_fun
=
"coxp_plot_height"
,
width_fun
=
"coxp_plot_width"
)
register_plot_output
(
"plot_coxp"
,
".plot_coxp"
,
height_fun
=
"coxp_plot_height"
,
width_fun
=
"coxp_plot_width"
)
coxp_output_panels
<-
tabsetPanel
(
coxp_output_panels
<-
tabsetPanel
(
...
@@ -352,9 +257,6 @@ output$coxp <- renderUI({
...
@@ -352,9 +257,6 @@ output$coxp <- renderUI({
download_link
(
"dl_coxp_coef"
),
br
(),
download_link
(
"dl_coxp_coef"
),
br
(),
verbatimTextOutput
(
"summary_coxp"
)),
verbatimTextOutput
(
"summary_coxp"
)),
tabPanel
(
i
18
n
$
t
(
"Predict"
),
value
=
"Predict"
,
tabPanel
(
i
18
n
$
t
(
"Predict"
),
value
=
"Predict"
,
conditionalPanel
(
"input.coxp_pred_plot == true"
,
download_link
(
"dlp_coxp_pred"
),
plotOutput
(
"predict_plot_coxp"
,
width
=
"100%"
,
height
=
"100%"
)),
download_link
(
"dl_coxp_pred"
),
br
(),
download_link
(
"dl_coxp_pred"
),
br
(),
verbatimTextOutput
(
"predict_coxp"
)),
verbatimTextOutput
(
"predict_coxp"
)),
tabPanel
(
i
18
n
$
t
(
"Plot"
),
value
=
"Plot"
,
tabPanel
(
i
18
n
$
t
(
"Plot"
),
value
=
"Plot"
,
...
@@ -370,118 +272,103 @@ output$coxp <- renderUI({
...
@@ -370,118 +272,103 @@ output$coxp <- renderUI({
)
)
})
})
##
10
. 可用性检查 ----------------------------------------------------------
##
9
. 可用性检查 ----------------------------------------------------------
coxp_available
<-
reactive
({
coxp_available
<-
reactive
({
if
(
!
input
$
dataset
%in%
names
(
r_data
))
{
if
(
!
input
$
dataset
%in%
names
(
r_data
))
{
return
(
i
18
n
$
t
(
"
数据集不存在:
请先加载有效数据集"
))
return
(
i
18
n
$
t
(
"请先加载有效数据集"
))
}
}
# 检查时间变量
# 检查时间变量
if
(
is.null
(
input
$
coxp_time
)
||
input
$
coxp_time
==
""
||
!
input
$
coxp_time
%in%
colnames
(
r_data
[[
input
$
dataset
]]))
{
if
(
is.null
(
input
$
coxp_time
)
||
input
$
coxp_time
==
""
||
!
input
$
coxp_time
%in%
colnames
(
r_data
[[
input
$
dataset
]]))
{
return
(
i
18
n
$
t
(
"
时间变量无效:
请选择数据集中存在的数值型变量"
))
return
(
i
18
n
$
t
(
"请选择数据集中存在的数值型变量"
))
}
}
# 检查状态变量
# 检查状态变量
if
(
is.null
(
input
$
coxp_status
)
||
input
$
coxp_status
==
""
||
!
input
$
coxp_status
%in%
colnames
(
r_data
[[
input
$
dataset
]]))
{
if
(
is.null
(
input
$
coxp_status
)
||
input
$
coxp_status
==
""
||
!
input
$
coxp_status
%in%
colnames
(
r_data
[[
input
$
dataset
]]))
{
return
(
i
18
n
$
t
(
"
状态变量无效:
请选择数据集中存在的变量"
))
return
(
i
18
n
$
t
(
"请选择数据集中存在的变量"
))
}
}
# 检查解释变量
# 检查解释变量
if
(
is.null
(
input
$
coxp_evar
)
||
length
(
input
$
coxp_evar
)
==
0
||
length
(
setdiff
(
input
$
coxp_evar
,
colnames
(
r_data
[[
input
$
dataset
]])))
>
0
)
{
if
(
is.null
(
input
$
coxp_evar
)
||
length
(
input
$
coxp_evar
)
==
0
||
length
(
setdiff
(
input
$
coxp_evar
,
colnames
(
r_data
[[
input
$
dataset
]])))
>
0
)
{
return
(
i
18
n
$
t
(
"
解释变量无效:
请选择至少一个数据集中存在的变量"
))
return
(
i
18
n
$
t
(
"请选择至少一个数据集中存在的变量"
))
}
}
return
(
"available"
)
return
(
"available"
)
})
})
## 1
1
. 模型估计
## 1
0
. 模型估计
.coxp
<-
eventReactive
(
input
$
coxp_run
,
{
.coxp
<-
eventReactive
(
input
$
coxp_run
,
{
cat
(
"---->coxp reactive entered"
)
ds
<-
tryCatch
(
# 严格校验变量
get_data
(
input
$
dataset
,
vars
=
c
(),
envir
=
r_data
),
ds
<-
tryCatch
({
error
=
function
(
e
)
return
(
paste
(
"数据集获取失败:"
,
e
$
message
))
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"
))
if
(
is.character
(
ds
))
return
(
ds
)
# 数据集不存在,返回错误
time_var
<-
input
$
coxp_time
if
(
!
time_var
%in%
colnames
(
ds
))
# 校验时间变量
return
(
"时间变量不存在于数据集中"
%>%
add_class
(
"coxp"
))
if
(
!
input
$
coxp_time
%in%
colnames
(
ds
))
{
if
(
!
is.numeric
(
ds
[[
time_var
]]))
return
(
paste
(
"时间变量不存在:数据集中无「"
,
input
$
coxp_time
,
"」列"
,
sep
=
""
))
return
(
"时间变量必须是数值型"
%>%
add_class
(
"coxp"
))
}
if
(
!
is.numeric
(
ds
[[
input
$
coxp_time
]]))
{
status_var
<-
input
$
coxp_status
return
(
paste
(
"时间变量类型错误:「"
,
input
$
coxp_time
,
"」需为数值型(整数/小数)"
,
sep
=
""
))
if
(
!
status_var
%in%
colnames
(
ds
))
}
return
(
"状态变量不存在于数据集中"
%>%
add_class
(
"coxp"
))
# 校验状态变量
surv_vec
<-
ds
[[
status_var
]]
if
(
!
input
$
coxp_status
%in%
colnames
(
ds
))
{
if
(
is.factor
(
surv_vec
)
||
is.character
(
surv_vec
))
{
return
(
paste
(
"状态变量不存在:数据集中无「"
,
input
$
coxp_status
,
"」列"
,
sep
=
""
))
lev
<-
unique
(
surv_vec
)
}
if
(
length
(
lev
)
!=
2
)
sv
<-
ds
[[
input
$
coxp_status
]]
return
(
"状态变量必须是二分类(0/1 或两个水平)"
%>%
add_class
(
"coxp"
))
sv
<-
if
(
is.factor
(
sv
))
as.numeric
(
sv
)
-
1
else
sv
# 因子转0/1
ds
[[
status_var
]]
<-
as.numeric
(
factor
(
surv_vec
,
levels
=
lev
))
-
1L
sv
<-
ifelse
(
sv
%in%
c
(
0
,
1
),
sv
,
0
)
# 非0/1强制为0
}
else
if
(
!
all
(
unique
(
surv_vec
)
%in%
c
(
0
,
1
)))
{
n_event
<-
sum
(
sv
)
return
(
"状态变量必须只包含 0 和 1"
%>%
add_class
(
"coxp"
))
if
(
n_event
<
1
)
{
return
(
paste
(
"事件数不足:状态变量转换后仅"
,
n_event
,
"个事件(需至少1个),请检查状态变量编码"
))
}
}
ds
[[
input
$
coxp_status
]]
<-
sv
n_event
<-
sum
(
ds
[[
status_var
]])
if
(
n_event
<
1
)
return
(
"数据中未发生任何事件(status = 1)"
%>%
add_class
(
"coxp"
))
# 校验解释变量(存在且非空)
evar_missing
<-
setdiff
(
input
$
coxp_evar
,
colnames
(
ds
))
evar_missing
<-
setdiff
(
input
$
coxp_evar
,
colnames
(
ds
))
if
(
length
(
evar_missing
)
>
0
)
{
if
(
length
(
evar_missing
)
>
0
)
return
(
paste
(
"解释变量不存在:数据集中无「"
,
paste
(
evar_missing
,
collapse
=
"、"
),
"」列"
,
sep
=
""
))
return
(
paste
(
"解释变量不存在:"
,
paste
(
evar_missing
,
collapse
=
", "
))
%>%
add_class
(
"coxp"
))
}
# 构建模型并运行
rhs
<-
if
(
length
(
input
$
coxp_evar
)
>
0
)
{
form
<-
as.formula
(
paste0
(
"Surv("
,
input
$
coxp_time
,
", "
,
input
$
coxp_status
,
") ~ "
,
paste
(
input
$
coxp_evar
,
collapse
=
" + "
)))
paste
(
input
$
coxp_evar
,
collapse
=
" + "
)
model
<-
tryCatch
({
}
else
{
survival
::
coxph
(
form
,
data
=
ds
)
"1"
},
error
=
function
(
e
)
return
(
paste
(
"coxph模型失败:"
,
gsub
(
"\n"
,
" "
,
e
$
message
))))
}
form
<-
as.formula
(
paste0
(
"Surv("
,
time_var
,
", "
,
status_var
,
") ~ "
,
rhs
))
return
(
model
)
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
)
})
})
## 1
2
. summary / predict / plot --------------------------------------------
## 1
1
. summary / predict / plot --------------------------------------------
.summary_coxp
<-
reactive
({
.summary_coxp
<-
reactive
({
if
(
not_pressed
(
input
$
coxp_run
))
{
if
(
not_pressed
(
input
$
coxp_run
))
return
(
i
18
n
$
t
(
"** 请点击「估计模型」按钮运行分析 **"
))
return
(
i
18
n
$
t
(
"** Press the Estimate button to estimate the model **"
))
}
# 先检查可用性(提前拦截无效操作)
obj
<-
.coxp
()
avail_msg
<-
coxp_available
()
if
(
avail_msg
!=
"available"
)
{
return
(
paste0
(
"** 前置检查失败:"
,
avail_msg
,
" **"
))
}
# 获取模型结果(可能是coxph对象或错误文本)
if
(
is.character
(
obj
))
{
model_result
<-
.coxp
()
cat
(
obj
,
"\n"
)
return
()
# 处理错误文本
if
(
is.character
(
model_result
))
{
return
(
paste0
(
"** 模型运行失败:"
,
model_result
,
" **"
))
}
# 处理有效模型
if
(
inherits
(
model_result
,
"coxph"
))
{
# 检查是否有系数(避免无系数的空模型)
if
(
length
(
coef
(
model_result
))
==
0
)
{
return
(
i
18
n
$
t
(
"** 未估计出系数:可能存在完全共线性、事件数不足或变量无效 **"
))
}
# 输出标准summary
return
(
summary
(
model_result
))
}
}
# 其他未知错误
summary.coxp
(
obj
,
dec
=
3
)
return
(
i
18
n
$
t
(
"** 未知错误:请检查数据集和变量设置 **"
))
})
})
## 确保UI输出绑定正确
output
$
summary_coxp
<-
renderPrint
({
res
<-
.summary_coxp
()
if
(
is.character
(
res
))
{
cat
(
res
,
"\n"
)
}
else
{
print
(
res
)
}
})
.predict_coxp
<-
reactive
({
.predict_coxp
<-
reactive
({
if
(
not_pressed
(
input
$
coxp_run
))
return
(
i
18
n
$
t
(
"** Press the Estimate button to estimate the model **"
))
if
(
not_pressed
(
input
$
coxp_run
))
return
(
i
18
n
$
t
(
"** Press the Estimate button to estimate the model **"
))
if
(
coxp_available
()
!=
"available"
)
return
(
coxp_available
())
if
(
coxp_available
()
!=
"available"
)
return
(
coxp_available
())
...
@@ -500,31 +387,31 @@ output$summary_coxp <- renderPrint({
...
@@ -500,31 +387,31 @@ output$summary_coxp <- renderPrint({
})
})
.predict_print_coxp
<-
reactive
({
.predict_print_coxp
<-
reactive
({
.predict_coxp
()
%>%
{
if
(
is.character
(
.
))
cat
(
.
,
"\n"
)
else
print
(
.
)
}
pred
<-
.predict_coxp
()
})
if
(
is.character
(
pred
))
{
cat
(
pred
,
"\n"
)
.predict_plot_coxp
<-
reactive
({
return
()
req
(
pressed
(
input
$
coxp_run
),
input
$
coxp_pred_plot
,
available
(
input
$
coxp_xvar
),
!
is.empty
(
input
$
coxp_predict
,
"none"
))
}
withProgress
(
message
=
i
18
n
$
t
(
"Generating prediction plot"
),
value
=
1
,
print.coxp.predict
(
pred
,
n
=
10
)
do.call
(
plot
,
c
(
list
(
x
=
.predict_coxp
()),
coxp_pred_plot_inputs
())))
})
})
.plot_coxp
<-
reactive
({
.plot_coxp
<-
reactive
({
if
(
not_pressed
(
input
$
coxp_run
))
return
(
i
18
n
$
t
(
"** Press the Estimate button to estimate the model **"
))
if
(
not_pressed
(
input
$
coxp_run
))
return
(
i
18
n
$
t
(
"** Press the Estimate button to estimate the model **"
))
if
(
is.empty
(
input
$
coxp_plots
,
"none"
))
return
(
i
18
n
$
t
(
"Please select a plot from the drop-down menu"
))
if
(
is.empty
(
input
$
coxp_plots
,
"none"
))
return
(
i
18
n
$
t
(
"Please select a plot from the drop-down menu"
))
if
(
coxp_available
()
!=
"available"
)
return
(
coxp_available
())
if
(
coxp_available
()
!=
"available"
)
return
(
coxp_available
())
if
(
!
input
$
coxp_plots
%in%
c
(
"coef"
,
"dist"
,
"influence"
,
"vip"
,
"pdp"
,
"pred_plot"
))
req
(
input
$
coxp_nrobs
)
valid_plots
<-
c
(
"coef"
,
"dist"
,
"vip"
,
"pdp"
,
"pred_plot"
,
"influence"
)
if
(
!
input
$
coxp_plots
%in%
valid_plots
)
{
return
(
i
18
n
$
t
(
"Selected plot type is not supported for Cox models."
))
}
if
(
input
$
coxp_plots
%in%
c
(
"pdp"
,
"pred_plot"
))
{
check_for_pdp_pred_plots
(
"coxp"
)
check_for_pdp_pred_plots
(
"coxp"
)
}
withProgress
(
message
=
i
18
n
$
t
(
"Generating plots"
),
value
=
1
,
{
withProgress
(
message
=
i
18
n
$
t
(
"Generating plots"
),
value
=
1
,
{
if
(
input
$
coxp_plots
==
"correlations"
)
{
capture_plot
(
do.call
(
plot
,
c
(
list
(
x
=
.coxp
()),
coxp_plot_inputs
())))
}
else
{
do.call
(
plot
,
c
(
list
(
x
=
.coxp
()),
coxp_plot_inputs
(),
shiny
=
TRUE
))
do.call
(
plot
,
c
(
list
(
x
=
.coxp
()),
coxp_plot_inputs
(),
shiny
=
TRUE
))
}
})
})
})
})
## 1
3
. 报告 / 下载 / 存储 -------------------------------------------------
## 1
2
. 报告 / 下载 / 存储 -------------------------------------------------
coxp_report
<-
function
()
{
coxp_report
<-
function
()
{
if
(
is.empty
(
input
$
coxp_evar
))
return
(
invisible
())
if
(
is.empty
(
input
$
coxp_evar
))
return
(
invisible
())
outputs
<-
c
(
"summary"
)
outputs
<-
c
(
"summary"
)
...
@@ -532,7 +419,7 @@ coxp_report <- function() {
...
@@ -532,7 +419,7 @@ coxp_report <- function() {
figs
<-
FALSE
figs
<-
FALSE
if
(
!
is.empty
(
input
$
coxp_plots
,
"none"
))
{
if
(
!
is.empty
(
input
$
coxp_plots
,
"none"
))
{
inp
<-
check_plot_inputs
(
coxp_plot_inputs
())
inp
<-
check_plot_inputs
(
coxp_plot_inputs
())
inp_out
[[
2
]]
<-
clean_args
(
inp
,
list
())
# coxp_plot_args 已空
inp_out
[[
2
]]
<-
clean_args
(
inp
,
list
())
inp_out
[[
2
]]
$
custom
<-
FALSE
inp_out
[[
2
]]
$
custom
<-
FALSE
outputs
<-
c
(
outputs
,
"plot"
)
outputs
<-
c
(
outputs
,
"plot"
)
figs
<-
TRUE
figs
<-
TRUE
...
@@ -557,12 +444,6 @@ coxp_report <- function() {
...
@@ -557,12 +444,6 @@ coxp_report <- function() {
fix_names
()
%>%
deparse
(
.
,
control
=
getOption
(
"dctrl"
),
width.cutoff
=
500L
)
fix_names
()
%>%
deparse
(
.
,
control
=
getOption
(
"dctrl"
),
width.cutoff
=
500L
)
xcmd
<-
paste0
(
xcmd
,
"\n"
,
input
$
coxp_pred_data
,
" <- store("
,
input
$
coxp_pred_data
,
", pred, name = "
,
fixed
,
")"
)
xcmd
<-
paste0
(
xcmd
,
"\n"
,
input
$
coxp_pred_data
,
" <- store("
,
input
$
coxp_pred_data
,
", pred, name = "
,
fixed
,
")"
)
}
}
if
(
input
$
coxp_pred_plot
&&
!
is.empty
(
input
$
coxp_xvar
))
{
inp_out
[[
3
+
figs
]]
<-
clean_args
(
coxp_pred_plot_inputs
(),
list
())
inp_out
[[
3
+
figs
]]
$
result
<-
"pred"
outputs
<-
c
(
outputs
,
"plot"
)
figs
<-
TRUE
}
}
}
update_report
(
update_report
(
inp_main
=
clean_args
(
coxp_inputs
(),
coxp_args
),
inp_main
=
clean_args
(
coxp_inputs
(),
coxp_args
),
...
@@ -576,16 +457,6 @@ coxp_report <- function() {
...
@@ -576,16 +457,6 @@ coxp_report <- function() {
)
)
}
}
observeEvent
(
input
$
coxp_store_res
,
{
req
(
pressed
(
input
$
coxp_run
))
robj
<-
.coxp
()
if
(
!
is.list
(
robj
))
return
()
fixed
<-
fix_names
(
input
$
coxp_store_res_name
)
updateTextInput
(
session
,
"coxp_store_res_name"
,
value
=
fixed
)
withProgress
(
message
=
i
18
n
$
t
(
"Storing residuals"
),
value
=
1
,
r_data
[[
input
$
dataset
]]
<-
store
(
r_data
[[
input
$
dataset
]],
robj
,
name
=
fixed
))
})
observeEvent
(
input
$
coxp_store_pred
,
{
observeEvent
(
input
$
coxp_store_pred
,
{
req
(
!
is.empty
(
input
$
coxp_pred_data
),
pressed
(
input
$
coxp_run
))
req
(
!
is.empty
(
input
$
coxp_pred_data
),
pressed
(
input
$
coxp_run
))
pred
<-
.predict_coxp
()
pred
<-
.predict_coxp
()
...
@@ -596,13 +467,133 @@ observeEvent(input$coxp_store_pred, {
...
@@ -596,13 +467,133 @@ observeEvent(input$coxp_store_pred, {
r_data
[[
input
$
coxp_pred_data
]]
<-
store
(
r_data
[[
input
$
coxp_pred_data
]],
pred
,
name
=
fixed
))
r_data
[[
input
$
coxp_pred_data
]]
<-
store
(
r_data
[[
input
$
coxp_pred_data
]],
pred
,
name
=
fixed
))
})
})
## 1
4
. 下载 ----------------------------------------------------------------
## 1
3
. 下载 ----------------------------------------------------------------
dl_coxp_coef
<-
function
(
path
)
{
dl_coxp_coef
<-
function
(
path
)
{
if
(
pressed
(
input
$
coxp_run
))
{
if
(
!
pressed
(
input
$
coxp_run
))
{
write.coeff
(
.coxp
(),
file
=
path
)
}
else
{
cat
(
i
18
n
$
t
(
"No output available. Press the Estimate button to generate results"
),
file
=
path
)
cat
(
i
18
n
$
t
(
"No output available. Press the Estimate button to generate results"
),
file
=
path
)
return
()
}
}
coxp_obj
<-
.coxp
()
if
(
is.character
(
coxp_obj
))
{
cat
(
i
18
n
$
t
(
"Model error: "
),
coxp_obj
,
file
=
path
)
return
()
}
if
(
inherits
(
coxp_obj
,
"coxp"
)
&&
!
is.null
(
coxp_obj
$
model
))
{
coxph_model
<-
coxp_obj
$
model
}
else
{
cat
(
i
18
n
$
t
(
"Invalid Cox model object. Cannot export coefficients."
),
file
=
path
)
return
()
}
if
(
!
inherits
(
coxph_model
,
"coxph"
))
{
cat
(
i
18
n
$
t
(
"Invalid Cox model object. Cannot export coefficients."
),
file
=
path
)
return
()
}
sum_obj
<-
summary
(
coxph_model
)
conf_int
<-
exp
(
confint
(
coxph_model
))
n_info
<-
data.frame
(
Content
=
paste0
(
"n="
,
sum_obj
$
n
,
", number of events="
,
sum_obj
$
nevent
),
stringsAsFactors
=
FALSE
)
coef_table
<-
as.data.frame
(
sum_obj
$
coefficients
)
coef_table
$
Variable
<-
rownames
(
coef_table
)
p_col
<-
grep
(
"Pr(>|z|)"
,
colnames
(
coef_table
),
value
=
TRUE
)
coef_table
$
"Pr(>|z|)"
<-
if
(
length
(
p_col
)
>
0
)
as.numeric
(
coef_table
[[
p_col
]])
else
NA
coef_table
$
Signif
<-
if
(
all
(
is.numeric
(
coef_table
$
"Pr(>|z|)"
)))
{
cut
(
coef_table
$
"Pr(>|z|)"
,
breaks
=
c
(
-
Inf
,
0.001
,
0.01
,
0.05
,
0.1
,
Inf
),
labels
=
c
(
"***"
,
"**"
,
"*"
,
"."
,
" "
))
}
else
{
rep
(
""
,
nrow
(
coef_table
))
}
coef_text
<-
do.call
(
rbind
,
lapply
(
1
:
nrow
(
coef_table
),
function
(
i
)
{
row
<-
coef_table
[
i
,
]
data.frame
(
Content
=
sprintf
(
"%-10s %8.4f %10.4f %8.4f %8.4f %10s %5s"
,
row
$
Variable
,
row
$
coef
,
row
$
`exp(coef)`
,
row
$
`se(coef)`
,
row
$
z
,
ifelse
(
row
$
"Pr(>|z|)"
<
0.0001
,
"<0.0001"
,
sprintf
(
"%.4f"
,
row
$
"Pr(>|z|)"
)),
as.character
(
row
$
Signif
)
),
stringsAsFactors
=
FALSE
)
}))
signif_note
<-
data.frame
(
Content
=
"Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
,
stringsAsFactors
=
FALSE
)
hr_text
<-
if
(
nrow
(
conf_int
)
>
0
)
{
do.call
(
rbind
,
lapply
(
1
:
nrow
(
conf_int
),
function
(
i
)
{
var
<-
rownames
(
conf_int
)[
i
]
exp_coef
<-
exp
(
sum_obj
$
coefficients
[
var
,
"coef"
])
exp_neg_coef
<-
1
/
exp_coef
data.frame
(
Content
=
sprintf
(
"%-10s %10.4f %10.4f %10.4f %10.4f"
,
var
,
exp_coef
,
exp_neg_coef
,
conf_int
[
i
,
1
],
conf_int
[
i
,
2
]
),
stringsAsFactors
=
FALSE
)
}))
}
else
{
data.frame
(
Content
=
"No HR confidence interval available"
,
stringsAsFactors
=
FALSE
)
}
hr_header
<-
data.frame
(
Content
=
sprintf
(
"%-10s %10s %10s %10s %10s"
,
""
,
"exp(coef)"
,
"exp(-coef)"
,
"lower .95"
,
"upper .95"
),
stringsAsFactors
=
FALSE
)
concordance
<-
data.frame
(
Content
=
paste0
(
"Concordance="
,
sprintf
(
"%.3f"
,
sum_obj
$
concordance
[
1
]),
" (se = "
,
sprintf
(
"%.3f"
,
sum_obj
$
concordance
[
2
]),
" )"
),
stringsAsFactors
=
FALSE
)
format_test
<-
function
(
name
,
test
)
{
if
(
!
is.null
(
test
))
{
paste0
(
name
,
"="
,
sprintf
(
"%.1f"
,
test
[
1
]),
" on "
,
test
[
2
],
" df, p="
,
ifelse
(
test
[
3
]
<
0.0001
,
"<0.0001"
,
sprintf
(
"%.4f"
,
test
[
3
])))
}
}
tests
<-
data.frame
(
Content
=
c
(
format_test
(
"Likelihood ratio test"
,
sum_obj
$
logtest
),
format_test
(
"Wald test"
,
sum_obj
$
waldtest
),
format_test
(
"Score (logrank) test"
,
sum_obj
$
sctest
)
),
stringsAsFactors
=
FALSE
)
all_parts
<-
list
(
n_info
,
data.frame
(
Content
=
""
,
stringsAsFactors
=
FALSE
),
coef_text
,
data.frame
(
Content
=
""
,
stringsAsFactors
=
FALSE
),
signif_note
,
data.frame
(
Content
=
""
,
stringsAsFactors
=
FALSE
),
hr_header
,
hr_text
,
data.frame
(
Content
=
""
,
stringsAsFactors
=
FALSE
),
concordance
,
data.frame
(
Content
=
""
,
stringsAsFactors
=
FALSE
),
tests
)
write.csv
(
do.call
(
rbind
,
all_parts
),
file
=
path
,
row.names
=
FALSE
,
na
=
""
,
fileEncoding
=
"UTF-8"
,
quote
=
FALSE
)
}
}
download_handler
(
download_handler
(
...
@@ -614,11 +605,16 @@ download_handler(
...
@@ -614,11 +605,16 @@ download_handler(
)
)
dl_coxp_pred
<-
function
(
path
)
{
dl_coxp_pred
<-
function
(
path
)
{
if
(
pressed
(
input
$
coxp_run
))
{
if
(
!
pressed
(
input
$
coxp_run
))
{
write.csv
(
.predict_coxp
(),
file
=
path
,
row.names
=
FALSE
)
}
else
{
cat
(
i
18
n
$
t
(
"No output available. Press the Estimate button to generate results"
),
file
=
path
)
cat
(
i
18
n
$
t
(
"No output available. Press the Estimate button to generate results"
),
file
=
path
)
return
()
}
}
pred
<-
.predict_coxp
()
if
(
is.character
(
pred
))
{
cat
(
i
18
n
$
t
(
"Prediction error: "
),
pred
,
file
=
path
)
return
()
}
write.csv
(
pred
,
file
=
path
,
row.names
=
FALSE
,
fileEncoding
=
"UTF-8"
)
}
}
download_handler
(
download_handler
(
...
@@ -629,17 +625,6 @@ download_handler(
...
@@ -629,17 +625,6 @@ download_handler(
caption
=
i
18
n
$
t
(
"Save Cox predictions"
)
caption
=
i
18
n
$
t
(
"Save Cox predictions"
)
)
)
download_handler
(
id
=
"dlp_coxp_pred"
,
fun
=
download_handler_plot
,
fn
=
paste0
(
input
$
dataset
,
"_coxp_pred"
),
type
=
"png"
,
caption
=
i
18
n
$
t
(
"Save Cox prediction plot"
),
plot
=
.predict_plot_coxp
,
width
=
plot_width
,
height
=
coxp_pred_plot_height
)
download_handler
(
download_handler
(
id
=
"dlp_coxp"
,
id
=
"dlp_coxp"
,
fun
=
download_handler_plot
,
fun
=
download_handler_plot
,
...
@@ -651,7 +636,7 @@ download_handler(
...
@@ -651,7 +636,7 @@ download_handler(
height
=
coxp_plot_height
height
=
coxp_plot_height
)
)
## 1
5
. 报告 / 截图 ---------------------------------------------------------
## 1
4
. 报告 / 截图 ---------------------------------------------------------
observeEvent
(
input
$
coxp_report
,
{
observeEvent
(
input
$
coxp_report
,
{
r_info
[[
"latest_screenshot"
]]
<-
NULL
r_info
[[
"latest_screenshot"
]]
<-
NULL
coxp_report
()
coxp_report
()
...
...
radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R
View file @
ad60c0cf
is.empty
<-
function
(
x
,
empty
=
"\\s*"
)
{
if
(
is.null
(
x
))
return
(
TRUE
)
if
(
is.atomic
(
x
)
&&
length
(
x
)
==
0
)
return
(
TRUE
)
if
(
!
is.character
(
x
))
return
(
FALSE
)
is_not
(
x
)
||
(
length
(
x
)
==
1
&&
any
(
grepl
(
paste0
(
"^"
,
empty
,
"$"
),
x
)))
}
make_desc_text
<-
function
(
df
)
{
make_desc_text
<-
function
(
df
)
{
if
(
is.null
(
df
)
||
nrow
(
df
)
==
0
)
return
(
i
18
n
$
t
(
"No data available"
))
if
(
is.null
(
df
)
||
nrow
(
df
)
==
0
)
return
(
i
18
n
$
t
(
"No data available"
))
num_cols
<-
sapply
(
df
,
is.numeric
)
num_cols
<-
sapply
(
df
,
is.numeric
)
...
...
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