diff --git a/DESCRIPTION b/DESCRIPTION
index 4c1ca88a..f793f117 100644
--- 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
index 1eb6e526..912462c5 100644
--- 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
index 4bda6c47..60fc3675 100644
--- 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
index 2d205e63..38f54046 100644
--- 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)
}
)
)
\ No newline at end of file
diff --git a/R/PairedComparison.R b/R/PairedComparison.R
deleted file mode 100644
index 1dd67e51..00000000
--- a/R/PairedComparison.R
+++ /dev/null
@@ -1,52 +0,0 @@
-#' @title `r PairedComparison$private_fields$.name`
-#'
-#' @description Performs two sample paired comparison on data vectors.
-#'
-#' @aliases paired.comparison
-#'
-#' @export
-#'
-#' @importFrom R6 R6Class
-
-
-PairedComparison <- R6Class(
- classname = "PairedComparison",
- inherit = TwoSamplePairedTest,
- cloneable = FALSE,
- public = list(
- #' @description Create a new `PairedComparison` object.
- #'
- #' @template init_params
- #'
- #' @return A `PairedComparison` object.
- initialize = function(
- type = c("permu", "approx"),
- alternative = c("two_sided", "less", "greater"), n_permu = NULL
- ) {
- private$.type <- match.arg(type)
-
- super$initialize(alternative = match.arg(alternative), n_permu = n_permu)
- }
- ),
- private = list(
- .name = "Paired Comparison",
-
- .diff = NULL,
-
- .define_statistic = function() {
- private$.diff <- private$.data$x - private$.data$y
-
- private$.statistic_func <- function(swapped, diff = private$.diff) {
- mean(diff * (2 * swapped - 1))
- }
- },
-
- .calculate_p = function() {
- z <- private$.statistic / sqrt(
- sum(private$.diff^2) / length(private$.diff)^2
- )
-
- private$.p_value <- get_p_continous(z, "norm", private$.side)
- }
- )
-)
\ No newline at end of file
diff --git a/R/PermuTest.R b/R/PermuTest.R
index 535548f9..99421596 100644
--- 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
index 167b5968..bcc8ea94 100644
--- 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)
)
diff --git a/R/RCBD.R b/R/RCBD.R
index 8e31826a..29ce8327 100644
--- a/R/RCBD.R
+++ b/R/RCBD.R
@@ -6,7 +6,7 @@
#' @export
#'
#' @importFrom R6 R6Class
-#' @importFrom arrangements permutations
+#' @importFrom RcppAlgos permuteGeneral
RCBD <- R6Class(
@@ -28,34 +28,13 @@ RCBD <- R6Class(
private$.raw_data <- data
},
- .permute = function() {
- k <- nrow(private$.data)
- b <- ncol(private$.data)
-
- private$.data_permu <- if (is.null(private$.n_permu)) {
- lapply(
- X = permutations(
- n = factorial(k), k = b, replace = TRUE, layout = "list"
- ),
- FUN = function(index, permus) {
- do.call(
- data.frame, .mapply(
- dots = list(permus, index), MoreArgs = NULL,
- FUN = function(permu, i) permu[[i]]
- )
- )
- }, permus = lapply(private$.data, permutations, layout = "list")
- )
- } else {
- lapply(
- X = seq_len(private$.n_permu),
- FUN = function(data, ...) {
- do.call(
- data.frame, lapply(data, function(x) x[sample.int(k)])
- )
- }, data = private$.data
+ .calculate_score = function() {
+ private$.data <- do.call(
+ data.frame, lapply(
+ X = private$.data, FUN = get_score,
+ method = private$.scoring, n = nrow(private$.data)
)
- }
+ )
},
.calculate_statistic = function() {
@@ -63,17 +42,26 @@ RCBD <- R6Class(
},
.calculate_statistic_permu = function() {
- private$.statistic_permu <- vapply(
- private$.data_permu, private$.statistic_func, numeric(1)
- )
- },
+ k <- nrow(private$.data)
+ b <- ncol(private$.data)
- .calculate_score = function() {
- private$.data <- do.call(
- data.frame, lapply(
- X = private$.data, FUN = get_score,
- method = private$.scoring, n = nrow(private$.data)
- )
+ private$.statistic_permu <- get_arrangement(
+ "permute", n_sample = private$.n_permu,
+ v = seq_len(factorial(k)), m = b, replace = TRUE,
+ func = function(index) {
+ statistic_func(do.call(
+ data.frame, .mapply(
+ dots = list(data, index),
+ FUN = function(data_i, i) {
+ as.numeric(permuteGeneral(
+ v = data_i, lower = i, upper = i
+ ))
+ }, MoreArgs = NULL
+ )
+ ))
+ }, func_value = numeric(1),
+ statistic_func = private$.statistic_func,
+ data = private$.data
)
}
)
diff --git a/R/SignedDiff.R b/R/SignedDiff.R
new file mode 100644
index 00000000..4c198439
--- /dev/null
+++ b/R/SignedDiff.R
@@ -0,0 +1,79 @@
+#' @title `r SignedDiff$private_fields$.name`
+#'
+#' @description Performs two sample signed score test on data vectors.
+#'
+#' @aliases paired.signeddiff
+#'
+#' @export
+#'
+#' @importFrom R6 R6Class
+
+
+SignedDiff <- R6Class(
+ classname = "SignedDiff",
+ inherit = TwoSamplePairedTest,
+ cloneable = FALSE,
+ public = list(
+ #' @description Create a new `SignedDiff` object.
+ #'
+ #' @template init_params
+ #' @param scoring a character string specifying which scoring system to be used on the absolute differences.
+ #' @param method a character string specifying the method of ranking data in computing adjusted signed ranks for tied data, must be one of `"with_zeros"` (default) or `"ignore"`. Note that the data fed will be modified when this parameter is set to `"ignore"`.
+ #' @param correct a logical indicating whether to apply continuity correction in the normal approximation for the p-value when `scoring` is set to `"rank"`.
+ #'
+ #' @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")
+ ) {
+ private$.correct <- correct
+ private$.type <- match.arg(type)
+ private$.method <- match.arg(method)
+
+ super$initialize(alternative = match.arg(alternative), n_permu = n_permu, scoring = match.arg(scoring))
+ }
+ ),
+ private = list(
+ .name = "Paired Comparison Based on Signed Differences",
+
+ .correct = NULL,
+
+ .abs_diff = NULL,
+
+ .define_statistic = function() {
+ diff <- private$.data$x - private$.data$y
+
+ if (private$.method == "ignore") {
+ private$.data <- private$.data[diff != 0, ]
+ diff <- diff[diff != 0]
+ }
+
+ private$.abs_diff <- abs(diff)
+ if (private$.scoring != "none") {
+ private$.abs_diff <- get_score(
+ private$.abs_diff, method = private$.scoring
+ )
+ }
+
+ private$.statistic_func <- function(
+ swapped, diff_positive = (diff > 0), abs_diff = private$.abs_diff
+ ) {
+ sum(abs_diff[diff_positive != swapped])
+ }
+ },
+
+ .calculate_p = function() {
+ n <- nrow(private$.data)
+
+ z <- private$.statistic - sum(private$.abs_diff) / 2
+ correction <- if (private$.scoring == "rank" & private$.correct) {
+ switch(private$.side, lr = sign(z) * 0.5, r = 0.5, l = -0.5)
+ } else 0
+ z <- (z - correction) / sqrt(
+ sum(private$.abs_diff^2) / 4
+ )
+
+ private$.p_value <- get_p_continous(z, "norm", private$.side)
+ }
+ )
+)
\ No newline at end of file
diff --git a/R/SignedScore.R b/R/SignedScore.R
deleted file mode 100644
index a72b5327..00000000
--- a/R/SignedScore.R
+++ /dev/null
@@ -1,74 +0,0 @@
-#' @title `r SignedScore$private_fields$.name`
-#'
-#' @description Performs two sample signed score test on data vectors.
-#'
-#' @aliases paired.signedscore
-#'
-#' @export
-#'
-#' @importFrom R6 R6Class
-
-
-SignedScore <- R6Class(
- classname = "SignedScore",
- inherit = TwoSamplePairedTest,
- cloneable = FALSE,
- public = list(
- #' @description Create a new `SignedScore` object.
- #'
- #' @template init_params
- #' @param correct a logical indicating whether to apply continuity correction in the normal approximation for the p-value when `scoring` is set to `"rank"`.
- #' @param ranking_method a character string specifying the method of ranking data in computing adjusted signed ranks for tied data, must be one of `"with_zeros"` (default) or `"ignore"`. Note that the data fed will be modified when this parameter is set to `"ignore"`.
- #'
- #' @return A `SignedScore` object.
- initialize = function(
- type = c("permu", "approx"), correct = TRUE, ranking_method = c("with_zeros", "ignore"),
- alternative = c("two_sided", "less", "greater"), n_permu = NULL, scoring = c("rank", "vw", "expon")
- ) {
- private$.correct <- correct
- private$.type <- match.arg(type)
- private$.ranking_method <- match.arg(ranking_method)
-
- super$initialize(alternative = match.arg(alternative), n_permu = n_permu, scoring = match.arg(scoring))
- }
- ),
- private = list(
- .name = "Signed Score Test",
-
- .correct = NULL,
- .ranking_method = NULL,
-
- .score = NULL,
-
- .define_statistic = function() {
- diff <- private$.data$x - private$.data$y
-
- if (private$.ranking_method == "ignore") {
- private$.data <- private$.data[diff != 0, ]
- diff <- diff[diff != 0]
- }
-
- private$.score <- get_score(abs(diff), method = private$.scoring)
-
- private$.statistic_func <- function(
- swapped, diff_positive = (diff > 0), score = private$.score
- ) {
- sum(score[diff_positive != swapped])
- }
- },
-
- .calculate_p = function() {
- n <- nrow(private$.data)
-
- z <- private$.statistic - 1 / 2 * sum(private$.score)
- correction <- if (private$.correct) {
- switch(private$.side, lr = sign(z) * 0.5, r = 0.5, l = -0.5)
- } else 0
- z <- (z - correction) / sqrt(
- 1 / 4 * sum(private$.score^2)
- )
-
- private$.p_value <- get_p_continous(z, "norm", private$.side)
- }
- )
-)
\ No newline at end of file
diff --git a/R/TwoSampleAssociationTest.R b/R/TwoSampleAssociationTest.R
index f8cdb980..cee5c5cd 100644
--- a/R/TwoSampleAssociationTest.R
+++ b/R/TwoSampleAssociationTest.R
@@ -6,7 +6,6 @@
#' @export
#'
#' @importFrom R6 R6Class
-#' @importFrom arrangements permutations
TwoSampleAssociationTest <- R6Class(
@@ -26,15 +25,15 @@ TwoSampleAssociationTest <- R6Class(
.calculate_score = function() {},
- .permute = function() {
- private$.data_permu <- lapply(
- X = permutations(
- v = private$.data$y,
- nsample = private$.n_permu, layout = "list"
- ),
- FUN = function(x, y) {
- data.frame(x = x, y = y)
- }, x = private$.data$x
+ .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),
+ statistic_func = private$.statistic_func,
+ x = private$.data$x
)
}
)
diff --git a/R/TwoSamplePairedTest.R b/R/TwoSamplePairedTest.R
index db6b4cff..b1b6fc06 100644
--- a/R/TwoSamplePairedTest.R
+++ b/R/TwoSamplePairedTest.R
@@ -6,7 +6,6 @@
#' @export
#'
#' @importFrom R6 R6Class
-#' @importFrom arrangements permutations
TwoSamplePairedTest <- R6Class(
@@ -16,9 +15,6 @@ TwoSamplePairedTest <- R6Class(
private = list(
.name = "Paired Two Sample Permutation Test",
- .swapped_permu = NULL,
- .use_swapped = TRUE,
-
.check = function() {},
.feed = function(...) {
@@ -29,42 +25,18 @@ TwoSamplePairedTest <- R6Class(
.calculate_score = function() {},
- .permute = function() {
- private$.swapped_permu <- permutations(
- v = c(TRUE, FALSE), k = nrow(private$.data), replace = TRUE,
- nsample = private$.n_permu, layout = "list"
- )
-
- private$.data_permu <- lapply(
- X = private$.swapped_permu,
- FUN = function(swapped, x, y) {
- data.frame(
- x = `[<-`(x, swapped, y[swapped]),
- y = `[<-`(y, swapped, x[swapped])
- )
- }, x = private$.data$x, y = private$.data$y
- )
- },
-
.calculate_statistic = function() {
- if (private$.use_swapped) {
- private$.statistic <- private$.statistic_func(
- swapped = rep_len(FALSE, nrow(private$.data))
- )
- } else {
- super$.calculate_statistic()
- }
+ private$.statistic <- private$.statistic_func(
+ swapped = rep_len(FALSE, nrow(private$.data))
+ )
},
.calculate_statistic_permu = function() {
- if (private$.use_swapped) {
- private$.statistic_permu <- vapply(
- X = private$.swapped_permu,
- FUN = private$.statistic_func, FUN.VALUE = numeric(1)
- )
- } else {
- super$.calculate_statistic_permu()
- }
+ 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)
+ )
}
)
)
\ No newline at end of file
diff --git a/R/TwoSampleTest.R b/R/TwoSampleTest.R
index 23fa1290..298c0aca 100644
--- a/R/TwoSampleTest.R
+++ b/R/TwoSampleTest.R
@@ -6,7 +6,6 @@
#' @export
#'
#' @importFrom R6 R6Class
-#' @importFrom arrangements combinations
TwoSampleTest <- R6Class(
@@ -22,18 +21,11 @@ TwoSampleTest <- R6Class(
private$.raw_data <- setNames(get_data_from(...), c("x", "y"))
},
- .permute = function() {
- c_xy <- c(private$.data$x, private$.data$y)
-
- private$.data_permu <- lapply(
- X = combinations(
- n = length(c_xy), k = length(private$.data$x),
- nsample = private$.n_permu, layout = "list"
- ),
- FUN = function(index, c_xy) {
- list(x = c_xy[index], y = c_xy[-index])
- }, c_xy = c_xy
- )
+ .calculate_score = function() {
+ scores <- get_score(c(private$.data$x, private$.data$y), method = private$.scoring)
+
+ x_index <- seq_along(private$.data$x)
+ private$.data <- list(x = scores[x_index], y = scores[-x_index])
},
.calculate_statistic = function() {
@@ -43,19 +35,18 @@ TwoSampleTest <- R6Class(
},
.calculate_statistic_permu = function() {
- private$.statistic_permu <- vapply(
- X = private$.data_permu, FUN.VALUE = numeric(1),
- FUN = function(data, statistic_func) {
- statistic_func(data$x, data$y)
- }, statistic_func = private$.statistic_func
+ m <- length(private$.data$x)
+ n <- length(private$.data$y)
+
+ private$.statistic_permu <- get_arrangement(
+ "combo", n_sample = private$.n_permu,
+ v = seq_len(m + n), m = m,
+ func = function(index) {
+ statistic_func(c_xy[index], c_xy[-index])
+ }, func_value = numeric(1),
+ statistic_func = private$.statistic_func,
+ c_xy = c(private$.data$x, private$.data$y)
)
- },
-
- .calculate_score = function() {
- scores <- get_score(c(private$.data$x, private$.data$y), method = private$.scoring)
-
- x_index <- seq_along(private$.data$x)
- private$.data <- list(x = scores[x_index], y = scores[-x_index])
}
)
)
\ No newline at end of file
diff --git a/R/auxiliary_funcs.R b/R/auxiliary_funcs.R
index 42942ab9..1ebb5fe3 100644
--- a/R/auxiliary_funcs.R
+++ b/R/auxiliary_funcs.R
@@ -25,6 +25,48 @@ get_score <- function(x, method, n = length(x)) {
)
}
+# for .calculate_statistic_permu
+
+#' @importFrom RcppAlgos comboGeneral comboSample permuteGeneral permuteSample
+get_arrangement <- function(
+ which = c("combo", "permute", "gpermute"), n_sample = NULL,
+ v = NULL, m = length(v), replace = FALSE,
+ func = NULL, func_value = NULL,
+ progress = getOption("pmt_progress"), ...
+) {
+ list2env(list(...), envir = environment(func))
+
+ args <- list(v = v, m = m, repetition = replace)
+
+ if (!isFALSE(progress)) {
+ progress <- interactive()
+ }
+ if (progress) {
+ if (is.null(count <- n_sample)) {
+ count <- do.call(paste0(which, "Count"), args)
+ }
+ assign(
+ "pb", ProgressBar$new(count),
+ envir = environment(func)
+ )
+ body(func) <- as.call(c(
+ as.name("{"),
+ expression(on.exit(pb$update())),
+ body(func)
+ ))
+ }
+
+ args <- c(args, list(FUN = func, FUN.VALUE = func_value))
+
+ if (is.null(n_sample)) {
+ do.call(paste0(which, "General"), args)
+ } else {
+ args$n <- n_sample
+ args$seed <- getOption("pmt_seed")
+ do.call(paste0(which, "Sample"), args)
+ }
+}
+
# for .calculate_p
get_p_continous <- function(x, dist, side, ...) {
diff --git a/R/pmt.R b/R/pmt.R
index 8cfae13e..711acc10 100644
--- a/R/pmt.R
+++ b/R/pmt.R
@@ -24,9 +24,8 @@ tests <- list(
multicomp.t = MultiCompT,
multicomp.tukey = TukeyHSD,
- paired.comparison = PairedComparison,
paired.sign = Sign,
- paired.signedscore = SignedScore,
+ paired.signeddiff = SignedDiff,
rcbd.anova = RCBDANOVA,
rcbd.friedman = Friedman,
diff --git a/README.Rmd b/README.Rmd
index 948f531a..717d911b 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -28,7 +28,7 @@ knitr::opts_chunk$set(
This package implements most of the tests in chapters 1-5 of [@Higgins2003](#references).
-It uses [R6](https://cran.r-project.org/package=R6) for clean OO-design and [arrangements](https://cran.r-project.org/package=arrangements) for fast generation of permutations, as well as [ggplot2](https://cran.r-project.org/package=ggplot2) to draw pretty graphs.
+It uses [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) to draw pretty graphs.
Examples in the book can be found [here](https://qddyy.github.io/LearnNonparam/articles/examples).
diff --git a/README.md b/README.md
index 4f5a958a..305174a8 100644
--- a/README.md
+++ b/README.md
@@ -17,8 +17,8 @@ This package implements most of the tests in chapters 1-5 of [Higgins
(2003)](#references).
It uses [R6](https://cran.r-project.org/package=R6) for clean OO-design
-and [arrangements](https://cran.r-project.org/package=arrangements) for
-fast generation of permutations, as well as
+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) to draw pretty
graphs.
@@ -63,17 +63,17 @@ library(LearnNonparam)
``` r
t$p_value
- #> [1] 0.006062
+ #> [1] 0.040509
t$print()
#>
#> Two Sample Wilcoxon Test
#>
- #> scoring: rank type: permu(1e+06) method: default
- #> statistic = 502, p-value = 0.006062
+ #> scoring: rank type: permu(1000000) method: default
+ #> statistic = 475, p-value = 0.040509
#> alternative hypothesis: greater
- #> estimate: 0.8774262
- #> 95 percent confidence interval: 0.1904005 1.5434681
+ #> estimate: 0.6022225
+ #> 95 percent confidence interval: -0.04779505 1.30040094
t$plot(binwidth = 1)
```
@@ -86,7 +86,7 @@ library(LearnNonparam)
t$type <- "approx"
t$p_value
- #> [1] 0.006660258
+ #> [1] 0.04051587
```
There is also support for chaining method calls, which means that you
@@ -130,9 +130,8 @@ t <- pmt(...)$feed(...)$print(...)$plot(...)
| ksample.jt | JonckheereTerpstra | Jonckheere-Terpstra Test |
| multicomp.t | MultiCompT | Multiple Comparison Based on t Statistic |
| multicomp.tukey | TukeyHSD | Tukey’s HSD |
- | paired.comparison | PairedComparison | Paired Comparison |
| paired.sign | Sign | Sign Test |
- | paired.signedscore | SignedScore | Signed Score Test |
+ | paired.signeddiff | SignedDiff | Paired Comparison Based on Signed Differences |
| rcbd.anova | RCBDANOVA | ANOVA for Randomized Complete Block Design |
| rcbd.friedman | Friedman | Friedman Test |
| rcbd.page | Page | Page Test |
diff --git a/man/PairedComparison.Rd b/man/PairedComparison.Rd
deleted file mode 100644
index d1e5a5b3..00000000
--- a/man/PairedComparison.Rd
+++ /dev/null
@@ -1,56 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/PairedComparison.R
-\name{PairedComparison}
-\alias{PairedComparison}
-\alias{paired.comparison}
-\title{Paired Comparison}
-\description{
-Performs two sample paired comparison on data vectors.
-}
-\section{Super classes}{
-\code{\link[LearnNonparam:PermuTest]{LearnNonparam::PermuTest}} -> \code{\link[LearnNonparam:TwoSampleTest]{LearnNonparam::TwoSampleTest}} -> \code{\link[LearnNonparam:TwoSamplePairedTest]{LearnNonparam::TwoSamplePairedTest}} -> \code{PairedComparison}
-}
-\section{Methods}{
-\subsection{Public methods}{
-\itemize{
-\item \href{#method-PairedComparison-new}{\code{PairedComparison$new()}}
-}
-}
-\if{html}{\out{
-Inherited methods
-
-