Robust fxns (#121)

R/app_server.R

@@ -10,7 +10,8 @@
   data_entered_probs <- mod_data_entry_server("data_entry_1")
   data_entered_iters <- mod_iterations_server("iterations_1")
   data_entered_sample_size <- mod_sample_size_server("sample_size_1")
+  data_entered_tests <- mod_select_tests_server("select_tests_1")
   data_sample_probabilities <- mod_sample_probabilities_server("sample_probabilities_1")
   rng_selections <- mod_rng_option_server("rng_option_1")
 
 
@@ -20,11 +21,12 @@
     sample_prob = data_sample_probabilities,
     iterations = data_entered_iters,
     sample_size = data_entered_sample_size,
-    rng_info = rng_selections
+    rng_info = rng_selections,
+    included_tests = data_entered_tests
   )
 
   # Plot the distribution of values
   distributions_power_error <- mod_plot_distributions_server("plot_distributions_1",
     p_value_table = results_output,
     n = data_entered_sample_size
   )

R/app_ui.R

@@ -30,10 +30,10 @@
       shinydashboardPlus::dashboardSidebar(
         sidebarMenu(
           menuItem("Home", tabName = "homeinfo_page", icon = icon("book")),
           menuItem("Simulation", tabName = "simulation_page", icon = icon("sliders")),
           menuItem("Distributions", tabName = "distributions_page", icon = icon("chart-simple")),
           menuItem("Report", tabName = "report_page", icon = icon("markdown")),
           menuItem("Data Download", tabName = "download_page", icon = icon("file-excel"))
         )
       ),
       dashboardBody(
@@ -49,8 +49,9 @@
                 width = 3,
                 mod_iterations_ui("iterations_1"),
                 mod_sample_size_ui("sample_size_1"),
-                mod_sample_probabilities_ui("sample_probabilities_1")
+                mod_sample_probabilities_ui("sample_probabilities_1"),
+                mod_select_tests_ui("select_tests_1")
                 ),
               box(
                 width = 9,
                 mod_data_entry_ui("data_entry_1")

R/assign_groups.R

@@ -3,9 +3,9 @@
 #' (Brief description of the function here.)
 #'
 #' @param sample_size total number of people under observation.
 #' @param sample_prob a vector of probability weights for obtaining the elements of the vector being sampled.
 #' @param prob0 vector probability of each possible outcome for the null group
 #' @param prob1 vector probability of each possible outcome for the intervention group
 #' @param seed integer specifying the seed number
 #' @param .rng_kind seeding info passed to withr::with_seed
 #' @param .rng_normal_kind seeding info passed to withr::with_seed
@@ -19,6 +19,23 @@
 #'
 assign_groups <- function(sample_size, sample_prob, prob0, prob1, seed,
                           .rng_kind = NULL, .rng_normal_kind = NULL, .rng_sample_kind = NULL) {
+
+  assertthat::assert_that(
+    length(prob0) == length(prob1),
+    msg = "prob0 and prob1 must have the same length"
+  )
+
+  assertthat::assert_that(
+    near(sum(prob0), 1),
+    msg = "prob0 must sum to 1"
+  )
+
+  assertthat::assert_that(
+    near(sum(prob1), 1),
+    msg = "prob1 must sum to 1"
+  )
+
+
   withr::with_seed(seed,
     {
       y <- factor(sample(x = 0:1, size = sample_size, replace = TRUE, prob = sample_prob))
@@ -29,13 +46,6 @@
 
       x[y == 0] <- sample(1:K, n_null, replace = TRUE, prob = prob0)
       x[y == 1] <- sample(1:K, n_intervene, replace = TRUE, prob = prob1)
-      #
-      #   if( length(unique(x[y==0])) < K ) {
-      #     warning("Not all possible outcomes observed in the null group.")
-      #   }
-      #   if( length(unique(x[y==1])) < K ) {
-      #     warning("Not all possible outcomes observed in the intervention group.")
-      #   }
 
       list(
         y = y, x = x, n_null = n_null, n_intervene = n_intervene, sample_size = sample_size, K = K,

R/mod_plot_distributions.R

@@ -91,7 +91,12 @@ mod_plot_distributions_server <- function(id, p_value_table, n) {
     # !!!plot!!!
     distribution_plot <- reactive({
       p_value_reactive_table() %>%
-        dplyr::select(.data$wilcox:.data$coinasymp, .data$sample_size) %>%
+        dplyr::select(
+          dplyr::any_of(c(
+            "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+            "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+          )),
+          .data$sample_size) %>%
         plot_distribution_results(
           outlier_removal = outlier_percent_removal(),
           alpha = p_val_threshold()
@@ -106,7 +111,12 @@ mod_plot_distributions_server <- function(id, p_value_table, n) {
     # !!!statistics!!!
     distribution_statistics <- reactive({
       p_value_reactive_table() %>%
-        select(.data$wilcox:.data$coinasymp, .data$sample_size) %>%
+        select(
+          dplyr::any_of(c(
+            "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+            "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+          )),
+          .data$sample_size) %>%
         calculate_power_t2error(
           alpha = p_val_threshold(),
           n = n(),
@@ -141,7 +151,16 @@ mod_plot_distributions_server <- function(id, p_value_table, n) {
     group1_t1_reactive_table <- reactive({
       p_value_table$group1_results() %>%
         bind_rows() %>%
-        dplyr::select(.data$wilcox:.data$coinasymp, .data$sample_size) %>%
+        dplyr::select(
+          dplyr::any_of(c(
+            "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+            "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+          )),
+          dplyr::any_of(c(
+            "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+            "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+          )),
+          .data$sample_size) %>%
         group_by(.data$sample_size) %>%
         calculate_t1_error(t1_error_confidence_int = input$t1_error_group1_confidence_int)
     })
@@ -163,7 +182,12 @@ mod_plot_distributions_server <- function(id, p_value_table, n) {
     group2_t1_reactive_table <- reactive({
       p_value_table$group2_results() %>%
         bind_rows() %>%
-        dplyr::select(.data$wilcox:.data$coinasymp, .data$sample_size) %>%
+        dplyr::select(
+          dplyr::any_of(c(
+            "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+            "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+          )),
+          .data$sample_size) %>%
         group_by(.data$sample_size) %>%
         calculate_t1_error(t1_error_confidence_int = input$t1_error_group2_confidence_int)
     })

R/mod_select_tests.R

@@ -0,0 +1,51 @@
+#' select_tests UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_select_tests_ui <- function(id){
+  ns <- NS(id)
+  tagList(
+
+    selectizeInput(
+      ns("included"),
+      label = "Select Tests",
+      choices = c(
+        "Wilcoxon", "Fisher", "Chi Squared (No Correction)",
+        "Chi Squared (Correction)", "Proportional Odds" = "Prop. Odds",
+        "Coin Independence Test" = "Coin Indep. Test"),
+      multiple = TRUE,
+      selected = c(
+        "Wilcoxon", "Fisher", "Chi Squared (No Correction)",
+        "Chi Squared (Correction)", "Proportional Odds" = "Prop. Odds",
+        "Coin Independence Test" = "Coin Indep. Test")
+      )
+
+  )
+}
+
+#' select_tests Server Functions
+#'
+#' @noRd
+mod_select_tests_server <- function(id){
+  moduleServer( id, function(input, output, session){
+    ns <- session$ns
+
+    selected_tests <- reactive({
+      input$included
+    })
+
+    return(selected_tests)
+
+  })
+}
+
+## To be copied in the UI
+# mod_select_tests_ui("select_tests_1")
+
+## To be copied in the server
+# mod_select_tests_server("select_tests_1")

R/mod_stats_calculations.R

@@ -46,7 +46,7 @@ mod_stats_calculations_ui <- function(id) {
 #' stats_calculations Server Functions
 #'
 #' @noRd
-mod_stats_calculations_server <- function(id, probability_data, sample_prob, iterations, sample_size, rng_info) {
+mod_stats_calculations_server <- function(id, probability_data, sample_prob, iterations, sample_size, rng_info, included_tests) {
   moduleServer(id, function(input, output, session) {
     ns <- session$ns
 
@@ -57,7 +57,8 @@ mod_stats_calculations_server <- function(id, probability_data, sample_prob, ite
         prob1 = dplyr::pull(probability_data(), "Group 2 Probabilities"),
         sample_prob = sample_prob(),
         iterations = iterations(),
-        sample_size = sample_size()
+        sample_size = sample_size(),
+        included_tests = included_tests()
       )
     })
 
@@ -72,6 +73,7 @@ mod_stats_calculations_server <- function(id, probability_data, sample_prob, ite
         sample_prob = parameters()$sample_prob,
         prob1 = parameters()$prob1,
         niter = parameters()$iterations,
+        included = parameters()$included_tests,
         .rng_kind = rng_info$rng_kind(),
         .rng_normal_kind = rng_info$rng_normal_kind(),
         .rng_sample_kind = rng_info$rng_sample_kind()
@@ -85,6 +87,7 @@ mod_stats_calculations_server <- function(id, probability_data, sample_prob, ite
           sample_prob = parameters()$sample_prob,
           prob1 = parameters()$prob0,
           niter = parameters()$iterations,
+          included = parameters()$included_tests,
           .rng_kind = rng_info$rng_kind(),
           .rng_normal_kind = rng_info$rng_normal_kind(),
           .rng_sample_kind = rng_info$rng_sample_kind()
@@ -101,6 +104,7 @@ mod_stats_calculations_server <- function(id, probability_data, sample_prob, ite
           sample_prob = parameters()$sample_prob,
           prob1 = parameters()$prob1,
           niter = parameters()$iterations,
+          included = parameters()$included_tests,
           .rng_kind = rng_info$rng_kind(),
           .rng_normal_kind = rng_info$rng_normal_kind(),
           .rng_sample_kind = rng_info$rng_sample_kind()
@@ -112,33 +116,50 @@ mod_stats_calculations_server <- function(id, probability_data, sample_prob, ite
 
 
     output$results_table <- DT::renderDataTable({
-      # browser()
-      comparison_results() %>%
+      comp_res <- comparison_results() %>%
         bind_rows() %>%
-        dplyr::select(.data$sample_size, .data$wilcox:.data$coinasymp) %>%
+        dplyr::select(.data$sample_size,
+                      dplyr::any_of(c(
+                        "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+                        "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+                      )))
+
+      comp_res %>%
         DT::datatable(options = list(scrollX = TRUE)) %>%
-        DT::formatRound(2:7, digits = 5)
+        DT::formatRound(2:ncol(comp_res), digits = 5)
     })
     outputOptions(output, "results_table", suspendWhenHidden = FALSE)
 
     # if not keeping these output tables, use observe({group1_results()}) to
     # ensure evaluation
-    output$group1_pvalues <- DT::renderDataTable(
-      group1_results() %>%
+    output$group1_pvalues <- DT::renderDataTable({
+      g1_res <- group1_results() %>%
         bind_rows() %>%
-        dplyr::select(.data$sample_size, .data$wilcox:.data$coinasymp) %>%
+        dplyr::select(.data$sample_size,
+                      dplyr::any_of(c(
+                        "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+                        "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+                      )))
+
+      g1_res %>%
         DT::datatable(options = list(scrollX = TRUE)) %>%
-        DT::formatRound(2:7, digits = 5)
-    )
+        DT::formatRound(2:ncol(g1_res), digits = 5)
+    })
     outputOptions(output, "group1_pvalues", suspendWhenHidden = FALSE)
 
-    output$group2_pvalues <- DT::renderDataTable(
-      group2_results() %>%
+    output$group2_pvalues <- DT::renderDataTable({
+      g2_res <- group2_results() %>%
         bind_rows() %>%
-        dplyr::select(.data$sample_size, .data$wilcox:.data$coinasymp) %>%
+        dplyr::select(.data$sample_size,
+                      dplyr::any_of(c(
+                        "Wilcoxon", "Fisher", "Chi Squared\n(No Correction)",
+                        "Chi Squared\n(Correction)", "Prop. Odds", "Coin Indep. Test"
+                      )))
+
+      g2_res %>%
         DT::datatable(options = list(scrollX = TRUE)) %>%
-        DT::formatRound(2:7, digits = 5)
-    )
+        DT::formatRound(2:ncol(g2_res), digits = 5)
+    })
     outputOptions(output, "group2_pvalues", suspendWhenHidden = FALSE)