Skip to content

R
Radiant
Commit 0dec47dc authored by wuzekai's avatar wuzekai
Browse files
Options

修改了部分功能的描述

parent 8427b521
Hide whitespace changes
Inline Side-by-side
Showing with 532 additions and 532 deletions
radiant.basics/inst/app/init.R
View file @ 0dec47dc
......@@ -2,7 +2,7 @@
r_url_list <- getOption("radiant.url.list")
r_url_list[["Single mean"]] <-
list("tabs_single_mean" = list("Summary" = "basics/single-mean/", "Plot" = "basics/single-mean/plot/"))
r_url_list[["Compare means"]] <-
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[["Single proportion"]] <-
list("tabs_single_prop" = list("Summary" = "basics/single-prop/", "Plot" = "basics/single-prop/plot/"))
......@@ -10,7 +10,7 @@ r_url_list[["Compare proportions"]] <-
list("tabs_compare_props" = list("Summary" = "basics/compare-props/", "Plot" = "basics/compare-props/plot/"))
r_url_list[["Goodness of fit"]] <-
list("tabs_goodness" = list("Summary" = "basics/goodness/", "Plot" = "basics/goodness/plot/"))
r_url_list[["Cross-tabs"]] <-
r_url_list[["Cross-tabs(Chi-square test, etc)"]] <-
list("tabs_cross_tabs" = list("Summary" = "basics/cross-tabs/", "Plot" = "basics/cross-tabs/plot/"))
r_url_list[["Correlation"]] <-
list("tabs_correlation" = list("Summary" = "basics/correlation/", "Plot" = "basics`/correlation/plot/"))
......@@ -34,7 +34,7 @@ options(
tabPanel(i18n$t("Central Limit Theorem"), uiOutput("clt")),
"----", i18n$t("Means"),
tabPanel(i18n$t("Single mean"), uiOutput("single_mean")),
tabPanel(i18n$t("Compare means"), uiOutput("compare_means")),
tabPanel(i18n$t("Compare means(t-test/Wilcoxon rank-sum test)"), uiOutput("compare_means")),
tabPanel(i18n$t("Normality test"),uiOutput("normality_test")),
tabPanel(i18n$t("Homogeneity of variance test"),uiOutput("homo_variance_test")),
"----", i18n$t("Proportions"),
......@@ -42,7 +42,7 @@ options(
tabPanel(i18n$t("Compare proportions"), uiOutput("compare_props")),
"----", i18n$t("Tables"),
tabPanel(i18n$t("Goodness of fit"), uiOutput("goodness")),
tabPanel(i18n$t("Cross-tabs"), uiOutput("cross_tabs")),
tabPanel(i18n$t("Cross-tabs(Chi-square test, etc)"), uiOutput("cross_tabs")),
tabPanel(i18n$t("Correlation"), uiOutput("correlation"))
)
)
......
radiant.basics/inst/app/tools/analysis/compare_means_ui.R
View file @ 0dec47dc
## choice lists for compare means
cm_alt <- c(
"two.sided",
"less",
"greater"
) %>% setNames(c(
i18n$t("Two sided"),
i18n$t("Less than"),
i18n$t("Greater than")
))
cm_samples <- c(
"independent",
"paired"
) %>% setNames(c(
i18n$t("independent"),
i18n$t("paired")
))
cm_adjust <- c(
"none",
"bonf"
) %>% setNames(c(
i18n$t("None"),
i18n$t("Bonferroni")
))
cm_plots <- c(
"scatter",
"box",
"density",
"bar"
) %>% setNames(c(
i18n$t("Scatter"),
i18n$t("Box"),
i18n$t("Density"),
i18n$t("Bar")
))
## list of function arguments
cm_args <- as.list(formals(compare_means))
## list of function inputs selected by user
cm_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
cm_args$data_filter <- if (input$show_filter) input$data_filter else ""
cm_args$dataset <- input$dataset
for (i in r_drop(names(cm_args))) {
cm_args[[i]] <- input[[paste0("cm_", i)]]
}
cm_args
})
###############################
# Compare means
###############################
output$ui_cm_var1 <- renderUI({
vars <- c("None" = "", groupable_vars())
isNum <- .get_class() %in% c("integer", "numeric", "ts")
## can't use unique here - removes variable type information
vars <- c(vars, varnames()[isNum]) %>% .[!duplicated(.)]
selectInput(
inputId = "cm_var1",
label = i18n$t("Select a factor or numeric variable:"),
choices = vars,
selected = state_single("cm_var1", vars),
multiple = FALSE
)
})
output$ui_cm_var2 <- renderUI({
if (not_available(input$cm_var1)) {
return()
}
isNum <- .get_class() %in% c("integer", "numeric", "ts")
vars <- varnames()[isNum]
if (input$cm_var1 %in% vars) {
## when cm_var1 is numeric comparisons for multiple variables are possible
vars <- vars[-which(vars == input$cm_var1)]
if (length(vars) == 0) {
return()
}
selectizeInput(
inputId = "cm_var2", label = i18n$t("Numeric variable(s):"),
selected = state_multiple("cm_var2", vars, isolate(input$cm_var2)),
choices = vars, multiple = TRUE,
options = list(placeholder = "None", plugins = list("remove_button", "drag_drop"))
)
} else {
## when cm_var1 is not numeric comparisons are across levels/groups
vars <- c("None" = "", vars)
selectInput(
"cm_var2", i18n$t("Numeric variable:"),
selected = state_single("cm_var2", vars),
choices = vars,
multiple = FALSE
)
}
})
output$ui_cm_comb <- renderUI({
if (not_available(input$cm_var1)) {
return()
}
if (.get_class()[[input$cm_var1]] == "factor") {
levs <- .get_data()[[input$cm_var1]] %>% levels()
} else {
levs <- c(input$cm_var1, input$cm_var2)
}
if (length(levs) > 2) {
cmb <- combn(levs, 2) %>% apply(2, paste, collapse = ":")
} else {
return()
}
selectizeInput(
"cm_comb",
label = i18n$t("Choose combinations:"),
choices = cmb,
selected = state_multiple("cm_comb", cmb, cmb[1]),
multiple = TRUE,
options = list(placeholder = i18n$t("Evaluate all combinations"), plugins = list("remove_button", "drag_drop"))
)
})
output$ui_compare_means <- renderUI({
req(input$dataset)
tagList(
wellPanel(
conditionalPanel(
uiOutput("ui_cm_var1"),
uiOutput("ui_cm_var2"),
condition = "input.tabs_compare_means == 'Summary'",
uiOutput("ui_cm_comb"),
selectInput(
inputId = "cm_alternative", label = i18n$t("Alternative hypothesis:"),
choices = cm_alt,
selected = state_single("cm_alternative", cm_alt, cm_args$alternative)
),
sliderInput(
"cm_conf_lev", i18n$t("Confidence level:"),
min = 0.85, max = 0.99, step = 0.01,
value = state_init("cm_conf_lev", cm_args$conf_lev)
),
checkboxInput("cm_show", i18n$t("Show additional statistics"), value = state_init("cm_show", FALSE)),
radioButtons(
inputId = "cm_samples", label = i18n$t("Sample type:"), cm_samples,
selected = state_init("cm_samples", cm_args$samples),
inline = TRUE
),
radioButtons(
inputId = "cm_adjust", label = i18n$t("Multiple comp. adjustment:"), cm_adjust,
selected = state_init("cm_adjust", cm_args$adjust),
inline = TRUE
),
radioButtons(
inputId = "cm_test", label = i18n$t("Test type:"),
choices = c(
"t",
"wilcox"
) %>% setNames(c(
i18n$t("t-test"),
i18n$t("Wilcox")
)),
selected = state_init("cm_test", cm_args$test),
inline = TRUE
)
),
conditionalPanel(
condition = "input.tabs_compare_means == 'Plot'",
selectizeInput(
inputId = "cm_plots", label = i18n$t("Select plots:"),
choices = cm_plots,
selected = state_multiple("cm_plots", cm_plots, "scatter"),
multiple = TRUE,
options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop"))
)
)
),
help_and_report(
modal_title = i18n$t("Compare means"),
fun_name = "compare_means",
help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/compare_means.md"))
)
)
})
cm_plot <- reactive({
list(plot_width = 650, plot_height = 400 * max(length(input$cm_plots), 1))
})
cm_plot_width <- function() {
cm_plot() %>%
(function(x) if (is.list(x)) x$plot_width else 650)
}
cm_plot_height <- function() {
cm_plot() %>%
(function(x) if (is.list(x)) x$plot_height else 400)
}
# output is called from the main radiant ui.R
output$compare_means <- renderUI({
register_print_output("summary_compare_means", ".summary_compare_means", )
register_plot_output(
"plot_compare_means", ".plot_compare_means",
height_fun = "cm_plot_height"
)
# two separate tabs
cm_output_panels <- tabsetPanel(
id = "tabs_compare_means",
tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_compare_means")),
tabPanel(
i18n$t("Plot"), value = "Plot",
download_link("dlp_compare_means"),
plotOutput("plot_compare_means", height = "100%")
)
)
stat_tab_panel(
menu = i18n$t("Basics > Means"),
tool = i18n$t("Compare means"),
tool_ui = "ui_compare_means",
output_panels = cm_output_panels
)
})
cm_available <- reactive({
if (not_available(input$cm_var1) || not_available(input$cm_var2)) {
return(i18n$t("This analysis requires at least two variables. The first can be of type\nfactor, numeric, or interval. The second must be of type numeric or interval.\nIf these variable types are not available please select another dataset.\n\n") %>% suggest_data("salary"))
} else if (length(input$cm_var2) > 1 && .get_class()[input$cm_var1] == "factor") {
" "
} else if (input$cm_var1 %in% input$cm_var2) {
" "
} else {
"available"
}
})
.compare_means <- reactive({
cmi <- cm_inputs()
cmi$envir <- r_data
do.call(compare_means, cmi)
})
.summary_compare_means <- reactive({
if (cm_available() != "available") {
return(cm_available())
}
if (input$cm_show) summary(.compare_means(), show = TRUE) else summary(.compare_means())
})
.plot_compare_means <- reactive({
if (cm_available() != "available") {
return(cm_available())
}
validate(need(input$cm_plots, i18n$t("Nothing to plot. Please select a plot type")))
withProgress(message = i18n$t("Generating plots"), value = 1, {
plot(.compare_means(), plots = input$cm_plots, shiny = TRUE)
})
})
compare_means_report <- function() {
if (is.empty(input$cm_var1) || is.empty(input$cm_var2)) {
return(invisible())
}
figs <- FALSE
outputs <- c("summary")
inp_out <- list(list(show = input$cm_show), "")
if (length(input$cm_plots) > 0) {
outputs <- c("summary", "plot")
inp_out[[2]] <- list(plots = input$cm_plots, custom = FALSE)
figs <- TRUE
}
update_report(
inp_main = clean_args(cm_inputs(), cm_args),
fun_name = "compare_means",
inp_out = inp_out,
outputs = outputs,
figs = figs,
fig.width = cm_plot_width(),
fig.height = cm_plot_height()
)
}
download_handler(
id = "dlp_compare_means",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_compare_means"),
type = "png",
caption = i18n$t("Save compare means plot"),
plot = .plot_compare_means,
width = cm_plot_width,
height = cm_plot_height
)
observeEvent(input$compare_means_report, {
r_info[["latest_screenshot"]] <- NULL
compare_means_report()
})
observeEvent(input$compare_means_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_compare_means_screenshot")
})
observeEvent(input$modal_compare_means_screenshot, {
compare_means_report()
removeModal() ## remove shiny modal after save
})
## choice lists for compare means
cm_alt <- c(
"two.sided",
"less",
"greater"
) %>% setNames(c(
i18n$t("Two sided"),
i18n$t("Less than"),
i18n$t("Greater than")
))
cm_samples <- c(
"independent",
"paired"
) %>% setNames(c(
i18n$t("independent"),
i18n$t("paired")
))
cm_adjust <- c(
"none",
"bonf"
) %>% setNames(c(
i18n$t("None"),
i18n$t("Bonferroni")
))
cm_plots <- c(
"scatter",
"box",
"density",
"bar"
) %>% setNames(c(
i18n$t("Scatter"),
i18n$t("Box"),
i18n$t("Density"),
i18n$t("Bar")
))
## list of function arguments
cm_args <- as.list(formals(compare_means))
## list of function inputs selected by user
cm_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
cm_args$data_filter <- if (input$show_filter) input$data_filter else ""
cm_args$dataset <- input$dataset
for (i in r_drop(names(cm_args))) {
cm_args[[i]] <- input[[paste0("cm_", i)]]
}
cm_args
})
###############################
# Compare means
###############################
output$ui_cm_var1 <- renderUI({
vars <- c("None" = "", groupable_vars())
isNum <- .get_class() %in% c("integer", "numeric", "ts")
## can't use unique here - removes variable type information
vars <- c(vars, varnames()[isNum]) %>% .[!duplicated(.)]
selectInput(
inputId = "cm_var1",
label = i18n$t("Select a factor or numeric variable:"),
choices = vars,
selected = state_single("cm_var1", vars),
multiple = FALSE
)
})
output$ui_cm_var2 <- renderUI({
if (not_available(input$cm_var1)) {
return()
}
isNum <- .get_class() %in% c("integer", "numeric", "ts")
vars <- varnames()[isNum]
if (input$cm_var1 %in% vars) {
## when cm_var1 is numeric comparisons for multiple variables are possible
vars <- vars[-which(vars == input$cm_var1)]
if (length(vars) == 0) {
return()
}
selectizeInput(
inputId = "cm_var2", label = i18n$t("Numeric variable(s):"),
selected = state_multiple("cm_var2", vars, isolate(input$cm_var2)),
choices = vars, multiple = TRUE,
options = list(placeholder = "None", plugins = list("remove_button", "drag_drop"))
)
} else {
## when cm_var1 is not numeric comparisons are across levels/groups
vars <- c("None" = "", vars)
selectInput(
"cm_var2", i18n$t("Numeric variable:"),
selected = state_single("cm_var2", vars),
choices = vars,
multiple = FALSE
)
}
})
output$ui_cm_comb <- renderUI({
if (not_available(input$cm_var1)) {
return()
}
if (.get_class()[[input$cm_var1]] == "factor") {
levs <- .get_data()[[input$cm_var1]] %>% levels()
} else {
levs <- c(input$cm_var1, input$cm_var2)
}
if (length(levs) > 2) {
cmb <- combn(levs, 2) %>% apply(2, paste, collapse = ":")
} else {
return()
}
selectizeInput(
"cm_comb",
label = i18n$t("Choose combinations:"),
choices = cmb,
selected = state_multiple("cm_comb", cmb, cmb[1]),
multiple = TRUE,
options = list(placeholder = i18n$t("Evaluate all combinations"), plugins = list("remove_button", "drag_drop"))
)
})
output$ui_compare_means <- renderUI({
req(input$dataset)
tagList(
wellPanel(
conditionalPanel(
uiOutput("ui_cm_var1"),
uiOutput("ui_cm_var2"),
condition = "input.tabs_compare_means == 'Summary'",
uiOutput("ui_cm_comb"),
selectInput(
inputId = "cm_alternative", label = i18n$t("Alternative hypothesis:"),
choices = cm_alt,
selected = state_single("cm_alternative", cm_alt, cm_args$alternative)
),
sliderInput(
"cm_conf_lev", i18n$t("Confidence level:"),
min = 0.85, max = 0.99, step = 0.01,
value = state_init("cm_conf_lev", cm_args$conf_lev)
),
checkboxInput("cm_show", i18n$t("Show additional statistics"), value = state_init("cm_show", FALSE)),
radioButtons(
inputId = "cm_samples", label = i18n$t("Sample type:"), cm_samples,
selected = state_init("cm_samples", cm_args$samples),
inline = TRUE
),
radioButtons(
inputId = "cm_adjust", label = i18n$t("Multiple comp. adjustment:"), cm_adjust,
selected = state_init("cm_adjust", cm_args$adjust),
inline = TRUE
),
radioButtons(
inputId = "cm_test", label = i18n$t("Test type:"),
choices = c(
"t",
"wilcox"
) %>% setNames(c(
i18n$t("t-test"),
i18n$t("Wilcox")
)),
selected = state_init("cm_test", cm_args$test),
inline = TRUE
)
),
conditionalPanel(
condition = "input.tabs_compare_means == 'Plot'",
selectizeInput(
inputId = "cm_plots", label = i18n$t("Select plots:"),
choices = cm_plots,
selected = state_multiple("cm_plots", cm_plots, "scatter"),
multiple = TRUE,
options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop"))
)
)
),
help_and_report(
modal_title = i18n$t("Compare means"),
fun_name = "compare_means",
help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/compare_means.md"))
)
)
})
cm_plot <- reactive({
list(plot_width = 650, plot_height = 400 * max(length(input$cm_plots), 1))
})
cm_plot_width <- function() {
cm_plot() %>%
(function(x) if (is.list(x)) x$plot_width else 650)
}
cm_plot_height <- function() {
cm_plot() %>%
(function(x) if (is.list(x)) x$plot_height else 400)
}
# output is called from the main radiant ui.R
output$compare_means <- renderUI({
register_print_output("summary_compare_means", ".summary_compare_means", )
register_plot_output(
"plot_compare_means", ".plot_compare_means",
height_fun = "cm_plot_height"
)
# two separate tabs
cm_output_panels <- tabsetPanel(
id = "tabs_compare_means",
tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_compare_means")),
tabPanel(
i18n$t("Plot"), value = "Plot",
download_link("dlp_compare_means"),
plotOutput("plot_compare_means", height = "100%")
)
)
stat_tab_panel(
menu = i18n$t("Basics > Means"),
tool = i18n$t("T-test/Wilcoxon rank-sum test"),
tool_ui = "ui_compare_means",
output_panels = cm_output_panels
)
})
cm_available <- reactive({
if (not_available(input$cm_var1) || not_available(input$cm_var2)) {
return(i18n$t("This analysis requires at least two variables. The first can be of type\nfactor, numeric, or interval. The second must be of type numeric or interval.\nIf these variable types are not available please select another dataset.\n\n") %>% suggest_data("salary"))
} else if (length(input$cm_var2) > 1 && .get_class()[input$cm_var1] == "factor") {
" "
} else if (input$cm_var1 %in% input$cm_var2) {
" "
} else {
"available"
}
})
.compare_means <- reactive({
cmi <- cm_inputs()
cmi$envir <- r_data
do.call(compare_means, cmi)
})
.summary_compare_means <- reactive({
if (cm_available() != "available") {
return(cm_available())
}
if (input$cm_show) summary(.compare_means(), show = TRUE) else summary(.compare_means())
})
.plot_compare_means <- reactive({
if (cm_available() != "available") {
return(cm_available())
}
validate(need(input$cm_plots, i18n$t("Nothing to plot. Please select a plot type")))
withProgress(message = i18n$t("Generating plots"), value = 1, {
plot(.compare_means(), plots = input$cm_plots, shiny = TRUE)
})
})
compare_means_report <- function() {
if (is.empty(input$cm_var1) || is.empty(input$cm_var2)) {
return(invisible())
}
figs <- FALSE
outputs <- c("summary")
inp_out <- list(list(show = input$cm_show), "")
if (length(input$cm_plots) > 0) {
outputs <- c("summary", "plot")
inp_out[[2]] <- list(plots = input$cm_plots, custom = FALSE)
figs <- TRUE
}
update_report(
inp_main = clean_args(cm_inputs(), cm_args),
fun_name = "compare_means",
inp_out = inp_out,
outputs = outputs,
figs = figs,
fig.width = cm_plot_width(),
fig.height = cm_plot_height()
)
}
download_handler(
id = "dlp_compare_means",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_compare_means"),
type = "png",
caption = i18n$t("Save compare means plot"),
plot = .plot_compare_means,
width = cm_plot_width,
height = cm_plot_height
)
observeEvent(input$compare_means_report, {
r_info[["latest_screenshot"]] <- NULL
compare_means_report()
})
observeEvent(input$compare_means_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_compare_means_screenshot")
})
observeEvent(input$modal_compare_means_screenshot, {
compare_means_report()
removeModal() ## remove shiny modal after save
})
radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R
View file @ 0dec47dc
## alternative hypothesis options
ct_check <- c(
"observed",
"expected",
"chi_sq",
"dev_std",
"row_perc",
"col_perc",
"perc"
)
names(ct_check) <- c(
i18n$t("Observed"),
i18n$t("Expected"),
i18n$t("Chi-squared"),
i18n$t("Deviation std."),
i18n$t("Row percentages"),
i18n$t("Column percentages"),
i18n$t("Table percentages")
)
## list of function arguments
ct_args <- as.list(formals(cross_tabs))
## list of function inputs selected by user
ct_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
ct_args$data_filter <- if (input$show_filter) input$data_filter else ""
ct_args$dataset <- input$dataset
for (i in r_drop(names(ct_args))) {
ct_args[[i]] <- input[[paste0("ct_", i)]]
}
ct_args
})
###############################
# Cross-tabs
###############################
output$ui_ct_var1 <- renderUI({
vars <- c("None" = "", groupable_vars())
selectInput(
inputId = "ct_var1", label = i18n$t("Select a categorical variable:"),
choices = vars, selected = state_single("ct_var1", vars), multiple = FALSE
)
})
output$ui_ct_var2 <- renderUI({
if (not_available(input$ct_var1)) {
return()
}
vars <- c("None" = "", groupable_vars())
if (length(vars) > 0) vars <- vars[-which(vars == input$ct_var1)]
selectInput(
inputId = "ct_var2", label = i18n$t("Select a categorical variable:"),
selected = state_single("ct_var2", vars),
choices = vars, multiple = FALSE
)
})
output$ui_cross_tabs <- renderUI({
req(input$dataset)
tagList(
wellPanel(
conditionalPanel(
condition = "input.tabs_cross_tabs == 'Summary'",
uiOutput("ui_ct_var1"),
uiOutput("ui_ct_var2")
),
br(),
checkboxGroupInput(
"ct_check", NULL,
choices = ct_check,
selected = state_group("ct_check"),
inline = FALSE
)
),
help_and_report(
modal_title = i18n$t("Cross-tabs"),
fun_name = "cross_tabs",
help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/cross_tabs.md"))
)
)
})
ct_plot <- reactive({
list(plot_width = 650, plot_height = 400 * max(length(input$ct_check), 1))
})
ct_plot_width <- function() {
ct_plot() %>%
(function(x) if (is.list(x)) x$plot_width else 650)
}
ct_plot_height <- function() {
ct_plot() %>%
(function(x) if (is.list(x)) x$plot_height else 400)
}
## output is called from the main radiant ui.R
output$cross_tabs <- renderUI({
register_print_output("summary_cross_tabs", ".summary_cross_tabs")
register_plot_output(
"plot_cross_tabs", ".plot_cross_tabs",
height_fun = "ct_plot_height",
width_fun = "ct_plot_width"
)
## two separate tabs
ct_output_panels <- tabsetPanel(
id = "tabs_cross_tabs",
tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_cross_tabs")),
tabPanel(
i18n$t("Plot"), value = "Plot",
download_link("dlp_cross_tabs"),
plotOutput("plot_cross_tabs", width = "100%", height = "100%")
)
)
stat_tab_panel(
menu = i18n$t("Basics > Tables"),
tool = i18n$t("Cross-tabs"),
tool_ui = "ui_cross_tabs",
output_panels = ct_output_panels
)
})
ct_available <- reactive({
if (not_available(input$ct_var1) || not_available(input$ct_var2)) {
i18n$t("This analysis requires two categorical variables. Both must have two or more levels.\nIf these variable types are not available please select another dataset.\n\n") %>%
suggest_data("newspaper")
} else {
"available"
}
})
.cross_tabs <- reactive({
cti <- ct_inputs()
cti$envir <- r_data
do.call(cross_tabs, cti)
})
.summary_cross_tabs <- reactive({
if (ct_available() != "available") {
return(ct_available())
}
summary(.cross_tabs(), check = input$ct_check)
})
.plot_cross_tabs <- reactive({
if (ct_available() != "available") {
return(ct_available())
}
validate(need(input$ct_check, i18n$t("Nothing to plot. Please select a plot type")))
withProgress(message = i18n$t("Generating plots"), value = 1, {
plot(.cross_tabs(), check = input$ct_check, shiny = TRUE)
})
})
cross_tabs_report <- function() {
if (is.empty(input$ct_var1) || is.empty(input$ct_var2)) {
return(invisible())
}
inp_out <- list("", "")
if (length(input$ct_check) > 0) {
outputs <- c("summary", "plot")
inp_out[[1]] <- list(check = input$ct_check)
inp_out[[2]] <- list(check = input$ct_check, custom = FALSE)
figs <- TRUE
} else {
outputs <- "summary"
inp_out[[1]] <- list(check = "")
figs <- FALSE
}
update_report(
inp_main = clean_args(ct_inputs(), ct_args),
inp_out = inp_out,
fun_name = "cross_tabs",
outputs = outputs,
figs = figs,
fig.width = ct_plot_width(),
fig.height = ct_plot_height()
)
}
download_handler(
id = "dlp_cross_tabs",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_cross_tabs"),
type = "png",
caption = i18n$t("Save cross-tabs plot"),
plot = .plot_cross_tabs,
width = ct_plot_width,
height = ct_plot_height
)
observeEvent(input$cross_tabs_report, {
r_info[["latest_screenshot"]] <- NULL
cross_tabs_report()
})
observeEvent(input$cross_tabs_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_cross_tabs_screenshot")
})
observeEvent(input$modal_cross_tabs_screenshot, {
cross_tabs_report()
removeModal() ## remove shiny modal after save
})
## alternative hypothesis options
ct_check <- c(
"observed",
"expected",
"chi_sq",
"dev_std",
"row_perc",
"col_perc",
"perc"
)
names(ct_check) <- c(
i18n$t("Observed"),
i18n$t("Expected"),
i18n$t("Chi-squared"),
i18n$t("Deviation std."),
i18n$t("Row percentages"),
i18n$t("Column percentages"),
i18n$t("Table percentages")
)
## list of function arguments
ct_args <- as.list(formals(cross_tabs))
## list of function inputs selected by user
ct_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
ct_args$data_filter <- if (input$show_filter) input$data_filter else ""
ct_args$dataset <- input$dataset
for (i in r_drop(names(ct_args))) {
ct_args[[i]] <- input[[paste0("ct_", i)]]
}
ct_args
})
###############################
# Cross-tabs
###############################
output$ui_ct_var1 <- renderUI({
vars <- c("None" = "", groupable_vars())
selectInput(
inputId = "ct_var1", label = i18n$t("Select a categorical variable:"),
choices = vars, selected = state_single("ct_var1", vars), multiple = FALSE
)
})
output$ui_ct_var2 <- renderUI({
if (not_available(input$ct_var1)) {
return()
}
vars <- c("None" = "", groupable_vars())
if (length(vars) > 0) vars <- vars[-which(vars == input$ct_var1)]
selectInput(
inputId = "ct_var2", label = i18n$t("Select a categorical variable:"),
selected = state_single("ct_var2", vars),
choices = vars, multiple = FALSE
)
})
output$ui_cross_tabs <- renderUI({
req(input$dataset)
tagList(
wellPanel(
conditionalPanel(
condition = "input.tabs_cross_tabs == 'Summary'",
uiOutput("ui_ct_var1"),
uiOutput("ui_ct_var2")
),
br(),
checkboxGroupInput(
"ct_check", NULL,
choices = ct_check,
selected = state_group("ct_check"),
inline = FALSE
)
),
help_and_report(
modal_title = i18n$t("Cross-tabs"),
fun_name = "cross_tabs",
help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/cross_tabs.md"))
)
)
})
ct_plot <- reactive({
list(plot_width = 650, plot_height = 400 * max(length(input$ct_check), 1))
})
ct_plot_width <- function() {
ct_plot() %>%
(function(x) if (is.list(x)) x$plot_width else 650)
}
ct_plot_height <- function() {
ct_plot() %>%
(function(x) if (is.list(x)) x$plot_height else 400)
}
## output is called from the main radiant ui.R
output$cross_tabs <- renderUI({
register_print_output("summary_cross_tabs", ".summary_cross_tabs")
register_plot_output(
"plot_cross_tabs", ".plot_cross_tabs",
height_fun = "ct_plot_height",
width_fun = "ct_plot_width"
)
## two separate tabs
ct_output_panels <- tabsetPanel(
id = "tabs_cross_tabs",
tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_cross_tabs")),
tabPanel(
i18n$t("Plot"), value = "Plot",
download_link("dlp_cross_tabs"),
plotOutput("plot_cross_tabs", width = "100%", height = "100%")
)
)
stat_tab_panel(
menu = i18n$t("Basics > Tables"),
tool = i18n$t("Cross-tabs(Chi-square test, etc)"),
tool_ui = "ui_cross_tabs",
output_panels = ct_output_panels
)
})
ct_available <- reactive({
if (not_available(input$ct_var1) || not_available(input$ct_var2)) {
i18n$t("This analysis requires two categorical variables. Both must have two or more levels.\nIf these variable types are not available please select another dataset.\n\n") %>%
suggest_data("newspaper")
} else {
"available"
}
})
.cross_tabs <- reactive({
cti <- ct_inputs()
cti$envir <- r_data
do.call(cross_tabs, cti)
})
.summary_cross_tabs <- reactive({
if (ct_available() != "available") {
return(ct_available())
}
summary(.cross_tabs(), check = input$ct_check)
})
.plot_cross_tabs <- reactive({
if (ct_available() != "available") {
return(ct_available())
}
validate(need(input$ct_check, i18n$t("Nothing to plot. Please select a plot type")))
withProgress(message = i18n$t("Generating plots"), value = 1, {
plot(.cross_tabs(), check = input$ct_check, shiny = TRUE)
})
})
cross_tabs_report <- function() {
if (is.empty(input$ct_var1) || is.empty(input$ct_var2)) {
return(invisible())
}
inp_out <- list("", "")
if (length(input$ct_check) > 0) {
outputs <- c("summary", "plot")
inp_out[[1]] <- list(check = input$ct_check)
inp_out[[2]] <- list(check = input$ct_check, custom = FALSE)
figs <- TRUE
} else {
outputs <- "summary"
inp_out[[1]] <- list(check = "")
figs <- FALSE
}
update_report(
inp_main = clean_args(ct_inputs(), ct_args),
inp_out = inp_out,
fun_name = "cross_tabs",
outputs = outputs,
figs = figs,
fig.width = ct_plot_width(),
fig.height = ct_plot_height()
)
}
download_handler(
id = "dlp_cross_tabs",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_cross_tabs"),
type = "png",
caption = i18n$t("Save cross-tabs plot"),
plot = .plot_cross_tabs,
width = ct_plot_width,
height = ct_plot_height
)
observeEvent(input$cross_tabs_report, {
r_info[["latest_screenshot"]] <- NULL
cross_tabs_report()
})
observeEvent(input$cross_tabs_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_cross_tabs_screenshot")
})
observeEvent(input$modal_cross_tabs_screenshot, {
cross_tabs_report()
removeModal() ## remove shiny modal after save
})
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment