dev/Rcpp (#2)

* introduced `Rcpp` * rewrote `TwoSampleTest` & `KSampleTest` * updated documentation * step * step_2 * step * step_4 * step_5 * final * fix * actions * readme
qddyy · Nov 15, 2023 · 548e1cc · 548e1cc
1 parent 7efc78c
commit 548e1cc
Show file tree

Hide file tree

Showing 66 changed files with 818 additions and 264 deletions.
diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml
@@ -25,11 +25,17 @@ jobs:
           - {os: macos-latest,   r: 'release'}
 
           - {os: windows-latest, r: 'release'}
+          # Use 3.6 to trigger usage of RTools35
+          - {os: windows-latest, r: '3.6'}
+          # use 4.1 to check with rtools40's older compiler
+          - {os: windows-latest, r: '4.1'}
 
           - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
           - {os: ubuntu-latest,   r: 'oldrel-1'}
           - {os: ubuntu-latest,   r: 'oldrel-2'}
+          - {os: ubuntu-latest,   r: 'oldrel-3'}
+          - {os: ubuntu-latest,   r: 'oldrel-4'}
 
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -9,11 +9,15 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Imports: 
+    cli,
     ggplot2,
     R6,
-    RcppAlgos
+    Rcpp
 Depends: 
     R (>= 2.10)
+LinkingTo: 
+    cli,
+    Rcpp
 LazyData: true
 Suggests: 
     knitr,

diff --git a/NAMESPACE b/NAMESPACE
@@ -33,12 +33,7 @@ export(Wilcoxon)
 export(pmt)
 export(pmts)
 importFrom(R6,R6Class)
-importFrom(RcppAlgos,comboCount)
-importFrom(RcppAlgos,comboGeneral)
-importFrom(RcppAlgos,comboSample)
-importFrom(RcppAlgos,permuteCount)
-importFrom(RcppAlgos,permuteGeneral)
-importFrom(RcppAlgos,permuteSample)
+importFrom(Rcpp,sourceCpp)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,element_text)
 importFrom(ggplot2,facet_grid)
@@ -49,3 +44,4 @@ importFrom(ggplot2,labs)
 importFrom(ggplot2,stat_bin)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,xlim)
