dev/RcppAlgos (#1)

* replace arrangements with RcppAlgos * combine `PairedComparison` & `SignedScore` * improve PermuTest * colorized ProgressBar * update readme, examples and documentation
qddyy · Sep 13, 2023 · 986ceb1 · 986ceb1
1 parent 7e24460
commit 986ceb1
Show file tree

Hide file tree

Showing 23 changed files with 633 additions and 822 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -9,9 +9,9 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Imports: 
-    arrangements,
     ggplot2,
-    R6
+    R6,
+    RcppAlgos
 Depends: 
     R (>= 2.10)
 LazyData: true

diff --git a/NAMESPACE b/NAMESPACE
@@ -16,7 +16,6 @@ export(MultiCompT)
 export(MultipleComparison)
 export(OneSampleTest)
 export(Page)
-export(PairedComparison)
 export(PermuTest)
 export(Quantile)
 export(RCBD)
@@ -25,7 +24,7 @@ export(RatioMeanDeviance)
 export(ScoreSum)
 export(SiegelTukey)
 export(Sign)
-export(SignedScore)
+export(SignedDiff)
 export(TukeyHSD)
 export(TwoSampleAssociationTest)
 export(TwoSamplePairedTest)
@@ -34,8 +33,10 @@ export(Wilcoxon)
 export(pmt)
 export(pmts)
 importFrom(R6,R6Class)
-importFrom(arrangements,combinations)
-importFrom(arrangements,permutations)
+importFrom(RcppAlgos,comboGeneral)
+importFrom(RcppAlgos,comboSample)
+importFrom(RcppAlgos,permuteGeneral)
+importFrom(RcppAlgos,permuteSample)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,element_text)
 importFrom(ggplot2,facet_grid)

diff --git a/R/ContingencyTableTest.R b/R/ContingencyTableTest.R
@@ -6,7 +6,6 @@
 #' @export
 #' 
 #' @importFrom R6 R6Class
