Merge branch 'hotfix-1xM-table-chisq.test-issue2' (returns NA when te…

…sting 1xM xtabs)

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: tableone
 Type: Package
 Title: Create "Table 1" to describe baseline characteristics
-Version: 0.6.1
+Version: 0.6.2
 Date: 2014-06-01
 Author: Kazuki Yoshida, Justin Bohn.
 Maintainer: Kazuki Yoshida <[email protected]>
@@ -17,5 +17,6 @@ Imports:
     e1071,
     gmodels
 Suggests:
-    survival
+    survival,
+    testthat
 URL: https://github.com/kaz-yos/tableone

NEWS

@@ -1,3 +1,21 @@
+tableone 0.6.2 (2014-06-01)
+----------------------------------------------------------------
+
+BUG FIXES
+
+* The testing of 1 x m table was problematic when a categorical
+  variable only have one level. chisq.test() returns Chi-squared
+  test for given probabilities (test for strata imbalance) in such
+  cases. In this version, testing a 1 x m table always return NA,
+  as test for a cross table is not defined in this context.
+
+* Special thanks to Atsushi Shiraishi for reporting this issues.
+
+* Unit testing with the testthat package was added for some
+  functions. Thus, the testthat package was added as a suggested
+  package.
+
+
 tableone 0.6.1 (2014-06-01)
 ----------------------------------------------------------------
 

R/modules.R

@@ -163,6 +163,7 @@ ModuleCreateStrataVarName <- function(obj) {
     paste0(names(attr(obj, "dimnames")), collapse = ":")
 }
 
+### ModuleTryCatchWE
 ## Try catch function           # Taken from demo(error.catching)
 ## Used to define non-failing functions, that return NA when there is an error
 ModuleTryCatchWE <- function(expr) {
@@ -176,14 +177,34 @@ ModuleTryCatchWE <- function(expr) {
          warning = W)
 }
 
+### ModuleTestSafe
 ## Function to perform non-failing tests (obj should be xtabs or formula)
 ModuleTestSafe <- function(obj, testFunction, testArgs = NULL) {
+
     ## Result from a function has to have $p.value element
     out <- ModuleTryCatchWE(do.call(testFunction, args = c(list(obj), testArgs))$p.value)
-    ## If it returns a numeric value, return it. Otherwise, return NA.
-    ifelse(is.numeric(out$value), out$value, NA)
+
+    ## If it contains a numeric value, return it. Otherwise, return NA.
+    pValue <- ifelse(is.numeric(out$value), out$value, NA)
+
+    ## When obj is an xtabs object
+    if (any(class(obj) %in% "xtabs")) {
+        ## and has 1 x M dimension, always return NA, and end there.
+        if (dim(obj)[1] == 1) {
+            ## ends here, returning NA
+            return(NA)
+
+        } else {
+            ## If obj is a multi-row xtabs object, return the p-value
+            pValue
+        }
+    } else {
+        ## If obj is not an xtabs (formula for continuous variables), return the p-value
+        pValue
+    }
 }
 
