Merge branch 'issue-7' into develop (close #7)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: permChacko
 Title: Chacko Test for Order-Restriction with Permutation
-Version: 0.1.0.9004
+Version: 0.1.0.9005
 Authors@R:
     c(
         person(

NAMESPACE

@@ -1,8 +1,12 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,chacko_test)
+S3method(print,reduced_vector)
+export(chacko63_tab1)
 export(chacko66_sec3)
 export(chacko66_sec5)
 export(permChacko)
 export(reduceVector)
+export(ruxton221207)
 importFrom(stats,pchisq)
 importFrom(stats,weighted.mean)

NEWS.md

@@ -4,6 +4,7 @@
 * Exported `reduceVector()` ([issue #4](https://github.com/ocbe-uio/permChacko/issues/4)).
 * Added package documentation ([issue #5](https://github.com/ocbe-uio/permChacko/issues/5)).
 * Standardized dataset names
+* Created print methods for `permChacko()` and `reduceVector()` ([issue #7](https://github.com/ocbe-uio/permChacko/issues/7)).
 
 # permChacko 0.1.0
 

R/datasets.R

@@ -6,6 +6,7 @@
 #' Annals of Mathematical Statistics, 945-956.
 #' @name chacko63_tab1
 #' @docType data
+#' @export
 chacko63_tab1 <- matrix(
   c(
     .333333, .500000, .166667, rep(NA, 7),
@@ -53,4 +54,5 @@ chacko66_sec5 <- c(
 #' element.
 #' @name ruxton221207
 #' @docType data
+#' @export
 ruxton221207 <- c(6, 8, 4, 7, 3)

R/permChacko.R

@@ -29,7 +29,7 @@
 permChacko <- function(x, n_perm = 1000L, verbosity = 0) {
   if (verbosity >= 1L) message("Reducing original vector")
   # Ordering and reducing vector
-  x_t <- reduceVector(x, verbosity)
+  x_t <- reduceVector(x, verbosity)[["x_t"]]
   k <- length(x)
   chisq_bar <- chackoStatistic(x_t, n = sum(x), k)
 
@@ -44,7 +44,7 @@ permChacko <- function(x, n_perm = 1000L, verbosity = 0) {
 
       # For each such permutation we can go through the ordering procedure and
       # calculate the test statistic according to equation 5.
-      perm_x_t <- reduceVector(perm_x, 0L)
+      perm_x_t <- reduceVector(perm_x, 0L)[["x_t"]]
       perm_chisq_bar <- chackoStatistic(perm_x_t, n = sum(perm_x), k)
       return(perm_chisq_bar)
     },
@@ -69,12 +69,18 @@ permChacko <- function(x, n_perm = 1000L, verbosity = 0) {
     table_p_value <- NA
   }
   if (verbosity >= 1L) message("\nTest statistics")
-  return(
-    c(
-      "chisq_bar" = chisq_bar,
-      "analytic_p-value" = anal_p_value,
-      "numeric_p-value" = perm_p_value,
-      "tabular_p-value" = table_p_value
-    )
+  p_values <- c(
+    "analytic" = anal_p_value,
+    "numeric" = perm_p_value,
+    "tabular" = table_p_value
   )
+  out <- list(
+    statistic = chisq_bar,
+    p_values = p_values,
+    n_perm = n_perm,
+    observed_data = x,
+    reduced_data = x_t
+  )
+  class(out) <- "chacko_test"
+  return(out)
 }

R/print.R

@@ -0,0 +1,45 @@
+#' @export
+print.chacko_test <- function(x, ...) {
+  p_values <- x[["p_values"]]
+  cat(
+    sprintf(
+      paste0(
+        "          Chacko Test for Order-restriction with Permutation Test\n\n",
+        "Null hypothesis       : %s\n",
+        "Alternative hypothesis: %s\n\n",
+        "Test statistic (chisq_bar): %f\n",
+        "p-values:\n",
+        "  Analytic p-value:         %f\n",
+        "  Numeric p-value:          %f (%d permutations)\n",
+        "  Tabular p-value:          %f\n\n"
+      ),
+      paste0("p", seq_along(x$observed_data), collapse = " == "),
+      paste0("p", seq_along(x$observed_data), collapse = " <= "),
+      x[["statistic"]], p_values[["analytic"]],
+      p_values[["numeric"]], x[["n_perm"]], p_values[["tabular"]]
+    )
+  )
+}
+
+#' @export
+print.reduced_vector <- function(x, details = TRUE, ...) {
+  if (x[["verbose"]] >= 1L) {
+    cat(sprintf("Original vector has been reduced %d times", x[["reductions"]]))
+  } else {
+    cat(
+      sprintf(
+        paste0(
+          "Original vector: %s\n",
+          "Reduced vector : %s\n",
+          "Final weights  : %s\n",
+          "Original vector has been reduced %d times\n\n",
+          "Run reduceVector() with verbosity > 1) to see the reduction process"
+        ),
+        paste0(x[["original_vector"]], collapse = "\t"),
+        paste0(x[["reduced_vector"]], collapse = "\t"),
+        paste0(x[["weights"]], collapse = "\t"),
+        x[["reductions"]]
+      )
+    )
+  }
+}

R/reduceVector.R

@@ -20,12 +20,23 @@
 #' reduceVector(chacko66_sec5)
 reduceVector <- function(x, verbosity = 0L) {
   x_t <- cbind("x" = unname(x), "t" = unname(x) ^ 0L)
+  reductions <- 0L
   while (nrow(x_t) > 1L && isMonotoneIncreasing(x_t[, "x"])) {
     if (verbosity >= 1L) {
       message("\nVector needs reduction\nInitial vector")
       print(t(x_t))
     }
+    reductions <- reductions + 1L
     x_t <- orderingProcess(x_t, verbosity)
   }
-  return(x_t)
+  out <- list(
+    "original_vector" = x,
+    "reduced_vector" = x_t[, "x"],
+    "weights" = x_t[, "t"],
+    "x_t" = x_t,
+    "reductions" = reductions,
+    "verbose" = verbosity
+  )
+  class(out) <- "reduced_vector"
+  return(out)
 }

tests/testthat/test-chackoPapers.R

@@ -1,19 +1,30 @@
-test_that("Examples from Chacko (1966) produce correct vectors", {
-  expect_equal(reduceVector(chacko66_sec3)[, "x"], c(10, 14, 18))
-  expect_equal(reduceVector(chacko66_sec3)[, "t"], c(1, 3, 1))
-  expect_equal(reduceVector(chacko66_sec5)[, 1], c(12, 14, 17, 20, 24, 26, 30))
-  expect_equal(reduceVector(chacko66_sec5)[, 2], c(1, 1, 2, 3, 1, 1, 1))
-  expect_equal(permChacko(chacko66_sec3)[["chisq_bar"]], 2.2857143)
-  expect_equal(permChacko(chacko66_sec5)[["chisq_bar"]], 13.5)
+test_that("Vector reduction procedure works well", {
+  c66s3 <- reduceVector(chacko66_sec3)
+  c66s5 <- reduceVector(chacko66_sec5)
+  expect_equal(c66s3[["x_t"]][, "x"], c(10, 14, 18))
+  expect_equal(c66s3[["x_t"]][, "t"], c(1, 3, 1))
+  expect_equal(c66s5[["x_t"]][, 1], c(12, 14, 17, 20, 24, 26, 30))
+  expect_equal(c66s5[["x_t"]][, 2], c(1, 1, 2, 3, 1, 1, 1))
+})
+
+test_that("Examples from Chacko (1966) produce correct statistics", {
   set.seed(3174)
+  c66s3 <- permChacko(chacko66_sec3)
+  c66s5 <- permChacko(chacko66_sec5)
+  expect_output(
+    print(c66s3),
+    "Chacko Test for Order-restriction with Permutation Test"
+  )
+  expect_equal(c66s3[["statistic"]], 2.2857143)
+  expect_equal(c66s5[["statistic"]], 13.5)
   expect_equal(
-    permChacko(chacko66_sec3)[["numeric_p-value"]],
-    permChacko(chacko66_sec3)[["tabular_p-value"]],
+    c66s3[["p_values"]][["numeric"]],
+    c66s3[["p_values"]][["tabular"]],
     tolerance = 1e-1
   )
   expect_equal(
-    permChacko(chacko66_sec5)[["numeric_p-value"]],
-    permChacko(chacko66_sec5)[["tabular_p-value"]],
+    c66s5[["p_values"]][["numeric"]],
+    c66s5[["p_values"]][["tabular"]],
     tolerance = 1e-1
   )
 })

tests/testthat/test-customExamples.R

@@ -1,7 +1,7 @@
 test_that("Other from produce correct vectors", {
-  expect_equal(reduceVector(ruxton221207)[, "x"], c("x" = 5.6))
-  expect_equal(reduceVector(ruxton221207)[, "t"], c("t" = 5))
-  expect_equal(permChacko(ruxton221207)[["chisq_bar"]], 0)
+  expect_equal(reduceVector(ruxton221207)[["x_t"]][, "x"], c("x" = 5.6))
+  expect_equal(reduceVector(ruxton221207)[["x_t"]][, "t"], c("t" = 5))
+  expect_equal(permChacko(ruxton221207)[["statistic"]], 0)
   set.seed(2715249)
   expect_equal(
     permChacko(ruxton221207)[["numeric_p-value"]],
@@ -23,7 +23,7 @@ test_that("Expected output is produced", {
     x <- rpois(n, lambda = mu)
     reps <- sample(c(0L, 10L, 100L, 1000L, 2000L), size = 1L)
     y <- permChacko(x, n_perm = reps)
-    expect_length(y, 4L)
-    expect_type(y, "double")
+    expect_length(y, 5L)
+    expect_type(y, "list")
   }
 })