added a bunch of new tests for coverage

DESCRIPTION

@@ -28,6 +28,5 @@ Maintainer: John Muschelli <muschellij2@gmail.com>
 VignetteBuilder: knitr
 URL: https://github.com/muschellij2/stapler
 BugReports: https://github.com/muschellij2/stapler/issues
-RoxygenNote: 7.0.1
+RoxygenNote: 7.0.2
 Language: en-US
-

R/staple.R

@@ -11,6 +11,42 @@
 #' @param set_orient Should the orientation be set to the same if x is a
 #' set of images, including \code{niftiImage}s.
 #' @export
+#' @examples
+#' n = 5
+#' r = 1000
+#' sens = c(0.8, 0.9, 0.8, 0.5, 0.8)
+#' spec = c(0.9, 0.75, 0.99, 0.98, 0.92)
+#' suppressWarnings(RNGversion("3.5.0"))
+#' set.seed(20171120)
+#' n_1 = 200
+#' n_0 = r - n_1
+#' truth = c(rep(0, n_0), rep(1, n_1))
+#' pred_1 = rbinom(n = n, size = n_1, prob = sens)
+#' pred_0 = rbinom(n = n, size = n_0, prob = spec)
+#' pred_0 = sapply(pred_0, function(n) {
+#'    sample(c(rep(0, n), rep(1, n_0 -n)))
+#' })
+#' pred_1 = sapply(pred_1, function(n) {
+#'    sample(c(rep(1, n), rep(0, n_1 -n)))
+#' })
+#' pred = rbind(pred_0, pred_1)
+#' true_sens = colMeans(pred[ truth == 1, ])
+#' true_spec = colMeans(1-pred[ truth == 0, ])
+#' x = t(pred)
+#' staple_out = staple(x)
+#' testthat::expect_equal(staple_out$sensitivity[,"1"],
+#' c(0.781593858553476, 0.895868301462594,
+#' 0.760514086161722, 0.464483444340873,
+#' 0.765239314719065))
+#' staple_out_prior = staple(x, prior = rep(0.5, r))
+#'
+#' testthat::expect_equal(staple_out_prior$sensitivity[, "1"],
+#' c(0.683572080864211, 0.821556768891859,
+#' 0.619166852992802, 0.389409921992467, 0.67042085955546))
+#'
+#' res_bin = staple_bin_mat(x, prior = rep(0.5, 1000))
+#' testthat::expect_equal(staple_out_prior$sensitivity[,"1"],
+#' res_bin$sensitivity)
 staple = function(
   x,
   ...,
@@ -66,6 +102,17 @@ staple.character = function(
 # array covers array/nifti/matrix
 #' @rdname staple
 #' @export
+#' @examples
+#' n = 5
+#' r = 1000
+#' x = lapply(seq(n), function(i) {
+#'    x = rbinom(n = r, size = 1, prob = 0.5)
+#'    array(x, dim = c(10,10, 10))
+#'  })
+#' mat = sapply(x, c)
+#' staple_out = staple_bin_img(x, set_orient = FALSE)
+#' res_mat = staple(t(mat))
+#' testthat::expect_equal(staple_out$sensitivity, res_mat$sensitivity[, "1"])
 staple.array = function(
   x,
   ...,

R/staple_binimg.R

@@ -20,6 +20,9 @@
 #'    array(x, dim = c(10,10, 10))
 #'  })
 #' staple_out = staple_bin_img(x, set_orient = FALSE)
+#' res = staple(x)
+#' testthat::expect_equal(staple_out$sensitivity,
+#' res$sensitivity)
 #'
 #' @importFrom RNifti readNifti niftiHeader updateNifti orientation
 #' @importFrom RNifti "orientation<-"

R/staple_binmat.R

@@ -88,6 +88,7 @@ staple_bin_mat = function(
   # }
 
   if (drop_all_same) {
+    warning("Dropping values where all the same - may be wrong!")
     cs = colSums(x)
     all_zero = cs == 0
     # only_one = cs == 1

R/staple_multi_mat.R

@@ -30,6 +30,10 @@
 #'   ties.method = "first"
 #'
 #' res = staple_multi_mat(x)
+#' xx = rbind(colMeans(x >= 2) > 0.5, colMeans(x >= 2) >= 0.5)
+#' res = staple_multi_mat(xx, prior = rep(0.5, 1000))
+#' res_bin = staple_bin_mat(xx, prior = rep(0.5, 1000))
+#' testthat::expect_equal(res$sensitivity[,"1"], res_bin$sensitivity)
 #'
 #' @importFrom matrixStats colProds colVars
 staple_multi_mat = function(
@@ -64,6 +68,7 @@ staple_multi_mat = function(
   }
 
   if (drop_all_same) {
+    warning("Dropping values where all the same - may be wrong!")
     not_all_same = matrixStats::colVars(x) > 0
   } else {
     not_all_same = rep(TRUE, ncol(x))
@@ -92,12 +97,22 @@ staple_multi_mat = function(
     f_t_i = sapply(xmats, colMeans, na.rm = TRUE)
     prior = f_t_i
   } else {
-    stop("Not implemented")
+    if (n_levels > 2) {
+      stop("Not implemented")
+    }
     prior = as.matrix(prior)
-    n_prior = ncol(prior)
+    n_prior = nrow(prior)
+    if (n_prior != n_all_voxels) {
+      prior = t(prior)
+      n_prior = nrow(prior)
+    }
     if (n_prior != n_all_voxels) {
       stop("Prior does not have same number of rated elements!")
     }
+    if (n_levels == 2 && ncol(prior) == 1) {
+      prior = cbind(1-prior, prior)
+    }
+
     stopifnot(!any(is.na(prior)))
     f_t_i = prior
     ####################

tests/testthat/test-binmat-bad.R

@@ -1,4 +1,4 @@
-test_that("Staple binary matrix", {
+testthat::test_that("Staple binary matrix", {
   suppressWarnings(RNGversion("3.5.0"))
 
   set.seed(20171120)
@@ -39,7 +39,7 @@ test_that("Staple binary matrix", {
   accuracy = mean(res$label == truth)
   testthat::expect_equal(accuracy, 0.981)
 
-  testthat::expect_silent({
+  testthat::expect_warning({
     res2 = staple_bin_mat(x, prior = rep(0.5, r),
                           verbose = FALSE,
                           drop_all_same = TRUE)