Merge pull request #65 from suzannejin/master

fix bugs related to updateCutoffs

NEWS.md

@@ -1,3 +1,8 @@
+# propr 5.1.5
+---------------------
+* Fixed bug in `updateCutoffs` related to the use of `custom_cutoffs`
+* Fixed `runNormalization` to properly work when `theta_mod` is used
+
 # propr 5.1.4
 ---------------------
 * Added `results_to_matrix` function

R/3-shared-graflex.R

@@ -47,8 +47,5 @@ runGraflex <- function(A, K, p=100, ncores=1) {
   # change the values to numeric, except for the concept column
   res[,1:9] <- lapply(res[,1:9], as.numeric)
 
-  # sort the results by the odds ratio
-  res <- res[order(res$Odds, decreasing=TRUE),]
-
   return(res)
 }

R/3-shared-updateCutoffs.R

@@ -13,10 +13,10 @@
 #' cutoffs will be evenly spaced across the data.
 #' @param custom_cutoffs A numeric vector. When provided, this vector is used as the set of 
 #' cutoffs to test, and 'number_of_cutoffs' is ignored.
-#' @param tails NA or 'right' or 'both'. 'right' is for one-sided on the right. 'both' for
-#' symmetric two-sided test. If NA, use default value according to the property 
-#' `has_meaningful_negative_values`. This is only relevant for \code{propr} objects, as 
-#' \code{propd} objects are always one-sided and only have positive values.
+#' @param tails 'right' or 'both'. 'right' is for one-sided on the right. 'both' for
+#' symmetric two-sided test. This is only relevant for \code{propr} objects, as 
+#' \code{propd} objects are always one-sided and only have positive values. Default 
+#' is 'right'.
 #' @param ncores An integer. The number of parallel cores to use.
 #' @return A \code{propr} or \code{propd} object with the FDR slot updated.
 #' 
@@ -25,7 +25,7 @@ updateCutoffs <-
   function(object,
            number_of_cutoffs = 100,
            custom_cutoffs = NA,
-           tails = NA,
+           tails = 'right',
            ncores = 1) {
 
     if (inherits(object, "propr")) {
@@ -53,25 +53,18 @@ updateCutoffs.propr <-
   function(object, 
            number_of_cutoffs = 100, 
            custom_cutoffs = NA, 
-           tails = NA, 
+           tails = 'right', 
            ncores = 1) {
     if (identical(object@permutes, list(NULL))) {
       stop("Permutation testing is disabled.")
     }
     if (object@metric == "phi") {
       warning("We recommend using the symmetric phi 'phs' for FDR permutation.")
     }
-
-    # handle right/both tails FDR test
-    if (is.na(tails)) {
-      tails <- ifelse(object@has_meaningful_negative_values, 'both', 'right')  # default option
-    } else if (!tails %in% c('right','both')) {
-      stop("Provided 'tails' not recognized.")
-    }
     object@tails <- tails
 
     # get cutoffs
-    if (is.na(custom_cutoffs)) {
+    if (length(custom_cutoffs) == 1 && is.na(custom_cutoffs)) {
       vals <- object@results$propr
       if (tails == 'right') {
         vals <- vals[vals >= 0]
@@ -203,7 +196,7 @@ updateCutoffs.propd <-
       stop("Permutation testing is disabled.")
 
     # get cutoffs
-    if (is.na(custom_cutoffs)) {
+    if (length(custom_cutoffs) == 1 && is.na(custom_cutoffs)) {
       cutoffs <- as.numeric(quantile(object@results$theta, seq(0, 1, length.out = number_of_cutoffs)))
     } else {
       cutoffs <- custom_cutoffs

tests/testthat/test-SHARED-getAdjacency-propr.R

@@ -134,7 +134,7 @@ test_that("getAdjacencyFDR returns the expected values for phs - 5", {
 
 test_that("getAdjacencyFDR and getSignificantResultsFDR return coherent results", {
 
-    for (metric in c('rho', 'phi', 'phs', 'pcor', 'pcor.shrink', 'pcor.bshrink')){
+    for (metric in c('rho', 'phi', 'phs', 'pcor', 'pcor.bshrink')) { # pcor.shrink does not provide positive values for this dataset, and it gives error when tails = 'right'
         print(metric)
 
         # get propr object

tests/testthat/test-SHARED-updateCutoffs-propd.R

@@ -102,13 +102,19 @@ test_that("updateCutoffs.propd properly set up cutoffs", {
 
   # get propd object and update cutoffs
   pd <- propd(x, as.character(y), p=10)
-  pd <- updateCutoffs(pd, number_of_cutoffs=10)
+  pd1 <- updateCutoffs(pd, number_of_cutoffs=10)
 
   # get cutoffs
   cutoffs <- as.numeric( quantile(pd@results$theta, probs = seq(0, 1, length.out = 10)) )
 
+  # run with cutoffs
+  pd2 <- updateCutoffs(pd, custom_cutoffs=cutoffs)
+
   # check that cutoffs are properly defined
-  expect_equal(pd@fdr$cutoff, cutoffs)
+  expect_equal(pd1@fdr$cutoff, cutoffs)
+
+  # check that the two calls agree
+  expect_equal(pd1@fdr, pd2@fdr)
 })
 
 test_that("updateCutoffs.propd properly calculates truecounts", {

tests/testthat/test-SHARED-updateCutoffs-propr.R

@@ -165,7 +165,7 @@ test_that("updateCutoffs.propr properly set up cutoffs", {
   pr <- propr(X, metric = "pcor.bshrink", p=10)
 
   # get cutoffs
-  values <- pr@matrix[lower.tri(pr@matrix)]
+  values <- pr@results$propr
   cutoffs_right <- as.numeric( quantile(values[values >= 0], probs = seq(0, 1, length.out = 10)) )
   cutoffs_both <- as.numeric( quantile(abs(values), probs = seq(0, 1, length.out = 10)) )
 
@@ -180,7 +180,15 @@ test_that("updateCutoffs.propr properly set up cutoffs", {
   )
   expect_equal(
     updateCutoffs(pr, number_of_cutoffs=10)@fdr$cutoff,
-    cutoffs_both
+    cutoffs_right
+  )
+  expect_equal(
+    updateCutoffs(pr, custom_cutoffs=cutoffs_right)@fdr,
+    updateCutoffs(pr, number_of_cutoffs=10)@fdr
+  )
+  expect_equal(
+    updateCutoffs(pr, custom_cutoffs=cutoffs_both, tails='both')@fdr,
+    updateCutoffs(pr, number_of_cutoffs=10, tails='both')@fdr
   )
 })