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
078f95fa
Commit
078f95fa
authored
Dec 03, 2025
by
wuzekai
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
update
parent
896921db
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
766 additions
and
2 deletions
+766
-2
NAMESPACE
radiant.basics/NAMESPACE
+3
-0
mda.R
radiant.basics/R/mda.R
+448
-0
init.R
radiant.basics/inst/app/init.R
+5
-2
mda_ui.R
radiant.basics/inst/app/tools/analysis/mda_ui.R
+310
-0
mda.md
radiant.basics/inst/app/tools/help/mda.md
+0
-0
No files found.
radiant.basics/NAMESPACE
View file @
078f95fa
...
...
@@ -7,6 +7,7 @@ S3method(plot,correlation)
S3method(plot,cross_tabs)
S3method(plot,goodness)
S3method(plot,homo_variance_test)
S3method(plot,mda)
S3method(plot,normality_test)
S3method(plot,prob_binom)
S3method(plot,prob_chisq)
...
...
@@ -27,6 +28,7 @@ S3method(summary,correlation)
S3method(summary,cross_tabs)
S3method(summary,goodness)
S3method(summary,homo_variance_test)
S3method(summary,mda)
S3method(summary,normality_test)
S3method(summary,prob_binom)
S3method(summary,prob_chisq)
...
...
@@ -48,6 +50,7 @@ export(correlation)
export(cross_tabs)
export(goodness)
export(homo_variance_test)
export(mda)
export(normality_test)
export(prob_binom)
export(prob_chisq)
...
...
radiant.basics/R/mda.R
0 → 100644
View file @
078f95fa
############################################
## Multigroup Difference Analysis (ANOVA/Kruskal-Wallis)
############################################
#' @export
mda
<-
function
(
dataset
,
var
,
group
,
normality_type
=
c
(
"overall"
,
"by_group"
),
data_filter
=
""
,
envir
=
parent.frame
())
{
# 1. 基础参数处理
normality_type
<-
match.arg
(
normality_type
,
choices
=
c
(
"overall"
,
"by_group"
))
df_name
<-
if
(
is_string
(
dataset
))
dataset
else
deparse
(
substitute
(
dataset
))
# 2. 数据提取:只保留“因变量+分组变量”
dataset
<-
get_data
(
dataset
,
vars
=
c
(
var
,
group
),
# 强制只取2个核心变量,剔除冗余列
filt
=
data_filter
,
na.rm
=
FALSE
,
# 先不删缺失值,后续统一过滤
envir
=
envir
)
# 3. 数据校验
if
(
!
var
%in%
colnames
(
dataset
))
{
stop
(
paste
(
"因变量"
,
var
,
"未在数据集中找到!"
),
call.
=
FALSE
)
}
if
(
!
group
%in%
colnames
(
dataset
))
{
stop
(
paste
(
"分组变量"
,
group
,
"未在数据集中找到!"
),
call.
=
FALSE
)
}
if
(
!
is.numeric
(
dataset
[[
var
]]))
{
stop
(
paste
(
"因变量"
,
var
,
"必须是数值型(当前类型:"
,
class
(
dataset
[[
var
]]),
")!"
),
call.
=
FALSE
)
}
# 4. 有效样本过滤:剔除任一变量缺失的样本
valid_indices
<-
!
is.na
(
dataset
[[
var
]])
&
!
is.na
(
dataset
[[
group
]])
valid_data
<-
dataset
[
valid_indices
,
]
# 仅保留有效样本的2列数据
if
(
nrow
(
valid_data
)
==
0
)
{
stop
(
"无有效样本(所有样本的因变量/分组变量存在缺失值)!"
,
call.
=
FALSE
)
}
# 5. 分组变量处理:强制转因子+校验水平
valid_data
[[
group
]]
<-
as.factor
(
valid_data
[[
group
]])
# 强制转因子,避免字符型干扰
valid_levels
<-
length
(
levels
(
valid_data
[[
group
]]))
# 用levels()确保因子水平正确
if
(
valid_levels
<
2
)
{
stop
(
paste
(
"分组变量有效水平不足2个(当前水平数:"
,
valid_levels
,
"),无法执行检验!"
),
call.
=
FALSE
)
}
# 6. 检验计算:调用辅助函数
homo_res
<-
run_homo_test
(
valid_data
,
var
,
group
)
# 方差齐性检验
norm_res
<-
run_norm_test
(
valid_data
,
var
,
group
,
normality_type
)
# 正态性检验
# 7. 绘图数据准备
plot_obj
<-
list
(
norm
=
list
(
data
=
valid_data
[[
var
]],
group_data
=
if
(
normality_type
==
"by_group"
)
{
# 把命名向量转为无命名列表,避免asJSON警告
lapply
(
split
(
valid_data
[[
var
]],
valid_data
[[
group
]]),
function
(
x
)
x
)
}
else
NULL
,
var
=
var
,
group
=
group
,
type
=
normality_type
),
homo
=
list
(
data
=
valid_data
,
var
=
var
,
group
=
group
)
)
# 8. 结果打包:对齐单独检验的输出结构
out
<-
structure
(
list
(
df_name
=
df_name
,
var
=
var
,
group
=
group
,
normality_type
=
normality_type
,
data_filter
=
if
(
data_filter
==
""
)
"None"
else
data_filter
,
valid_n
=
nrow
(
valid_data
),
# 有效样本量
homo_res
=
homo_res
,
# 方差齐性检验结果
norm_res
=
norm_res
,
# 正态性检验结果
plot_obj
=
plot_obj
),
class
=
"mda"
)
out
}
# ------------------------------
# 辅助函数1:方差齐性检验
# ------------------------------
run_homo_test
<-
function
(
valid_data
,
var
,
group
)
{
x
<-
valid_data
[[
var
]]
g
<-
valid_data
[[
group
]]
res
<-
tibble
::
tibble
(
Test
=
character
(),
Statistic
=
numeric
(),
p.value
=
numeric
())
# 1. Levene检验
if
(
requireNamespace
(
"car"
,
quietly
=
TRUE
))
{
tmp
<-
tryCatch
(
expr
=
car
::
leveneTest
(
x
~
g
),
error
=
function
(
e
)
{
message
(
paste
(
"Levene检验执行失败:"
,
e
$
message
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
)
&&
nrow
(
tmp
)
>
0
)
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Levene"
,
Statistic
=
as.numeric
(
tmp
[[
"F value"
]][
1
]),
p.value
=
as.numeric
(
tmp
[[
"Pr(>F)"
]][
1
]))
}
}
else
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Levene"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
message
(
"提示:需安装car包以运行Levene检验"
)
}
# 2. Bartlett检验
tmp
<-
tryCatch
(
expr
=
stats
::
bartlett.test
(
x
,
g
),
error
=
function
(
e
)
{
message
(
paste
(
"Bartlett检验执行失败:"
,
e
$
message
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
))
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Bartlett"
,
Statistic
=
as.numeric
(
tmp
$
statistic
),
p.value
=
as.numeric
(
tmp
$
p.value
))
}
else
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Bartlett"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
}
# 3. Fligner检验
tmp
<-
tryCatch
(
expr
=
stats
::
fligner.test
(
x
,
g
),
error
=
function
(
e
)
{
message
(
paste
(
"Fligner检验执行失败:"
,
e
$
message
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
))
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Fligner"
,
Statistic
=
as.numeric
(
tmp
$
statistic
),
p.value
=
as.numeric
(
tmp
$
p.value
))
}
else
{
res
<-
tibble
::
add_row
(
res
,
Test
=
"Fligner"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
}
res
}
# ------------------------------
# 辅助函数2:正态性检验
# ------------------------------
run_norm_test
<-
function
(
valid_data
,
var
,
group
,
normality_type
)
{
x
<-
valid_data
[[
var
]]
g
<-
valid_data
[[
group
]]
res
<-
tibble
::
tibble
(
Group
=
character
(),
Test
=
character
(),
Statistic
=
numeric
(),
p.value
=
numeric
())
# 1. 整体正态性检验
if
(
normality_type
==
"overall"
)
{
res
<-
dplyr
::
bind_rows
(
res
,
get_single_norm
(
x
,
group_label
=
"Overall"
))
}
# 2. 按分组正态性检验
if
(
normality_type
==
"by_group"
)
{
for
(
level
in
levels
(
g
))
{
group_x
<-
x
[
g
==
level
]
res
<-
dplyr
::
bind_rows
(
res
,
get_single_norm
(
group_x
,
group_label
=
level
))
}
}
res
}
# ------------------------------
# 辅助函数3:单组正态性检验
# ------------------------------
get_single_norm
<-
function
(
x
,
group_label
)
{
res
<-
tibble
::
tibble
(
Group
=
group_label
,
Test
=
character
(),
Statistic
=
numeric
(),
p.value
=
numeric
())
n
<-
length
(
x
)
# 1. Shapiro-Wilk检验
if
(
n
>=
3
&&
n
<=
5000
)
{
tmp
<-
tryCatch
(
expr
=
stats
::
shapiro.test
(
x
),
error
=
function
(
e
)
{
message
(
paste
(
"Shapiro-Wilk检验("
,
group_label
,
")失败:"
,
e
$
message
,
sep
=
""
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
))
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Shapiro-Wilk"
,
Statistic
=
tmp
$
statistic
,
p.value
=
tmp
$
p.value
)
}
}
else
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Shapiro-Wilk"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
message
(
paste
(
"Shapiro-Wilk检验("
,
group_label
,
")跳过:样本量需3-5000(当前n="
,
n
,
")"
,
sep
=
""
))
}
# 2. Lilliefors-KS检验
if
(
requireNamespace
(
"nortest"
,
quietly
=
TRUE
))
{
tmp
<-
tryCatch
(
expr
=
nortest
::
lillie.test
(
x
),
error
=
function
(
e
)
{
message
(
paste
(
"Lilliefors-KS检验("
,
group_label
,
")失败:"
,
e
$
message
,
sep
=
""
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
))
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Lilliefors-KS"
,
Statistic
=
tmp
$
statistic
,
p.value
=
tmp
$
p.value
)
}
else
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Lilliefors-KS"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
}
}
else
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Lilliefors-KS"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
message
(
"提示:需安装nortest包以运行KS/AD检验"
)
}
# 3. Anderson-Darling检验
if
(
requireNamespace
(
"nortest"
,
quietly
=
TRUE
))
{
tmp
<-
tryCatch
(
expr
=
nortest
::
ad.test
(
x
),
error
=
function
(
e
)
{
message
(
paste
(
"Anderson-Darling检验("
,
group_label
,
")失败:"
,
e
$
message
,
sep
=
""
))
return
(
NULL
)
}
)
if
(
!
is.null
(
tmp
))
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Anderson-Darling"
,
Statistic
=
tmp
$
statistic
,
p.value
=
tmp
$
p.value
)
}
else
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Anderson-Darling"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
}
}
else
{
res
<-
tibble
::
add_row
(
res
,
Group
=
group_label
,
Test
=
"Anderson-Darling"
,
Statistic
=
NA_real_
,
p.value
=
NA_real_
)
}
res
}
# ------------------------------
# Summary方法
# ------------------------------
#' @export
summary.mda
<-
function
(
object
,
dec
=
3
,
...
)
{
# 1. 基础信息
cat
(
"Multigroup Difference Analysis (ANOVA/KW)\n"
)
cat
(
"Data :"
,
object
$
df_name
,
"\n"
)
cat
(
"Dependent var:"
,
object
$
var
,
"(numeric)\n"
)
cat
(
"Group var :"
,
object
$
group
,
"(factor,"
,
length
(
levels
(
object
$
plot_obj
$
homo
$
data
[[
object
$
group
]])),
"levels)\n"
)
cat
(
"Normality test:"
,
object
$
normality_type
,
"\n"
)
cat
(
"Valid samples:"
,
object
$
valid_n
,
"\n\n"
)
# 2. 正态性检验结果
cat
(
"=== 1. Normality Test Results ===\n"
)
if
(
nrow
(
object
$
norm_res
)
==
0
)
{
cat
(
" No valid normality test results.\n\n"
)
}
else
{
norm_formatted
<-
object
$
norm_res
%>%
dplyr
::
mutate
(
Statistic
=
as.character
(
round
(
Statistic
,
dec
)),
# 转为字符型,统一类型
p.value
=
dplyr
::
case_when
(
is.na
(
p.value
)
~
""
,
p.value
<
0.001
~
"<0.001"
,
p.value
<
0.01
~
as.character
(
round
(
p.value
,
3
)),
# 数值转字符
TRUE
~
as.character
(
round
(
p.value
,
4
))
# 数值转字符
)
)
%>%
as.data.frame
(
stringsAsFactors
=
FALSE
)
print
(
norm_formatted
,
row.names
=
FALSE
,
right
=
FALSE
)
cat
(
"\n"
)
}
# 3. 方差齐性检验结果
cat
(
"=== 2. Homogeneity of Variance Results ===\n"
)
if
(
nrow
(
object
$
homo_res
)
==
0
)
{
cat
(
" No valid homogeneity test results.\n\n"
)
}
else
{
homo_formatted
<-
object
$
homo_res
%>%
dplyr
::
mutate
(
Statistic
=
as.character
(
round
(
Statistic
,
dec
)),
# 转为字符型,统一类型
p.value
=
dplyr
::
case_when
(
is.na
(
p.value
)
~
""
,
p.value
<
0.001
~
"<0.001"
,
p.value
<
0.01
~
as.character
(
round
(
p.value
,
3
)),
# 数值转字符
TRUE
~
as.character
(
round
(
p.value
,
4
))
# 数值转字符
)
)
%>%
as.data.frame
(
stringsAsFactors
=
FALSE
)
print
(
homo_formatted
,
row.names
=
FALSE
,
right
=
FALSE
)
cat
(
"\n"
)
}
# 4. 结论提示
cat
(
"=== 3. Interpretation Tips ===\n"
)
cat
(
"• 正态性:p ≥ 0.05 → 满足正态性假设\n"
)
cat
(
"• 方差齐性:p ≥ 0.05 → 满足方差齐性假设\n"
)
cat
(
"• 若同时满足这两个假设 → 使用方差分析(ANOVA)\n"
)
cat
(
"• 若任一假设不满足 → 使用Kruskal-Wallis检验\n"
)
invisible
(
object
)
}
# ------------------------------
# Plot方法
# ------------------------------
#' @export
plot.mda
<-
function
(
x
,
plots
=
c
(
"norm_qq"
,
"norm_hist"
,
"homo_box"
),
shiny
=
FALSE
,
custom
=
FALSE
,
...
)
{
# 1. 基础校验
if
(
length
(
plots
)
==
0
)
{
return
(
ggplot2
::
ggplot
()
+
ggplot2
::
annotate
(
"text"
,
x
=
1
,
y
=
1
,
label
=
i
18
n
$
t
(
"No plots selected"
))
+
ggplot2
::
theme_void
())
}
plot_list
<-
list
()
var_name
<-
x
$
var
group_name
<-
x
$
group
# 2. 正态性检验图表
# 2.1 Q-Q图
if
(
"norm_qq"
%in%
plots
)
{
if
(
x
$
normality_type
==
"overall"
)
{
p
<-
ggplot2
::
ggplot
(
data.frame
(
y
=
x
$
plot_obj
$
norm
$
data
),
ggplot2
::
aes
(
sample
=
y
))
+
ggplot2
::
stat_qq
(
color
=
"#2E86AB"
,
size
=
1
)
+
ggplot2
::
stat_qq_line
(
color
=
"#A23B72"
,
linetype
=
"dashed"
)
+
ggplot2
::
labs
(
x
=
"Theoretical Quantiles"
,
y
=
paste
(
"Empirical Quantiles ("
,
var_name
,
")"
,
sep
=
""
),
title
=
"Normality: Q-Q Plot (Overall)"
)
+
ggplot2
::
theme_minimal
()
+
ggplot2
::
theme
(
plot.title
=
ggplot2
::
element_text
(
hjust
=
0.5
,
size
=
12
))
plot_list
[[
"norm_qq"
]]
<-
p
}
else
{
# 按分组画QQ图
group_data
<-
x
$
plot_obj
$
norm
$
group_data
for
(
level
in
names
(
group_data
))
{
p
<-
ggplot2
::
ggplot
(
data.frame
(
y
=
group_data
[[
level
]]),
ggplot2
::
aes
(
sample
=
y
))
+
ggplot2
::
stat_qq
(
color
=
"#2E86AB"
,
size
=
1
)
+
ggplot2
::
stat_qq_line
(
color
=
"#A23B72"
,
linetype
=
"dashed"
)
+
ggplot2
::
labs
(
x
=
"Theoretical Quantiles"
,
y
=
paste
(
"Empirical Quantiles ("
,
var_name
,
")"
,
sep
=
""
),
title
=
paste
(
"Normality: Q-Q Plot ("
,
level
,
")"
,
sep
=
""
))
+
ggplot2
::
theme_minimal
()
+
ggplot2
::
theme
(
plot.title
=
ggplot2
::
element_text
(
hjust
=
0.5
,
size
=
12
))
plot_list
[[
paste
(
"norm_qq_"
,
level
,
sep
=
""
)]]
<-
p
}
}
}
# 2.2 直方图
if
(
"norm_hist"
%in%
plots
)
{
if
(
x
$
normality_type
==
"overall"
)
{
p
<-
ggplot2
::
ggplot
(
data.frame
(
y
=
x
$
plot_obj
$
norm
$
data
),
ggplot2
::
aes
(
x
=
y
))
+
ggplot2
::
geom_histogram
(
fill
=
"#F18F01"
,
alpha
=
0.7
,
bins
=
30
)
+
ggplot2
::
labs
(
x
=
var_name
,
y
=
"Count"
,
title
=
"Normality: Histogram (Overall)"
)
+
ggplot2
::
theme_minimal
()
+
ggplot2
::
theme
(
plot.title
=
ggplot2
::
element_text
(
hjust
=
0.5
,
size
=
12
))
plot_list
[[
"norm_hist"
]]
<-
p
}
else
{
# 按分组画直方图
group_data
<-
x
$
plot_obj
$
norm
$
group_data
for
(
level
in
names
(
group_data
))
{
p
<-
ggplot2
::
ggplot
(
data.frame
(
y
=
group_data
[[
level
]]),
ggplot2
::
aes
(
x
=
y
))
+
ggplot2
::
geom_histogram
(
fill
=
"#F18F01"
,
alpha
=
0.7
,
bins
=
30
)
+
ggplot2
::
labs
(
x
=
var_name
,
y
=
"Count"
,
title
=
paste
(
"Normality: Histogram ("
,
level
,
")"
,
sep
=
""
))
+
ggplot2
::
theme_minimal
()
+
ggplot2
::
theme
(
plot.title
=
ggplot2
::
element_text
(
hjust
=
0.5
,
size
=
12
))
plot_list
[[
paste
(
"norm_hist_"
,
level
,
sep
=
""
)]]
<-
p
}
}
}
# 3. 方差齐性检验图表
if
(
"homo_box"
%in%
plots
)
{
p
<-
ggplot2
::
ggplot
(
x
$
plot_obj
$
homo
$
data
,
ggplot2
::
aes
(
x
=
.data
[[
group_name
]],
y
=
.data
[[
var_name
]],
fill
=
.data
[[
group_name
]]))
+
ggplot2
::
geom_boxplot
(
alpha
=
0.7
,
show.legend
=
FALSE
)
+
ggplot2
::
scale_fill_brewer
(
palette
=
"Set2"
)
+
ggplot2
::
labs
(
x
=
group_name
,
y
=
var_name
,
title
=
"Homogeneity: Boxplot by Group"
)
+
ggplot2
::
theme_minimal
()
+
ggplot2
::
theme
(
plot.title
=
ggplot2
::
element_text
(
hjust
=
0.5
,
size
=
12
))
plot_list
[[
"homo_box"
]]
<-
p
}
# 4. 组合图表
combined_plot
<-
patchwork
::
wrap_plots
(
plot_list
,
ncol
=
1
,
guides
=
"collect"
)
# 5. 输出
if
(
shiny
)
{
print
(
combined_plot
)
return
(
invisible
(
combined_plot
))
}
else
{
return
(
combined_plot
)
}
}
radiant.basics/inst/app/init.R
View file @
078f95fa
...
...
@@ -4,6 +4,8 @@ r_url_list[["Single mean"]] <-
list
(
"tabs_single_mean"
=
list
(
"Summary"
=
"basics/single-mean/"
,
"Plot"
=
"basics/single-mean/plot/"
))
r_url_list
[[
"Compare means(t-test/Wilcoxon rank-sum test)"
]]
<-
list
(
"tabs_compare_means"
=
list
(
"Summary"
=
"basics/compare-means/"
,
"Plot"
=
"basics/compare-means/plot/"
))
r_url_list
[[
"Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"
]]
<-
list
(
"tabs_mda"
=
list
(
"Summary"
=
"basics/mda/"
,
"Plot"
=
"basics/mda/plot/"
))
r_url_list
[[
"Single proportion"
]]
<-
list
(
"tabs_single_prop"
=
list
(
"Summary"
=
"basics/single-prop/"
,
"Plot"
=
"basics/single-prop/plot/"
))
r_url_list
[[
"Compare proportions"
]]
<-
...
...
@@ -35,8 +37,9 @@ options(
"----"
,
i
18
n
$
t
(
"Means"
),
tabPanel
(
i
18
n
$
t
(
"Single mean"
),
uiOutput
(
"single_mean"
)),
tabPanel
(
i
18
n
$
t
(
"Compare means(t-test/Wilcoxon rank-sum test)"
),
uiOutput
(
"compare_means"
)),
tabPanel
(
i
18
n
$
t
(
"Normality test"
),
uiOutput
(
"normality_test"
)),
tabPanel
(
i
18
n
$
t
(
"Homogeneity of variance test"
),
uiOutput
(
"homo_variance_test"
)),
#tabPanel(i18n$t("Normality test"),uiOutput("normality_test")),
#tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")),
tabPanel
(
i
18
n
$
t
(
"Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"
),
uiOutput
(
"mda"
)),
"----"
,
i
18
n
$
t
(
"Proportions"
),
tabPanel
(
i
18
n
$
t
(
"Single proportion"
),
uiOutput
(
"single_prop"
)),
tabPanel
(
i
18
n
$
t
(
"Compare proportions"
),
uiOutput
(
"compare_props"
)),
...
...
radiant.basics/inst/app/tools/analysis/mda_ui.R
0 → 100644
View file @
078f95fa
############################################
## Multigroup Difference Analysis (ANOVA/KW) - UI
## 对齐单独检验的UI设计:简洁+严格校验+统一风格
############################################
## 1. 翻译标签(对齐单独检验的i18n逻辑,保持术语一致)
mda_norm_type
<-
c
(
"overall"
,
"by_group"
)
names
(
mda_norm_type
)
<-
c
(
i
18
n
$
t
(
"Overall (Whole variable)"
),
i
18
n
$
t
(
"By Group (Each level separately)"
))
mda_plots
<-
c
(
"norm_qq"
,
"norm_hist"
,
"homo_box"
)
names
(
mda_plots
)
<-
c
(
i
18
n
$
t
(
"Normality: Q-Q Plot"
),
i
18
n
$
t
(
"Normality: Histogram"
),
i
18
n
$
t
(
"Homogeneity: Boxplot by Group"
))
## 2. 函数形参
mda_args
<-
as.list
(
formals
(
mda
))
mda_args
<-
mda_args
[
names
(
mda_args
)
%in%
c
(
"dataset"
,
"var"
,
"group"
,
"normality_type"
,
"data_filter"
)]
## 3. 输入收集
mda_inputs
<-
reactive
({
req
(
input
$
dataset
)
# 基础参数
inputs
<-
list
(
dataset
=
input
$
dataset
,
var
=
input
$
mda_var
,
group
=
input
$
mda_group
,
normality_type
=
input
$
mda_normality_type
,
data_filter
=
if
(
input
$
show_filter
)
input
$
data_filter
else
"None"
,
envir
=
r_data
)
# 校验参数完整性
for
(
arg
in
names
(
mda_args
))
{
if
(
is.null
(
inputs
[[
arg
]]))
inputs
[[
arg
]]
<-
mda_args
[[
arg
]]
}
inputs
})
## 4. 因变量选择
output
$
ui_mda_var
<-
renderUI
({
req
(
input
$
dataset
)
current_data
<-
get_data
(
input
$
dataset
,
envir
=
r_data
)
is_num
<-
sapply
(
current_data
,
function
(
col
)
is.numeric
(
col
)
||
is.ts
(
col
))
num_vars
<-
names
(
is_num
)[
is_num
]
if
(
length
(
num_vars
)
==
0
)
{
return
(
div
(
class
=
"alert alert-warning"
,
i
18
n
$
t
(
"No numeric variables in dataset. Please select another dataset."
)))
}
# 提取变量类型并组合标签
var_types
<-
sapply
(
current_data
[,
num_vars
,
drop
=
FALSE
],
function
(
col
)
class
(
col
)[
1
])
choices
<-
setNames
(
nm
=
paste0
(
num_vars
,
" {"
,
var_types
,
"}"
),
object
=
num_vars
)
selectInput
(
inputId
=
"mda_var"
,
label
=
i
18
n
$
t
(
"Dependent variable:"
),
choices
=
c
(
"None"
=
""
,
choices
),
selected
=
state_single
(
"mda_var"
,
num_vars
),
multiple
=
FALSE
)
})
## 5. 分组变量选择
output
$
ui_mda_group
<-
renderUI
({
req
(
input
$
dataset
)
current_data
<-
get_data
(
input
$
dataset
,
envir
=
r_data
)
is_group
<-
sapply
(
current_data
,
function
(
col
)
is.factor
(
col
)
||
is.character
(
col
))
group_candidates
<-
names
(
is_group
)[
is_group
]
valid_groups
<-
character
(
0
)
for
(
grp
in
group_candidates
)
{
grp_vals
<-
current_data
[[
grp
]]
valid_levels
<-
length
(
unique
(
grp_vals
[
!
is.na
(
grp_vals
)]))
if
(
valid_levels
>=
2
)
{
valid_groups
<-
c
(
valid_groups
,
grp
)
}
}
if
(
length
(
valid_groups
)
==
0
)
{
return
(
div
(
class
=
"alert alert-warning"
,
i
18
n
$
t
(
"No valid grouping variables (need ≥2 levels)."
)))
}
#提取变量类型并组合标签
group_types
<-
sapply
(
current_data
[,
valid_groups
,
drop
=
FALSE
],
function
(
col
)
class
(
col
)[
1
])
choices
<-
setNames
(
nm
=
paste0
(
valid_groups
,
" {"
,
group_types
,
"}"
),
object
=
valid_groups
)
selectInput
(
inputId
=
"mda_group"
,
label
=
i
18
n
$
t
(
"Grouping variable:"
),
choices
=
choices
,
selected
=
state_single
(
"mda_group"
,
valid_groups
),
multiple
=
FALSE
)
})
## 6. 正态性检验类型选择
output
$
ui_mda_normality_type
<-
renderUI
({
selectInput
(
inputId
=
"mda_normality_type"
,
label
=
i
18
n
$
t
(
"Normality test:"
),
choices
=
mda_norm_type
,
selected
=
state_single
(
"mda_normality_type"
,
mda_norm_type
,
"overall"
),
multiple
=
FALSE
)
})
## 7. 主UI
output
$
ui_mda
<-
renderUI
({
req
(
input
$
dataset
)
tagList
(
wellPanel
(
# Summary标签页
conditionalPanel
(
condition
=
"input.tabs_mda == 'Summary'"
,
uiOutput
(
"ui_mda_var"
),
uiOutput
(
"ui_mda_group"
),
uiOutput
(
"ui_mda_normality_type"
)
),
# Plot标签页
conditionalPanel
(
condition
=
"input.tabs_mda == 'Plot'"
,
selectizeInput
(
inputId
=
"mda_plots"
,
label
=
i
18
n
$
t
(
"Select plots:"
),
choices
=
mda_plots
,
selected
=
state_multiple
(
"mda_plots"
,
mda_plots
,
"norm_qq"
),
# 默认选QQ图
multiple
=
TRUE
,
options
=
list
(
placeholder
=
i
18
n
$
t
(
"Select plot types"
),
plugins
=
list
(
"remove_button"
,
"drag_drop"
)
)
)
)
),
# 帮助与报告
help_and_report
(
modal_title
=
i
18
n
$
t
(
"Multigroup Difference Analysis (ANOVA/KW)"
),
fun_name
=
"mda"
,
help_file
=
inclMD
(
file.path
(
getOption
(
"radiant.path.basics"
),
"app/tools/help/mda.md"
))
)
)
})
## 8. 图表尺寸
mda_plot_dims
<-
reactive
({
req
(
.mda
())
plot_count
<-
length
(
input
$
mda_plots
)
group_count
<-
if
(
.mda
()
$
normality_type
==
"by_group"
)
{
length
(
levels
(
.mda
()
$
plot_obj
$
homo
$
data
[[
.mda
()
$
group
]]))
}
else
{
1
}
base_subplot_height_px
<-
350
total_height_px
<-
base_subplot_height_px
*
plot_count
*
group_count
total_height_px
<-
min
(
total_height_px
,
2000
)
total_height_px
<-
max
(
total_height_px
,
400
)
list
(
width
=
700
,
height
=
total_height_px
)
})
mda_plot_width
<-
function
()
mda_plot_dims
()
$
width
mda_plot_height
<-
function
()
mda_plot_dims
()
$
height
## 9. 输出面板
output
$
mda
<-
renderUI
({
# 注册输出
register_print_output
(
"summary_mda"
,
".summary_mda"
)
register_plot_output
(
"plot_mda"
,
".plot_mda"
,
height_fun
=
"mda_plot_height"
)
# 标签页
mda_panels
<-
tabsetPanel
(
id
=
"tabs_mda"
,
tabPanel
(
title
=
i
18
n
$
t
(
"Summary"
),
value
=
"Summary"
,
verbatimTextOutput
(
"summary_mda"
,
placeholder
=
TRUE
)
),
tabPanel
(
title
=
i
18
n
$
t
(
"Plot"
),
value
=
"Plot"
,
download_link
(
"dlp_mda"
),
# 下载按钮
plotOutput
(
"plot_mda"
,
height
=
"100%"
),
style
=
"margin-top: 10px;"
)
)
# 整合到Radiant标准面板
stat_tab_panel
(
menu
=
i
18
n
$
t
(
"Basics > Means"
),
tool
=
i
18
n
$
t
(
"Multigroup Difference Analysis(ANOVA/Kruskal-Wallis)"
),
tool_ui
=
"ui_mda"
,
output_panels
=
mda_panels
)
})
## 10. 可用性检验
mda_available
<-
reactive
({
req
(
input
$
dataset
)
current_data
<-
get_data
(
input
$
dataset
,
envir
=
r_data
)
# 1. 校验因变量
if
(
not_available
(
input
$
mda_var
)
||
!
input
$
mda_var
%in%
colnames
(
current_data
))
{
return
(
i
18
n
$
t
(
"Please select a valid numeric dependent variable."
))
}
# 2. 校验分组变量
if
(
not_available
(
input
$
mda_group
)
||
!
input
$
mda_group
%in%
colnames
(
current_data
))
{
return
(
i
18
n
$
t
(
"Please select a valid grouping variable."
))
}
# 3. 校验分组变量水平
group_vals
<-
current_data
[[
input
$
mda_group
]]
valid_levels
<-
length
(
unique
(
group_vals
[
!
is.na
(
group_vals
)]))
if
(
valid_levels
<
2
)
{
return
(
i
18
n
$
t
(
"Grouping variable has <2 valid levels. Choose another."
))
}
# 4. 校验有效样本
valid_n
<-
sum
(
!
is.na
(
current_data
[[
input
$
mda_var
]])
&
!
is.na
(
current_data
[[
input
$
mda_group
]]))
if
(
valid_n
<
5
)
{
# 最小样本量校验
return
(
i
18
n
$
t
(
paste
(
"Valid samples are too few (n="
,
valid_n
,
"). Need at least 5."
,
sep
=
""
)))
}
"available"
# 所有校验通过
})
## 11. 计算核心
.mda
<-
reactive
({
req
(
mda_available
()
==
"available"
)
do.call
(
mda
,
mda_inputs
())
})
.summary_mda
<-
reactive
({
req
(
mda_available
()
==
"available"
)
summary
(
.mda
())
})
.plot_mda
<-
reactive
({
req
(
mda_available
()
==
"available"
)
validate
(
need
(
input
$
mda_plots
,
i
18
n
$
t
(
"Please select at least one plot type first."
)))
# 进度提示
withProgress
(
message
=
i
18
n
$
t
(
"Generating plots..."
),
value
=
0.5
,
{
p
<-
plot
(
.mda
(),
plots
=
input
$
mda_plots
,
shiny
=
TRUE
)
setProgress
(
value
=
1
)
})
p
})
## 12. 下载与截图
# 图表下载
download_handler
(
id
=
"dlp_mda"
,
fun
=
function
(
file
)
{
# 1. 校验图表对象
plot_obj
<-
.plot_mda
()
width_in
<-
mda_plot_width
()
/
96
height_in
<-
mda_plot_height
()
/
96
ggsave
(
filename
=
file
,
plot
=
plot_obj
,
width
=
width_in
,
height
=
height_in
,
device
=
"png"
,
dpi
=
300
,
limitsize
=
FALSE
,
bg
=
"white"
)
},
fn
=
function
()
paste0
(
input
$
dataset
,
"_mda_plots"
),
type
=
"png"
,
caption
=
i
18
n
$
t
(
"Save plots"
)
)
# 报告生成
mda_report
<-
function
()
{
req
(
mda_available
()
==
"available"
)
figs
<-
length
(
input
$
mda_plots
)
>
0
# 报告结构
update_report
(
inp_main
=
clean_args
(
mda_inputs
(),
mda_args
),
fun_name
=
"mda"
,
inp_out
=
if
(
figs
)
list
(
""
,
list
(
plots
=
input
$
mda_plots
))
else
list
(
""
),
outputs
=
if
(
figs
)
c
(
"summary"
,
"plot"
)
else
"summary"
,
figs
=
figs
,
fig.width
=
mda_plot_width
(),
fig.height
=
mda_plot_height
()
)
}
# 截图功能
observeEvent
(
input
$
mda_report
,
{
r_info
[[
"latest_screenshot"
]]
<-
NULL
mda_report
()
})
observeEvent
(
input
$
mda_screenshot
,
{
r_info
[[
"latest_screenshot"
]]
<-
NULL
radiant_screenshot_modal
(
"modal_mda_screenshot"
)
})
observeEvent
(
input
$
modal_mda_screenshot
,
{
mda_report
()
removeModal
()
})
radiant.basics/inst/app/tools/help/mda.md
0 → 100644
View file @
078f95fa
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