-#' @importFrom arrangements permutations
 
 
 ContingencyTableTest <- R6Class(
@@ -22,34 +21,28 @@ ContingencyTableTest <- R6Class(
             private$.raw_data <- as.matrix(table)
         },
 
-        .permute = function() {
+        .calculate_statistic = function() {
+            private$.statistic <- private$.statistic_func(private$.data)
+        },
+
+        .calculate_statistic_permu = function() {
             r <- nrow(private$.data)
             c <- ncol(private$.data)
 
             row_sum <- .rowSums(private$.data, r, c)
             col_sum <- .colSums(private$.data, r, c)
 
-            private$.data_permu <- lapply(
-                X = permutations(
-                    v = rep.int(seq_len(r), row_sum),
-                    nsample = private$.n_permu, layout = "list"
-                ),
-                FUN = function(data, col_index) {
-                    vapply(
+            private$.statistic_permu <- get_arrangement(
+                "permute", n_sample = private$.n_permu,
+                v = rep.int(seq_len(r), row_sum),
+                func = function(data) {
+                    statistic_func(vapply(
                         X = split(data, col_index), USE.NAMES = FALSE,
                         FUN = tabulate, nbins = r, FUN.VALUE = integer(r)
-                    )
-                }, col_index = rep.int(seq_len(c), col_sum)
-            )
-        },
-
-        .calculate_statistic = function() {
-            private$.statistic <- private$.statistic_func(private$.data)
-        },
-
-        .calculate_statistic_permu = function() {
-            private$.statistic_permu <- vapply(
-                private$.data_permu, private$.statistic_func, numeric(1)
+                    ))
+                }, func_value = numeric(1),
+                statistic_func = private$.statistic_func,
+                col_index = rep.int(seq_len(c), col_sum)
             )
         }
     )

diff --git a/R/KSampleTest.R b/R/KSampleTest.R
@@ -6,7 +6,6 @@
 #' @export
 #' 
 #' @importFrom R6 R6Class
-#' @importFrom arrangements permutations
 
 
 KSampleTest <- R6Class(
@@ -16,8 +15,6 @@ KSampleTest <- R6Class(
     private = list(
         .name = "K Sample Permutation Test",
 
-        .group_permu = NULL,
-
         .check = function() {},
 
         .feed = function(...) {
@@ -29,16 +26,8 @@ KSampleTest <- R6Class(
             )
         },
 
-        .permute = function() {
-            private$.group_permu <- permutations(
-                v = as.integer(names(private$.data)),
-                nsample = private$.n_permu, layout = "list"
-            )
-
-            private$.data_permu <- lapply(
-                X = private$.group_permu,
-                FUN = setNames, object = unname(private$.data)
-            )
+        .calculate_score = function() {
+            private$.data <- get_score(private$.data, method = private$.scoring)
         },
 
         .calculate_statistic = function() {
@@ -48,18 +37,15 @@ KSampleTest <- R6Class(
         },
 
         .calculate_statistic_permu = function() {
-            private$.statistic_permu <- vapply(
-                X = private$.group_permu,
-                FUN = function(group, data, statistic_func) {
+            private$.statistic_permu <- get_arrangement(
+                "permute", n_sample = private$.n_permu,
+                v = as.integer(names(private$.data)),
+                func = function(group) {
                     statistic_func(data, group)
-                }, FUN.VALUE = numeric(1),
-                data = unname(private$.data),
-                statistic_func = private$.statistic_func
+                }, func_value = numeric(1),
+                statistic_func = private$.statistic_func,
+                data = unname(private$.data)
             )
-        },
-
-        .calculate_score = function() {
-            private$.data <- get_score(private$.data, method = private$.scoring)
         }
     )
 )
diff --git a/R/PairedComparison.R b/R/PairedComparison.R
diff --git a/R/PermuTest.R b/R/PermuTest.R
@@ -24,15 +24,6 @@ PermuTest <- R6Class(
             private$.null_value <- null_value
             private$.alternative <- match.arg(alternative)
             private$.conf_level <- conf_level
-
-            private$.side <- switch(private$.trend,
-                "+" = switch(private$.alternative,
-                    greater = "r", less = "l", two_sided = "lr"
-                ),
-                "-" = switch(private$.alternative,
-                    greater = "l", less = "r", two_sided = "lr"
-                ),
-            )
         },
 
         #' @description Feed the data to the test. 
@@ -209,20 +200,26 @@ PermuTest <- R6Class(
             # private$.ci <- ...
         },
 
-        # @Override
-        .permute = function() {
-            # private$.data_permu <- ...
-        },
-
         # @Override
         .calculate_statistic_permu = function() {
             # private$.statistic_permu <- ...
         },
 
+        .calculate_side = function() {
+            private$.side <- switch(private$.trend,
+                "+" = switch(private$.alternative,
+                    greater = "r", less = "l", two_sided = "lr"
+                ),
+                "-" = switch(private$.alternative,
+                    greater = "l", less = "r", two_sided = "lr"
+                ),
+            )
+        },
+
         .calculate_p_permu = function() {
-            r <- quote(mean(private$.statistic_permu >= private$.statistic))
             l <- quote(mean(private$.statistic_permu <= private$.statistic))
-            lr <- quote(mean(abs(private$.statistic_permu) >= abs(private$.statistic)))
+            r <- quote(mean(private$.statistic_permu >= private$.statistic))
+            lr <- quote(2 * min(eval(l), eval(r)))
 
             private$.p_value <- eval(get(private$.side))
         },
@@ -236,33 +233,9 @@ PermuTest <- R6Class(
             private$.define_statistic()
             private$.calculate_statistic()
 
+            private$.calculate_side()
             if (private$.type == "permu") {
-                if (!isFALSE(progress <- getOption("pmt_progress"))) {
-                    progress <- interactive()
-                }
-
-                if (progress) {
-                    cat("Permuting...\n")
-                    private$.permute()
-
-                    assign(
-                        "pb", ProgressBar$new(length(private$.data_permu)),
-                        envir = environment(private$.statistic_func)
-                    )
-                    body(private$.statistic_func) <- as.call(c(
-                        as.name("{"),
-                        expression(on.exit(pb$update())),
-                        body(private$.statistic_func)
-                    ))
-
-                    cat("Calculating statistic...\n")
-                    private$.calculate_statistic_permu()
-                    cat("\n")
-                } else {
-                    private$.permute()
-                    private$.calculate_statistic_permu()
-                }
-
+                private$.calculate_statistic_permu()
                 private$.calculate_p_permu()
             } else {
                 private$.calculate_p()
@@ -319,6 +292,7 @@ PermuTest <- R6Class(
             } else {
                 private$.alternative <- value
                 private$.check()
+                private$.calculate_side()
                 if (private$.type == "permu") {
                     private$.calculate_p_permu()
                 } else {
@@ -351,20 +325,8 @@ PermuTest <- R6Class(
 
         #' @field data Data fed into the object. 
         data = function() private$.data,
-        #' @field data_permu All permutations used. 
-        data_permu = function() {
-            if (private$.type == "permu") {
-                private$.data_permu
-            }
-        },
         #' @field statistic The test statistic. 
         statistic = function() private$.statistic,
-        #' @field statistic_permu Test statistics calculated on permutations. 
-        statistic_permu = function() {
-            if (private$.type == "permu") {
-                private$.statistic_permu
-            }
-        },
         #' @field p_value The p-value. 
         p_value = function() private$.p_value,
         #' @field estimate The estimated parameter. 

diff --git a/R/ProgressBar.R b/R/ProgressBar.R
@@ -17,6 +17,7 @@ ProgressBar <- R6Class(
             if (private$.step %% private$.update_every == 0) {
                 percentage <- private$.step / private$.n_steps
                 cat(
+                    "\033[0;31m",
                     sprintf("\r %.0f%% >", percentage * 100),
                     strrep("=", private$.width * percentage)
                 )