diff --git a/radiant.basics/inst/app/init.R b/radiant.basics/inst/app/init.R index 5f9513350f94f8488166992b6fbf5e26204ab920..76b33b87222ef0e7312a2eb9092eb879b339cdc3 100644 --- a/radiant.basics/inst/app/init.R +++ b/radiant.basics/inst/app/init.R @@ -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")) ) ) diff --git a/radiant.basics/inst/app/tools/analysis/compare_means_ui.R b/radiant.basics/inst/app/tools/analysis/compare_means_ui.R index 4e0de2e3ee302ed066b3c2507f65fc83205e9058..53b474987791c791b14d04cd4c960782eb535057 100644 --- a/radiant.basics/inst/app/tools/analysis/compare_means_ui.R +++ b/radiant.basics/inst/app/tools/analysis/compare_means_ui.R @@ -1,317 +1,317 @@ -## 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 +}) diff --git a/radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R b/radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R index b349d232b44e881711c0d8a8f91f0cee62284958..9be55d8ddc10784f0bbf9fc6b032b3f99541b43b 100644 --- a/radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R +++ b/radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R @@ -1,211 +1,211 @@ -## 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 +})