fixed TwoSamplePairedTest & Sign & SignedScore

qddyy · Sep 11, 2023 · 45aaadd · 45aaadd
1 parent 0cacf11
commit 45aaadd
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 28 deletions.
diff --git a/R/PairedComparison.R b/R/PairedComparison.R
@@ -36,8 +36,8 @@ PairedComparison <- R6Class(
         .define_statistic = function() {
             private$.diff <- private$.data$x - private$.data$y
 
-            private$.statistic_func <- function(is_swapped, diff = private$.diff) {
-                mean(diff * (2 * is_swapped - 1))
+            private$.statistic_func <- function(swapped, diff = private$.diff) {
+                mean(diff * (2 * swapped - 1))
             }
         },
 

diff --git a/R/Sign.R b/R/Sign.R
@@ -35,10 +35,10 @@ Sign <- R6Class(
         .correct = NULL,
 
         .define_statistic = function() {
-            sign <- sign(private$.data$x - private$.data$y)
-
-            private$.statistic_func <- function(is_swapped, sign = sign) {
-                sum(sign * (2 * is_swapped - 1) == 1)
+            private$.statistic_func <- function(
+                swapped, sign_diff = sign(private$.data$x - private$.data$y)
+            ) {
+                sum(sign_diff * (2 * swapped - 1) == 1)
             }
         },
 

diff --git a/R/SignedScore.R b/R/SignedScore.R
@@ -38,7 +38,7 @@ SignedScore <- R6Class(
         .correct = NULL,
         .ranking_method = NULL,
 
-        .signed_score = NULL,
+        .score = NULL,
 
         .define_statistic = function() {
             diff <- private$.data$x - private$.data$y
@@ -48,23 +48,24 @@ SignedScore <- R6Class(
                 diff <- diff[diff != 0]
             }
 
-            private$.signed_score <- sign(diff) * score(abs(diff), method = private$.scoring)
+            private$.score <- score(abs(diff), method = private$.scoring)
 
-            private$.statistic_func <- function(is_swapped, signed_score = private$.signed_score) {
-                mean(signed_score * (2 * is_swapped - 1))
+            private$.statistic_func <- function(
+                swapped, diff_positive = (diff > 0), score = private$.score
+            ) {
+                sum(score[diff_positive != swapped])
             }
         },
 
         .calculate_p = function() {
             n <- nrow(private$.data)
 
-            sa <- sum(pmax.int(0, private$.signed_score))
-            z <- sa - 1 / 2 * sum(abs(private$.signed_score))
+            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$.signed_score^2)
+                1 / 4 * sum(private$.score^2)
             )
 
             private$.p_value <- get_p_continous(z, "norm", private$.side)

diff --git a/R/TwoSamplePairedTest.R b/R/TwoSamplePairedTest.R
@@ -37,29 +37,30 @@ TwoSamplePairedTest <- R6Class(
 
             private$.data_permu <- lapply(
                 X = private$.swapped_permu,
-                FUN = function(is_swapped, x, y) {
+                FUN = function(swapped, x, y) {
                     data.frame(
-                        x = `[<-`(x, is_swapped, y[is_swapped]),
-                        y = `[<-`(y, is_swapped, x[is_swapped])
+                        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.int(FALSE, nrow(private$.data))
+                )
+            } else {
+                super$.calculate_statistic()
+            }
+        },
+
         .calculate_statistic_permu = function() {
             if (private$.use_swapped) {
-                statistic_func <- private$.statistic_func
-                private$.statistic_permu <- do.call(
-                    vapply, c(
-                        list(
-                            X = private$.swapped_permu,
-                            FUN = statistic_func, FUN.VALUE = numeric(1)
-                        ),
-                        lapply(
-                            X = formals(statistic_func)[-1],
-                            FUN = eval, envir = environment(statistic_func)
-                        )
-                    )
+                private$.statistic_permu <- vapply(
+                    X = private$.swapped_permu,
+                    FUN = private$.statistic_func, FUN.VALUE = numeric(1)
                 )
             } else {
                 super$.calculate_statistic_permu()