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 - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PairedComparison-new}{}}} -\subsection{Method \code{new()}}{ -Create a new \code{PairedComparison} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PairedComparison$new( - type = c("permu", "approx"), - alternative = c("two_sided", "less", "greater"), - n_permu = NULL -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{type}}{a character string specifying the way to calculate the p-value.} - -\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.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -A \code{PairedComparison} object. -} -} -} diff --git a/man/PermuTest.Rd b/man/PermuTest.Rd index 4788b69c..28c9e12f 100644 --- a/man/PermuTest.Rd +++ b/man/PermuTest.Rd @@ -25,12 +25,8 @@ This is the abstract base class for permutation test objects. Note that it is no \item{\code{data}}{Data fed into the object.} -\item{\code{data_permu}}{All permutations used.} - \item{\code{statistic}}{The test statistic.} -\item{\code{statistic_permu}}{Test statistics calculated on permutations.} - \item{\code{p_value}}{The p-value.} \item{\code{estimate}}{The estimated parameter.} diff --git a/man/SignedScore.Rd b/man/SignedDiff.Rd similarity index 69% rename from man/SignedScore.Rd rename to man/SignedDiff.Rd index 36675051..35c967c7 100644 --- a/man/SignedScore.Rd +++ b/man/SignedDiff.Rd @@ -1,19 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SignedScore.R -\name{SignedScore} -\alias{SignedScore} -\alias{paired.signedscore} -\title{Signed Score Test} +% Please edit documentation in R/SignedDiff.R +\name{SignedDiff} +\alias{SignedDiff} +\alias{paired.signeddiff} +\title{Paired Comparison Based on Signed Differences} \description{ Performs two sample signed score test 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{SignedScore} +\code{\link[LearnNonparam:PermuTest]{LearnNonparam::PermuTest}} -> \code{\link[LearnNonparam:TwoSampleTest]{LearnNonparam::TwoSampleTest}} -> \code{\link[LearnNonparam:TwoSamplePairedTest]{LearnNonparam::TwoSamplePairedTest}} -> \code{SignedDiff} } \section{Methods}{ \subsection{Public methods}{ \itemize{ -\item \href{#method-SignedScore-new}{\code{SignedScore$new()}} +\item \href{#method-SignedDiff-new}{\code{SignedDiff$new()}} } } \if{html}{\out{ @@ -26,18 +26,18 @@ Performs two sample signed score test on data vectors. }} \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SignedScore-new}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SignedDiff-new}{}}} \subsection{Method \code{new()}}{ -Create a new \code{SignedScore} object. +Create a new \code{SignedDiff} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SignedScore$new( +\if{html}{\out{
}}\preformatted{SignedDiff$new( type = c("permu", "approx"), + method = c("with_zeros", "ignore"), correct = TRUE, - ranking_method = c("with_zeros", "ignore"), alternative = c("two_sided", "less", "greater"), n_permu = NULL, - scoring = c("rank", "vw", "expon") + scoring = c("none", "rank", "vw", "expon") )}\if{html}{\out{
}} } @@ -46,20 +46,20 @@ Create a new \code{SignedScore} object. \describe{ \item{\code{type}}{a character string specifying the way to calculate the p-value.} -\item{\code{correct}}{a logical indicating whether to apply continuity correction in the normal approximation for the p-value when \code{scoring} is set to \code{"rank"}.} +\item{\code{method}}{a character string specifying the method of ranking data in computing adjusted signed ranks for tied data, must be one of \code{"with_zeros"} (default) or \code{"ignore"}. Note that the data fed will be modified when this parameter is set to \code{"ignore"}.} -\item{\code{ranking_method}}{a character string specifying the method of ranking data in computing adjusted signed ranks for tied data, must be one of \code{"with_zeros"} (default) or \code{"ignore"}. Note that the data fed will be modified when this parameter is set to \code{"ignore"}.} +\item{\code{correct}}{a logical indicating whether to apply continuity correction in the normal approximation for the p-value when \code{scoring} is set to \code{"rank"}.} \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{scoring}}{a character string specifying which scoring system to be used.} +\item{\code{scoring}}{a character string specifying which scoring system to be used on the absolute differences.} } \if{html}{\out{
}} } \subsection{Returns}{ -A \code{SignedScore} object. +A \code{SignedDiff} object. } } } diff --git a/man/figures/README-results-1.svg b/man/figures/README-results-1.svg index f25d2de4..20273936 100644 --- a/man/figures/README-results-1.svg +++ b/man/figures/README-results-1.svg @@ -112,52 +112,52 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -168,409 +168,398 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - - - - + + + + - - - - + + + + - - - - + + + + - - - - - - + + + + + + - - - + + + - - - + + + - - - + + + diff --git a/man/pmt.Rd b/man/pmt.Rd index cd4531be..40141b9d 100644 --- a/man/pmt.Rd +++ b/man/pmt.Rd @@ -7,7 +7,7 @@ \alias{pmts} \title{Syntactic Sugar for Object Construction} \format{ -An object of class \code{list} of length 22. +An object of class \code{list} of length 21. } \usage{ tests diff --git a/vignettes/examples.Rmd b/vignettes/examples.Rmd index cd5bcd5c..7c650873 100644 --- a/vignettes/examples.Rmd +++ b/vignettes/examples.Rmd @@ -210,7 +210,7 @@ t$p_value ```{r} # See ?KolmogorovSmirnov or ?twosample.ks t <- pmt( - "twosample.ks", n_permu = 5000 + "twosample.ks" ) # See ?Table2.8.1 @@ -350,9 +350,10 @@ t$p_value ## Table 4.1.1 ```{r} -# See ?PairedComparison or ?paired.comparison +# See ?SignedDiff or ?paired.signeddiff t <- pmt( - "paired.comparison", alternative = "greater" + "paired.signeddiff", alternative = "greater", + scoring = "none" ) # See ?Table4.1.1 @@ -360,17 +361,15 @@ t$feed(Table4.1.1) t$statistic t$p_value - -t$n_permu <- 4000 -t$p_value ``` -## Table 4.1.3 +## Example 4.1.1 ```{r} -# See ?PairedComparison or ?paired.comparison +# See ?SignedDiff or ?paired.signeddiff t <- pmt( - "paired.comparison", alternative = "two_sided", n_permu = 4000 + "paired.signeddiff", alternative = "two_sided", + scoring = "none", method = "ignore" ) # See ?Table4.1.3 @@ -379,6 +378,9 @@ t$feed(Table4.1.3) t$statistic t$p_value +t$n_permu <- 4000 +t$p_value + t$type <- "approx" t$p_value ``` @@ -386,10 +388,10 @@ t$p_value ## Example 4.2.1 & 4.2.2 ```{r} -# See ?SignedScore or ?paired.signedscore +# See ?SignedDiff or ?paired.signeddiff t <- pmt( - "paired.signedscore", alternative = "greater", - ranking_method = "with_zeros" + "paired.signeddiff", alternative = "greater", + scoring = "rank", method = "with_zeros" ) # See ?Table4.1.1 @@ -398,9 +400,6 @@ t$feed(Table4.1.1) t$statistic t$p_value -t$n_permu <- 4000 -t$p_value - t$type <- "approx" t$p_value ``` @@ -408,10 +407,10 @@ t$p_value ## Table 4.2.3 ```{r} -# See ?SignedScore or ?paired.signedscore +# See ?SignedDiff or ?paired.signeddiff t <- pmt( - "paired.signedscore", alternative = "greater", - ranking_method = "ignore" + "paired.signeddiff", alternative = "greater", + scoring = "rank", method = "ignore" ) t$feed(data.frame( @@ -421,9 +420,6 @@ t$feed(data.frame( t$statistic t$p_value - -t$n_permu <- 4000 -t$p_value ``` ## Example 4.3.1