Merge pull request #57 from bluefoxr/aggregate_debug

Aggregate debug

R/aggregate.R

@@ -876,8 +876,8 @@ a_copeland <- function(X, w = NULL){
   orm <- outrankMatrix(X, w)$OutRankMatrix
 
   orm[orm > 0.5] <- 1
-  orm[orm == 0.5] <- 0
   orm[orm < 0.5] <- -1
+  orm[orm == 0.5] <- 0
   diag(orm) <- 0
 
   # get scores by summing across rows

R/treat.R

@@ -454,7 +454,8 @@ Treat.data.frame <- function(x, global_specs = NULL, indiv_specs = NULL, combine
           }
         }
         # merge with defaults (overwrites any differences)
-        specs <- utils::modifyList(specs_def, indiv_specs_col)
+        #specs <- utils::modifyList(specs_def, indiv_specs_col)
+        specs <- modify_treat_specs(specs_def, indiv_specs_col)
       } else {
         # otherwise, use defaults
         specs <- specs_def
@@ -1222,3 +1223,31 @@ check_SkewKurt <- function(x, na.rm = FALSE, skew_thresh = 2, kurt_thresh = 3.5)
   # output
   list(Pass = ans, Skew = sk, Kurt = kt)
 }
+
+
+modify_treat_specs <- function(l_def, l_mod){
+
+  if(is.null(l_mod)){
+    return(l_def)
+  }
+
+  l_out <- l_def
+
+  # if any functions have changed we completely delete the function parameters
+  # to avoid passing unused arguments
+  if(!identical(l_def$f1, l_mod$f1)){
+    l_out$f1_para <- NULL
+  }
+  if(!identical(l_def$f2, l_mod$f2)){
+    l_out$f2_para <- NULL
+  }
+  if(!identical(l_def$f_pass, l_mod$f_pass)){
+    l_out$f_pass_para <- NULL
+  }
+
+  # now, merge lists
+  l_out <- utils::modifyList(l_out, l_mod)
+
+  l_out
+
+}

tests/testthat/test-aggregate.R

@@ -184,12 +184,25 @@ test_that("copeland", {
 
   orm <- outrankMatrix(X)$OutRankMatrix
   orm[orm > 0.5] <- 1
-  orm[orm == 0.5] <- 0
   orm[orm < 0.5] <- -1
+  orm[orm == 0.5] <- 0
   diag(orm) <- 0
 
   expect_equal(y, rowSums(orm))
 
+  # test equal units correctly assigned
+  X <- data.frame(
+    x1 = c(1,2),
+    x2 = c(2,1)
+  )
+
+  orm <- outrankMatrix(X)$OutRankMatrix
+  expect_equal(orm[1,2], 0.5)
+  expect_equal(orm[2,1], 0.5)
+
+  y <- a_copeland(X)
+  expect_equal(y, c(0,0))
+
 })
 
 test_that("aggregation by level", {