From 548e1ccbf78b74543af386c06e62df7583f7cca5 Mon Sep 17 00:00:00 2001 From: qddyy <140293741+qddyy@users.noreply.github.com> Date: Wed, 15 Nov 2023 18:45:39 +0800 Subject: [PATCH] dev/Rcpp (#2) * introduced `Rcpp` * rewrote `TwoSampleTest` & `KSampleTest` * updated documentation * step * step_2 * step * step_4 * step_5 * final * fix * actions * readme --- .github/workflows/R-CMD-check.yaml | 6 ++ DESCRIPTION | 6 +- NAMESPACE | 8 +- R/ANOVA.R | 2 +- R/AnsariBradley.R | 2 +- R/ChiSquare.R | 10 +-- R/ContingencyTableTest.R | 14 +-- R/Correlation.R | 2 +- R/Difference.R | 2 +- R/Friedman.R | 8 +- R/JonckheereTerpstra.R | 2 +- R/KSampleTest.R | 13 +-- R/KolmogorovSmirnov.R | 2 +- R/KruskalWallis.R | 2 +- R/LearnNonparam-package.R | 3 + R/MultiCompT.R | 10 +-- R/MultipleComparison.R | 48 +++++------ R/Page.R | 4 +- R/PermuTest.R | 2 +- R/RCBD.R | 31 ++----- R/RCBDANOVA.R | 12 +-- R/RatioMeanDeviance.R | 2 +- R/RcppExports.R | 31 +++++++ R/ScoreSum.R | 2 +- R/Sign.R | 2 +- R/SignedDiff.R | 2 +- R/TukeyHSD.R | 10 +-- R/TwoSampleAssociationTest.R | 12 ++- R/TwoSamplePairedTest.R | 8 +- R/TwoSampleTest.R | 15 ++-- R/Wilcoxon.R | 2 +- R/{auxiliary_funcs.R => utils.R} | 47 ---------- README.Rmd | 26 +++--- README.md | 34 +++----- man/ANOVA.Rd | 4 +- man/AnsariBradley.Rd | 4 +- man/ChiSquare.Rd | 4 +- man/Correlation.Rd | 4 +- man/Difference.Rd | 4 +- man/Friedman.Rd | 4 +- man/JonckheereTerpstra.Rd | 4 +- man/KolmogorovSmirnov.Rd | 4 +- man/KruskalWallis.Rd | 4 +- man/MultiCompT.Rd | 4 +- man/Page.Rd | 4 +- man/PermuTest.Rd | 4 +- man/RCBDANOVA.Rd | 4 +- man/RatioMeanDeviance.Rd | 4 +- man/ScoreSum.Rd | 4 +- man/Sign.Rd | 4 +- man/SignedDiff.Rd | 4 +- man/TukeyHSD.Rd | 4 +- man/Wilcoxon.Rd | 4 +- man/figures/README-results-1.png | Bin 0 -> 7606 bytes man/roxygen/templates/init_params.R | 2 +- src/.gitignore | 3 + src/RcppExports.cpp | 127 ++++++++++++++++++++++++++++ src/association_pmt.cpp | 56 ++++++++++++ src/ksample_pmt.cpp | 56 ++++++++++++ src/multicomp_pmt.cpp | 71 ++++++++++++++++ src/paired_pmt.cpp | 59 +++++++++++++ src/rcbd_pmt.cpp | 69 +++++++++++++++ src/table_pmt.cpp | 65 ++++++++++++++ src/twosample_pmt.cpp | 72 ++++++++++++++++ src/utils.h | 42 +++++++++ vignettes/examples.Rmd | 2 +- 66 files changed, 818 insertions(+), 264 deletions(-) create mode 100644 R/LearnNonparam-package.R create mode 100644 R/RcppExports.R rename R/{auxiliary_funcs.R => utils.R} (53%) create mode 100644 man/figures/README-results-1.png create mode 100644 src/.gitignore create mode 100644 src/RcppExports.cpp create mode 100644 src/association_pmt.cpp create mode 100644 src/ksample_pmt.cpp create mode 100644 src/multicomp_pmt.cpp create mode 100644 src/paired_pmt.cpp create mode 100644 src/rcbd_pmt.cpp create mode 100644 src/table_pmt.cpp create mode 100644 src/twosample_pmt.cpp create mode 100644 src/utils.h diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 234a94e0..ee65ccb5 100644 --- 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 index 681ddb42..99cf4255 100644 --- 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 index 0ff859c5..b8fd0804 100644 --- 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 index 65db66b6..21466583 100644 --- 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 index 0b1219f4..601652c0 100644 --- 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 index dabdf76a..2f39ecd8 100644 --- 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 index b915b4b7..eea79059 100644 --- 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 index 86488775..d75c46c2 100644 --- 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 index 0ab996a2..0d4d3e86 100644 --- 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 index b4384325..8df749ba 100644 --- 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 index 1c0b2a79..69c0d4a6 100644 --- 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 index 8dcc20b9..0b0b42a1 100644 --- 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 index 9912317d..b9ae7c79 100644 --- 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 index e422eaff..e7c6210a 100644 --- 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 new file mode 100644 index 00000000..82abdb01 --- /dev/null +++ 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 index 301d5804..155124c0 100644 --- 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 index 1d0674cf..1b78f784 100644 --- 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 index c329eb77..6dd8186d 100644 --- 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 index 4723ef86..de9fc8ec 100644 --- 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 diff --git a/R/RCBD.R b/R/RCBD.R index c2b21acf..25b118d5 100644 --- a/R/RCBD.R +++ b/R/RCBD.R @@ -6,7 +6,6 @@ #' @export #' #' @importFrom R6 R6Class -#' @importFrom RcppAlgos permuteCount permuteGeneral RCBD <- R6Class( @@ -19,7 +18,7 @@ RCBD <- R6Class( .check = function() {}, .input = function(...) { - data <- do.call(data.frame, get_list(...)) + data <- do.call(cbind, get_list(...)) dim <- dim(data) rownames(data) <- paste0("treatment_", seq_len(dim[1])) @@ -29,11 +28,9 @@ RCBD <- R6Class( }, .calculate_score = function() { - private$.data <- do.call( - data.frame, lapply( - X = private$.data, FUN = get_score, - method = private$.scoring, n = nrow(private$.data) - ) + private$.data <- apply( + X = private$.data, MARGIN = 2, FUN = get_score, + method = private$.scoring, n = nrow(private$.data) ) }, @@ -42,24 +39,10 @@ RCBD <- R6Class( }, .calculate_statistic_permu = function() { - k <- nrow(private$.data) - b <- ncol(private$.data) - - private$.statistic_permu <- get_arrangement( - "permute", n_sample = private$.n_permu, - v = permuteCount(k), m = b, replace = TRUE, - func = function(index) { - statistic_func(do.call( - cbind, .mapply( - dots = list(data, index), - FUN = function(block, i) { - permuteSample(v = block, sampleVec = i)[1, ] - }, MoreArgs = NULL - ) - )) - }, func_value = numeric(1), + private$.statistic_permu <- rcbd_pmt( + data = apply(private$.data, 2, sort), statistic_func = private$.statistic_func, - data = private$.data + n_permu = as.integer(private$.n_permu) ) } ) diff --git a/R/RCBDANOVA.R b/R/RCBDANOVA.R index 050ced21..cd0bb126 100644 --- a/R/RCBDANOVA.R +++ b/R/RCBDANOVA.R @@ -19,7 +19,7 @@ RCBDANOVA <- R6Class( #' @template init_params #' #' @return A `RCBDANOVA` object. - initialize = function(type = c("permu", "approx"), n_permu = NULL) { + initialize = function(type = c("permu", "approx"), n_permu = 0L) { private$.type <- match.arg(type) super$initialize(alternative = "greater", n_permu = n_permu) @@ -31,15 +31,15 @@ RCBDANOVA <- R6Class( .define = function() { private$.statistic_func <- switch(private$.type, permu = function(data) sum(rowMeans(data)^2), - approx = function(df) { - b <- ncol(df) + approx = function(data) { + b <- ncol(data) - bar_i. <- rowMeans(df) - bar_.j <- colMeans(df) + bar_i. <- rowMeans(data) + bar_.j <- colMeans(data) bar_.. <- mean(bar_i.) sst <- b * sum((bar_i. - bar_..)^2) - sse <- sum((df - outer(bar_i., bar_.j, "+") + bar_..)^2) + sse <- sum((data - outer(bar_i., bar_.j, "+") + bar_..)^2) (b - 1) * sst / sse } ) diff --git a/R/RatioMeanDeviance.R b/R/RatioMeanDeviance.R index ea3a140e..972c52e2 100644 --- a/R/RatioMeanDeviance.R +++ b/R/RatioMeanDeviance.R @@ -19,7 +19,7 @@ RatioMeanDeviance <- R6Class( #' @template init_params #' #' @return A `RatioMeanDeviance` object. - initialize = function(alternative = c("two_sided", "less", "greater"), n_permu = NULL) { + initialize = function(alternative = c("two_sided", "less", "greater"), n_permu = 0L) { super$initialize(null_value = 1, alternative = match.arg(alternative), n_permu = n_permu) private$.scoring <- "dev" diff --git a/R/RcppExports.R b/R/RcppExports.R new file mode 100644 index 00000000..eddef808 --- /dev/null +++ b/R/RcppExports.R @@ -0,0 +1,31 @@ +# Generated by using Rcpp::compileAttributes() -> do not edit by hand +# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +association_pmt <- function(x, y, statistic_func, n_permu) { + .Call(`_LearnNonparam_association_pmt`, x, y, statistic_func, n_permu) +} + +ksample_pmt <- function(data, group, statistic_func, n_permu) { + .Call(`_LearnNonparam_ksample_pmt`, data, group, statistic_func, n_permu) +} + +multicomp_pmt <- function(group_i, group_j, data, group, statistic_func, n_permu) { + .Call(`_LearnNonparam_multicomp_pmt`, group_i, group_j, data, group, statistic_func, n_permu) +} + +paired_pmt <- function(n, statistic_func, n_permu) { + .Call(`_LearnNonparam_paired_pmt`, n, statistic_func, n_permu) +} + +rcbd_pmt <- function(data, statistic_func, n_permu) { + .Call(`_LearnNonparam_rcbd_pmt`, data, statistic_func, n_permu) +} + +table_pmt <- function(row_loc, col_loc, statistic_func, n_permu) { + .Call(`_LearnNonparam_table_pmt`, row_loc, col_loc, statistic_func, n_permu) +} + +twosample_pmt <- function(n_1, n_2, c_xy, statistic_func, n_permu) { + .Call(`_LearnNonparam_twosample_pmt`, n_1, n_2, c_xy, statistic_func, n_permu) +} + diff --git a/R/ScoreSum.R b/R/ScoreSum.R index b7ad8d35..5d0584ba 100644 --- a/R/ScoreSum.R +++ b/R/ScoreSum.R @@ -19,7 +19,7 @@ ScoreSum <- R6Class( #' @template init_params #' #' @return A `ScoreSum` object. - initialize = function(alternative = c("two_sided", "less", "greater"), n_permu = NULL, scoring = c("rank", "vw", "expon")) { + initialize = function(alternative = c("two_sided", "less", "greater"), n_permu = 0L, scoring = c("rank", "vw", "expon")) { super$initialize(scoring = match.arg(scoring), alternative = match.arg(alternative), n_permu = n_permu) } ), diff --git a/R/Sign.R b/R/Sign.R index 79a1e672..25e9fb97 100644 --- a/R/Sign.R +++ b/R/Sign.R @@ -21,7 +21,7 @@ Sign <- R6Class( #' @return A `Sign` object. initialize = function( type = c("permu", "approx", "exact"), correct = TRUE, - alternative = c("two_sided", "less", "greater"), n_permu = NULL + alternative = c("two_sided", "less", "greater"), n_permu = 0L ) { private$.correct <- correct private$.type <- match.arg(type) diff --git a/R/SignedDiff.R b/R/SignedDiff.R index a925fad5..118cd65c 100644 --- a/R/SignedDiff.R +++ b/R/SignedDiff.R @@ -24,7 +24,7 @@ SignedDiff <- R6Class( #' @return A `SignedDiff` object. initialize = function( type = c("permu", "approx"), method = c("with_zeros", "ignore"), correct = TRUE, - alternative = c("two_sided", "less", "greater"), n_permu = NULL, scoring = c("none", "rank", "vw", "expon") + alternative = c("two_sided", "less", "greater"), n_permu = 0L, scoring = c("none", "rank", "vw", "expon") ) { private$.correct <- correct private$.type <- match.arg(type) diff --git a/R/TukeyHSD.R b/R/TukeyHSD.R index 285c0270..48bd2b47 100644 --- a/R/TukeyHSD.R +++ b/R/TukeyHSD.R @@ -22,7 +22,7 @@ TukeyHSD <- R6Class( #' @return A `TukeyHSD` object. initialize = function( type = c("permu", "approx"), - 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) @@ -36,9 +36,9 @@ TukeyHSD <- 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) @@ -48,14 +48,12 @@ TukeyHSD <- 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 / 2 * (1 / length(x) + 1 / length(y)) ) } } - - super$.define() }, .calculate_p_permu = function() { diff --git a/R/TwoSampleAssociationTest.R b/R/TwoSampleAssociationTest.R index 0dd79aa8..f603236a 100644 --- a/R/TwoSampleAssociationTest.R +++ b/R/TwoSampleAssociationTest.R @@ -26,14 +26,12 @@ TwoSampleAssociationTest <- R6Class( .calculate_score = function() {}, .calculate_statistic_permu = function() { - private$.statistic_permu <- get_arrangement( - "permute", n_sample = private$.n_permu, - v = private$.data$y, - func = function(y) { - statistic_func(x, y) - }, func_value = numeric(1), + data_y_order <- private$.data[order(private$.data$y),] + private$.statistic_permu <- association_pmt( + x = data_y_order$x, + y = data_y_order$y, statistic_func = private$.statistic_func, - x = private$.data$x + n_permu = as.integer(private$.n_permu) ) } ) diff --git a/R/TwoSamplePairedTest.R b/R/TwoSamplePairedTest.R index 0ee125c4..e35366f0 100644 --- a/R/TwoSamplePairedTest.R +++ b/R/TwoSamplePairedTest.R @@ -32,10 +32,10 @@ TwoSamplePairedTest <- R6Class( }, .calculate_statistic_permu = function() { - private$.statistic_permu <- get_arrangement( - "permute", n_sample = private$.n_permu, - v = c(TRUE, FALSE), m = nrow(private$.data), replace = TRUE, - func = private$.statistic_func, func_value = numeric(1) + private$.statistic_permu <- paired_pmt( + n = length(private$.data$x), + statistic_func = private$.statistic_func, + n_permu = as.integer(private$.n_permu) ) } ) diff --git a/R/TwoSampleTest.R b/R/TwoSampleTest.R index d9fb47f0..5915f8e0 100644 --- a/R/TwoSampleTest.R +++ b/R/TwoSampleTest.R @@ -37,17 +37,12 @@ TwoSampleTest <- R6Class( }, .calculate_statistic_permu = function() { - m <- length(private$.data$x) - n <- length(private$.data$y) - - private$.statistic_permu <- get_arrangement( - "combo", n_sample = private$.n_permu, - v = m + n, m = m, - func = function(index) { - statistic_func(c_xy[index], c_xy[-index]) - }, func_value = numeric(1), + private$.statistic_permu <- twosample_pmt( + n_1 = length(private$.data$x), + n_2 = length(private$.data$y), + c_xy = c(private$.data$x, private$.data$y), statistic_func = private$.statistic_func, - c_xy = c(private$.data$x, private$.data$y) + n_permu = as.integer(private$.n_permu) ) } ) diff --git a/R/Wilcoxon.R b/R/Wilcoxon.R index 96ccbebd..02bf7ac4 100644 --- a/R/Wilcoxon.R +++ b/R/Wilcoxon.R @@ -21,7 +21,7 @@ Wilcoxon <- R6Class( #' @return A `Wilcoxon` object. initialize = function( type = c("permu", "approx", "exact"), correct = TRUE, - 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) private$.correct <- correct diff --git a/R/auxiliary_funcs.R b/R/utils.R similarity index 53% rename from R/auxiliary_funcs.R rename to R/utils.R index 554cf37e..1ac3f553 100644 --- a/R/auxiliary_funcs.R +++ b/R/utils.R @@ -25,53 +25,6 @@ get_score <- function(x, method, n = length(x)) { ) } -# for .calculate_statistic_permu - -#' @importFrom RcppAlgos comboGeneral comboSample comboCount -#' @importFrom RcppAlgos permuteGeneral permuteSample permuteCount -get_arrangement <- function( - which = c("combo", "permute"), n_sample = NULL, - v = NULL, replace = FALSE, freq = NULL, - m = if (is.null(freq)) length(v) else sum(freq), - func = NULL, func_value = NULL, ..., - progress = getOption("pmt_progress") -) { - envir <- list2env(list(...), envir = environment(func)) - - args <- list(v = v, m = m, repetition = replace, freqs = freq) - - if (!isFALSE(progress)) progress <- interactive() - - if (progress) { - if (is.null(n_step <- n_sample)) { - n_step <- do.call(paste0(which, "Count"), args) - } - assign("pb", ProgressBar$new(n_step), envir = envir) - body(func) <- as.call(c( - as.name("{"), - expression(on.exit(pb$update())), - body(func) - )) - on.exit(get("pb", envir = envir)$close()) - } - - if (is.null(n_sample)) { - res <- do.call( - paste0(which, "General"), - c(args, list(FUN = func, FUN.VALUE = func_value)) - ) - if (is.matrix(res)) res <- t(res) - } else { - if (!is.null(freq)) v <- rep.int(v, freq) - res <- vapply( - X = integer(n_sample), FUN = function(...) { - func(sample(x = v, size = m, replace = replace)) - }, FUN.VALUE = func_value - ) - } - res -} - # for .calculate_p get_p_continous <- function(x, dist, side, ...) { diff --git a/README.Rmd b/README.Rmd index 02dfa724..f67ec8fd 100644 --- a/README.Rmd +++ b/README.Rmd @@ -5,17 +5,14 @@ output: df_print: kable fig_width: 8 fig_height: 6 - dev: svg --- ```{r, setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - fig.path = "man/figures/README-" + fig.path = "man/figures/README-", out.width = "100%" ) -set.seed(2023) - library(LearnNonparam) ``` @@ -31,8 +28,6 @@ library(LearnNonparam) This package implements some of the non-parametric tests in chapters 1-5 of [@Higgins2003](#references). -It depends on [R6](https://cran.r-project.org/package=R6) for clean OO-design and [RcppAlgos](https://cran.r-project.org/package=RcppAlgos) for fast generation of combinations/permutations, as well as [ggplot2](https://cran.r-project.org/package=ggplot2) for pretty graphs. - Examples in the book can be found [here](https://qddyy.github.io/LearnNonparam/articles/examples). ## Installation @@ -46,21 +41,22 @@ pak::pkg_install("qddyy/LearnNonparam") - Create a test object (for example, a `Wilcoxon` object) ```{r, eval = FALSE} - t <- Wilcoxon$new(alternative = "greater", type = "permu", n_permu = 1e6) + t <- Wilcoxon$new(alternative = "greater", type = "permu", n_permu = 1e7) ``` or you can use `pmt` (**p**er**m**utation **t**est) function (**Recommended*): ```{r, create} - t <- pmt("twosample.wilcoxon", alternative = "greater", type = "permu", n_permu = 1e6) + t <- pmt("twosample.wilcoxon", alternative = "greater", type = "permu", n_permu = 1e7) ``` - Test some data (`vector` | `data.frame` | `list`) - ```{r, test} + ```{r, test, include = FALSE} + set.seed(2023) t$test(rnorm(20, mean = 1), rnorm(20, mean = 0)) ``` - Check the results - ```{r, results, out.width = "100%"} + ```{r, results} t$p_value t$print(digits = 2) @@ -83,13 +79,11 @@ t <- pmt(...)$test(...)$print(...)$plot(...) ## Tips -- Use `options(pmt_progress = FALSE)` to disable the progress bar and speed up the calculation. - - (By default, a progress bar will appear when calculating the permutation distribution if R is used interactively) - -- Explore `?PermuTest` (all tests' base class) for all available methods and attributes. +- This package uses `iterator` progress bar provided by the `cli` package, which can be customized. See . -- Check `pmts()` for all available tests. +- Check + - `?PermuTest` (all tests' base class) for all available methods and attributes. + - `pmts()` for all available tests. ```{r, pmts} pmts() ``` diff --git a/README.md b/README.md index 90fdf70a..e2d51e63 100644 --- a/README.md +++ b/README.md @@ -16,11 +16,6 @@ check](https://github.com/qddyy/LearnNonparam/workflows/R-CMD-check/badge.svg)]( This package implements some of the non-parametric tests in chapters 1-5 of [Higgins (2003)](#references). -It depends on [R6](https://cran.r-project.org/package=R6) for clean -OO-design and [RcppAlgos](https://cran.r-project.org/package=RcppAlgos) -for fast generation of combinations/permutations, as well as -[ggplot2](https://cran.r-project.org/package=ggplot2) for pretty graphs. - Examples in the book can be found [here](https://qddyy.github.io/LearnNonparam/articles/examples). @@ -36,33 +31,29 @@ pak::pkg_install("qddyy/LearnNonparam") - Create a test object (for example, a `Wilcoxon` object) ``` r - t <- Wilcoxon$new(alternative = "greater", type = "permu", n_permu = 1e6) + t <- Wilcoxon$new(alternative = "greater", type = "permu", n_permu = 1e7) ``` or you can use `pmt` (**p**er**m**utation **t**est) function (\*\*Recommended\*): ``` r - t <- pmt("twosample.wilcoxon", alternative = "greater", type = "permu", n_permu = 1e6) + t <- pmt("twosample.wilcoxon", alternative = "greater", type = "permu", n_permu = 1e7) ``` - Test some data (`vector` \| `data.frame` \| `list`) - ``` r - t$test(rnorm(20, mean = 1), rnorm(20, mean = 0)) - ``` - - Check the results ``` r t$p_value - #> [1] 0.001312 + #> [1] 0.0013138 t$print(digits = 2) #> #> Two Sample Wilcoxon Test #> - #> scoring: rank type: permu(1e+06) method: default + #> scoring: rank type: permu(1e+07) method: default #> statistic = 519, p_value = 0.0013 #> alternative hypothesis: true location shift is greater than 0 #> estimate: 0.95 @@ -71,7 +62,7 @@ pak::pkg_install("qddyy/LearnNonparam") t$plot(binwidth = 1) ``` - + - Modify some attributes and see how the results change @@ -91,16 +82,15 @@ t <- pmt(...)$test(...)$print(...)$plot(...) ## Tips -- Use `options(pmt_progress = FALSE)` to disable the progress bar and - speed up the calculation. - - (By default, a progress bar will appear when calculating the - permutation distribution if R is used interactively) +- This package uses `iterator` progress bar provided by the `cli` + package, which can be customized. See + . -- Explore `?PermuTest` (all tests’ base class) for all available methods - and attributes. +- Check -- Check `pmts()` for all available tests. + - `?PermuTest` (all tests’ base class) for all available methods and + attributes. + - `pmts()` for all available tests. ``` r pmts() diff --git a/man/ANOVA.Rd b/man/ANOVA.Rd index 12020be0..767867a1 100644 --- a/man/ANOVA.Rd +++ b/man/ANOVA.Rd @@ -31,7 +31,7 @@ Performs F statistic based k sample permutation test on data vectors. \subsection{Method \code{new()}}{ Create a new \code{ANOVA} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ANOVA$new(type = c("permu", "approx"), n_permu = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ANOVA$new(type = c("permu", "approx"), n_permu = 0L)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -39,7 +39,7 @@ Create a new \code{ANOVA} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate the p-value.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/AnsariBradley.Rd b/man/AnsariBradley.Rd index c335bc7d..03b02425 100644 --- a/man/AnsariBradley.Rd +++ b/man/AnsariBradley.Rd @@ -34,7 +34,7 @@ Create a new \code{AnsariBradley} object. \if{html}{\out{
}}\preformatted{AnsariBradley$new( type = c("permu", "approx"), alternative = c("two_sided", "less", "greater"), - n_permu = NULL, + n_permu = 0L, conf_level = 0.95 )}\if{html}{\out{
}} } @@ -46,7 +46,7 @@ Create a new \code{AnsariBradley} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{conf_level}}{a number specifying confidence level of the interval.} } diff --git a/man/ChiSquare.Rd b/man/ChiSquare.Rd index 8e7bfd2e..d8c288ed 100644 --- a/man/ChiSquare.Rd +++ b/man/ChiSquare.Rd @@ -31,7 +31,7 @@ Performs chi-square statistic based permutation test on contingency tables. \subsection{Method \code{new()}}{ Create a new \code{ChiSquare} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ChiSquare$new(type = c("permu", "approx"), n_permu = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ChiSquare$new(type = c("permu", "approx"), n_permu = 0L)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -39,7 +39,7 @@ Create a new \code{ChiSquare} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate the p-value.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/Correlation.Rd b/man/Correlation.Rd index 8e743288..7275f106 100644 --- a/man/Correlation.Rd +++ b/man/Correlation.Rd @@ -35,7 +35,7 @@ Create a new \code{Correlation} object. type = c("permu", "approx"), method = c("pearson", "kendall", "spearman"), alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{}} } @@ -48,7 +48,7 @@ Create a new \code{Correlation} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/Difference.Rd b/man/Difference.Rd index f68c907f..c1857d40 100644 --- a/man/Difference.Rd +++ b/man/Difference.Rd @@ -34,7 +34,7 @@ Create a new \code{Difference} object. \if{html}{\out{
}}\preformatted{Difference$new( method = c("mean", "median"), alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{
}} } @@ -43,7 +43,7 @@ Create a new \code{Difference} object. \describe{ \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/Friedman.Rd b/man/Friedman.Rd index d492c3a4..078333c1 100644 --- a/man/Friedman.Rd +++ b/man/Friedman.Rd @@ -31,7 +31,7 @@ Performs Friedman test on data for a randomized complete block design. \subsection{Method \code{new()}}{ Create a new \code{Friedman} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Friedman$new(type = c("permu", "approx"), n_permu = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Friedman$new(type = c("permu", "approx"), n_permu = 0L)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -39,7 +39,7 @@ Create a new \code{Friedman} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate the p-value.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/JonckheereTerpstra.Rd b/man/JonckheereTerpstra.Rd index 2746d6cf..da8ed35f 100644 --- a/man/JonckheereTerpstra.Rd +++ b/man/JonckheereTerpstra.Rd @@ -34,7 +34,7 @@ Create a new \code{JonckheereTerpstra} object. \if{html}{\out{
}}\preformatted{JonckheereTerpstra$new( type = c("permu", "approx"), alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{
}} } @@ -45,7 +45,7 @@ Create a new \code{JonckheereTerpstra} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/KolmogorovSmirnov.Rd b/man/KolmogorovSmirnov.Rd index 7ab0abf5..3f5002bb 100644 --- a/man/KolmogorovSmirnov.Rd +++ b/man/KolmogorovSmirnov.Rd @@ -31,13 +31,13 @@ Performs two sample Kolmogorov-Smirnov test on data vectors. \subsection{Method \code{new()}}{ Create a new \code{KolmogorovSmirnov} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{KolmogorovSmirnov$new(n_permu = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{KolmogorovSmirnov$new(n_permu = 0L)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{
}} } diff --git a/man/KruskalWallis.Rd b/man/KruskalWallis.Rd index 97f725f9..9835e7ed 100644 --- a/man/KruskalWallis.Rd +++ b/man/KruskalWallis.Rd @@ -33,7 +33,7 @@ Create a new \code{KruskalWallis} object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{KruskalWallis$new( type = c("permu", "approx"), - n_permu = NULL, + n_permu = 0L, scoring = c("rank", "vw", "expon") )}\if{html}{\out{
}} } @@ -43,7 +43,7 @@ Create a new \code{KruskalWallis} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate p-values, must be one of \code{"permu"} (default) or \code{"approx"}.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{scoring}}{a character string specifying which scoring system to be used.} } diff --git a/man/MultiCompT.Rd b/man/MultiCompT.Rd index 1d500377..8ec6f96f 100644 --- a/man/MultiCompT.Rd +++ b/man/MultiCompT.Rd @@ -35,7 +35,7 @@ Create a new \code{MultiCompT} object. type = c("permu", "approx"), bonferroni = TRUE, conf_level = 0.95, - n_permu = NULL, + n_permu = 0L, scoring = c("none", "rank", "vw", "expon") )}\if{html}{\out{}} } @@ -49,7 +49,7 @@ Create a new \code{MultiCompT} object. \item{\code{conf_level}}{a numeric value between zero and one giving the family-wise confidence level to use.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{scoring}}{a character string specifying which scoring system to be used.} } diff --git a/man/Page.Rd b/man/Page.Rd index 8dd142c1..75d4667d 100644 --- a/man/Page.Rd +++ b/man/Page.Rd @@ -34,7 +34,7 @@ Create a new \code{Page} object. \if{html}{\out{
}}\preformatted{Page$new( type = c("permu", "approx"), alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{
}} } @@ -45,7 +45,7 @@ Create a new \code{Page} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/PermuTest.Rd b/man/PermuTest.Rd index 2403ba8b..a01e229a 100644 --- a/man/PermuTest.Rd +++ b/man/PermuTest.Rd @@ -53,7 +53,7 @@ Create a new \code{PermuTest} object. Note that it is not recommended to create \if{html}{\out{
}}\preformatted{PermuTest$new( null_value = 0, alternative = c("two_sided", "less", "greater"), - n_permu = NULL, + n_permu = 0L, conf_level = 0.95, scoring = c("none", "rank", "vw", "expon") )}\if{html}{\out{
}} @@ -66,7 +66,7 @@ Create a new \code{PermuTest} object. Note that it is not recommended to create \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{conf_level}}{a number specifying confidence level of the interval.} diff --git a/man/RCBDANOVA.Rd b/man/RCBDANOVA.Rd index 0af7cc5f..d4abc056 100644 --- a/man/RCBDANOVA.Rd +++ b/man/RCBDANOVA.Rd @@ -31,7 +31,7 @@ Performs F-statistic based permutation test on data for a randomized complete bl \subsection{Method \code{new()}}{ Create a new \code{RCBDANOVA} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RCBDANOVA$new(type = c("permu", "approx"), n_permu = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{RCBDANOVA$new(type = c("permu", "approx"), n_permu = 0L)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -39,7 +39,7 @@ Create a new \code{RCBDANOVA} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate the p-value.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/RatioMeanDeviance.Rd b/man/RatioMeanDeviance.Rd index 11b901a5..eb795bd3 100644 --- a/man/RatioMeanDeviance.Rd +++ b/man/RatioMeanDeviance.Rd @@ -33,7 +33,7 @@ Create a new \code{RatioMeanDeviance} object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{RatioMeanDeviance$new( alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{
}} } @@ -42,7 +42,7 @@ Create a new \code{RatioMeanDeviance} object. \describe{ \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/ScoreSum.Rd b/man/ScoreSum.Rd index c4751643..9588e009 100644 --- a/man/ScoreSum.Rd +++ b/man/ScoreSum.Rd @@ -33,7 +33,7 @@ Create a new \code{ScoreSum} object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{ScoreSum$new( alternative = c("two_sided", "less", "greater"), - n_permu = NULL, + n_permu = 0L, scoring = c("rank", "vw", "expon") )}\if{html}{\out{
}} } @@ -43,7 +43,7 @@ Create a new \code{ScoreSum} object. \describe{ \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{scoring}}{a character string specifying which scoring system to be used.} } diff --git a/man/Sign.Rd b/man/Sign.Rd index 63c10af2..b372103a 100644 --- a/man/Sign.Rd +++ b/man/Sign.Rd @@ -35,7 +35,7 @@ Create a new \code{Sign} object. type = c("permu", "approx", "exact"), correct = TRUE, alternative = c("two_sided", "less", "greater"), - n_permu = NULL + n_permu = 0L )}\if{html}{\out{}} } @@ -48,7 +48,7 @@ Create a new \code{Sign} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} } \if{html}{\out{}} } diff --git a/man/SignedDiff.Rd b/man/SignedDiff.Rd index 35fabe27..306bf72f 100644 --- a/man/SignedDiff.Rd +++ b/man/SignedDiff.Rd @@ -36,7 +36,7 @@ Create a new \code{SignedDiff} object. method = c("with_zeros", "ignore"), correct = TRUE, alternative = c("two_sided", "less", "greater"), - n_permu = NULL, + n_permu = 0L, scoring = c("none", "rank", "vw", "expon") )}\if{html}{\out{}} } @@ -52,7 +52,7 @@ Create a new \code{SignedDiff} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{scoring}}{a character string specifying which scoring system to be used on the absolute differences.} } diff --git a/man/TukeyHSD.Rd b/man/TukeyHSD.Rd index 8b1d65c7..17bbbc3b 100644 --- a/man/TukeyHSD.Rd +++ b/man/TukeyHSD.Rd @@ -34,7 +34,7 @@ Create a new \code{TukeyHSD} object. \if{html}{\out{
}}\preformatted{TukeyHSD$new( type = c("permu", "approx"), conf_level = 0.95, - n_permu = NULL, + n_permu = 0L, scoring = c("none", "rank", "vw", "expon") )}\if{html}{\out{
}} } @@ -46,7 +46,7 @@ Create a new \code{TukeyHSD} object. \item{\code{conf_level}}{a numeric value between zero and one giving the family-wise confidence level to use.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{scoring}}{a character string specifying which scoring system to be used.} } diff --git a/man/Wilcoxon.Rd b/man/Wilcoxon.Rd index bd5d993a..6cff9463 100644 --- a/man/Wilcoxon.Rd +++ b/man/Wilcoxon.Rd @@ -35,7 +35,7 @@ Create a new \code{Wilcoxon} object. type = c("permu", "approx", "exact"), correct = TRUE, alternative = c("two_sided", "less", "greater"), - n_permu = NULL, + n_permu = 0L, conf_level = 0.95 )}\if{html}{\out{}} } @@ -49,7 +49,7 @@ Create a new \code{Wilcoxon} object. \item{\code{alternative}}{a character string specifying the alternative hypothesis.} -\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If \code{NULL} (default) then all permutations are used.} +\item{\code{n_permu}}{an integer specifying how many permutations should be used to construct the permutation distribution. If set to zero (default) then all permutations are used.} \item{\code{conf_level}}{a number specifying confidence level of the interval.} } diff --git a/man/figures/README-results-1.png b/man/figures/README-results-1.png new file mode 100644 index 0000000000000000000000000000000000000000..3498a366a8aeecacc18c1dd651ef3032717f0745 GIT binary patch literal 7606 zcmai33p`Y5|3Bv#HA7_#hEfcrUE4HkGAO#3G^9ap^MB6F^nP~V|NDRcHJ$UE=RD{8{I1{M^E@5hu-<#7 z#vBa@f@ZGqS+x;@)IbxV;<4Mz*um`(1kc*AZj%>ygdi6PVnQx1kPEoxL(B>X2M5pv zo?Rd&*6qRse_fdQF3bv-eDD+bVSl3i{Br%G*?zeXnTqe3V03;3Ghf8406%%eZdcE@1a~S%6AdvGes3l5dgsc$iYi+ z5y|B}?C2i3Tq2PG2rwE9m5VB{H$7~*0swpsM#<%JhZ|a#fjtPZK3n!f(5!mwAKV;s z4VY{0`ZcTEHzl6$zcBNlZs5Mv!BhOGn@5jFt*dcNoQK2*9D9S_f~6Ksj0=8<2VHZ` zq+IS(_0DtXMMvA#ts?;)weME6EIGNd=7;h1^ZYtbxO)-u?SGU(&>0G}eI`N`{D&Jp zG3aUHNcR1@q0jF+T}6`+Qea z-F0DwtvIP-Jjow^n^$?@-SLK5@Yu?YsT35I{P^nCTcf3#t>c5ost@WsSr5|#py&Onu(-{oIL9jZs6cE;iz?Wp7?LwWI~lO%9z(zU4g1xObwkxp7>c5MsMm zc2K_W)-`GDz0u?oBc3vU`BZb#R9aequ5qm}xyJa|>!#NQPh!~PwIdNf4b%-Cnc6$3 zG4T7v7_v0w<(G%!Mho4DRDKl{6HU%8y&))_qSr?1rB#le<5eGS(br#Uh&)Xje|o() zaKg|qFR(KptWo0swvJmRU5iSJz19!Smma)2L51MRLaHo&k`^4x7PEJkOa)1M-Z|Jt zzo-+_g6s8%G*9#yCx_Nfa>P}4tcFS&?R(EC_7f)S%JXupK zU9xSk^@#&jR^>3>u{^J4QGAc)E#&9SeSh17GwWn z{lZV#^UCBOhStO4@#rb(8RQjBymxSKN+%PpQfk;PI+<-%{CZ5%pZwuvTF2Jfnj4!BY`6t&%{yg`r_lSKHQZv{ghQL+s28TDT7^gQ@$xjEa1Z- zhzT@<>4)yF7LV^uHQJ*?k1u@UrWc9mhMjWL-+H8L4;*kL_piG1<{?w97SzGU6%p@F zjJPTSMJ6q=nFX^KztZkvrLjBXDp+m%WM7+#3fR(@j`)G@*Z1{f4hg!SG|YqpZq7(n z_`*=`e*fd{nyDKb*^n%uTs-;mtH`5M5IOqx*6XgJzsw&_49Q~rc?*KoY2z{JHu8{; zk&ZD@%&pAD@R?4$D5WO_QykiI2+Cjf-)?h|nm^pFj?mn=UT0~u4Y_z~R3;6V|GZ>6 z_b?Yvx!|wGIJzgx3u4^L{l{f~!#@0(zmJ+3u1$5hXw)#L$rO!qU72NGVM2zpp1J(v za-8_Yg!cDQ%W}M+56LWIq(L_H$JZ~EGs43(9K})c_lwW`;ZQG>X6}rePZbIe;)|yv zSM`EpT#*GC(5^;PbO}B`;3H4(9QT~r+-&GmxRbiUPWPMUxNI+|lRFasd)8))ZW?Z2 zUN)2-uFc;cRX^5}+b}=;MK^H<91$WvIKq@aU{$1#hS`R~6O9#kySFY`foMPY#4sDW z+_}t}4A(Tpm!|DQMvr?zCESkjJSd2Z?^;TRiPXXd#t5FWiNYnBHkhJMgglAuCe(8v z-Ws`^J>YY$$^^8{cIg->$H|B^OTz0P7je8m<2D zJ97hI@@(NCfW8SvYcD?lJL7!cwbdW6MzS#d>S#D(<6|n61|k{rz!amz2GcH9n{7fh zRu3tpgBgq%2ZoJd91scw>{B3==f@tEP%YfG$j3mXjXkZAhZtrx$PNrMfm@)@kBQQP zpVzIJ=(%cbYh)yL-E+?!wZ8_uJR`5emfu)^<#TU;8@u_%vyvTeW+FKVJR^KWGd5Lz zyJmFkQKOS(@7F-f<4$-xq*3OLc5`{^@2jqVlDT_D;^K-I@mEUZPKzVv+SlKFM|%Ip zvMi=0o;S$c+d|Cf>s}TRh_<$AgcqdhUvt69+eXGiK{RS055srh#nVb}$i7po5Q+y#*D6r;JKsP+fC3;p-~xBrX{L_`6KXoLb*3wW-e?TuEzCwXMO!LFq_Sr z!rR%A;V9s2XYA&nP3iTtLoz``+hacd-Wtg{3hbH7(5A2B%)rI!vTdm)h^ucoNar>o z5hREwFeFG24uJS}bJSP4X9xHkb4M!U5We*ighYV|*`?|WWvG?bdBPJQhCyZs!JB`( zMY$re81o#d7t)d2b5KYGf`V)qJ*iy`676iGDgQkdGV>iR6(C!zkwidWw?Oz3v!T^o zlb3Z{;hpBrpzn&X2B!?Zom_k|5#+%N5KkUJA8e=wrl@CBs3P#LfX}tD&jBzn2*XpF zmW|Y|#l|^ueOZ7YPdEfHHrfw#t86) z8{i3$pA#UeL4FQ~JLsaG<$!=E0DJ(@#SUa?DUgOf*U%rGr%t3VC&P^9rjRrzOfysn zR9b}fn4)YNE(?(44aPEc)U`p6KPK--Q&+0acQp}nvi}Kh-c<_6AIR#@BzhP z#L|di&n_xah_%le83jb}5P({dVJ!2@0O(xsR;ik)e3#Q8&;4%!Y zfQD;7_}yQ_fJA4uV^w?;Da?u3r(;mZLrcZZk0OjSodHVhNH`Ubn3{U3jR-QC^a zcE%9*p3jmvl`p!#2QX%;%c8JOR~{>QQ|-jNI*2`7>Bo$~M$LY$I1*SzsNP^Pu0J#5v@Ce}Nra+~_a^N{4EO)+T)^fpOZ zZ=SvW*#!6EP#`+z3TdM&E+OSZ7!RRPtpv;K(!VDx)QlZG^4H1z)AAdGVkXFr=4Okj zlQtVFV`4}BeXo#}*c&6PF9gm3g{M?zKrcF&Zm;loSyQw=$%z-i`PW?1AgbDJ;T`a6|RP{rlqy z4YTQS9NA4LZ659=*AEFX(&CMIqhwAY@92B;ySaNvr~?}Gj{)=1jmqcDz(?~krl(DZ z;Gpu*VWw%}z@lZaSiH~~Cus;OV>z7gO+0-L+UW7LWI7U}b1yRxPr2x?g}ZC94@_T# z>mvDB30Q5xS-}}np#@ByGf_W36kgpF6vNWo>pL({WJ66Fp3=k_=tuHCEN)nQKOw3R z3PFx%-w_W5FwWRnKJpy+Arx+E43Z{U+54U?I0I#S4!}FnyKWrEDeO(3yxauBPF1gz%jqnjR_Y?yUF1X&0aO>{c3mUi+iU?n|9X<$u}kGb_4 zKWMhXtpYHTq)a%D&UFAV6M6caU)by^_od*34Xj20l_3{yg~hMVhfTQ6o3MQ2iJ40| zxEfi(<4(eej|z7*uS1(It7HtOpx<)^R<(Hxz*O&vInW}mK*GC-H|O~HpikcPj>}uV zs@Z?0Nn~RGOj3ZE8Gk~=H?*Me2flS(HKTrw8}`007SEn=jR1w3iu#$J%J+ym1PvK$ z*^O$gGUdA{F|QIuW-2olty*C6BMpZqMe;g$_^lo!U=I*ol?Sz}GMAln!C{L^NyjIz z_ap%oTZvQnj+cCCYDxwYW!h|;sWin$Qbnd2L!08mkugWiq6ljmOsObM!u#a+kVHD_ zg+joA9Yy)(W?)4HGfGFQoJ@R$%1T6}7v`Hsq1gJKif;8dQx2?yu~0l=%Y$i(Ee1|# zzMXIs6f71;7NBK9BRo>JH!9n^H6RC0Aqy|q`ZYZex zaXQ^RDqT6zYUFgex^kj9giRhx0I$!D<0KTh-vD?&!Za2*#1TX2w$ARvh*=Ue`C`u%gZr zi{~|x&Z#6?e$0I7A*KGZ{QRY_)m$`r>}6G~MY7#=5`a)t*YIhQXPX%z1egk@qT60si-)k+2WM~guvAH_ zXse)}TqC(Ct-%jneY%yPP=dyhwfEUy&ZH>(thSfnj)4_Ve@)6jF$ZcjnB!o~u0~nD zLN&!AL(%zBQHr$zf$The;&i!m)*8)$v4Metf}1soiHYO4d#Aw`hd7xj2|ioUp|bUl z3oo7t%*zXkA<|tQuH9g>j1iR=h~C5Lcb>m3rtstPPZx*mZV;v-o5Ffqq!-WVhq>*l zx&CR;-D_vVcCMJVgCn_p*%uwMbxYk?Tf0&uYbt7-^uYh-eU>Ik+3fwN$4393di09> zedT?65SY36$2G3^`kBZ&g1cq`xi~o~k#+$d zb*0W1h~_}1;iOKiuRZC&=+h z;(hy%j!bI=&lR_H8N?epkl{?4bZ6|0>f>Ms>%kduaQ>}Bc{+j2SamB{NnqbvM|N{$ z`TdW=bQf$7`K)Dc=xuvGf*I(%bKLUxjzC>}dFWFbEzS_w0Y|fCT7RkPRcuyq z205XX%6R)%iwDRsCo4eJO(gO}@4=RKuB0@_=S%dJW>bDFr*etu@72eRz~-APess5? zUjQ};hZ($+d%y2Hqs(P$#zqxDe(|3QV|ZE$SSI0Dln-j~_6CW-41BeXmpgd$Whq#1 z&ZuY2d!thp43?Y*hh;8JmZ6mvU}C&v&r<3y!KxMDLX8f^sSJ^N%;Vbx4pj=v9P!}D zjLvCa3I@x61N1*N-yfHegGg1uVCM^(q@X1gDp*uIr(fmq`354D?^fI2P~bK{q)F6o zTWqg9!^OAid~2RV*3AL!=CRp$%`&Ki7IRT8<3Qw`Y-qAv>^eQ?gUSwcv+yd#!4QQX z(W4Z-2`qbm)=@nW=}X9IRv$0OGcR2yShw>R{~yJ6HB zap}+gRIFmOdbBQ9a0H%F>h#R2zFH|NI_H12X5`)pb!f@yuQ0{{7A&a{frDcU&+yWO zr{7(v>Q@N;TTWjEko8eH*bnS$DgTxYr)K}55HTE7+-URr`O%8wHGJ_i^jj_JCY4a~&C-KXsZm>oHr-yAsJ}ZyZ)VI*kI2*F!R4&*R_4Ca^fZ4!0L@KEc zQ3Tlg+&kinUp{d3vGo64FOs*St@sKZ%R6sxj_mEa%-qjP>4`rl`u_x&p?vDtD%NA& z@LT$P){bAjPL-@%=9mC;oS6GE(;ml#50Uw-V2j7mzbp8iYZ%G1Y}-+?8v|^P=g3a3 zD=NLI01V~|43{K1wy(wtaukRVZ=-9jJ6Jt7s4S=_^N$~X^%Wqrm{o^!QXc>LC;*c9 zJv^=LzlHc&m(SAttf-%QoQtUon04(j528Q%z&6++j?5Yz)Y001Oy(cuc*#8eJOn5m zFuRK`zwhW_=CQ+R&0gvKyrG!x2M>QsnPkTcH`EpdRjx#1;aDJZ*HE4fy46{k#iU874r z4mDI|UEn~5nP$ihdk_enOG%&$l_ivZgSxQFw*QjsDuip+f9lr|f9JS!&0zqf{gWKH^=gDyL{oCDC6i085rBD&OJDXn#jTliNZ9z(aBnx~)v8~?CU11GU^v=x5p^;!ux=vm>y`74 zX_pIpLye5g9s2#fWn~1v@v-4ulG{3Z#lN1U55Bw`GqvZF(RcFZG}lEsKMnVd|D|=< zXL~!V_GWlHL36`TwWIDvMQ$ziCV`!DZ`m&kPwZl|v+C=&|GKhH-aJOScA)){M(orM zS=zxtH-3;*Zl0xOY__C7XL}WIv_7hL|8h0!&_1%;<6T3RF88jcsspL2MC>%T zHQU?Awif?o74-yDV(N0c>{Hot(zq+tqa$GGK#F(7ZwT}Sfhmzh=;pM)-T3M)*_WLY zH>C_b$z!L{QYPLy<+Z!2>k;{CEuBdLXLdGr9G}_Q9)HFSkM9DTglgHdwvjLjHHyfG z3!5w78rR(0qFc$VBUdtwUk1C4fB7UUDQx!ITOTi8m<|~^vqx%w6%SMv{q!v;8FpU&z(w5&7z}*@?re zTig0rbye@(Mk{xBu=947;j^VATi4z_8#e!&)&6Ni< do not edit by hand +// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +#include + +using namespace Rcpp; + +#ifdef RCPP_USE_GLOBAL_ROSTREAM +Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); +Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); +#endif + +// association_pmt +NumericVector association_pmt(NumericVector x, NumericVector y, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_association_pmt(SEXP xSEXP, SEXP ySEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); + Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(association_pmt(x, y, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// ksample_pmt +NumericVector ksample_pmt(NumericVector data, IntegerVector group, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_ksample_pmt(SEXP dataSEXP, SEXP groupSEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericVector >::type data(dataSEXP); + Rcpp::traits::input_parameter< IntegerVector >::type group(groupSEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(ksample_pmt(data, group, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// multicomp_pmt +NumericMatrix multicomp_pmt(IntegerVector group_i, IntegerVector group_j, NumericVector data, IntegerVector group, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_multicomp_pmt(SEXP group_iSEXP, SEXP group_jSEXP, SEXP dataSEXP, SEXP groupSEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< IntegerVector >::type group_i(group_iSEXP); + Rcpp::traits::input_parameter< IntegerVector >::type group_j(group_jSEXP); + Rcpp::traits::input_parameter< NumericVector >::type data(dataSEXP); + Rcpp::traits::input_parameter< IntegerVector >::type group(groupSEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(multicomp_pmt(group_i, group_j, data, group, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// paired_pmt +NumericVector paired_pmt(int n, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_paired_pmt(SEXP nSEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< int >::type n(nSEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(paired_pmt(n, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// rcbd_pmt +NumericVector rcbd_pmt(NumericMatrix data, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_rcbd_pmt(SEXP dataSEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericMatrix >::type data(dataSEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(rcbd_pmt(data, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// table_pmt +NumericVector table_pmt(IntegerVector row_loc, IntegerVector col_loc, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_table_pmt(SEXP row_locSEXP, SEXP col_locSEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< IntegerVector >::type row_loc(row_locSEXP); + Rcpp::traits::input_parameter< IntegerVector >::type col_loc(col_locSEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(table_pmt(row_loc, col_loc, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} +// twosample_pmt +NumericVector twosample_pmt(int n_1, int n_2, NumericVector c_xy, Function statistic_func, int n_permu); +RcppExport SEXP _LearnNonparam_twosample_pmt(SEXP n_1SEXP, SEXP n_2SEXP, SEXP c_xySEXP, SEXP statistic_funcSEXP, SEXP n_permuSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< int >::type n_1(n_1SEXP); + Rcpp::traits::input_parameter< int >::type n_2(n_2SEXP); + Rcpp::traits::input_parameter< NumericVector >::type c_xy(c_xySEXP); + Rcpp::traits::input_parameter< Function >::type statistic_func(statistic_funcSEXP); + Rcpp::traits::input_parameter< int >::type n_permu(n_permuSEXP); + rcpp_result_gen = Rcpp::wrap(twosample_pmt(n_1, n_2, c_xy, statistic_func, n_permu)); + return rcpp_result_gen; +END_RCPP +} + +static const R_CallMethodDef CallEntries[] = { + {"_LearnNonparam_association_pmt", (DL_FUNC) &_LearnNonparam_association_pmt, 4}, + {"_LearnNonparam_ksample_pmt", (DL_FUNC) &_LearnNonparam_ksample_pmt, 4}, + {"_LearnNonparam_multicomp_pmt", (DL_FUNC) &_LearnNonparam_multicomp_pmt, 6}, + {"_LearnNonparam_paired_pmt", (DL_FUNC) &_LearnNonparam_paired_pmt, 3}, + {"_LearnNonparam_rcbd_pmt", (DL_FUNC) &_LearnNonparam_rcbd_pmt, 3}, + {"_LearnNonparam_table_pmt", (DL_FUNC) &_LearnNonparam_table_pmt, 4}, + {"_LearnNonparam_twosample_pmt", (DL_FUNC) &_LearnNonparam_twosample_pmt, 5}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_LearnNonparam(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff --git a/src/association_pmt.cpp b/src/association_pmt.cpp new file mode 100644 index 00000000..2c590a84 --- /dev/null +++ b/src/association_pmt.cpp @@ -0,0 +1,56 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +inline void association_do( + int i, + NumericVector x, + NumericVector y, + Function statistic_func, + NumericVector statistic_permu, + RObject bar) +{ + statistic_permu[i] = as(statistic_func(x, y)); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector association_pmt( + NumericVector x, + NumericVector y, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = n_permutation(y); + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + if (n_permu == 0) { + int i = 0; + do { + association_do(i, x, y, statistic_func, statistic_permu, bar); + i++; + } while (std::next_permutation(y.begin(), y.end())); + } else { + for (int i = 0; i < total; i++) { + random_shuffle(y); + association_do(i, x, y, statistic_func, statistic_permu, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/ksample_pmt.cpp b/src/ksample_pmt.cpp new file mode 100644 index 00000000..0fe3487b --- /dev/null +++ b/src/ksample_pmt.cpp @@ -0,0 +1,56 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +inline void ksample_do( + int i, + NumericVector data, + IntegerVector group, + Function statistic_func, + NumericVector statistic_permu, + RObject bar) +{ + statistic_permu[i] = as(statistic_func(data, group)); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector ksample_pmt( + NumericVector data, + IntegerVector group, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = n_permutation(group); + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + if (n_permu == 0) { + int i = 0; + do { + ksample_do(i, data, group, statistic_func, statistic_permu, bar); + i++; + } while (std::next_permutation(group.begin(), group.end())); + } else { + for (int i = 0; i < total; i++) { + random_shuffle(group); + ksample_do(i, data, group, statistic_func, statistic_permu, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/multicomp_pmt.cpp b/src/multicomp_pmt.cpp new file mode 100644 index 00000000..cb540f02 --- /dev/null +++ b/src/multicomp_pmt.cpp @@ -0,0 +1,71 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +inline void multicomp_do( + int i, int n, int n_pair, + IntegerVector group_i, + IntegerVector group_j, + NumericVector data, + IntegerVector group, + Function statistic_func, + NumericMatrix statistic_permu, + List split, RObject bar) +{ + for (int j = 0; j < n; j++) { + split[j] = data[group == j]; + } + + for (int k = 0; k < n_pair; k++) { + statistic_permu(k, i) = as(statistic_func(split[group_i[k]], split[group_j[k]], data, group)); + } + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericMatrix multicomp_pmt( + IntegerVector group_i, + IntegerVector group_j, + NumericVector data, + IntegerVector group, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = n_permutation(group); + } else { + total = n_permu; + } + + int n_pair = group_i.size(); + + NumericMatrix statistic_permu(n_pair, total); + RObject bar = cli_progress_bar(total, NULL); + + int n = *std::max_element(group.begin(), group.end()) + 1; + List split(n); + + if (n_permu == 0) { + int i = 0; + do { + multicomp_do(i, n, n_pair, group_i, group_j, data, group, statistic_func, statistic_permu, split, bar); + i++; + } while (std::next_permutation(group.begin(), group.end())); + } else { + for (int i = 0; i < total; i++) { + random_shuffle(group); + multicomp_do(i, n, n_pair, group_i, group_j, data, group, statistic_func, statistic_permu, split, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/paired_pmt.cpp b/src/paired_pmt.cpp new file mode 100644 index 00000000..3a12cfbe --- /dev/null +++ b/src/paired_pmt.cpp @@ -0,0 +1,59 @@ +#include "utils.h" +#include +#include + +using namespace Rcpp; + +inline void paired_do( + int i, + Function statistic_func, + NumericVector statistic_permu, + LogicalVector swapped, RObject bar) +{ + statistic_permu[i] = as(statistic_func(swapped)); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector paired_pmt( + int n, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = (1 << n); + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + LogicalVector swapped(n); + + if (n_permu == 0) { + for (int i = 0; i < total; i++) { + for (int j = 0; j < n; j++) { + swapped[j] = ((i & (1 << j)) != 0); + } + paired_do(i, statistic_func, statistic_permu, swapped, bar); + } + } else { + int r_int; + for (int i = 0; i < total; i++) { + r_int = rand_int(total); + for (int j = 0; j < n; j++) { + swapped[j] = ((r_int & (1 << j)) != 0); + } + paired_do(i, statistic_func, statistic_permu, swapped, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} \ No newline at end of file diff --git a/src/rcbd_pmt.cpp b/src/rcbd_pmt.cpp new file mode 100644 index 00000000..0baf248e --- /dev/null +++ b/src/rcbd_pmt.cpp @@ -0,0 +1,69 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +inline void rcbd_do( + int i, + NumericMatrix data, + Function statistic_func, + NumericVector statistic_permu, + RObject bar) +{ + statistic_permu[i] = as(statistic_func(data)); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector rcbd_pmt( + NumericMatrix data, + Function statistic_func, + int n_permu) +{ + int n_col = data.ncol(); + + int total = 1; + if (n_permu == 0) { + for (int k = 0; k < n_col; k++) { + total *= n_permutation(data.column(k)); + } + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + if (n_permu == 0) { + int i = 0; + int j = 0; + while (j < n_col) { + if (j == 0) { + rcbd_do(i, data, statistic_func, statistic_permu, bar); + i++; + } + + if (std::next_permutation(data.column(j).begin(), data.column(j).end())) { + j = 0; + } else { + j++; + } + } + } else { + for (int i = 0; i < total; i++) { + for (int j = 0; j < n_col; j++) { + random_shuffle(data.column(j)); + } + rcbd_do(i, data, statistic_func, statistic_permu, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/table_pmt.cpp b/src/table_pmt.cpp new file mode 100644 index 00000000..b7ad8e03 --- /dev/null +++ b/src/table_pmt.cpp @@ -0,0 +1,65 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +inline void table_do( + int i, int n, + IntegerVector row_loc, + IntegerVector col_loc, + Function statistic_func, + NumericVector statistic_permu, + IntegerMatrix data, RObject bar) +{ + std::fill(data.begin(), data.end(), 0); + + for (int j = 0; j < n; j++) { + data(row_loc[j], col_loc[j])++; + } + + statistic_permu[i] = as(statistic_func(data)); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector table_pmt( + IntegerVector row_loc, + IntegerVector col_loc, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = n_permutation(row_loc); + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + int n = row_loc.size(); + IntegerMatrix data(row_loc[n - 1] + 1, col_loc[n - 1] + 1); + + if (n_permu == 0) { + int i = 0; + do { + table_do(i, n, row_loc, col_loc, statistic_func, statistic_permu, data, bar); + i++; + } while (std::next_permutation(row_loc.begin(), row_loc.end())); + } else { + for (int i = 0; i < total; i++) { + random_shuffle(row_loc); + table_do(i, n, row_loc, col_loc, statistic_func, statistic_permu, data, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/twosample_pmt.cpp b/src/twosample_pmt.cpp new file mode 100644 index 00000000..bece3f47 --- /dev/null +++ b/src/twosample_pmt.cpp @@ -0,0 +1,72 @@ +#include "utils.h" +#include +#include +#include + +using namespace Rcpp; + +int n_combination(int n, int k) +{ + double C = 1; + + for (int i = 1; i <= k; i++) { + C *= (i + n - k); + C /= i; + } + + return (int)C; +} + +inline void twosample_do( + int i, + NumericVector c_xy, + Function statistic_func, + NumericVector statistic_permu, + LogicalVector where_x, RObject bar) +{ + statistic_permu[i] = as(statistic_func(c_xy[where_x], c_xy[!where_x])); + + if (CLI_SHOULD_TICK) { + cli_progress_set(bar, i); + } +} + +// [[Rcpp::export]] +NumericVector twosample_pmt( + int n_1, int n_2, + NumericVector c_xy, + Function statistic_func, + int n_permu) +{ + int total; + if (n_permu == 0) { + total = n_combination(n_1 + n_2, std::min(n_1, n_2)); + } else { + total = n_permu; + } + + NumericVector statistic_permu(total); + RObject bar = cli_progress_bar(total, NULL); + + LogicalVector where_x(n_1 + n_2, FALSE); + for (int k = 0; k < n_1; k++) { + where_x[k] = TRUE; + } + + if (n_permu == 0) { + int i = 0; + do { + twosample_do(i, c_xy, statistic_func, statistic_permu, where_x, bar); + i++; + } while (std::prev_permutation(where_x.begin(), where_x.end())); + } else { + for (int i = 0; i < total; i++) { + random_shuffle(c_xy); + twosample_do(i, c_xy, statistic_func, statistic_permu, where_x, bar); + } + } + + cli_progress_done(bar); + + return statistic_permu; +} diff --git a/src/utils.h b/src/utils.h new file mode 100644 index 00000000..5fa493ad --- /dev/null +++ b/src/utils.h @@ -0,0 +1,42 @@ +#pragma once + +#include +#include + +inline int rand_int(const int n) +{ + return floor(unif_rand() * n); +} + +template +void random_shuffle(T v) +{ + int j; + int n = v.size(); + for (int i = 0; i < n - 1; i++) { + j = i + rand_int(n - i); + std::swap(v[i], v[j]); + } +} + +template +int n_permutation(T v) +{ + double A = 1; + + int n_i = 0; + int n = v.size(); + double current = v[0]; + for (int i = 0; i < n; i++) { + A *= (i + 1); + if (v[i] == current) { + n_i++; + A /= n_i; + } else { + n_i = 1; + } + current = v[i]; + } + + return (int)A; +} diff --git a/vignettes/examples.Rmd b/vignettes/examples.Rmd index 24da9161..e5fb9aa3 100644 --- a/vignettes/examples.Rmd +++ b/vignettes/examples.Rmd @@ -127,7 +127,7 @@ t$p_value # install.packages("microbenchmark") microbenchmark::microbenchmark( - use_all = {t$n_permu <- NULL}, + use_all = {t$n_permu <- 0}, use_1000 = {t$n_permu <- 1000} ) ```