diff --git a/R/CDF.R b/R/CDF.R index 881dde47..7ff74375 100644 --- a/R/CDF.R +++ b/R/CDF.R @@ -43,9 +43,29 @@ CDF <- R6Class( .lims_for_plot = NULL, + .calculate_extra = function() { + n <- length(private$.data) + sorted <- sort(private$.data) + + F_n <- seq.int(0, n) / n + private$.estimate <- stepfun(sorted, F_n, right = TRUE) + + A <- 1 / sqrt(n) * qnorm(1 - (1 - private$.conf_level) / 2) + delta_n <- A * sqrt(F_n * (1 - F_n)) + private$.ci <- list( + lower = stepfun(sorted, F_n - delta_n, right = TRUE), + upper = stepfun(sorted, F_n + delta_n, right = TRUE) + ) + + private$.lims_for_plot <- list( + x = c(sorted[1], get_last(sorted)), + y = c(min(F_n - delta_n), max(F_n + delta_n)) + ) + }, + .print = function(...) {}, - .plot = function() { + .plot = function(...) { plot( private$.estimate, lty = "solid", xlim = private$.lims_for_plot$x, @@ -57,7 +77,7 @@ CDF <- R6Class( plot(private$.ci$upper, lty = "dashed", add = TRUE) }, - .autoplot = function() { + .autoplot = function(...) { ggplot2::ggplot( data = data.frame( x = private$.data, @@ -85,26 +105,6 @@ CDF <- R6Class( ggplot2::theme( plot.title = ggplot2::element_text(face = "bold", hjust = 0.5) ) - }, - - .calculate_extra = function() { - n <- length(private$.data) - sorted <- sort(private$.data) - - F_n <- seq.int(0, n) / n - private$.estimate <- stepfun(x = sorted, y = F_n, right = TRUE) - - A <- 1 / sqrt(n) * qnorm(1 - (1 - private$.conf_level) / 2) - delta_n <- A * sqrt(F_n * (1 - F_n)) - private$.ci <- list( - lower = stepfun(x = sorted, y = F_n - delta_n, right = TRUE), - upper = stepfun(x = sorted, y = F_n + delta_n, right = TRUE) - ) - - private$.lims_for_plot <- list( - x = c(sorted[1], get_last(sorted)), - y = c(min(F_n - delta_n), max(F_n + delta_n)) - ) } ) ) \ No newline at end of file diff --git a/R/ContingencyTableTest.R b/R/ContingencyTableTest.R index eea79059..0029172e 100644 --- a/R/ContingencyTableTest.R +++ b/R/ContingencyTableTest.R @@ -17,8 +17,8 @@ ContingencyTableTest <- R6Class( .check = function() {}, - .input = function(table) { - private$.raw_data <- as.matrix(table) + .preprocess = function(table) { + private$.data <- unname(do_call(cbind, private$.raw_data)) }, .calculate_statistic = function() { diff --git a/R/KSampleTest.R b/R/KSampleTest.R index 2690beef..404ec7b1 100644 --- a/R/KSampleTest.R +++ b/R/KSampleTest.R @@ -17,10 +17,9 @@ KSampleTest <- R6Class( .check = function() {}, - .input = function(...) { - data <- get_list(...) - - private$.raw_data <- setNames( + .preprocess = function() { + data <- private$.raw_data + private$.data <- setNames( unlist(data, recursive = FALSE, use.names = FALSE), rep.int(seq_along(data), vapply(data, length, integer(1))) ) diff --git a/R/MultipleComparison.R b/R/MultipleComparison.R index df482c8c..06085c9d 100644 --- a/R/MultipleComparison.R +++ b/R/MultipleComparison.R @@ -15,11 +15,63 @@ MultipleComparison <- R6Class( private = list( .name = "Multiple Comparison", - .ij = NULL, + .group_ij = NULL, .multicomp = NULL, .check = function() {}, + .preprocess = function(...) { + super$.preprocess(...) + + k <- as.integer(get_last(names(private$.data))) + private$.group_ij <- list( + i = rep.int(seq_len(k - 1), seq.int(k - 1, 1)), + j = unlist(lapply( + seq.int(2, k), seq.int, to = k + ), recursive = FALSE, use.names = FALSE) + ) + }, + + .calculate_statistic = function() { + 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$.group_ij, MoreArgs = NULL + )) + }, + + .calculate_statistic_permu = function() { + private$.statistic_permu <- multicomp_pmt( + group_i = private$.group_ij$i - 1, + group_j = private$.group_ij$j - 1, + data = unname(private$.data), + group = as.integer(names(private$.data)), + statistic_func = private$.statistic_func, + n_permu = as.integer(private$.n_permu) + ) + }, + + .calculate_p_permu = function() { + private$.p_value <- rowMeans( + abs(private$.statistic_permu) >= abs(private$.statistic) + ) + }, + + .calculate_extra = function() { + private$.multicomp <- data.frame( + group_i = private$.group_ij$i, + group_j = private$.group_ij$j, + statistic = private$.statistic, + p_value = private$.p_value, + differ = (private$.p_value < 1 - private$.conf_level) + ) + }, + .print = function(digits) { cat("\n\t", private$.name, "\n\n") @@ -41,13 +93,17 @@ MultipleComparison <- R6Class( private$.conf_level * 100 )) - print(private$.multicomp, digits = digits, row.names = FALSE) + data_names <- names(private$.raw_data) + multicomp <- private$.multicomp + multicomp$group_i <- data_names[multicomp$group_i] + multicomp$group_j <- data_names[multicomp$group_j] + print(multicomp, digits = digits, row.names = FALSE) }, .plot = function(...) { - n <- get_last(private$.ij$i) + n <- get_last(private$.group_ij$i) - dots <- c(private$.ij, list(seq_len(n * (n + 1) / 2))) + dots <- c(private$.group_ij, list(seq_len(n * (n + 1) / 2))) layout_matrix <- matrix(0, n, n) .mapply( @@ -59,6 +115,8 @@ MultipleComparison <- R6Class( defaut_par <- par(no.readonly = TRUE) par(oma = c(0, 0, 3, 0)) layout(layout_matrix) + + data_names <- names(private$.raw_data) .mapply( FUN = function(i, j, k) { do_call( @@ -67,7 +125,7 @@ MultipleComparison <- R6Class( x = private$.statistic_permu[k, ], plot = TRUE, xlab = "Statistic", - main = paste(i, "versus", j) + main = paste(data_names[i], "versus", data_names[j]) ), ... ) abline(v = private$.statistic[k], lty = "dashed") @@ -77,6 +135,7 @@ MultipleComparison <- R6Class( text = expression(bold("Permutation Distribution")), side = 3, line = 0, outer = TRUE ) + par(defaut_par) }, @@ -91,8 +150,8 @@ MultipleComparison <- R6Class( data = { n <- ncol(private$.statistic_permu) data.frame( - i = rep.int(private$.ij$i, n), - j = rep.int(private$.ij$j, n), + group_i = rep.int(private$.group_ij$i, n), + group_j = rep.int(private$.group_ij$j, n), statistic = as.vector(private$.statistic_permu) ) } @@ -104,9 +163,15 @@ MultipleComparison <- R6Class( linetype = "dashed" ) + ggplot2::facet_grid( - rows = ggplot2::vars(.data$j), - cols = ggplot2::vars(.data$i), - scales = "free", switch = "both" + rows = ggplot2::vars(.data$group_j), + cols = ggplot2::vars(.data$group_i), + scales = "free", switch = "both", + labeller = { + data_names <- names(private$.raw_data) + ggplot2::as_labeller( + function(index) data_names[as.integer(index)] + ) + } ) + ggplot2::labs( title = "Permutation Distribution", @@ -115,58 +180,6 @@ MultipleComparison <- R6Class( ggplot2::theme( plot.title = ggplot2::element_text(face = "bold", hjust = 0.5) ) - }, - - .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 = unlist(lapply( - seq.int(2, k), seq.int, to = k - ), recursive = FALSE, use.names = FALSE) - ) - }, - - .calculate_statistic = function() { - 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 <- multicomp_pmt( - group_i = private$.ij$i - 1, - group_j = private$.ij$j - 1, - data = unname(private$.data), - group = as.integer(names(private$.data)), - statistic_func = private$.statistic_func, - n_permu = as.integer(private$.n_permu) - ) - }, - - .calculate_p_permu = function() { - private$.p_value <- rowMeans( - abs(private$.statistic_permu) >= abs(private$.statistic) - ) - }, - - .calculate_extra = function() { - private$.multicomp <- data.frame( - i = private$.ij$i, - j = private$.ij$j, - statistic = private$.statistic, - p_value = private$.p_value, - differ = (private$.p_value < 1 - private$.conf_level) - ) } ) ) \ No newline at end of file diff --git a/R/OneSampleTest.R b/R/OneSampleTest.R index 7205a9df..af558aaa 100644 --- a/R/OneSampleTest.R +++ b/R/OneSampleTest.R @@ -18,10 +18,11 @@ OneSampleTest <- R6Class( .check = function() {}, - .plot = function() {}, + .preprocess = function() { + private$.data <- private$.raw_data[[1]] + }, - .input = function(x) { - private$.raw_data <- x - } + .plot = function(...) {}, + .autoplot = function(...) {} ) ) \ No newline at end of file diff --git a/R/PermuTest.R b/R/PermuTest.R index d4b70ad6..d36a782f 100644 --- a/R/PermuTest.R +++ b/R/PermuTest.R @@ -28,11 +28,11 @@ PermuTest <- R6Class( #' @description Perform test on data. #' - #' @param ... data. + #' @param ... data to be tested. Can be a `data.frame`, a `list` or numeric vector(s). #' #' @return The object itself (invisibly). test = function(...) { - private$.input(...) + private$.raw_data <- get_data(match.call(), parent.frame()) private$.check() private$.calculate() @@ -81,6 +81,7 @@ PermuTest <- R6Class( .n_permu = NULL, + .data_name = NULL, .raw_data = NULL, .data = NULL, @@ -100,9 +101,87 @@ PermuTest <- R6Class( .ci = NULL, .conf_level = NULL, + .calculate = function() { + private$.preprocess() + if (private$.scoring != "none") { + private$.calculate_score() + } + + private$.define() + + private$.calculate_statistic() + + private$.calculate_side() + if (private$.type == "permu") { + private$.calculate_statistic_permu() + private$.calculate_p_permu() + } else { + private$.calculate_p() + } + + private$.calculate_extra() + }, + # @Override .check = function() {}, + # @Override + .preprocess = function() { + # private$.data <- ... + }, + + # @Override + .calculate_score = function() { + # private$.data <- ... + }, + + # @Override + .define = function() { + # private$.param_name <- ... + # private$.statistic_func <- ... + }, + + # @Override + .calculate_statistic = function() { + # private$.statistic <- ... + }, + + # @Override + .calculate_p = function() { + # private$.p_value <- ... + # when private$.type != "permu" + }, + + # @Override + .calculate_extra = function() { + # private$.estimate <- ... + # private$.ci <- ... + }, + + # @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() { + l <- quote(mean(private$.statistic_permu <= 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)) + }, + .print = function(digits) { cat("\n", "\t", private$.name, "\n\n") @@ -196,84 +275,6 @@ PermuTest <- R6Class( ggplot2::theme( plot.title = ggplot2::element_text(face = "bold", hjust = 0.5) ) - }, - - # @Override - .input = function(...) { - # private$.raw_data <- ... - }, - - # @Override - .calculate_score = function() { - # private$.data <- ... - }, - - # @Override - .define = function() { - # private$.param_name <- ... - # private$.statistic_func <- ... - }, - - # @Override - .calculate_statistic = function() { - # private$.statistic <- ... - }, - - # @Override - .calculate_p = function() { - # private$.p_value <- ... - # when private$.type != "permu" - }, - - # @Override - .calculate_extra = function() { - # private$.estimate <- ... - # private$.ci <- ... - }, - - # @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() { - l <- quote(mean(private$.statistic_permu <= 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)) - }, - - .calculate = function() { - private$.data <- private$.raw_data - if (private$.scoring != "none") { - private$.calculate_score() - } - - private$.define() - - private$.calculate_statistic() - - private$.calculate_side() - if (private$.type == "permu") { - private$.calculate_statistic_permu() - private$.calculate_p_permu() - } else { - private$.calculate_p() - } - - private$.calculate_extra() } ), active = list( @@ -356,7 +357,7 @@ PermuTest <- R6Class( }, #' @field data The data. - data = function() private$.data, + data = function() private$.raw_data, #' @field statistic The test statistic. statistic = function() private$.statistic, #' @field p_value The p-value. diff --git a/R/RCBD.R b/R/RCBD.R index 25b118d5..15f5fb44 100644 --- a/R/RCBD.R +++ b/R/RCBD.R @@ -17,14 +17,8 @@ RCBD <- R6Class( .check = function() {}, - .input = function(...) { - data <- do.call(cbind, get_list(...)) - - dim <- dim(data) - rownames(data) <- paste0("treatment_", seq_len(dim[1])) - colnames(data) <- paste0("block_", seq_len(dim[2])) - - private$.raw_data <- data + .preprocess = function() { + private$.data <- unname(do_call(cbind, private$.raw_data)) }, .calculate_score = function() { diff --git a/R/TwoSampleAssociationTest.R b/R/TwoSampleAssociationTest.R index f603236a..e6b4faab 100644 --- a/R/TwoSampleAssociationTest.R +++ b/R/TwoSampleAssociationTest.R @@ -17,16 +17,16 @@ TwoSampleAssociationTest <- R6Class( .check = function() {}, - .input = function(...) { - super$.input(...) + .preprocess = function() { + super$.preprocess() - private$.raw_data <- do.call(data.frame, private$.raw_data) + private$.data <- do_call(data.frame, private$.data) }, .calculate_score = function() {}, .calculate_statistic_permu = function() { - data_y_order <- private$.data[order(private$.data$y),] + data_y_order <- private$.data[order(private$.data$y), ] private$.statistic_permu <- association_pmt( x = data_y_order$x, y = data_y_order$y, diff --git a/R/TwoSamplePairedTest.R b/R/TwoSamplePairedTest.R index 6ed1ed2d..67be7f7b 100644 --- a/R/TwoSamplePairedTest.R +++ b/R/TwoSamplePairedTest.R @@ -17,10 +17,10 @@ TwoSamplePairedTest <- R6Class( .check = function() {}, - .input = function(...) { - super$.input(...) + .preprocess = function() { + super$.preprocess() - private$.raw_data <- do.call(data.frame, private$.raw_data) + private$.data <- do_call(data.frame, private$.data) }, .calculate_score = function() {}, @@ -33,7 +33,7 @@ TwoSamplePairedTest <- R6Class( .calculate_statistic_permu = function() { private$.statistic_permu <- paired_pmt( - n = length(private$.data$x), + n = nrow(private$.data), statistic_func = private$.statistic_func, n_permu = as.integer(private$.n_permu) ) diff --git a/R/TwoSampleTest.R b/R/TwoSampleTest.R index 09c7a5e3..d276cedd 100644 --- a/R/TwoSampleTest.R +++ b/R/TwoSampleTest.R @@ -17,8 +17,8 @@ TwoSampleTest <- R6Class( .check = function() {}, - .input = function(...) { - private$.raw_data <- setNames(get_list(...), c("x", "y")) + .preprocess = function() { + private$.data <- setNames(private$.raw_data, c("x", "y")) }, .calculate_score = function() { diff --git a/R/utils.R b/R/utils.R index 3a0b74a3..03c97dae 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,5 @@ get_last <- function(x) x[length(x)] -# for .input - -get_list <- function(...) { - data <- list(...) - - if (length(data) == 1 & is.list(data[[1]])) { - data <- as.list(data[[1]]) - } - if (all(vapply(data, length, numeric(1)) >= 2)) data -} - -# for .plot & .ggplot - do_call <- function(func, default = NULL, fixed = NULL, ...) { env_args <- list2env(as.list(default)) env_args <- list2env(list(...), envir = env_args) @@ -24,7 +11,32 @@ do_call <- function(func, default = NULL, fixed = NULL, ...) { ) } -# for .calculate_score +# for test() + +get_data <- function(call, env) { + data_expr <- as.list(call)[-1] + n_data <- length(data_expr) + + if ( + n_data == 1 & + is.list(data_1 <- eval(data_expr[[1]], envir = env)) + ) data_expr <- data_1 + + data_names <- names(data_expr) + if (is.null(data_names)) data_names <- rep_len("", n_data) + + unlist(.mapply( + dots = list(data_expr, data_names), + FUN = function(data, name) { + setNames( + list(eval(data, envir = env)), + if (name != "") name else deparse(data, width.cutoff = 20)[1] + ) + }, MoreArgs = NULL + ), recursive = FALSE, use.names = TRUE) +} + +# for .calculate_score() get_score <- function(x, method, n = length(x)) { rank <- rank(x) @@ -38,7 +50,7 @@ get_score <- function(x, method, n = length(x)) { ) } -# for .calculate_p +# for .calculate_p() get_p_continous <- function(x, dist, side, ...) { F <- match.fun(paste0("p", dist)) diff --git a/man/PermuTest.Rd b/man/PermuTest.Rd index 280732b7..942b85f2 100644 --- a/man/PermuTest.Rd +++ b/man/PermuTest.Rd @@ -90,7 +90,7 @@ Perform test on data. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{...}}{data.} +\item{\code{...}}{data to be tested. Can be a \code{data.frame}, a \code{list} or numeric vector(s).} } \if{html}{\out{
}} } diff --git a/vignettes/examples.Rmd b/vignettes/examples.Rmd index e7bf8214..1f0da84b 100644 --- a/vignettes/examples.Rmd +++ b/vignettes/examples.Rmd @@ -409,10 +409,7 @@ t <- pmt( scoring = "rank", method = "ignore" ) -t$test(data.frame( - diff = c(-5, -3, -3, 0, 0, 2, 4, 4, 4, 5), - zero = 0 -)) +t$test(c(-5, -3, -3, 0, 0, 2, 4, 4, 4, 5), 0) t$statistic t$p_value @@ -426,10 +423,7 @@ t <- pmt( "paired.sign", alternative = "greater", type = "exact" ) -t$test(data.frame( - diff = c(rep(+1, 12), rep(-1, 5)), - zero = 0 -)) +t$test(c(rep(+1, 12), rep(-1, 5)), 0) t$statistic t$p_value