\ No newline at end of file
diff --git a/radiant.basics/_pkgdown.yml b/radiant.basics/_pkgdown.yml
new file mode 100644
index 0000000..36f5023
--- /dev/null
+++ b/radiant.basics/_pkgdown.yml
@@ -0,0 +1,136 @@
+url: https://radiant-rstats.github.io/radiant.basics
+
+template:
+ params:
+ docsearch:
+ api_key: 0629d253426ce7046f92e2bc5bb11b03
+ index_name: radiant_basics
+
+navbar:
+ title: "radiant.basics"
+ left:
+ - icon: fa-home fa-lg
+ href: index.html
+ - text: "Reference"
+ href: reference/index.html
+ - text: "Articles"
+ href: articles/index.html
+ - text: "Changelog"
+ href: news/index.html
+ - text: "Other Packages"
+ menu:
+ - text: "radiant"
+ href: https://radiant-rstats.github.io/radiant/
+ - text: "radiant.data"
+ href: https://radiant-rstats.github.io/radiant.data/
+ - text: "radiant.design"
+ href: https://radiant-rstats.github.io/radiant.design/
+ - text: "radiant.basics"
+ href: https://radiant-rstats.github.io/radiant.basics/
+ - text: "radiant.model"
+ href: https://radiant-rstats.github.io/radiant.model/
+ - text: "radiant.multivariate"
+ href: https://radiant-rstats.github.io/radiant.multivariate/
+ - text: "docker"
+ href: https://github.com/radiant-rstats/docker
+ right:
+ - icon: fa-twitter fa-lg
+ href: https://twitter.com/vrnijs
+ - icon: fa-github fa-lg
+ href: https://github.com/radiant-rstats
+
+reference:
+- title: Basics > Probability
+ desc: Functions used with the Probability Calculator and the Central Limit Theorem simulator
+ contents:
+ - clt
+ - plot.clt
+ - prob_binom
+ - summary.prob_binom
+ - plot.prob_binom
+ - prob_chisq
+ - summary.prob_chisq
+ - plot.prob_chisq
+ - prob_disc
+ - summary.prob_disc
+ - plot.prob_disc
+ - prob_expo
+ - summary.prob_expo
+ - plot.prob_expo
+ - prob_fdist
+ - summary.prob_fdist
+ - plot.prob_fdist
+ - prob_lnorm
+ - summary.prob_lnorm
+ - plot.prob_lnorm
+ - prob_norm
+ - summary.prob_norm
+ - plot.prob_norm
+ - prob_pois
+ - summary.prob_pois
+ - plot.prob_pois
+ - prob_tdist
+ - summary.prob_tdist
+ - plot.prob_tdist
+ - prob_unif
+ - summary.prob_unif
+ - plot.prob_unif
+- title: Basics > Means
+ desc: Functions used with Basics > Means
+ contents:
+ - single_mean
+ - summary.single_mean
+ - plot.single_mean
+ - compare_means
+ - summary.compare_means
+ - plot.compare_means
+- title: Basics > Proportions
+ desc: Functions used with Basics > Proportions
+ contents:
+ - single_prop
+ - summary.single_prop
+ - plot.single_prop
+ - compare_props
+ - summary.compare_props
+ - plot.compare_props
+- title: Basics > Tables
+ desc: Functions used with Basics > Tables
+ contents:
+ - goodness
+ - summary.goodness
+ - plot.goodness
+ - cross_tabs
+ - summary.cross_tabs
+ - plot.cross_tabs
+ - correlation
+ - summary.correlation
+ - plot.correlation
+ - print.rcorr
+ - cor2df
+- title: Data sets
+ desc: Data sets bundled with radiant.basics
+ contents:
+ - consider
+ - demand_uk
+ - newspaper
+ - salary
+- title: Starting radiant.basics
+ desc: Functions used to start the radiant.basics shiny app
+ contents:
+ - radiant.basics
+ - radiant.basics_viewer
+ - radiant.basics_window
+articles:
+- title: Basics Menu
+ desc: >
+ These vignettes provide an introduction to the Basics menu in radiant
+ contents:
+ - pkgdown/clt
+ - pkgdown/prob_calc
+ - pkgdown/single_mean
+ - pkgdown/compare_means
+ - pkgdown/single_prop
+ - pkgdown/compare_props
+ - pkgdown/goodness
+ - pkgdown/cross_tabs
+ - pkgdown/correlation
diff --git a/radiant.basics/build/build.R b/radiant.basics/build/build.R
new file mode 100644
index 0000000..c901d8c
--- /dev/null
+++ b/radiant.basics/build/build.R
@@ -0,0 +1,87 @@
+setwd(rstudioapi::getActiveProject())
+curr <- getwd()
+pkg <- basename(curr)
+
+## building package for mac and windows
+rv <- R.Version()
+rv <- paste(rv$major, substr(rv$minor, 1, 1), sep = ".")
+
+rvprompt <- readline(prompt = paste0("Running for R version: ", rv, ". Is that what you wanted y/n: "))
+if (grepl("[nN]", rvprompt)) stop("Change R-version")
+
+dirsrc <- "../minicran/src/contrib"
+
+if (rv < "3.4") {
+ dirmac <- fs::path("../minicran/bin/macosx/mavericks/contrib", rv)
+} else if (rv > "3.6") {
+ dirmac <- c(
+ fs::path("../minicran/bin/macosx/big-sur-arm64/contrib", rv),
+ fs::path("../minicran/bin/macosx/contrib", rv)
+ )
+} else {
+ dirmac <- fs::path("../minicran/bin/macosx/el-capitan/contrib", rv)
+}
+
+dirwin <- fs::path("../minicran/bin/windows/contrib", rv)
+
+if (!fs::file_exists(dirsrc)) fs::dir_create(dirsrc, recursive = TRUE)
+for (d in dirmac) {
+ if (!fs::file_exists(d)) fs::dir_create(d, recursive = TRUE)
+}
+if (!fs::file_exists(dirwin)) fs::dir_create(dirwin, recursive = TRUE)
+
+# delete older version of radiant
+rem_old <- function(pkg) {
+ unlink(paste0(dirsrc, "/", pkg, "*"))
+ for (d in dirmac) {
+ unlink(paste0(d, "/", pkg, "*"))
+ }
+ unlink(paste0(dirwin, "/", pkg, "*"))
+}
+
+sapply(pkg, rem_old)
+
+## avoid 'loaded namespace' stuff when building for mac
+system(paste0(Sys.which("R"), " -e \"setwd('", getwd(), "'); app <- '", pkg, "'; source('build/build_mac.R')\""))
+
+
+win <- readline(prompt = "Did you build on Windows? y/n: ")
+if (grepl("[yY]", win)) {
+
+ fl <- list.files(pattern = "*.zip", path = "~/Dropbox/r-packages/", full.names = TRUE)
+ for (f in fl) {
+ file.copy(f, "~/gh/")
+ }
+
+ ## move packages to radiant_miniCRAN. must package in Windows first
+ # path <- normalizePath("../")
+ pth <- fs::path_abs("../")
+
+ sapply(list.files(pth, pattern = "*.tar.gz", full.names = TRUE), file.copy, dirsrc)
+ unlink("../*.tar.gz")
+ for (d in dirmac) {
+ sapply(list.files(pth, pattern = "*.tgz", full.names = TRUE), file.copy, d)
+ }
+ unlink("../*.tgz")
+ sapply(list.files(pth, pattern = "*.zip", full.names = TRUE), file.copy, dirwin)
+ unlink("../*.zip")
+
+ tools::write_PACKAGES(dirwin, type = "win.binary")
+ for (d in dirmac) {
+ tools::write_PACKAGES(d, type = "mac.binary")
+ }
+ tools::write_PACKAGES(dirsrc, type = "source")
+
+ # commit to repo
+ setwd("../minicran")
+ system("git add --all .")
+ mess <- paste0(pkg, " package update: ", format(Sys.Date(), format = "%m-%d-%Y"))
+ system(paste0("git commit -m '", mess, "'"))
+ system("git push")
+}
+
+setwd(curr)
+
+# remove.packages(c("radiant.model", "radiant.data"))
+# radiant.update::radiant.update()
+# install.packages("radiant.update")
diff --git a/radiant.basics/build/build_mac.R b/radiant.basics/build/build_mac.R
new file mode 100644
index 0000000..1452bac
--- /dev/null
+++ b/radiant.basics/build/build_mac.R
@@ -0,0 +1,6 @@
+## build for mac
+app <- basename(getwd())
+curr <- setwd("../")
+f <- devtools::build(app)
+system(paste0("R CMD INSTALL --build ", f))
+setwd(curr)
diff --git a/radiant.basics/build/build_win.R b/radiant.basics/build/build_win.R
new file mode 100644
index 0000000..e6861ce
--- /dev/null
+++ b/radiant.basics/build/build_win.R
@@ -0,0 +1,26 @@
+## build for windows
+rv <- R.Version()
+rv <- paste(rv$major, substr(rv$minor, 1, 1), sep = ".")
+
+rvprompt <- readline(prompt = paste0("Running for R version: ", rv, ". Is that what you wanted y/n: "))
+if (grepl("[nN]", rvprompt))
+ stop("Change R-version using Rstudio > Tools > Global Options > Rversion")
+
+## build for windows
+setwd(rstudioapi::getActiveProject())
+f <- devtools::build(binary = TRUE)
+devtools::install(upgrade = "never")
+
+fl <- list.files(pattern = "*.zip", path = "../", full.names = TRUE)
+
+for (f in fl) {
+ print(glue::glue("Copying: {f}"))
+ file.copy(f, "C:/Users/vnijs/Dropbox/r-packages/", overwrite = TRUE)
+ unlink(f)
+}
+
+#options(repos = c(RSM = "https://radiant-rstats.github.io/minicran"))
+#install.packages("radiant.data", type = "binary")
+# remove.packages(c("radiant.data", "radiant.model"))
+#install.packages("radiant.update")
+# radiant.update::radiant.update()
diff --git a/radiant.basics/data/consider.rda b/radiant.basics/data/consider.rda
new file mode 100644
index 0000000000000000000000000000000000000000..d00b31838f8bf9cbe39ca333d1fba82a47346ba9
GIT binary patch
literal 3248
zcmV;h3{UePiwFP!000001I?Ltd?i&C$0wWH@0}U2Vjo>mz%}fG4HXeV1r-Y*U}YzH
zliepT@5T3CHpGg(_ulKr-h1!8_uhNQUXkT{@-_>s2-%S2vwz&o%)RHH`a9))a^kV4
z9TrXtS(a_c#`RdXVVqaBfj?uJ$~;du)$0!0t)`!4*;hbkFVr Select help files to show and search
")),
+ htmlOutput("help_data"),
+ htmlOutput("help_basics")
+ )
+ )
+ })
+
+ ## packages to use for example data
+ options(radiant.example.data = c("radiant.data", "radiant.basics"))
+
+ ## source data & app tools from radiant.data
+ for (file in list.files(
+ c(
+ file.path(getOption("radiant.path.data"), "app/tools/app"),
+ file.path(getOption("radiant.path.data"), "app/tools/data")
+ ),
+ pattern = "\\.(r|R)$", full.names = TRUE
+ ))
+ source(file, encoding = getOption("radiant.encoding"), local = TRUE)
+
+ ## 'sourcing' package functions in the server.R environment for development
+ if (!isTRUE(getOption("radiant.from.package"))) {
+ for (file in list.files("../../R", pattern = "\\.(r|R)$", full.names = TRUE)) {
+ source(file, encoding = getOption("radiant.encoding"), local = TRUE)
+ }
+ cat("\nGetting radiant.basics from source ...\n")
+ } else {
+ ## weired but required
+ summary.correlation <- radiant.basics:::summary.correlation
+ }
+
+ ## source analysis tools for basic app
+ for (file in list.files(c("tools/analysis"), pattern = "\\.(r|R)$", full.names = TRUE))
+ source(file, encoding = getOption("radiant.encoding"), local = TRUE)
+
+ ## save state on refresh or browser close
+ saveStateOnRefresh(session)
+})
diff --git a/radiant.basics/inst/app/tools/analysis/clt_ui.R b/radiant.basics/inst/app/tools/analysis/clt_ui.R
new file mode 100644
index 0000000..fd2b94b
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/clt_ui.R
@@ -0,0 +1,252 @@
+###############################
+# Central Limit Theorem
+###############################
+clt_dist <- c("Normal", "Binomial", "Uniform", "Exponential") %>%
+ setNames(c(
+ i18n$t("Normal"),
+ i18n$t("Binomial"),
+ i18n$t("Uniform"),
+ i18n$t("Exponential")
+ ))
+
+clt_stat <- c("sum", "mean") %>%
+ setNames(c(
+ i18n$t("Sum"),
+ i18n$t("Mean")
+ ))
+clt_args <- as.list(formals(clt))
+
+clt_inputs <- reactive({
+ for (i in names(clt_args)) {
+ clt_args[[i]] <- input[[paste0("clt_", i)]]
+ }
+ clt_args
+})
+
+## add a spinning refresh icon if the tabel needs to be (re)calculated
+run_refresh(clt_args, "clt", init = "dist", label = i18n$t("Run simulation"), relabel = i18n$t("Re-run simulation"), data = FALSE)
+
+output$ui_clt <- renderUI({
+ tagList(
+ wellPanel(
+ actionButton("clt_run", i18n$t("Run simulation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success")
+ ),
+ wellPanel(
+ selectInput(
+ "clt_dist", i18n$t("Distribution:"),
+ choices = clt_dist,
+ selected = state_single("clt_dist", clt_dist),
+ multiple = FALSE
+ ),
+ conditionalPanel(
+ condition = "input.clt_dist == 'Uniform'",
+ make_side_by_side(
+ numericInput(
+ "clt_unif_min", i18n$t("Min:"),
+ value = state_init("clt_unif_min", 0)
+ ),
+ numericInput(
+ "clt_unif_max", i18n$t("Max:"),
+ value = state_init("clt_unif_max", 1)
+ )
+ )
+ ),
+ conditionalPanel(
+ condition = "input.clt_dist == 'Normal'",
+ make_side_by_side(
+ numericInput(
+ "clt_norm_mean", i18n$t("Mean:"),
+ value = state_init("clt_norm_mean", 0)
+ ),
+ numericInput(
+ "clt_norm_sd", i18n$t("SD:"),
+ value = state_init("clt_norm_sd", 1),
+ min = 0.1, step = 0.1
+ )
+ )
+ ),
+ conditionalPanel(
+ condition = "input.clt_dist == 'Exponential'",
+ numericInput(
+ "clt_expo_rate", i18n$t("Rate:"),
+ value = state_init("clt_expo_rate", 1),
+ min = 1, step = 1
+ )
+ ),
+ conditionalPanel(
+ condition = "input.clt_dist == 'Binomial'",
+ make_side_by_side(
+ numericInput(
+ "clt_binom_size", i18n$t("Size:"),
+ value = state_init("clt_binom_size", 10),
+ min = 1, step = 1
+ ),
+ numericInput(
+ "clt_binom_prob", i18n$t("Prob:"),
+ value = state_init("clt_binom_prob", 0.2),
+ min = 0, max = 1, step = .1
+ )
+ )
+ ),
+ make_side_by_side(
+ numericInput(
+ "clt_n", i18n$t("Sample size:"),
+ value = state_init("clt_n", 100),
+ min = 2, step = 1
+ ),
+ numericInput(
+ "clt_m", i18n$t("# of samples:"),
+ value = state_init("clt_m", 100),
+ min = 2, step = 1
+ )
+ ),
+ sliderInput(
+ "clt_bins",
+ label = i18n$t("Number of bins:"),
+ min = 1, max = 50, step = 1,
+ value = state_init("clt_bins", 15),
+ ),
+ radioButtons(
+ "clt_stat", NULL,
+ choices = clt_stat,
+ selected = state_init("clt_stat", "sum"),
+ inline = TRUE
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Central Limit Theorem"), fun_name = "clt",
+ help_file = inclRmd(file.path(getOption("radiant.path.basics"), "app/tools/help/clt.md"))
+ )
+ )
+})
+
+clt_plot_width <- function() 700
+clt_plot_height <- function() 700
+
+## output is called from the main radiant ui.R
+output$clt <- renderUI({
+ register_plot_output(
+ "plot_clt", ".plot_clt",
+ height_fun = "clt_plot_height",
+ width_fun = "clt_plot_width"
+ )
+
+ ## two separate tabs
+ clt_output_panels <- tagList(
+ tabPanel(
+ "Plot",
+ download_link("dlp_clt"),
+ plotOutput("plot_clt", width = "100%", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Probability"),
+ tool = i18n$t("Central Limit Theorem"),
+ data = NULL,
+ tool_ui = "ui_clt",
+ output_panels = clt_output_panels
+ )
+})
+
+.clt <- eventReactive(input$clt_run, {
+ ## avoiding input errors
+ ret <- ""
+ if (is.na(input$clt_n) || input$clt_n < 2) {
+ ret <- i18n$t("Please choose a sample size larger than 2")
+ } else if (is.na(input$clt_m) || input$clt_m < 2) {
+ ret <- i18n$t("Please choose 2 or more samples")
+ } else if (input$clt_dist == "Uniform") {
+ if (is.na(input$clt_unif_min)) {
+ ret <- i18n$t("Please choose a minimum value for the uniform distribution")
+ } else if (is.na(input$clt_unif_max)) {
+ ret <- i18n$t("Please choose a maximum value for the uniform distribution")
+ } else if (input$clt_unif_max <= input$clt_unif_min) {
+ ret <- i18n$t("The maximum value for the uniform distribution\nmust be larger than the minimum value")
+ }
+ } else if (input$clt_dist == "Normal") {
+ if (is.na(input$clt_norm_mean)) {
+ ret <- i18n$t("Please choose a mean value for the normal distribution")
+ } else if (is.na(input$clt_norm_sd) || input$clt_norm_sd < .001) {
+ ret <- i18n$t("Please choose a non-zero standard deviation for the normal distribution")
+ }
+ } else if (input$clt_dist == "Exponential") {
+ if (is.na(input$clt_expo_rate) || input$clt_expo_rate < 1) {
+ ret <- i18n$t("Please choose a rate larger than 1 for the exponential distribution")
+ }
+ } else if (input$clt_dist == "Binomial") {
+ if (is.na(input$clt_binom_size) || input$clt_binom_size < 1) {
+ ret <- i18n$t("Please choose a size parameter larger than 1 for the binomial distribution")
+ } else if (is.na(input$clt_binom_prob) || input$clt_binom_prob < 0.01) {
+ ret <- i18n$t("Please choose a probability between 0 and 1 for the binomial distribution")
+ }
+ }
+ if (is.empty(ret)) {
+ do.call(clt, clt_inputs())
+ } else {
+ ret
+ }
+})
+
+.plot_clt <- reactive({
+ if (not_pressed(input$clt_run)) {
+ return(i18n$t("** Press the Run simulation button to simulate data **"))
+ }
+ clt <- .clt()
+ validate(need(!is.character(clt), paste0("\n\n\n ", clt)))
+ withProgress(message = i18n$t("Generating plots"), value = 1, {
+ plot(clt, stat = input$clt_stat, bins = input$clt_bins)
+ })
+})
+
+clt_report <- function() {
+ outputs <- c("plot")
+ inp_out <- list(list(stat = input$clt_stat, bins = input$clt_bins))
+ inp <- clt_inputs()
+ inp3 <- inp[!grepl("_", names(inp))]
+ if (input$clt_dist == "Normal") {
+ inp <- c(inp3, inp[grepl("norm_", names(inp))])
+ } else if (input$clt_dist == "Uniform") {
+ inp <- c(inp3, inp[grepl("unif", names(inp))])
+ } else if (input$clt_dist == "Binomial") {
+ inp <- c(inp3, inp[grepl("binom_", names(inp))])
+ } else if (input$clt_dist == "Exponential") {
+ inp <- c(inp3, inp[grepl("expo_", names(inp))])
+ }
+
+ update_report(
+ inp_main = clean_args(inp, clt_args),
+ fun_name = "clt",
+ inp_out = inp_out,
+ outputs = outputs,
+ figs = TRUE,
+ fig.width = clt_plot_width(),
+ fig.height = clt_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_clt",
+ fun = download_handler_plot,
+ fn = function() paste0(tolower(input$clt_dist), "_clt"),
+ type = "png",
+ caption = i18n$t("Save central limit theorem plot"),
+ plot = .plot_clt,
+ width = clt_plot_width,
+ height = clt_plot_height
+)
+
+observeEvent(input$clt_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ clt_report()
+})
+
+observeEvent(input$clt_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_clt_screenshot")
+})
+
+observeEvent(input$modal_clt_screenshot, {
+ clt_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/analysis/compare_means_ui.R b/radiant.basics/inst/app/tools/analysis/compare_means_ui.R
new file mode 100644
index 0000000..4e0de2e
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/compare_means_ui.R
@@ -0,0 +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
+})
diff --git a/radiant.basics/inst/app/tools/analysis/compare_props_ui.R b/radiant.basics/inst/app/tools/analysis/compare_props_ui.R
new file mode 100644
index 0000000..8e814a8
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/compare_props_ui.R
@@ -0,0 +1,281 @@
+## choice lists for compare proportions（不使用等号命名）
+cp_alt <- c("two.sided", "less", "greater") %>%
+ setNames(c(
+ i18n$t("Two sided"),
+ i18n$t("Less than"),
+ i18n$t("Greater than")
+ ))
+
+cp_adjust <- c("none", "bonf") %>%
+ setNames(c(
+ i18n$t("None"),
+ i18n$t("Bonferroni")
+ ))
+
+# cp_plots <- c("props", "counts") %>% setNames(c(i18n$t("Proportions"), i18n$t("Relative")))
+cp_plots <- c("bar", "dodge") %>%
+ setNames(c(
+ i18n$t("Bar"),
+ i18n$t("Dodge")
+ ))
+
+## list of function arguments
+cp_args <- as.list(formals(compare_props))
+
+## list of function inputs selected by user
+cp_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ cp_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ cp_args$dataset <- input$dataset
+ for (i in r_drop(names(cp_args))) {
+ cp_args[[i]] <- input[[paste0("cp_", i)]]
+ }
+ cp_args
+})
+
+###############################
+# Compare proportions
+###############################
+output$ui_cp_var1 <- renderUI({
+ vars <- c("None" = "", groupable_vars())
+ selectInput(
+ "cp_var1", i18n$t("Select a grouping variable:"),
+ choices = vars,
+ selected = state_single("cp_var1", vars),
+ multiple = FALSE
+ )
+})
+
+output$ui_cp_var2 <- renderUI({
+ vars <- two_level_vars()
+ if (not_available(input$cp_var1)) {
+ return()
+ }
+ if (input$cp_var1 %in% vars) vars <- vars[-which(vars == input$cp_var1)]
+
+ vars <- c("None" = "", vars)
+ selectInput(
+ inputId = "cp_var2", i18n$t("Variable (select one):"),
+ selected = state_single("cp_var2", vars),
+ choices = vars,
+ multiple = FALSE
+ )
+})
+
+output$ui_cp_levs <- renderUI({
+ if (not_available(input$cp_var2)) {
+ return()
+ } else {
+ levs <- .get_data()[[input$cp_var2]] %>%
+ as.factor() %>%
+ levels()
+ }
+
+ selectInput(
+ inputId = "cp_levs", i18n$t("Choose level:"),
+ choices = levs,
+ selected = state_single("cp_levs", levs),
+ multiple = FALSE
+ )
+})
+
+output$ui_cp_comb <- renderUI({
+ if (not_available(input$cp_var1)) {
+ return()
+ }
+
+ dat <- .get_data()[[input$cp_var1]] %>% as.factor()
+ levs <- levels(dat)
+ alevs <- unique(dat)
+ len <- length(dat)
+ levs <- levs[levs %in% alevs]
+
+ if (length(levs) > 2 && length(levs) < len) {
+ cmb <- combn(levs, 2) %>% apply(2, paste, collapse = ":")
+ } else {
+ return()
+ }
+
+ selectizeInput(
+ "cp_comb", i18n$t("Choose combinations:"),
+ choices = cmb,
+ selected = state_multiple("cp_comb", cmb, cmb[1]),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Evaluate all combinations"), plugins = list("remove_button", "drag_drop"))
+ )
+})
+
+
+output$ui_compare_props <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_compare_props == 'Summary'",
+ uiOutput("ui_cp_var1"),
+ uiOutput("ui_cp_var2"),
+ uiOutput("ui_cp_levs"),
+ uiOutput("ui_cp_comb"),
+ selectInput(
+ inputId = "cp_alternative", i18n$t("Alternative hypothesis:"),
+ choices = cp_alt,
+ selected = state_single("cp_alternative", cp_alt, cp_args$alternative)
+ ),
+ checkboxInput(
+ "cp_show", i18n$t("Show additional statistics"),
+ value = state_init("cp_show", FALSE)
+ ),
+ sliderInput(
+ "cp_conf_lev", i18n$t("Confidence level:"),
+ min = 0.85, max = 0.99, step = 0.01,
+ value = state_init("cp_conf_lev", cp_args$conf_lev)
+ ),
+ radioButtons(
+ inputId = "cp_adjust", i18n$t("Multiple comp. adjustment:"),
+ cp_adjust,
+ selected = state_init("cp_adjust", cp_args$adjust),
+ inline = TRUE
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_compare_props == 'Plot'",
+ selectizeInput(
+ inputId = "cp_plots", label = i18n$t("Select plots:"),
+ choices = cp_plots,
+ selected = state_multiple("cp_plots", cp_plots, "bar"),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop"))
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Compare proportions"),
+ fun_name = "compare_props",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/compare_props.md"))
+ )
+ )
+})
+
+cp_plot <- reactive({
+ list(plot_width = 650, plot_height = 400 * max(length(input$cp_plots), 1))
+})
+
+cp_plot_width <- function() {
+ cp_plot() %>%
+ (function(x) if (is.list(x)) x$plot_width else 650)
+}
+
+cp_plot_height <- function() {
+ cp_plot() %>%
+ (function(x) if (is.list(x)) x$plot_height else 400)
+}
+
+# output is called from the main radiant ui.R
+output$compare_props <- renderUI({
+ register_print_output("summary_compare_props", ".summary_compare_props", )
+ register_plot_output(
+ "plot_compare_props", ".plot_compare_props",
+ height_fun = "cp_plot_height"
+ )
+
+ # two separate tabs
+ cp_output_panels <- tabsetPanel(
+ id = "tabs_compare_props",
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_compare_props")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_compare_props"),
+ plotOutput("plot_compare_props", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Proportions"),
+ tool = i18n$t("Compare proportions"),
+ tool_ui = "ui_compare_props",
+ output_panels = cp_output_panels
+ )
+})
+
+cp_available <- reactive({
+ if (not_available(input$cp_var1) || not_available(input$cp_var2)) {
+ i18n$t("This analysis requires two categorical variables. The first must have\ntwo or more levels. The second can have only two levels. If these\nvariable types are not available please select another dataset.\n\n") %>% suggest_data("titanic")
+ } else if (input$cp_var1 %in% input$cp_var2) {
+ " "
+ } else {
+ "available"
+ }
+})
+
+.compare_props <- reactive({
+ cpi <- cp_inputs()
+ cpi$envir <- r_data
+ do.call(compare_props, cpi)
+})
+
+.summary_compare_props <- reactive({
+ if (cp_available() != "available") {
+ return(cp_available())
+ }
+ if (input$cp_show) summary(.compare_props(), show = TRUE) else summary(.compare_props())
+})
+
+.plot_compare_props <- reactive({
+ if (cp_available() != "available") {
+ return(cp_available())
+ }
+ validate(need(input$cp_plots, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1, {
+ plot(.compare_props(), plots = input$cp_plots, shiny = TRUE)
+ })
+})
+
+compare_props_report <- function() {
+ if (is.empty(input$cp_var1) || is.empty(input$cp_var2)) {
+ return(invisible())
+ }
+ figs <- FALSE
+ outputs <- c("summary")
+ inp_out <- list(list(show = input$cp_show), "")
+ if (length(input$cp_plots) > 0) {
+ outputs <- c("summary", "plot")
+ inp_out[[2]] <- list(plots = input$cp_plots, custom = FALSE)
+ figs <- TRUE
+ }
+
+ update_report(
+ inp_main = clean_args(cp_inputs(), cp_args),
+ fun_name = "compare_props",
+ inp_out = inp_out,
+ outputs = outputs,
+ figs = figs,
+ fig.width = cp_plot_width(),
+ fig.height = cp_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_compare_props",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_compare_props"),
+ type = "png",
+ caption = i18n$t("Save compare proportions plot"),
+ plot = .plot_compare_props,
+ width = cp_plot_width,
+ height = cp_plot_height
+)
+
+observeEvent(input$compare_props_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ compare_props_report()
+})
+
+observeEvent(input$compare_props_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_compare_props_screenshot")
+})
+
+observeEvent(input$modal_compare_props_screenshot, {
+ compare_props_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/analysis/correlation_ui.R b/radiant.basics/inst/app/tools/analysis/correlation_ui.R
new file mode 100644
index 0000000..89417d7
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/correlation_ui.R
@@ -0,0 +1,330 @@
+###############################
+## Correlation
+###############################
+cor_method <- c(
+ "pearson",
+ "spearman",
+ "kendall"
+) %>% setNames(c(
+ i18n$t("Pearson"),
+ i18n$t("Spearman"),
+ i18n$t("Kendall")
+))
+## list of function arguments
+cor_args <- as.list(formals(correlation))
+
+## list of function inputs selected by user
+cor_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ cor_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ cor_args$dataset <- input$dataset
+ for (i in r_drop(names(cor_args))) {
+ cor_args[[i]] <- input[[paste0("cor_", i)]]
+ }
+ cor_args
+})
+
+output$ui_cor_method <- renderUI({
+ if (isTRUE(input$cor_hcor)) {
+ cor_method <- c("pearson") %>%
+ setNames(c(i18n$t("Pearson")))
+ }
+ selectInput(
+ "cor_method", i18n$t("Method:"),
+ choices = cor_method,
+ selected = state_single("cor_method", cor_method, "pearson"),
+ multiple = FALSE
+ )
+})
+
+cor_sum_args <- as.list(if (exists("summary.correlation")) {
+ formals(summary.correlation)
+} else {
+ formals(radiant.basics::summary.correlation)
+})
+
+## list of function inputs selected by user
+cor_sum_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ for (i in names(cor_sum_args)) {
+ cor_sum_args[[i]] <- input[[paste0("cor_", i)]]
+ }
+ cor_sum_args
+})
+
+output$ui_cor_vars <- renderUI({
+ withProgress(message = i18n$t("Acquiring variable information"), value = 1, {
+ vars <- varnames()
+ toSelect <- .get_class() %in% c("numeric", "integer", "date", "factor")
+ vars <- vars[toSelect]
+ })
+ if (length(vars) == 0) {
+ return()
+ }
+ selectInput(
+ inputId = "cor_vars", label = i18n$t("Select variables:"),
+ choices = vars,
+ selected = state_multiple("cor_vars", vars, isolate(input$cor_vars)),
+ multiple = TRUE,
+ size = min(10, length(vars)),
+ selectize = FALSE
+ )
+})
+
+output$ui_cor_nrobs <- renderUI({
+ nrobs <- nrow(.get_data())
+ choices <- c("1,000" = 1000, "5,000" = 5000, "10,000" = 10000, "All" = -1) %>%
+ .[. < nrobs]
+ selectInput(
+ "cor_nrobs", i18n$t("Number of data points plotted:"),
+ choices = choices,
+ selected = state_single("cor_nrobs", choices, 1000)
+ )
+})
+
+output$ui_cor_name <- renderUI({
+ req(input$dataset)
+ textInput("cor_name", i18n$t("Store as data.frame:"), "", placeholder = "Provide a name")
+})
+
+## add a spinning refresh icon if correlations need to be (re)calculated
+run_refresh(cor_args, "cor", init = "vars", tabs = "tabs_correlation", label = i18n$t("Calculate correlation"), relabel = i18n$t("Re-calculate correlations"))
+
+output$ui_correlation <- renderUI({
+ req(input$dataset)
+ tagList(
+ conditionalPanel(
+ condition = "input.tabs_correlation == 'Summary'",
+ wellPanel(
+ actionButton("cor_run", i18n$t("Calculate correlation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success")
+ )
+ ),
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_correlation == 'Summary'",
+ uiOutput("ui_cor_vars"),
+ uiOutput("ui_cor_method"),
+ checkboxInput("cor_hcor", i18n$t("Adjust for {factor} variables"), value = state_init("cor_hcor", FALSE)),
+ conditionalPanel(
+ condition = "input.cor_hcor == true",
+ checkboxInput("cor_hcor_se", i18n$t("Calculate adjusted p.values"), value = state_init("cor_hcor_se", FALSE))
+ ),
+ numericInput(
+ "cor_cutoff", i18n$t("Correlation cutoff:"),
+ min = 0, max = 1, step = 0.05,
+ value = state_init("cor_cutoff", 0)
+ ),
+ conditionalPanel(
+ condition = "input.cor_hcor == false",
+ checkboxInput(
+ "cor_covar", i18n$t("Show covariance matrix"),
+ value = state_init("cor_covar", FALSE)
+ )
+ ),
+ ),
+ conditionalPanel(
+ condition = "input.tabs_correlation == 'Plot'",
+ uiOutput("ui_cor_nrobs")
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_correlation == 'Summary'",
+ wellPanel(
+ tags$table(
+ tags$td(uiOutput("ui_cor_name")),
+ tags$td(actionButton("cor_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top")
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Correlation"),
+ fun_name = "correlation",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/correlation.md"))
+ )
+ )
+})
+
+observeEvent(input$cor_hcor, {
+ if (input$cor_hcor == FALSE) {
+ updateCheckboxInput(session, "cor_hcor_se", value = FALSE)
+ } else {
+ updateCheckboxInput(session, "cor_covar", value = FALSE)
+ }
+})
+
+cor_plot <- reactive({
+ max(2, length(input$cor_vars)) %>%
+ (function(x) list(plot_width = 400 + 75 * x, plot_height = 400 + 75 * x))
+})
+
+cor_plot_width <- function() {
+ cor_plot() %>%
+ (function(x) if (is.list(x)) x$plot_width else 650)
+}
+
+cor_plot_height <- function() {
+ cor_plot() %>%
+ (function(x) if (is.list(x)) x$plot_height else 650)
+}
+
+## output is called from the main radiant ui.R
+output$correlation <- renderUI({
+ register_print_output("summary_correlation", ".summary_correlation")
+ register_plot_output(
+ "plot_correlation", ".plot_correlation",
+ height_fun = "cor_plot_height",
+ width_fun = "cor_plot_width"
+ )
+
+ ## two separate tabs
+ cor_output_panels <- tabsetPanel(
+ id = "tabs_correlation",
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_correlation")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_correlation"),
+ plotOutput(
+ "plot_correlation",
+ width = "100%",
+ height = "100%"
+ )
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Tables"),
+ tool = i18n$t("Correlation"),
+ tool_ui = "ui_correlation",
+ output_panels = cor_output_panels
+ )
+})
+
+cor_available <- reactive({
+ if (not_available(input$cor_vars) || length(input$cor_vars) < 2) {
+ return(i18n$t("This analysis requires two or more variables or type numeric,\ninteger,or date. If these variable types are not available\nplease select another dataset.\n\n") %>% suggest_data("salary"))
+ }
+ "available"
+})
+
+# .correlation <- reactive({
+.correlation <- eventReactive(input$cor_run, {
+ cori <- cor_inputs()
+ cori$envir <- r_data
+ do.call(correlation, cori)
+})
+
+.summary_correlation <- reactive({
+ if (cor_available() != "available") {
+ return(cor_available())
+ }
+ if (not_pressed(input$cor_run)) {
+ return(i18n$t("** Press the Calculate correlation button to generate output **"))
+ }
+ validate(
+ need(
+ input$cor_cutoff >= 0 && input$cor_cutoff <= 1,
+ i18n$t("Provide a correlation cutoff value in the range from 0 to 1")
+ )
+ )
+ withProgress(message = i18n$t("Calculating correlations"), value = 0.5, {
+ do.call(summary, c(list(object = .correlation()), cor_sum_inputs()))
+ })
+})
+
+.plot_correlation <- reactive({
+ if (cor_available() != "available") {
+ return(cor_available())
+ }
+ if (not_pressed(input$cor_run)) {
+ return(i18n$t("** Press the Calculate correlation button to generate output **"))
+ }
+ req(input$cor_nrobs)
+ withProgress(message = i18n$t("Generating correlation plot"), value = 0.5, {
+ capture_plot(plot(.correlation(), nrobs = input$cor_nrobs))
+ })
+})
+
+correlation_report <- function() {
+ if (length(input$cor_vars) < 2) {
+ return(invisible())
+ }
+ inp_out <- list("", "")
+ nrobs <- ifelse(is.empty(input$cor_nrobs), 1000, as_integer(input$cor_nrobs))
+ inp_out[[1]] <- clean_args(cor_sum_inputs(), cor_sum_args[-1])
+ inp_out[[2]] <- list(nrobs = nrobs)
+
+ if (!is.empty(input$cor_name)) {
+ dataset <- fix_names(input$cor_name)
+ if (input$cor_name != dataset) {
+ updateTextInput(session, inputId = "cor_name", value = dataset)
+ }
+ xcmd <- paste0(dataset, " <- cor2df(result)\nregister(\"", dataset, "\", descr = result$descr)")
+ } else {
+ xcmd <- ""
+ }
+
+ update_report(
+ inp_main = clean_args(cor_inputs(), cor_args),
+ fun_name = "correlation",
+ inp_out = inp_out,
+ fig.width = cor_plot_width(),
+ fig.height = cor_plot_height(),
+ xcmd = xcmd
+ )
+}
+
+download_handler(
+ id = "dlp_correlation",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_correlation"),
+ type = "png",
+ caption = i18n$t("Save correlation plot"),
+ plot = .plot_correlation,
+ width = cor_plot_width,
+ height = cor_plot_height
+)
+
+observeEvent(input$cor_store, {
+ req(input$cor_name)
+ cmat <- try(.correlation(), silent = TRUE)
+ if (inherits(cmat, "try-error") || is.null(cmat)) {
+ return()
+ }
+
+ dataset <- fix_names(input$cor_name)
+ updateTextInput(session, inputId = "cor_name", value = dataset)
+ r_data[[dataset]] <- cor2df(cmat)
+ register(dataset, descr = cmat$descr)
+ updateSelectInput(session, "dataset", selected = input$dataset)
+
+ ## See https://shiny.posit.co//reference/shiny/latest/modalDialog.html
+ showModal(
+ modalDialog(
+ title = i18n$t("Data Stored"),
+ span(
+ i18n$t(
+ "Dataset '{dataset}' was successfully added to the datasets dropdown. Add code to Report > Rmd or Report > R to (re)create the results by clicking the report icon on the bottom left of your screen.",
+ dataset = dataset
+ )
+ ),
+ footer = modalButton(i18n$t("OK")),
+ size = "s",
+ easyClose = TRUE
+ )
+ )
+})
+
+observeEvent(input$correlation_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ correlation_report()
+})
+
+observeEvent(input$correlation_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_correlation_screenshot")
+})
+
+observeEvent(input$modal_correlation_screenshot, {
+ correlation_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
new file mode 100644
index 0000000..b349d23
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/cross_tabs_ui.R
@@ -0,0 +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
+})
diff --git a/radiant.basics/inst/app/tools/analysis/goodness_ui.R b/radiant.basics/inst/app/tools/analysis/goodness_ui.R
new file mode 100644
index 0000000..66723f0
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/goodness_ui.R
@@ -0,0 +1,197 @@
+## alternative hypothesis options
+gd_check <- c("observed", "expected", "chi_sq", "dev_std")
+names(gd_check) <- c(
+ i18n$t("Observed"),
+ i18n$t("Expected"),
+ i18n$t("Chi-squared"),
+ i18n$t("Deviation std.")
+)
+
+## list of function arguments
+gd_args <- as.list(formals(goodness))
+
+## list of function inputs selected by user
+gd_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ gd_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ gd_args$dataset <- input$dataset
+ for (i in r_drop(names(gd_args))) {
+ gd_args[[i]] <- input[[paste0("gd_", i)]]
+ }
+ gd_args
+})
+
+###############################
+# Goodness of fit test
+###############################
+output$ui_gd_var <- renderUI({
+ vars <- c("None" = "", groupable_vars())
+ selectInput(
+ "gd_var", i18n$t("Select a categorical variable:"),
+ choices = vars,
+ selected = state_single("gd_var", vars),
+ multiple = FALSE
+ )
+})
+
+output$ui_gd_p <- renderUI({
+ req(input$gd_var)
+ returnTextInput(
+ "gd_p", i18n$t("Probabilities:"),
+ value = state_init("gd_p", ""),
+ placeholder = i18n$t("Enter probabilities (e.g., 1/2 1/2)")
+ )
+})
+
+output$ui_goodness <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_goodness == 'Summary'",
+ uiOutput("ui_gd_var"),
+ uiOutput("ui_gd_p"),
+ br()
+ ),
+ checkboxGroupInput(
+ "gd_check", NULL,
+ choices = gd_check,
+ selected = state_group("gd_check"),
+ inline = FALSE
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Goodness of fit"),
+ fun_name = "goodness",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/goodness.md"))
+ )
+ )
+})
+
+gd_plot <- reactive({
+ list(plot_width = 650, plot_height = 400 * max(length(input$gd_check), 1))
+})
+
+gd_plot_width <- function() {
+ gd_plot() %>%
+ (function(x) if (is.list(x)) x$plot_width else 650)
+}
+
+gd_plot_height <- function() {
+ gd_plot() %>%
+ (function(x) if (is.list(x)) x$plot_height else 400)
+}
+
+## output is called from the main radiant ui.R
+output$goodness <- renderUI({
+ register_print_output("summary_goodness", ".summary_goodness")
+ register_plot_output(
+ "plot_goodness", ".plot_goodness",
+ height_fun = "gd_plot_height",
+ width_fun = "gd_plot_width"
+ )
+
+ ## two separate tabs
+ gd_output_panels <- tabsetPanel(
+ id = "tabs_goodness",
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_goodness")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_goodness"),
+ plotOutput("plot_goodness", width = "100%", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Tables"),
+ tool = i18n$t("Goodness of fit"),
+ tool_ui = "ui_goodness",
+ output_panels = gd_output_panels
+ )
+})
+
+gd_available <- reactive({
+ if (not_available(input$gd_var)) {
+ i18n$t("This analysis requires a categorical variables with two or more levels.\nIf such a variable type is not available please select another dataset.\n\n") %>% suggest_data("newspaper")
+ } else {
+ "available"
+ }
+})
+
+.goodness <- reactive({
+ gdi <- gd_inputs()
+ gdi$envir <- r_data
+ do.call(goodness, gdi)
+})
+
+.summary_goodness <- reactive({
+ if (gd_available() != "available") {
+ return(gd_available())
+ }
+ summary(.goodness(), check = input$gd_check)
+})
+
+.plot_goodness <- reactive({
+ if (gd_available() != "available") {
+ return(gd_available())
+ }
+ validate(need(input$gd_check, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1, {
+ plot(.goodness(), check = input$gd_check, shiny = TRUE)
+ })
+})
+
+goodness_report <- function() {
+ if (is.empty(input$gd_var)) {
+ return(invisible())
+ }
+ inp_out <- list("", "")
+ if (length(input$gd_check) > 0) {
+ outputs <- c("summary", "plot")
+ inp_out[[1]] <- list(check = input$gd_check)
+ inp_out[[2]] <- list(check = input$gd_check, custom = FALSE)
+ figs <- TRUE
+ } else {
+ outputs <- "summary"
+ figs <- FALSE
+ }
+
+ gdi <- gd_inputs()
+ gdi$p <- radiant.data::make_vec(gdi$p)
+
+ update_report(
+ inp_main = clean_args(gdi, gd_args),
+ inp_out = inp_out,
+ fun_name = "goodness",
+ outputs = outputs,
+ figs = figs,
+ fig.width = gd_plot_width(),
+ fig.height = gd_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_goodness",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_goodness"),
+ type = "png",
+ caption = i18n$t("Save goodness of fit plot"),
+ plot = .plot_goodness,
+ width = gd_plot_width,
+ height = gd_plot_height
+)
+
+observeEvent(input$goodness_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ goodness_report()
+})
+
+observeEvent(input$goodness_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_goodness_screenshot")
+})
+
+observeEvent(input$modal_goodness_screenshot, {
+ goodness_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R b/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R
new file mode 100644
index 0000000..7a400fd
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/homo_variance_test_ui.R
@@ -0,0 +1,190 @@
+############################################
+## Homogeneity of variance test - ui
+############################################
+
+## 1. 翻译标签
+hv_method <- c("levene", "bartlett", "fligner")
+names(hv_method) <- c(i18n$t("Levene"),
+ i18n$t("Bartlett"),
+ i18n$t("Fligner"))
+
+hv_plots <- c("hist", "density", "boxplot")
+names(hv_plots) <- c(i18n$t("Histogram"),
+ i18n$t("Density"),
+ i18n$t("Boxplot"))
+
+## 2. 函数形参
+hv_args <- as.list(formals(homo_variance_test))
+
+## 3. 收集输入
+hv_inputs <- reactive({
+ hv_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ hv_args$dataset <- input$dataset
+ for (i in r_drop(names(hv_args))) {
+ hv_args[[i]] <- input[[paste0("hv_", i)]]
+ }
+ hv_args
+})
+
+## 4. 变量选择（numeric + grouping）
+output$ui_hv_var <- renderUI({
+ isNum <- .get_class() %in% c("integer", "numeric", "ts")
+ vars <- c("None" = "", varnames()[isNum])
+ selectInput(
+ inputId = "hv_var", label = i18n$t("Variable (select one):"),
+ choices = vars, selected = state_single("hv_var", vars), multiple = FALSE
+ )
+})
+
+output$ui_hv_group <- renderUI({
+ vars <- groupable_vars()
+ selectInput(
+ inputId = "hv_group", label = i18n$t("Grouping variable:"),
+ choices = vars, selected = state_single("hv_group", vars), multiple = FALSE
+ )
+})
+
+## 5. 主 UI
+output$ui_homo_variance_test <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_homo_variance_test == 'Summary'",
+ uiOutput("ui_hv_var"),
+ uiOutput("ui_hv_group"),
+ selectInput(
+ inputId = "hv_method", label = i18n$t("Test method:"),
+ choices = hv_method,
+ selected = state_single("hv_method", hv_method, "levene"),
+ multiple = FALSE
+ ),
+ sliderInput(
+ "hv_conf_lev", i18n$t("Confidence level:"),
+ min = 0.85, max = 0.99,
+ value = state_init("hv_conf_lev", 0.95), step = 0.01
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_homo_variance_test == 'Plot'",
+ selectizeInput(
+ inputId = "hv_plots", label = i18n$t("Select plots:"),
+ choices = hv_plots,
+ selected = state_multiple("hv_plots", hv_plots, "boxplot"),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Select plots"),
+ plugins = list("remove_button", "drag_drop"))
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Homogeneity of variance test"),
+ fun_name = "homo_variance_test",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"),
+ "app/tools/help/homo_variance_test.md"))
+ )
+ )
+})
+
+## 6. 画图尺寸
+hv_plot <- reactive({
+ list(plot_width = 650,
+ plot_height = 400 * max(length(input$hv_plots), 1))
+})
+hv_plot_width <- function() hv_plot()$plot_width
+hv_plot_height <- function() hv_plot()$plot_height
+
+## 7. 输出面板
+output$homo_variance_test <- renderUI({
+ register_print_output("summary_homo_variance_test", ".summary_homo_variance_test")
+ register_plot_output("plot_homo_variance_test", ".plot_homo_variance_test",
+ height_fun = "hv_plot_height")
+
+ hv_output_panels <- tabsetPanel(
+ id = "tabs_homo_variance_test",
+ tabPanel(title = i18n$t("Summary"),
+ value = "Summary",
+ verbatimTextOutput("summary_homo_variance_test")),
+ tabPanel(title = i18n$t("Plot"),
+ value = "Plot",
+ download_link("dlp_homo_variance_test"),
+ plotOutput("plot_homo_variance_test", height = "100%"))
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Homogeneity"),
+ tool = i18n$t("Homogeneity of variance test"),
+ tool_ui = "ui_homo_variance_test",
+ output_panels = hv_output_panels
+ )
+})
+
+## 8. 可用性检查
+hv_available <- reactive({
+ if (not_available(input$hv_var))
+ return(i18n$t("This analysis requires a numeric variable. If none are\navailable please select another dataset.") %>% suggest_data("demand_uk"))
+ if (not_available(input$hv_group))
+ return(i18n$t("Please select a grouping variable."))
+ "available"
+})
+
+## 9. 计算核心
+.homo_variance_test <- reactive({
+ hvi <- hv_inputs()
+ hvi$envir <- r_data
+ do.call(homo_variance_test, hvi)
+})
+
+.summary_homo_variance_test <- reactive({
+ if (hv_available() != "available") return(hv_available())
+ summary(.homo_variance_test())
+})
+
+.plot_homo_variance_test <- reactive({
+ if (hv_available() != "available") return(hv_available())
+ validate(need(input$hv_plots, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1,
+ plot(.homo_variance_test(), plots = input$hv_plots, shiny = TRUE))
+})
+
+## 10. Report
+homo_variance_test_report <- function() {
+ if (is.empty(input$hv_var)) return(invisible())
+ figs <- length(input$hv_plots) > 0
+ outputs <- if (figs) c("summary", "plot") else "summary"
+ inp_out <- if (figs) list("", list(plots = input$hv_plots, custom = FALSE)) else list("", "")
+ update_report(inp_main = clean_args(hv_inputs(), hv_args),
+ fun_name = "homo_variance_test",
+ inp_out = inp_out,
+ outputs = outputs,
+ figs = figs,
+ fig.width = hv_plot_width(),
+ fig.height = hv_plot_height())
+}
+
+## 11. 下载 & 截图
+download_handler(
+ id = "dlp_homo_variance_test",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_homo_variance_test"),
+ type = "png",
+ caption = i18n$t("Save homogeneity of variance plot"),
+ plot = .plot_homo_variance_test,
+ width = hv_plot_width,
+ height = hv_plot_height
+)
+
+observeEvent(input$homo_variance_test_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ homo_variance_test_report()
+})
+
+observeEvent(input$homo_variance_test_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_homo_variance_test_screenshot")
+})
+
+observeEvent(input$modal_homo_variance_test_screenshot, {
+ homo_variance_test_report()
+ removeModal()
+})
diff --git a/radiant.basics/inst/app/tools/analysis/normality_test_ui.R b/radiant.basics/inst/app/tools/analysis/normality_test_ui.R
new file mode 100644
index 0000000..b22ad9a
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/normality_test_ui.R
@@ -0,0 +1,181 @@
+############################################
+## Normality test - ui
+############################################
+
+## 1. 翻译标签
+nt_method <- c("shapiro", "ks", "ad") # 先给 3 个常用方法
+names(nt_method) <- c(i18n$t("Shapiro-Wilk"),
+ i18n$t("Kolmogorov-Smirnov"),
+ i18n$t("Anderson-Darling"))
+
+nt_plots <- c("qq", "hist", "pp", "density")
+names(nt_plots) <- c(i18n$t("Q-Q plot"),
+ i18n$t("Histogram"),
+ i18n$t("P-P plot"),
+ i18n$t("Density"))
+
+## 2. 函数形参
+nt_args <- as.list(formals(normality_test))
+
+## 3. 收集输入
+nt_inputs <- reactive({
+ nt_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ nt_args$dataset <- input$dataset
+ for (i in r_drop(names(nt_args))) {
+ nt_args[[i]] <- input[[paste0("nt_", i)]]
+ }
+ nt_args
+})
+
+## 4. 变量选择（仅 numeric）
+output$ui_nt_var <- renderUI({
+ isNum <- .get_class() %in% c("integer", "numeric", "ts")
+ vars <- c("None" = "", varnames()[isNum])
+ selectInput(
+ inputId = "nt_var", label = i18n$t("Variable (select one):"),
+ choices = vars, selected = state_single("nt_var", vars), multiple = FALSE
+ )
+})
+
+## 5. 主 UI
+output$ui_normality_test <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_normality_test == 'Summary'",
+ uiOutput("ui_nt_var"),
+ selectInput(
+ inputId = "nt_method", label = i18n$t("Test method:"),
+ choices = nt_method,
+ selected = state_single("nt_method", nt_method, "shapiro"),
+ multiple = FALSE
+ ),
+ sliderInput(
+ "nt_conf_lev", i18n$t("Confidence level:"),
+ min = 0.85, max = 0.99,
+ value = state_init("nt_conf_lev", 0.95), step = 0.01
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_normality_test == 'Plot'",
+ selectizeInput(
+ inputId = "nt_plots", label = i18n$t("Select plots:"),
+ choices = nt_plots,
+ selected = state_multiple("nt_plots", nt_plots, "qq"),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Select plots"),
+ plugins = list("remove_button", "drag_drop"))
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Normality test"),
+ fun_name = "normality_test",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"),
+ "app/tools/help/normality_test.md"))
+ )
+ )
+})
+
+## 6. 画图尺寸（直接抄）
+nt_plot <- reactive({
+ list(plot_width = 650,
+ plot_height = 400 * max(length(input$nt_plots), 1))
+})
+nt_plot_width <- function() nt_plot()$plot_width
+nt_plot_height <- function() nt_plot()$plot_height
+
+
+## 7. 输出面板
+output$normality_test <- renderUI({
+ register_print_output("summary_normality_test", ".summary_normality_test")
+ register_plot_output("plot_normality_test", ".plot_normality_test",
+ height_fun = "nt_plot_height")
+
+ nt_output_panels <- tabsetPanel(
+ id = "tabs_normality_test",
+ tabPanel(title = i18n$t("Summary"),
+ value = "Summary",
+ verbatimTextOutput("summary_normality_test")),
+ tabPanel(title = i18n$t("Plot"),
+ value = "Plot",
+ download_link("dlp_normality_test"),
+ plotOutput("plot_normality_test", height = "100%"))
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Normality"),
+ tool = i18n$t("Normality test"),
+ tool_ui = "ui_normality_test",
+ output_panels = nt_output_panels
+ )
+})
+
+## 8. 可用性检查
+nt_available <- reactive({
+ if (not_available(input$nt_var))
+ return(i18n$t("This analysis requires a numeric variable. If none are\navailable please select another dataset.") %>% suggest_data("demand_uk"))
+ "available"
+})
+
+## 9. 计算核心
+.normality_test <- reactive({
+ nti <- nt_inputs()
+ nti$envir <- r_data
+ do.call(normality_test, nti)
+})
+
+.summary_normality_test <- reactive({
+ if (nt_available() != "available") return(nt_available())
+ summary(.normality_test())
+})
+
+.plot_normality_test <- reactive({
+ if (nt_available() != "available") return(nt_available())
+ validate(need(input$nt_plots, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1,
+ plot(.normality_test(), plots = input$nt_plots, shiny = TRUE))
+})
+
+## 10. Report
+normality_test_report <- function() {
+ if (is.empty(input$nt_var)) return(invisible())
+ figs <- length(input$nt_plots) > 0
+ outputs <- if (figs) c("summary", "plot") else "summary"
+ inp_out <- if (figs) list("", list(plots = input$nt_plots, custom = FALSE)) else list("", "")
+ update_report(inp_main = clean_args(nt_inputs(), nt_args),
+ fun_name = "normality_test",
+ inp_out = inp_out,
+ outputs = outputs,
+ figs = figs,
+ fig.width = nt_plot_width(),
+ fig.height = nt_plot_height())
+}
+
+## 11. 下载 & 截图
+download_handler(
+ id = "dlp_normality_test",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_normality_test"),
+ type = "png",
+ caption = i18n$t("Save normality test plot"),
+ plot = .plot_normality_test,
+ width = nt_plot_width,
+ height = nt_plot_height
+)
+
+observeEvent(input$normality_test_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ normality_test_report()
+})
+
+observeEvent(input$normality_test_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_normality_test_screenshot")
+})
+
+observeEvent(input$modal_normality_test_screenshot, {
+ normality_test_report()
+ removeModal()
+})
\ No newline at end of file
diff --git a/radiant.basics/inst/app/tools/analysis/prob_calc_ui.R b/radiant.basics/inst/app/tools/analysis/prob_calc_ui.R
new file mode 100644
index 0000000..a842298
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/prob_calc_ui.R
@@ -0,0 +1,572 @@
+pc_dist <- c("binom", "chisq", "disc", "expo", "fdist", "lnorm", "norm", "pois", "tdist", "unif")
+names(pc_dist) <- c(
+ i18n$t("Binomial"), i18n$t("Chi-squared"), i18n$t("Discrete"),
+ i18n$t("Exponential"), i18n$t("F"), i18n$t("Log normal"),
+ i18n$t("Normal"), i18n$t("Poisson"), i18n$t("t"), i18n$t("Uniform")
+)
+
+pc_type <- c("values", "probs")
+names(pc_type) <- c(i18n$t("Values"), i18n$t("Probabilities"))
+
+
+make_pc_values_input <- function(lb, lb_init = NA, ub, ub_init = 0) {
+ if(!is.empty(r_state[[lb]])) ub_init <- NA
+ if(!is.empty(r_state[[ub]])) lb_init <- NA
+ tags$table(
+ tags$td(numericInput(lb, i18n$t("Lower bound:"), value = state_init(lb, lb_init))),
+ tags$td(numericInput(ub, i18n$t("Upper bound:"), value = state_init(ub, ub_init)))
+ )
+}
+
+make_side_by_side <- function(a, b) {
+ tags$table(
+ tags$td(a, width="50%"),
+ tags$td(b, width="50%"),
+ width="100%"
+ )
+}
+
+make_pc_prob_input <- function(lb, lb_init = NA, ub, ub_init = 0.95) {
+ if(!is.empty(r_state[[lb]])) ub_init <- NA
+ if(!is.empty(r_state[[ub]])) lb_init <- NA
+ make_side_by_side(
+ numericInput(
+ lb, i18n$t("Lower bound:"), value = state_init(lb, lb_init),
+ min = 0, max = 1, step = .005
+ ),
+ numericInput(
+ ub, i18n$t("Upper bound:"), value = state_init(ub, ub_init),
+ min = 0, max = 1, step = .005
+ )
+ )
+}
+
+output$ui_pc_pois <- renderUI({
+ numericInput(
+ "pcp_lambda", i18n$t("Lambda:"),
+ value = state_init("pcp_lambda", 1),
+ min = 1
+ )
+})
+
+output$ui_pc_input_pois <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcp_lb", lb_init = NA, "pcp_ub", ub_init = 3)
+ } else {
+ make_pc_prob_input("pcp_plb", lb_init = NA, "pcp_pub", ub_init = 0.95)
+ }
+})
+
+output$ui_pc_expo <- renderUI({
+ numericInput(
+ "pce_rate", i18n$t("Rate:"),
+ value = state_init("pce_rate", 1),
+ min = 0
+ )
+})
+
+output$ui_pc_input_expo <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pce_lb", lb_init = NA, "pce_ub", ub_init = 2.996)
+ } else {
+ make_pc_prob_input("pce_plb", lb_init = NA, "pce_pub", ub_init = 0.95)
+ }
+})
+
+output$ui_pc_disc <- renderUI({
+ tagList(
+ returnTextInput(
+ "pcd_v", i18n$t("Values:"),
+ value = state_init("pcd_v", "1 2 3 4 5 6")
+ ),
+ returnTextInput(
+ "pcd_p", i18n$t("Probabilities:"),
+ value = state_init("pcd_p", "1/6")
+ )
+ )
+})
+
+output$ui_pc_input_disc <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcd_lb", lb_init = NA, "pcd_ub", ub_init = 3)
+ } else {
+ make_pc_prob_input("pcd_plb", lb_init = NA, "pcd_pub", ub_init = 0.95)
+ }
+})
+
+output$ui_pc_fdist <- renderUI({
+ tagList(
+ numericInput(
+ "pcf_df1", i18n$t("Degrees of freedom 1:"),
+ value = state_init("pcf_df1", 10),
+ min = 1
+ ),
+ numericInput(
+ "pcf_df2", i18n$t("Degrees of freedom 2:"),
+ value = state_init("pcf_df2", 10),
+ min = 5
+ )
+ )
+})
+
+output$ui_pc_input_fdist <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcf_lb", lb_init = NA, "pcf_ub", ub_init = 2.978)
+ } else {
+ make_pc_prob_input("pcf_plb", lb_init = NA, "pcf_pub", ub_init = 0.95)
+ }
+})
+
+output$ui_pc_chisq <- renderUI({
+ numericInput(
+ "pcc_df", i18n$t("Degrees of freedom:"),
+ value = state_init("pcc_df", 1),
+ min = 1
+ )
+})
+
+output$ui_pc_input_chisq <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcc_lb", lb_init = NA, "pcc_ub", ub_init = 3.841)
+ } else {
+ make_pc_prob_input("pcc_plb", lb_init = NA, "pcc_pub", ub_init = 0.95)
+ }
+})
+
+output$ui_pc_tdist <- renderUI({
+ numericInput(
+ "pct_df", i18n$t("Degrees of freedom:"),
+ value = state_init("pct_df", 10),
+ min = 3
+ )
+})
+
+output$ui_pc_input_tdist <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pct_lb", lb_init = -Inf, "pct_ub", ub_init = 2.228)
+ } else {
+ make_pc_prob_input("pct_plb", lb_init = 0.025, "pct_pub", ub_init = 0.975)
+ }
+})
+
+output$ui_pc_norm <- renderUI({
+ make_side_by_side(
+ numericInput(
+ "pc_mean", i18n$t("Mean:"),
+ value = state_init("pc_mean", 0)
+ ),
+ numericInput(
+ "pc_stdev", i18n$t("St. dev:"),
+ min = 0,
+ value = state_init("pc_stdev", 1)
+ )
+ )
+})
+
+output$ui_pc_input_norm <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pc_lb", lb_init = -Inf, "pc_ub", ub_init = 0)
+ } else {
+ make_pc_prob_input("pc_plb", lb_init = 0.025, "pc_pub", ub_init = 0.975)
+ }
+})
+
+output$ui_pc_lnorm <- renderUI({
+ make_side_by_side(
+ numericInput(
+ "pcln_meanlog", i18n$t("Mean log:"),
+ value = state_init("pcln_meanlog", 0)
+ ),
+ numericInput(
+ "pcln_sdlog", i18n$t("St. dev log:"),
+ min = 0,
+ value = state_init("pcln_sdlog", 1)
+ )
+ )
+})
+
+output$ui_pc_input_lnorm <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcln_lb", lb_init = 0, "pcln_ub", ub_init = 1)
+ } else {
+ make_pc_prob_input("pcln_plb", lb_init = 0.025, "pcln_pub", ub_init = 0.975)
+ }
+})
+
+output$ui_pc_binom <- renderUI({
+ make_side_by_side(
+ numericInput(
+ "pcb_n", label = i18n$t("n:"),
+ value = state_init("pcb_n", 10), min = 0
+ ),
+ numericInput(
+ "pcb_p", i18n$t("p:"),
+ min = 0, max = 1, step = .005,
+ value = state_init("pcb_p", .2)
+ )
+ )
+})
+
+output$ui_pc_input_binom <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcb_lb", lb_init = NA, "pcb_ub", ub_init = 3)
+ } else {
+ make_pc_prob_input("pcb_plb", lb_init = NA, "pcb_pub", ub_init = 0.3)
+ }
+})
+
+output$ui_pc_unif <- renderUI({
+ make_side_by_side(
+ numericInput(
+ "pcu_min", i18n$t("Min:"),
+ value = state_init("pcu_min", 0)
+ ),
+ numericInput(
+ "pcu_max", i18n$t("Max:"),
+ value = state_init("pcu_max", 1)
+ )
+ )
+})
+
+output$ui_pc_input_unif <- renderUI({
+ if (input$pc_type == "values") {
+ make_pc_values_input("pcu_lb", lb_init = NA, "pcu_ub", ub_init = 0.3)
+ } else {
+ make_pc_prob_input("pcu_plb", lb_init = NA, "pcu_pub", ub_init = 0.3)
+ }
+})
+
+output$ui_prob_calc <- renderUI({
+ tagList(
+ wellPanel(
+ selectInput(
+ "pc_dist", label = i18n$t("Distribution:"),
+ choices = pc_dist,
+ selected = state_init("pc_dist", "norm"),
+ multiple = FALSE
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'norm'",
+ uiOutput("ui_pc_norm")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'lnorm'",
+ uiOutput("ui_pc_lnorm")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'binom'",
+ uiOutput("ui_pc_binom")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'unif'",
+ uiOutput("ui_pc_unif")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'tdist'",
+ uiOutput("ui_pc_tdist")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'fdist'",
+ uiOutput("ui_pc_fdist")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'chisq'",
+ uiOutput("ui_pc_chisq")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'disc'",
+ uiOutput("ui_pc_disc")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'expo'",
+ uiOutput("ui_pc_expo")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'pois'",
+ uiOutput("ui_pc_pois")
+ )
+ ),
+ wellPanel(
+ radioButtons(
+ "pc_type", i18n$t("Input type:"),
+ choices = pc_type,
+ selected = state_init("pc_type", "values"),
+ inline = TRUE
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'norm'",
+ uiOutput("ui_pc_input_norm")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'lnorm'",
+ uiOutput("ui_pc_input_lnorm")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'binom'",
+ uiOutput("ui_pc_input_binom")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'unif'",
+ uiOutput("ui_pc_input_unif")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'tdist'",
+ uiOutput("ui_pc_input_tdist")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'fdist'",
+ uiOutput("ui_pc_input_fdist")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'chisq'",
+ uiOutput("ui_pc_input_chisq")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'disc'",
+ uiOutput("ui_pc_input_disc")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'expo'",
+ uiOutput("ui_pc_input_expo")
+ ),
+ conditionalPanel(
+ "input.pc_dist == 'pois'",
+ uiOutput("ui_pc_input_pois")
+ ),
+ numericInput(
+ "pc_dec", i18n$t("Decimals:"),
+ value = state_init("pc_dec", 3),
+ min = 0
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Probability calculator"),
+ fun_name = "prob_calc",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/prob_calc.md"))
+ )
+ )
+})
+
+pc_plot_width <- function()
+ if (!is.null(input$viz_plot_width)) input$viz_plot_width else 650
+
+pc_plot_height <- function() 400
+
+pc_args <- reactive({
+ pc_dist <- input$pc_dist
+ if (is.empty(pc_dist) || pc_dist == "norm") {
+ as.list(formals(prob_norm))
+ } else if (pc_dist == "lnorm") {
+ as.list(formals(prob_lnorm))
+ } else if (pc_dist == "binom") {
+ as.list(formals(prob_binom))
+ } else if (pc_dist == "unif") {
+ as.list(formals(prob_unif))
+ } else if (pc_dist == "tdist") {
+ as.list(formals(prob_tdist))
+ } else if (pc_dist == "fdist") {
+ as.list(formals(prob_fdist))
+ } else if (pc_dist == "chisq") {
+ as.list(formals(prob_chisq))
+ } else if (pc_dist == "disc") {
+ as.list(formals(prob_disc))
+ } else if (pc_dist == "expo") {
+ as.list(formals(prob_expo))
+ } else if (pc_dist == "pois") {
+ as.list(formals(prob_pois))
+ }
+})
+
+## list of function inputs selected by user
+pc_inputs <- reactive({
+ pc_dist <- input$pc_dist
+ if (is.empty(pc_dist) || pc_dist == "norm") {
+ pre <- "pc_"
+ } else if (pc_dist == "lnorm") {
+ pre <- "pcln_"
+ } else if (pc_dist == "binom") {
+ pre <- "pcb_"
+ } else if (pc_dist == "unif") {
+ pre <- "pcu_"
+ } else if (pc_dist == "tdist") {
+ pre <- "pct_"
+ } else if (pc_dist == "fdist") {
+ pre <- "pcf_"
+ } else if (pc_dist == "chisq") {
+ pre <- "pcc_"
+ } else if (pc_dist == "disc") {
+ pre <- "pcd_"
+ } else if (pc_dist == "expo") {
+ pre <- "pce_"
+ } else if (pc_dist == "pois") {
+ pre <- "pcp_"
+ }
+
+ # loop needed because reactive values don't allow single bracket indexing
+ args <- pc_args()
+ for (i in names(args))
+ args[[i]] <- input[[paste0(pre, i)]]
+
+ validate(
+ need(
+ input$pc_dec,
+ i18n$t("Provide an integer value for the number of decimal places")
+ )
+ )
+
+ args[["dec"]] <- input$pc_dec
+ args
+})
+
+## output is called from the main radiant ui.R
+output$prob_calc <- renderUI({
+ register_print_output("summary_prob_calc", ".summary_prob_calc")
+ register_plot_output(
+ "plot_prob_calc", ".plot_prob_calc",
+ height_fun = "pc_plot_height",
+ width_fun = "pc_plot_width"
+ )
+
+ ## two separate tabs
+ pc_output_panels <- tagList(
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_prob_calc")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_prob_calc"),
+ plotOutput("plot_prob_calc", width = "100%", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Probability"),
+ tool = i18n$t("Probability calculator"),
+ data = NULL,
+ tool_ui = "ui_prob_calc",
+ output_panels = pc_output_panels
+ )
+})
+
+pc_available <- reactive({
+ if (is.empty(input$pc_dist) || is.empty(input$pc_type)) {
+ ""
+ } else {
+ a <- "available"
+ if (input$pc_dist == "norm") {
+ if (is_not(input$pc_mean) || is_not(input$pc_stdev) || input$pc_stdev <= 0) {
+ a <- i18n$t("Please provide a mean and standard deviation (> 0)")
+ }
+ } else if (input$pc_dist == "lnorm") {
+ if (is_not(input$pcln_meanlog) || is_not(input$pcln_sdlog) || input$pcln_sdlog <= 0) {
+ a <- i18n$t("Please provide a mean and standard deviation (> 0)")
+ }
+ } else if (input$pc_dist == "binom") {
+ if (is_not(input$pcb_n) || input$pcb_n < 0 || is_not(input$pcb_p) || input$pcb_p < 0) {
+ a <- i18n$t("Please provide a value for n (number of trials) and p (probability of success)")
+ }
+ } else if (input$pc_dist == "unif") {
+ if (is_not(input$pcu_min) || is_not(input$pcu_max)) {
+ a <- i18n$t("Please provide a minimum and a maximum value")
+ }
+ } else if (input$pc_dist == "tdist") {
+ if (is_not(input$pct_df)) {
+ a <- i18n$t("Please provide a value for the degrees of freedom (> 0)")
+ }
+ } else if (input$pc_dist == "fdist") {
+ if (is_not(input$pcf_df1) || is_not(input$pcf_df2) || input$pcf_df1 < 1 || input$pcf_df2 < 5) {
+ a <- i18n$t("Please provide a value for Degrees of freedom 1 (> 0)\nand for Degrees of freedom 2 (> 4)")
+ }
+ } else if (input$pc_dist == "chisq") {
+ if (is_not(input$pcc_df)) {
+ a <- i18n$t("Please provide a value for the degrees of freedom (> 0)")
+ }
+ } else if (input$pc_dist == "disc") {
+ if (is.empty(input$pcd_v) || is.empty(input$pcd_p)) {
+ a <- i18n$t("Please provide a set of values and probabilities.\nSeparate numbers using spaces (e.g., 1/2 1/2)")
+ }
+ } else if (input$pc_dist == "expo") {
+ if (is_not(input$pce_rate) || input$pce_rate <= 0) {
+ a <- i18n$t("Please provide a value for the rate (> 0)")
+ }
+ } else if (input$pc_dist == "pois") {
+ if (is_not(input$pcp_lambda) || input$pcp_lambda <= 0) {
+ a <- i18n$t("Please provide a value for lambda (> 0)")
+ }
+ } else {
+ a <- ""
+ }
+ a
+ }
+})
+
+.prob_calc <- reactive({
+ validate(
+ need(pc_available() == "available", pc_available())
+ )
+ do.call(get(paste0("prob_", input$pc_dist)), pc_inputs())
+})
+
+.summary_prob_calc <- reactive({
+ type <- if (is.empty(input$pc_type)) "values" else input$pc_type
+ summary(.prob_calc(), type = type)
+})
+
+.plot_prob_calc <- reactive({
+ req(pc_available() == "available")
+ type <- if (is.empty(input$pc_type)) "values" else input$pc_type
+ plot(.prob_calc(), type = type)
+})
+
+prob_calc_report <- function() {
+ req(input$pc_dist)
+ type <- input$pc_type
+ inp <- pc_inputs()
+ if (!is.null(type) && type == "probs") {
+ inp_out <- list(type = type) %>% list(., .)
+ inp[["ub"]] <- inp[["lb"]] <- NA
+ } else {
+ inp_out <- list("", "")
+ inp[["pub"]] <- inp[["plb"]] <- NA
+ }
+
+ if (input$pc_dist == "disc") {
+ inp$v <- radiant.data::make_vec(inp$v)
+ inp$p <- radiant.data::make_vec(inp$p)
+ }
+
+ outputs <- c("summary", "plot")
+ update_report(
+ inp_main = clean_args(inp, pc_args()),
+ fun_name = paste0("prob_", input$pc_dist),
+ inp_out = inp_out,
+ outputs = outputs,
+ figs = TRUE,
+ fig.width = pc_plot_width(),
+ fig.height = pc_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_prob_calc",
+ fun = download_handler_plot,
+ fn = function() paste0(input$pc_dist, "_prob_calc"),
+ type = "png",
+ caption = i18n$t("Save probability calculator plot"),
+ plot = .plot_prob_calc,
+ width = pc_plot_width,
+ height = pc_plot_height
+)
+
+observeEvent(input$prob_calc_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ prob_calc_report()
+})
+
+observeEvent(input$prob_calc_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_prob_calc_screenshot")
+})
+
+observeEvent(input$modal_prob_calc_screenshot, {
+ prob_calc_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/analysis/single_mean_ui.R b/radiant.basics/inst/app/tools/analysis/single_mean_ui.R
new file mode 100644
index 0000000..7dd1259
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/single_mean_ui.R
@@ -0,0 +1,201 @@
+###############################
+## Single mean - ui
+###############################
+
+## alternative hypothesis options
+sm_alt <- c("two.sided", "less", "greater")
+names(sm_alt) <- c(i18n$t("Two sided"), i18n$t("Less than"), i18n$t("Greater than"))
+
+sm_plots <- c("hist", "simulate")
+names(sm_plots) <- c(i18n$t("Histogram"), i18n$t("Simulate"))
+
+## list of function arguments
+sm_args <- as.list(formals(single_mean))
+
+## list of function inputs selected by user
+sm_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ sm_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ sm_args$dataset <- input$dataset
+ for (i in r_drop(names(sm_args))) {
+ sm_args[[i]] <- input[[paste0("sm_", i)]]
+ }
+ sm_args
+})
+
+output$ui_sm_var <- renderUI({
+ isNum <- .get_class() %in% c("integer", "numeric", "ts")
+ vars <- c("None" = "", varnames()[isNum])
+ selectInput(
+ inputId = "sm_var", label = i18n$t("Variable (select one):"),
+ choices = vars, selected = state_single("sm_var", vars), multiple = FALSE
+ )
+})
+
+output$ui_single_mean <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_single_mean == 'Summary'",
+ uiOutput("ui_sm_var"),
+ selectInput(
+ inputId = "sm_alternative", label = i18n$t("Alternative hypothesis:"),
+ choices = sm_alt,
+ selected = state_single("sm_alternative", sm_alt, sm_args$alternative),
+ multiple = FALSE
+ ),
+ sliderInput(
+ "sm_conf_lev", i18n$t("Confidence level:"),
+ min = 0.85, max = 0.99,
+ value = state_init("sm_conf_lev", sm_args$conf_lev), step = 0.01
+ ),
+ numericInput(
+ "sm_comp_value", i18n$t("Comparison value:"),
+ state_init("sm_comp_value", sm_args$comp_value)
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_single_mean == 'Plot'",
+ selectizeInput(
+ inputId = "sm_plots", label = i18n$t("Select plots:"),
+ choices = sm_plots,
+ selected = state_multiple("sm_plots", sm_plots, "hist"),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop"))
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Single mean"),
+ fun_name = "single_mean",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/single_mean.md"))
+ )
+ )
+})
+
+sm_plot <- reactive({
+ list(plot_width = 650, plot_height = 400 * max(length(input$sm_plots), 1))
+})
+
+sm_plot_width <- function() {
+ sm_plot() %>%
+ {
+ if (is.list(.)) .$plot_width else 650
+ }
+}
+
+sm_plot_height <- function() {
+ sm_plot() %>%
+ {
+ if (is.list(.)) .$plot_height else 400
+ }
+}
+
+## output is called from the main radiant ui.R
+output$single_mean <- renderUI({
+ register_print_output("summary_single_mean", ".summary_single_mean")
+ register_plot_output(
+ "plot_single_mean", ".plot_single_mean",
+ height_fun = "sm_plot_height"
+ )
+
+ ## two separate tabs
+ sm_output_panels <- tabsetPanel(
+ id = "tabs_single_mean",
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_single_mean")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_single_mean"),
+ plotOutput("plot_single_mean", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Means"),
+ tool = i18n$t("Single mean"),
+ tool_ui = "ui_single_mean",
+ output_panels = sm_output_panels
+ )
+})
+
+sm_available <- reactive({
+ if (not_available(input$sm_var)) {
+ i18n$t("This analysis requires a variable of type numeric or interval. If none are\navailable please select another dataset.\n\n") %>% suggest_data("demand_uk")
+ } else if (is.na(input$sm_comp_value)) {
+ i18n$t("Please choose a comparison value")
+ } else {
+ "available"
+ }
+})
+
+.single_mean <- reactive({
+ smi <- sm_inputs()
+ smi$envir <- r_data
+ do.call(single_mean, smi)
+})
+
+.summary_single_mean <- reactive({
+ if (sm_available() != "available") {
+ return(sm_available())
+ }
+ summary(.single_mean())
+})
+
+.plot_single_mean <- reactive({
+ if (sm_available() != "available") {
+ return(sm_available())
+ }
+ validate(need(input$sm_plots, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1, {
+ plot(.single_mean(), plots = input$sm_plots, shiny = TRUE)
+ })
+})
+
+single_mean_report <- function() {
+ if (is.empty(input$sm_var)) {
+ return(invisible())
+ }
+ if (length(input$sm_plots) == 0) {
+ figs <- FALSE
+ outputs <- c("summary")
+ inp_out <- list("", "")
+ } else {
+ outputs <- c("summary", "plot")
+ inp_out <- list("", list(plots = input$sm_plots, custom = FALSE))
+ figs <- TRUE
+ }
+ update_report(
+ inp_main = clean_args(sm_inputs(), sm_args),
+ fun_name = "single_mean", inp_out = inp_out,
+ outputs = outputs, figs = figs,
+ fig.width = sm_plot_width(),
+ fig.height = sm_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_single_mean",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_single_mean"),
+ type = "png",
+ caption = i18n$t("Save single mean plot"),
+ plot = .plot_single_mean,
+ width = sm_plot_width,
+ height = sm_plot_height
+)
+
+observeEvent(input$single_mean_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ single_mean_report()
+})
+
+observeEvent(input$single_mean_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_single_mean_screenshot")
+})
+
+observeEvent(input$modal_single_mean_screenshot, {
+ single_mean_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/analysis/single_prop_ui.R b/radiant.basics/inst/app/tools/analysis/single_prop_ui.R
new file mode 100644
index 0000000..df99c83
--- /dev/null
+++ b/radiant.basics/inst/app/tools/analysis/single_prop_ui.R
@@ -0,0 +1,228 @@
+###############################
+# Single proportion - ui
+###############################
+
+## alternative hypothesis options
+sp_alt <- list("two.sided", "less", "greater")
+names(sp_alt) <- c(
+ i18n$t("Two sided"),
+ i18n$t("Less than"),
+ i18n$t("Greater than")
+)
+sp_plots <- c("bar", "simulate")
+names(sp_plots) <- c(i18n$t("Bar"), i18n$t("Simulate"))
+
+## list of function arguments
+sp_args <- as.list(formals(single_prop))
+
+## list of function inputs selected by user
+sp_inputs <- reactive({
+ ## loop needed because reactive values don't allow single bracket indexing
+ sp_args$data_filter <- if (input$show_filter) input$data_filter else ""
+ sp_args$dataset <- input$dataset
+ for (i in r_drop(names(sp_args))) {
+ sp_args[[i]] <- input[[paste0("sp_", i)]]
+ }
+ sp_args
+})
+
+output$ui_sp_var <- renderUI({
+ vars <- c("None" = "", groupable_vars())
+ selectInput(
+ inputId = "sp_var", label = i18n$t("Variable (select one):"),
+ choices = vars,
+ selected = state_single("sp_var", vars),
+ multiple = FALSE
+ )
+})
+
+output$up_sp_lev <- renderUI({
+ req(available(input$sp_var))
+ levs <- .get_data()[[input$sp_var]] %>%
+ as.factor() %>%
+ levels()
+
+ selectInput(
+ "sp_lev", i18n$t("Choose level:"),
+ choices = levs,
+ selected = state_single("sp_lev", levs),
+ multiple = FALSE
+ )
+})
+
+output$ui_single_prop <- renderUI({
+ req(input$dataset)
+ tagList(
+ wellPanel(
+ conditionalPanel(
+ condition = "input.tabs_single_prop == 'Summary'",
+ uiOutput("ui_sp_var"),
+ uiOutput("up_sp_lev"),
+ selectInput(
+ "sp_alternative", i18n$t("Alternative hypothesis:"),
+ choices = sp_alt,
+ selected = state_single("sp_alternative", sp_alt, sp_args$alternative),
+ multiple = FALSE
+ ),
+ sliderInput(
+ "sp_conf_lev", i18n$t("Confidence level:"),
+ min = 0.85, max = 0.99, step = 0.01,
+ value = state_init("sp_conf_lev", sp_args$conf_lev)
+ ),
+ numericInput(
+ "sp_comp_value", i18n$t("Comparison value:"),
+ value = state_init("sp_comp_value", sp_args$comp_value),
+ min = 0.01, max = 0.99, step = 0.01
+ ),
+ # radioButtons("sp_type", label = "Test:", c("Binomial" = "binom", "Chi-square" = "chisq"),
+ radioButtons(
+ inputId = "sp_test",
+ label = i18n$t("Test type:"),
+ choices = {
+ opts <- c("binom", "z")
+ names(opts) <- c(i18n$t("Binomial exact"), i18n$t("Z-test"))
+ opts
+ },
+ selected = state_init("sp_test", "binom"), inline = TRUE
+ )
+ ),
+ conditionalPanel(
+ condition = "input.tabs_single_prop == 'Plot'",
+ selectizeInput(
+ "sp_plots", i18n$t("Select plots:"),
+ choices = sp_plots,
+ selected = state_multiple("sp_plots", sp_plots, "bar"),
+ multiple = TRUE,
+ options = list(placeholder = i18n$t("Select plots"), plugins = list("remove_button", "drag_drop"))
+ )
+ )
+ ),
+ help_and_report(
+ modal_title = i18n$t("Single proportion"),
+ fun_name = "single_prop",
+ help_file = inclMD(file.path(getOption("radiant.path.basics"), "app/tools/help/single_prop.md"))
+ )
+ )
+})
+
+sp_plot <- reactive({
+ list(plot_width = 650, plot_height = 400 * max(length(input$sp_plots), 1))
+})
+
+sp_plot_width <- function() {
+ sp_plot() %>%
+ (function(x) if (is.list(x)) x$plot_width else 650)
+}
+
+sp_plot_height <- function() {
+ sp_plot() %>%
+ (function(x) if (is.list(x)) x$plot_height else 400)
+}
+
+## output is called from the main radiant ui.R
+output$single_prop <- renderUI({
+ register_print_output("summary_single_prop", ".summary_single_prop")
+ register_plot_output(
+ "plot_single_prop", ".plot_single_prop",
+ height_fun = "sp_plot_height"
+ )
+
+ ## two separate tabs
+ sp_output_panels <- tabsetPanel(
+ id = "tabs_single_prop",
+ tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_single_prop")),
+ tabPanel(
+ i18n$t("Plot"), value = "Plot",
+ download_link("dlp_single_prop"),
+ plotOutput("plot_single_prop", height = "100%")
+ )
+ )
+
+ stat_tab_panel(
+ menu = i18n$t("Basics > Proportions"),
+ tool = i18n$t("Single proportion"),
+ tool_ui = "ui_single_prop",
+ output_panels = sp_output_panels
+ )
+})
+
+sp_available <- reactive({
+ if (not_available(input$sp_var)) {
+ i18n$t("This analysis requires a categorical variable. In none are available\nplease select another dataset.\n\n") %>% suggest_data("consider")
+ } else if (input$sp_comp_value %>% (function(x) is.na(x) | x > 1 | x <= 0)) {
+ i18n$t("Please choose a comparison value between 0 and 1")
+ } else {
+ "available"
+ }
+})
+
+.single_prop <- reactive({
+ spi <- sp_inputs()
+ spi$envir <- r_data
+ do.call(single_prop, spi)
+})
+
+.summary_single_prop <- reactive({
+ if (sp_available() != "available") {
+ return(sp_available())
+ }
+ summary(.single_prop())
+})
+
+.plot_single_prop <- reactive({
+ if (sp_available() != "available") {
+ return(sp_available())
+ }
+ validate(need(input$sp_plots, i18n$t("Nothing to plot. Please select a plot type")))
+ withProgress(message = i18n$t("Generating plots"), value = 1, {
+ plot(.single_prop(), plots = input$sp_plots, shiny = TRUE)
+ })
+})
+
+single_prop_report <- function() {
+ if (is.empty(input$sp_var)) {
+ return(invisible())
+ }
+ if (length(input$sp_plots) == 0) {
+ figs <- FALSE
+ outputs <- c("summary")
+ inp_out <- list("", "")
+ } else {
+ outputs <- c("summary", "plot")
+ inp_out <- list("", list(plots = input$sp_plots, custom = FALSE))
+ figs <- TRUE
+ }
+ update_report(
+ inp_main = clean_args(sp_inputs(), sp_args),
+ fun_name = "single_prop", inp_out = inp_out,
+ outputs = outputs, figs = figs,
+ fig.width = sp_plot_width(),
+ fig.height = sp_plot_height()
+ )
+}
+
+download_handler(
+ id = "dlp_single_prop",
+ fun = download_handler_plot,
+ fn = function() paste0(input$dataset, "_single_prop"),
+ type = "png",
+ caption = i18n$t("Save single proportion plot"),
+ plot = .plot_single_prop,
+ width = sp_plot_width,
+ height = sp_plot_height
+)
+
+observeEvent(input$single_prop_report, {
+ r_info[["latest_screenshot"]] <- NULL
+ single_prop_report()
+})
+
+observeEvent(input$single_prop_screenshot, {
+ r_info[["latest_screenshot"]] <- NULL
+ radiant_screenshot_modal("modal_single_prop_screenshot")
+})
+
+observeEvent(input$modal_single_prop_screenshot, {
+ single_prop_report()
+ removeModal() ## remove shiny modal after save
+})
diff --git a/radiant.basics/inst/app/tools/help/clt.md b/radiant.basics/inst/app/tools/help/clt.md
new file mode 100644
index 0000000..a446ed5
--- /dev/null
+++ b/radiant.basics/inst/app/tools/help/clt.md
@@ -0,0 +1,19 @@
+> 用随机抽样说明中心极限定理
+
+### 什么是中心极限定理？
+
+“在概率论中，中心极限定理（CLT）指出，在特定条件下，大量独立随机变量（每个变量都有明确的期望值和方差）的算术平均值将近似服从正态分布，而与变量的潜在分布无关。也就是说，假设获取一个包含大量观测值的样本，每个观测值都是随机生成的，且不依赖于其他观测值的值，然后计算观测值的算术平均值。如果多次执行此过程，中心极限定理表明，计算得到的平均值将服从正态分布（通常称为‘钟形曲线’）。”
+
+来源：维基百科
+
+## 抽样
+
+要生成样本，请从 “分布（Distribution）” 下拉菜单中选择一种分布，并接受（或更改）默认值。然后点击 “抽样（Sample）” 按钮或按`CTRL-enter`（Mac 上为`CMD-enter`）运行模拟并显示模拟数据的图表。
+
+### Khan 讲解中心极限定理
+
+
+
+### R 函数
+
+有关 Radiant 中用于概率计算的相关 R 函数概述，请参见*基础 > 概率* 。
\ No newline at end of file
diff --git a/radiant.basics/inst/app/tools/help/compare_means.md b/radiant.basics/inst/app/tools/help/compare_means.md
new file mode 100644
index 0000000..be4a420
--- /dev/null
+++ b/radiant.basics/inst/app/tools/help/compare_means.md
@@ -0,0 +1,120 @@
+> 比较数据中两个或多个变量或组的均值
+
+均值比较 t 检验用于比较一个组中某个变量的均值与一个或多个其他组中同一变量的均值。总体中组间差异的原假设设为零。我们使用样本数据检验这一假设。
+
+我们可以执行单侧检验（即`小于`或`大于`）或双侧检验（见 “备择假设（Alternative hypothesis）” 下拉菜单）。单侧检验用于评估现有数据是否提供证据表明组间样本均值差异小于（或大于）零。
+
+### 示例：教授薪资
+
+我们获取了美国某学院助理教授、副教授和教授的 9 个月学术薪资数据（2008-09 学年）。这些数据是学院行政部门为监测男女教师薪资差异而持续收集的一部分。数据包含 397 个观测值和以下 6 个变量：
+
+- `rank` = 因子，水平为 AsstProf（助理教授）、AssocProf（副教授）、Prof（教授）
+- `discipline` = 因子，水平为 A（“理论型” 院系）或 B（“应用型” 院系）
+- `yrs.since.phd` = 获得博士学位后的年数
+- `yrs.service` = 任职年数
+- `sex` = 因子，水平为 Female（女性）和 Male（男性）
+- `salary` = 9 个月薪资（美元）
+
+这些数据来自 CAR 包，与以下书籍相关：Fox J. 和 Weisberg, S. (2011)《应用回归的 R 伴侣（第二版）》，Sage 出版社。
+
+假设我们要检验职级较低的教授是否比职级较高的教授薪资更低。为检验这一假设，我们首先选择教授`rank`，并选择`salary`作为要在不同职级间比较的数值变量。在 “选择组合（Choose combinations）” 框中选择所有可用条目，对三个职级进行两两比较。注意，移除所有条目会自动选择所有组合。我们关注单侧假设（即`小于`）。
+
+
+Pairwise mean comparisons (t-test)
+Data : salary
+Variables : rank, salary
+Samples : independent
+Confidence: 0.95
+Adjustment: None
+
+ rank mean n n_missing sd se me
+ AsstProf 80,775.985 67 0 8,174.113 998.627 1,993.823
+ AssocProf 93,876.438 64 0 13,831.700 1,728.962 3,455.056
+ Prof 126,772.109 266 0 27,718.675 1,699.541 3,346.322
+
+ Null hyp. Alt. hyp. diff p.value se t.value df 0% 95%
+ AsstProf = AssocProf AsstProf < AssocProf -13100.45 < .001 1996.639 -6.561 101.286 -Inf -9785.958 ***
+ AsstProf = Prof AsstProf < Prof -45996.12 < .001 1971.217 -23.334 324.340 -Inf -42744.474 ***
+ AssocProf = Prof AssocProf < Prof -32895.67 < .001 2424.407 -13.569 199.325 -Inf -28889.256 ***
+
+Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+
+* `se`是标准误（即`diff`抽样分布的标准差）
+* `t.value`是与`diff`相关的 t 统计量，可与 t 分布比较（即`diff` / `se`）
+* `df`是统计检验的自由度。注意，自由度使用 Welch 近似法计算
+* `0% 95%`显示样本均值差异的 95% 置信区间。这些数值提供了真实总体差异可能落入的范围
+
+### 检验方法
+
+我们可以使用三种方法评估原假设。我们选择显著性水平为 0.05。1 当然，每种方法会得出相同结论。
+
+#### p 值
+
+由于每个 p 值都**小于**显著性水平，我们拒绝每个评估的教授职级对的原假设。数据表明，副教授薪资高于助理教授，教授薪资高于助理教授和副教授。注意，“***” 用作显著性指标。
+
+#### 置信区间
+
+由于任何置信区间都**不**包含零，我们拒绝每个评估的职级组合的原假设。由于我们的备择假设是`小于`，置信区间实际上是总体薪资差异的 95% 置信上限（即 - 9785.958、-42744.474 和 - 28889.256）。
+
+#### t 值
+
+由于计算的 t 值（-6.561、-23.334 和 - 13.569）**小于**相应的临界 t 值，我们拒绝每个评估的职级组合的原假设。可通过 “基础（Basics）” 菜单中的概率计算器获取临界 t 值。以助理教授与副教授的检验为例，我们发现对于自由度为 101.286 的 t 分布（见`df`），临界 t 值为 1.66。由于备择假设是`小于`，我们选择 0.05 作为下侧概率界。
+
+
usethis::use_course("https://www.dropbox.com/sh/0xvhyolgcvox685/AADSppNSIocrJS-BqZXhD1Kna?dl=1")
+
+均值比较假设检验
+
+- 本视频展示如何进行均值比较假设检验
+- 主题列表：
+ - 按组计算汇总统计量
+ - 在 Radiant 中设置均值比较的假设检验
+ - 使用 p 值和置信区间评估假设检验
diff --git a/radiant.basics/inst/app/tools/help/compare_props.md b/radiant.basics/inst/app/tools/help/compare_props.md
new file mode 100644
index 0000000..d309afe
--- /dev/null
+++ b/radiant.basics/inst/app/tools/help/compare_props.md
@@ -0,0 +1,119 @@
+> 比较数据中两个或多个组的比例
+
+比例比较检验用于评估某些事件、行为、意图等的发生频率在不同组间是否存在差异。总体中组间比例差异的原假设设为零。我们使用样本数据检验这一假设。
+
+我们可以执行单侧检验（即`小于`或`大于`）或双侧检验（见 “备择假设（Alternative hypothesis）” 下拉菜单）。单侧检验适用于评估样本数据是否表明，例如，某一无线运营商的掉话比例比其他运营商更高（或更低）。
+
+### 示例
+
+我们将使用泰坦尼克号乘客生存状态数据集的一个样本。泰坦尼克号乘客数据的主要来源是《泰坦尼克号百科全书》。原始来源之一是 Eaton & Haas（1994）的《泰坦尼克号：胜利与悲剧》（Patrick Stephens Ltd 出版），其中包含由多位研究者整理、经 Michael A. Findlay 编辑的乘客名单。我们关注数据中的两个变量：
+
+- `survived` = 因子，水平为`Yes`（是）和`No`（否）
+- `pclass` = 乘客等级（1 等、2 等、3 等），作为社会经济地位（SES）的替代指标：1 等≈上层；2 等≈中层；3 等≈下层
+
+假设我们要检验泰坦尼克号沉没事件中，不同乘客等级的生存比例是否存在差异。为检验这一假设，我们选择`pclass`作为分组变量，并计算`survived`中`yes`的比例（见 “选择水平（Choose level）”）（见 “变量（选择一个）（Variable (select one)）”）。
+
+在 “选择组合（Choose combinations）” 框中选择所有可用条目，对三个乘客等级进行两两比较。注意，移除所有条目会自动选择所有组合。除非我们对效应方向有明确假设，否则应使用双侧检验（即`two.sided`）。我们的第一个备择假设是 “1 等舱乘客的生存比例与 2 等舱乘客不同”。
+
+
+Pairwise proportion comparisons
+Data : titanic
+Variables : pclass, survived
+Level : Yes in survived
+Confidence: 0.95
+Adjustment: None
+
+ pclass Yes No p n n_missing sd se me
+ 1st 179 103 0.635 282 0 8.086 0.029 0.056
+ 2nd 115 146 0.441 261 0 8.021 0.031 0.060
+ 3rd 131 369 0.262 500 0 9.832 0.020 0.039
+
+ Null hyp. Alt. hyp. diff p.value chisq.value df 2.5% 97.5%
+ 1st = 2nd 1st not equal to 2nd 0.194 < .001 20.576 1 0.112 0.277 ***
+ 1st = 3rd 1st not equal to 3rd 0.373 < .001 104.704 1 0.305 0.441 ***
+ 2nd = 3rd 2nd not equal to 3rd 0.179 < .001 25.008 1 0.107 0.250 ***
+
+Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+
+* `chisq.value`是与`diff`相关的卡方统计量，可与卡方分布比较。关于该指标的计算方法，详见 “基础> 表格 > 交叉表” 的帮助文件。每组组合都会计算等效的 2×2 交叉表。
+* `df`是每个统计检验的自由度（1）。
+* `2.5% 97.5%`显示样本比例差异的 95% 置信区间。这些数值提供了真实总体差异可能落入的范围。
+
+### 检验方法
+
+我们可以使用三种方法评估原假设。我们选择显著性水平为 0.05。1 当然，每种方法会得出相同结论。
+
+#### p 值
+
+由于每个两两比较的 p 值都**小于**显著性水平，基于可用样本数据，我们可以拒绝比例相等的原假设。结果表明，1 等舱乘客比 2 等舱和 3 等舱乘客更可能在沉没事件中幸存；同样，2 等舱乘客比 3 等舱乘客更可能幸存。
+
+#### 置信区间
+
+由于任何置信区间都**不**包含零，我们拒绝每个评估的乘客等级组合的原假设。
+
+#### 卡方值
+
+由于计算的卡方值（20.576、104.704 和 25.008）**大于**相应的临界卡方值，我们拒绝每个评估的乘客等级组合的原假设。可通过 “基础（Basics）” 菜单中的概率计算器获取临界卡方值。以 1 等舱与 2 等舱乘客的检验为例，我们发现对于自由度为 1（见`df`）、置信水平为 0.95 的卡方分布，临界卡方值为 3.841。
+
+
usethis::use_course("https://www.dropbox.com/sh/0xvhyolgcvox685/AADSppNSIocrJS-BqZXhD1Kna?dl=1")
+
+比例比较假设检验
+
+- 本视频展示如何进行比例比较假设检验
+- 主题列表：
+ - 在 Radiant 中设置比例比较的假设检验
+ - 使用 p 值和置信区间评估假设检验
diff --git a/radiant.basics/inst/app/tools/help/correlation.md b/radiant.basics/inst/app/tools/help/correlation.md
new file mode 100644
index 0000000..9520c3e
--- /dev/null
+++ b/radiant.basics/inst/app/tools/help/correlation.md
@@ -0,0 +1,54 @@
+> 数据中变量的相关性如何？
+
+创建所选变量的相关矩阵。为每个变量对提供相关性和 p 值。要仅显示高于特定（绝对）水平的相关性，使用相关性截断框。
+
+注意：相关性可基于`numeric`、`integer`、`date`和`factor`类型的变量计算。当纳入因子型变量时，应勾选 “调整因子型变量（Adjust for {factor} variables）” 框。进行调整后估计相关性时，因子型变量将被视为（有序）分类变量，其他所有变量将被视为连续变量。
+
+
usethis::use_course("https://www.dropbox.com/sh/0xvhyolgcvox685/AADSppNSIocrJS-BqZXhD1Kna?dl=1")
+
+交叉表假设检验
+
+- 本视频演示如何通过交叉表假设检验研究两个分类变量之间的关联
+- 主题列表：
+ - 在 Radiant 中设置交叉表的假设检验
+ - 解释观察频数表、期望频数表和卡方贡献表的构建方式
+ - 使用 p 值和临界值评估假设检验
diff --git a/radiant.basics/inst/app/tools/help/figures/compare_means_plot.png b/radiant.basics/inst/app/tools/help/figures/compare_means_plot.png
new file mode 100644
index 0000000000000000000000000000000000000000..78038008b60cd31b4eddaf6a4af9ab3d434b6563
GIT binary patch
literal 121299
zcmbrlb6BQZ`#+p*+qTUKGu32Iw(ZF^S(7KbCfl}c+pfua@AiH+zx(&s+i@Ko>%Nvx
zug^NK5ILET@Gv+qKtMq75}!mBfPlbKfq*~*p&$Tn3VTA!fq-Dz%|t}xBt%4r