+
 ## Define special skewness and kurtosis functions that do not fail (SAS definitions)
 ModuleSasSkewness <- function(x) {
     out <- ModuleTryCatchWE(e1071::skewness(x, na.rm = TRUE, type = 2))

tests/test-all.R

@@ -0,0 +1,13 @@
+################################################################################
+### Unit tests for the package
+## Reference: http://adv-r.had.co.nz/Testing.html
+## See the testthat subdirectory for actual test code
+## Created on: 2014-06-01
+## Author: Kazuki Yoshida
+################################################################################
+
+
+### Run all tests
+################################################################################
+library(testthat)
+test_check("tableone")

tests/testthat/test-CreateTableOne.R

@@ -0,0 +1,80 @@
+################################################################################
+### Unit tests for the CreateTableOne function
+## Reference: http://adv-r.had.co.nz/Testing.html
+## Created on: 2014-06-01
+## Author: Kazuki Yoshida
+################################################################################
+
+### Structure
+## expectations within tests within context
+
+### Prepare environment
+################################################################################
+library(testthat)
+library(tableone)
+
+### Context (1 for each file)
+context("Unit tests for the CreateTableOne function")
+
+
+### Tests for
+## Tests for ModuleTestSafe, a wrapper for test functions such as oneway.test and chisq.test
+
+## Create a dataset for a table
+dat <- read.table(header = TRUE, text = "
+rowVar  colVar
+m       s
+f       s
+m       d
+f       d
+")
+
+## Increase numbers to avoid "cells are too small" warnings
+dat1   <- dat[rep(seq_len(nrow(dat)), 100), ]
+## m's only dataset but level f is retained
+dat2 <- dat1[dat1$rowVar == "m", ]
+## m's only dataset without level f
+dat3 <- dat2
+dat3$rowVar <- factor(dat3$rowVar)
+## m's only dataset without level f. Strata imbalance
+dat4 <- dat3[c(1:100, seq(101,200,2)), ]
+
+
+test_that("P-values are returned for appropriate 2x2 xtabs, even with an empty factor level.", {
+
+    ## Create tables
+    tab1 <- CreateTableOne(vars = "rowVar", strata = "colVar", data = dat1)
+    tab2 <- CreateTableOne(vars = "rowVar", strata = "colVar", data = dat2)
+
+    ## Create corresponding xtabs
+    xtabs1 <- xtabs(~ rowVar + colVar, dat1)
+    xtabs2 <- xtabs(~ rowVar + colVar, dat2)
+
+    ## chisq.test
+    expect_that(attributes(tab1)$pValues["rowVar","pApprox"], equals(chisq.test(xtabs1)$p.value))
+    expect_that(attributes(tab2)$pValues["rowVar","pApprox"], equals(chisq.test(xtabs2)$p.value))
+    ## fisher.test
+    expect_that(attributes(tab1)$pValues["rowVar","pExact"],  equals(fisher.test(xtabs1)$p.value))
+    expect_that(attributes(tab2)$pValues["rowVar","pExact"],  equals(fisher.test(xtabs2)$p.value))
+})
+
+
+test_that("P-values should be NA for 1xM xtabs", {
+
+    ## Create a table
+    tab3 <- CreateTableOne(vars = "rowVar", strata = "colVar", data = dat3)
+    tab4 <- CreateTableOne(vars = "rowVar", strata = "colVar", data = dat4)
+
+    ## Create corresponding xtabs
+    xtabs3 <- xtabs(~ rowVar + colVar, dat3)
+    xtabs4 <- xtabs(~ rowVar + colVar, dat4)
+
+    ## chisq.test
+    expect_that(attributes(tab3)$pValues["rowVar","pApprox"], equals(NA))
+    expect_that(attributes(tab4)$pValues["rowVar","pApprox"], equals(NA))
+    ## fisher.test
+    expect_that(attributes(tab3)$pValues["rowVar","pExact"],  equals(NA))
+    expect_that(attributes(tab4)$pValues["rowVar","pExact"],  equals(NA))
+})
+
+

tests/testthat/test-modules.R

@@ -0,0 +1,68 @@
+################################################################################
+### Unit tests for the modules
+## Reference: http://adv-r.had.co.nz/Testing.html
+## Created on: 2014-06-01
+## Author: Kazuki Yoshida
+################################################################################
+
+### Structure
+## expectations within tests within context
+
+### Prepare environment
+################################################################################
+library(testthat)
+library(tableone)
+
+### Context (1 for each file)
+context("Unit tests for the modules")
+
+
+### Tests for ModuleTestSafe
+## Tests for ModuleTestSafe, a wrapper for test functions such as oneway.test and chisq.test
+
+## Create a dataset for a table
+dat <- read.table(header = TRUE, text = "
+rowVar  colVar
+m       s
+f       s
+m       d
+f       d
+")
+
+## Increase numbers to avoid "cells are too small" warnings
+dat1   <- dat[rep(seq_len(nrow(dat)), 100), ]
+
+## Create a null cross table
+xtabs1 <- xtabs( ~ rowVar + colVar, data = dat1)
+
+## Create a non-null cross table by replacement
+xtabs2      <- xtabs1
+xtabs2[2,2] <- 50
+
+test_that("P-values are returned for appropriate 2x2 xtabs", {
+    ## chisq.test
+    expect_that(ModuleTestSafe(xtabs1, chisq.test),  equals(chisq.test(xtabs1)$p.value))
+    expect_that(ModuleTestSafe(xtabs2, chisq.test),  equals(chisq.test(xtabs2)$p.value))
+    ## fisher.test
+    expect_that(ModuleTestSafe(xtabs1, fisher.test), equals(fisher.test(xtabs1)$p.value))
+    expect_that(ModuleTestSafe(xtabs2, fisher.test), equals(fisher.test(xtabs2)$p.value))
+})
+
+
+## 1xM equal size
+xtabs3 <- xtabs1[2,,drop = FALSE]
+class(xtabs3) <- c("xtabs", "table")
+## 1xM unequal size
+xtabs4 <- xtabs2[2,,drop = FALSE]
+class(xtabs4) <- c("xtabs", "table")
+
+test_that("P-values should be NA for 1xM xtabs", {
+    ## chisq.test
+    expect_that(ModuleTestSafe(xtabs3, chisq.test),  equals(NA))
+    expect_that(ModuleTestSafe(xtabs4, chisq.test),  equals(NA))
+    ## fisher.test
+    expect_that(ModuleTestSafe(xtabs3, fisher.test), equals(NA))
+    expect_that(ModuleTestSafe(xtabs4, fisher.test), equals(NA))
+})
+
+