+useDynLib(LearnNonparam, .registration = TRUE)
diff --git a/R/ANOVA.R b/R/ANOVA.R
@@ -21,7 +21,7 @@ ANOVA <- R6Class(
         #' @return A `ANOVA` object. 
         initialize = function(
             type = c("permu", "approx"),
-            n_permu = NULL
+            n_permu = 0L
         ) {
             private$.type <- match.arg(type)
 

diff --git a/R/AnsariBradley.R b/R/AnsariBradley.R
@@ -21,7 +21,7 @@ AnsariBradley <- R6Class(
         #' @return A `AnsariBradley` object. 
         initialize = function(
             type = c("permu", "approx"),
-            alternative = c("two_sided", "less", "greater"), n_permu = NULL, conf_level = 0.95
+            alternative = c("two_sided", "less", "greater"), n_permu = 0L, conf_level = 0.95
         ) {
             private$.type <- match.arg(type)
 

diff --git a/R/ChiSquare.R b/R/ChiSquare.R
@@ -21,7 +21,7 @@ ChiSquare <- R6Class(
         #' @return A `ChiSquare` object. 
         initialize = function(
             type = c("permu", "approx"),
-            n_permu = NULL
+            n_permu = 0L
         ) {
             private$.type <- match.arg(type)
 
@@ -34,13 +34,13 @@ ChiSquare <- R6Class(
         .define = function() {
             dim <- dim(private$.data)
             sum <- sum(private$.data)
-            private$.statistic_func <- function(mat) {
-                row_sum <- .rowSums(mat, dim[1], dim[2])
-                col_sum <- .colSums(mat, dim[1], dim[2])
+            private$.statistic_func <- function(data) {
+                row_sum <- .rowSums(data, dim[1], dim[2])
+                col_sum <- .colSums(data, dim[1], dim[2])
 
                 expect <- row_sum %*% matrix(col_sum, nrow = 1) / sum
 
-                sum((mat - expect)^2 / expect)
+                sum((data - expect)^2 / expect)
             }
         },
 

diff --git a/R/ContingencyTableTest.R b/R/ContingencyTableTest.R
@@ -32,17 +32,11 @@ ContingencyTableTest <- R6Class(
             row_sum <- .rowSums(private$.data, r, c)
             col_sum <- .colSums(private$.data, r, c)
 
-            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)
-                    ))
-                }, func_value = numeric(1),
+            private$.statistic_permu <- table_pmt(
+                row_loc = rep.int(seq_len(r), row_sum) - 1,
+                col_loc = rep.int(seq_len(c), col_sum) - 1,
                 statistic_func = private$.statistic_func,
-                col_index = rep.int(seq_len(c), col_sum)
+                n_permu = as.integer(private$.n_permu)
             )
         }
     )

diff --git a/R/Correlation.R b/R/Correlation.R
@@ -22,7 +22,7 @@ Correlation <- R6Class(
         #' @return A `Correlation` object. 
         initialize = function(
             type = c("permu", "approx"), method = c("pearson", "kendall", "spearman"),
-            alternative = c("two_sided", "less", "greater"), n_permu = NULL
+            alternative = c("two_sided", "less", "greater"), n_permu = 0L
         ) {
             private$.type <- match.arg(type)
             private$.method <- match.arg(method)

diff --git a/R/Difference.R b/R/Difference.R
@@ -21,7 +21,7 @@ Difference <- R6Class(
         #' @return A `Difference` object. 
         initialize = function(
             method = c("mean", "median"),
-            alternative = c("two_sided", "less", "greater"), n_permu = NULL
+            alternative = c("two_sided", "less", "greater"), n_permu = 0L
         ) {
             private$.method <- match.arg(method)
 

diff --git a/R/Friedman.R b/R/Friedman.R
@@ -21,7 +21,7 @@ Friedman <- R6Class(
         #' @return A `Friedman` object. 
         initialize = function(
             type = c("permu", "approx"),
-            n_permu = NULL
+            n_permu = 0L
         ) {
             private$.type <- match.arg(type)
 
@@ -34,9 +34,9 @@ Friedman <- R6Class(
         .define = function() {
             private$.statistic_func <- switch(private$.type,
                 permu = function(data) sum(rowMeans(data)^2),
-                approx = function(df) {
-                    ncol(df)^2 / sum(vapply(df, var, numeric(1))) *
-                    sum((rowMeans(df) - (nrow(df) + 1) / 2)^2)
+                approx = function(data) {
+                    ncol(data)^2 / sum(apply(data, 2, var)) *
+                    sum((rowMeans(data) - (nrow(data) + 1) / 2)^2)
                 }
             )
         },

diff --git a/R/JonckheereTerpstra.R b/R/JonckheereTerpstra.R
@@ -21,7 +21,7 @@ JonckheereTerpstra <- R6Class(
         #' @return A `JonckheereTerpstra` object. 
         initialize = function(
             type = c("permu", "approx"),
-            alternative = c("two_sided", "less", "greater"), n_permu = NULL
+            alternative = c("two_sided", "less", "greater"), n_permu = 0L
         ) {
             private$.type <- match.arg(type)
 

diff --git a/R/KSampleTest.R b/R/KSampleTest.R
@@ -37,16 +37,11 @@ KSampleTest <- R6Class(
         },
 
         .calculate_statistic_permu = function() {
-            group_count <- tabulate(as.integer(names(private$.data)))
-
-            private$.statistic_permu <- get_arrangement(
-                "permute", n_sample = private$.n_permu,
-                v = seq_along(group_count), freq = group_count,
-                func = function(group) {
-                    statistic_func(data, group)
-                }, func_value = numeric(1),
+            private$.statistic_permu <- ksample_pmt(
+                data = unname(private$.data),
+                group = as.integer(names(private$.data)),
                 statistic_func = private$.statistic_func,
-                data = unname(private$.data)
+                n_permu = as.integer(private$.n_permu)
             )
         }
     )

diff --git a/R/KolmogorovSmirnov.R b/R/KolmogorovSmirnov.R
@@ -19,7 +19,7 @@ KolmogorovSmirnov <- R6Class(
         #' @template init_params
         #' 
         #' @return A `KolmogorovSmirnov` object. 
-        initialize = function(n_permu = NULL) {
+        initialize = function(n_permu = 0L) {
             super$initialize(alternative = "greater", n_permu = n_permu)
         }
     ),

diff --git a/R/KruskalWallis.R b/R/KruskalWallis.R
@@ -22,7 +22,7 @@ KruskalWallis <- R6Class(
         #' @return A `KruskalWallis` object. 
         initialize = function(
             type = c("permu", "approx"),
-            n_permu = NULL, scoring = c("rank", "vw", "expon")
+            n_permu = 0L, scoring = c("rank", "vw", "expon")
         ) {
             private$.type <- match.arg(type)
 

diff --git a/R/LearnNonparam-package.R b/R/LearnNonparam-package.R
@@ -0,0 +1,3 @@
+#' @importFrom Rcpp sourceCpp
+#' @useDynLib LearnNonparam, .registration = TRUE
+NULL
diff --git a/R/MultiCompT.R b/R/MultiCompT.R
@@ -23,7 +23,7 @@ MultiCompT <- R6Class(
         #' @return A `MultiCompT` object. 
         initialize = function(
             type = c("permu", "approx"), bonferroni = TRUE,
-            conf_level = 0.95, n_permu = NULL, scoring = c("none", "rank", "vw", "expon")
+            conf_level = 0.95, n_permu = 0L, scoring = c("none", "rank", "vw", "expon")
         ) {
             private$.type <- match.arg(type)
             private$.bonferroni <- bonferroni
@@ -40,9 +40,9 @@ MultiCompT <- R6Class(
             if (private$.scoring == "none") {
                 N <- length(private$.data)
                 k <- as.integer(names(private$.data)[N])
-                private$.statistic_func <- function(x, y, data) {
+                private$.statistic_func <- function(x, y, data, group) {
                     mse <- sum(vapply(
-                        X = split(data, names(data)),
+                        X = split(data, group),
                         FUN = function(x) (length(x) - 1) * var(x),
                         FUN.VALUE = numeric(1), USE.NAMES = FALSE
                     )) / (N - k)
@@ -52,14 +52,12 @@ MultiCompT <- R6Class(
                 }
             } else {
                 var <- var(private$.data)
-                private$.statistic_func <- function(x, y, data) {
+                private$.statistic_func <- function(x, y, ...) {
                     (mean(x) - mean(y)) / sqrt(
                         var * (1 / length(x) + 1 / length(y))
                     )
                 }
             }
-
-            super$.define()
         },
 
         .calculate_p = function() {

diff --git a/R/MultipleComparison.R b/R/MultipleComparison.R
@@ -70,41 +70,37 @@ MultipleComparison <- R6Class(
             print(histograms)
         },
 
-        .define = function() {
-            k <- as.integer(get_last(names(private$.data)))
-            private$.ij <- ij <- list(
+        .input = function(...) {
+            super$.input(...)
+
+            k <- as.integer(get_last(names(private$.raw_data)))
+            private$.ij <- list(
                 i = rep.int(seq_len(k - 1), seq.int(k - 1, 1)),
                 j = c(lapply(seq.int(2, k), seq.int, to = k), recursive = TRUE)
             )
-
-            data <- unname(private$.data)
-            statistic_func <- private$.statistic_func
-            private$.statistic_func <- function(group) {
-                where <- split(seq_along(group), group)
-                as.numeric(.mapply(
-                    FUN = function(i, j) {
-                        statistic_func(
-                            data[where[[i]]],
-                            data[where[[j]]],
-                            setNames(data, group)
-                        )
-                    }, dots = ij, MoreArgs = NULL
-                ))
-            }
         },
 
         .calculate_statistic = function() {
-            private$.statistic <- private$.statistic_func(
-                as.integer(names(private$.data))
-            )
+            data <- unname(private$.data)
+            group <- as.integer(names(private$.data))
+            where <- split(seq_along(group), group)
+            private$.statistic <- as.numeric(.mapply(
+                FUN = function(i, j) {
+                    private$.statistic_func(
+                        data[where[[i]]], data[where[[j]]], data, group
+                    )
+                }, dots = private$.ij, MoreArgs = NULL
+            ))
         },
 
         .calculate_statistic_permu = function() {
-            private$.statistic_permu <- get_arrangement(
-                "permute", n_sample = private$.n_permu,
-                v = as.integer(names(private$.data)),
-                func = private$.statistic_func,
-                func_value = numeric(length(private$.ij$i))
+            private$.statistic_permu <- multicomp_pmt(
+                group_i = private$.ij$i - 1,
+                group_j = private$.ij$j - 1,
+                data = unname(private$.data),
+                group = as.integer(names(private$.data)) - 1,
+                statistic_func = private$.statistic_func,
+                n_permu = as.integer(private$.n_permu)
             )
         },
 

diff --git a/R/Page.R b/R/Page.R
@@ -21,7 +21,7 @@ Page <- R6Class(
         #' @return A `Page` object. 
         initialize = function(
             type = c("permu", "approx"),
-            alternative = c("two_sided", "less", "greater"), n_permu = NULL
+            alternative = c("two_sided", "less", "greater"), n_permu = 0L
         ) {
             private$.type <- match.arg(type)
 
@@ -41,7 +41,7 @@ Page <- R6Class(
             b <- ncol(private$.data)
 
             z <- (private$.statistic - b * k * (k + 1)^2 / 4) / sqrt(
-                (k - 1) * k * (k + 1) / 12 * sum(vapply(private$.data, var, numeric(1)))
+                (k - 1) * k * (k + 1) / 12 * sum(apply(private$.data, 2, var))
             )
 
             private$.p_value <- get_p_continous(z, "norm", private$.side)

diff --git a/R/PermuTest.R b/R/PermuTest.R
@@ -18,7 +18,7 @@ PermuTest <- R6Class(
         #' @template init_params
         #' 
         #' @return A `PermuTest` object. 
-        initialize = function(null_value = 0, alternative = c("two_sided", "less", "greater"), n_permu = NULL, conf_level = 0.95, scoring = c("none", "rank", "vw", "expon")) {
+        initialize = function(null_value = 0, alternative = c("two_sided", "less", "greater"), n_permu = 0L, conf_level = 0.95, scoring = c("none", "rank", "vw", "expon")) {
             private$.n_permu <- n_permu
             private$.scoring <- match.arg(scoring)
             private$.null_value <- null_value