#' Count Similarly Margined Contingency Tables
#'
#' Count the number of contingency tables with the same marginals as a given
#' table.
#'
#' \code{count_tables} uses LattE's count function (via latte's [latte_count()])
#' to count the tables. In many cases, the number of such tables is enormous.
#' In these cases, instead of giving back an integer \code{count_tables}
#' provides a character string with the integer in it; see examples.
#'
#' @param table the table of interest
#' @param A the configuration/transpose design matrix
#' @param dir directory to place the files in, without an ending /
#' @param quiet show latte output
#' @param cache use count (default) or fcount
#' @param ... arguments to pass to [latte_count()]
#' @return an integer
#' @seealso [latte_count()], [count_fiber()]
#' @name count-tables
#' @examples
#'
#'
#' if (has_latte()) {
#'
#'
#' data(politics); politics
#' count_tables(politics)
#' (A <- hmat(c(2,2), list(1, 2)))
#' count_tables(politics, A)
#'
#'
#'
#' data(handy); handy
#' count_tables(handy)
#'
#'
#'
#' data(HairEyeColor); HairEyeColor
#' eyeHairColor <- margin.table(HairEyeColor, 2:1)
#' count_tables(eyeHairColor)
#'
#' system.time(count_tables(eyeHairColor)) # it was computed above
#' system.time(count_tables(eyeHairColor)) # it was computed above
#' system.time(count_tables(eyeHairColor, cache = FALSE))
#' system.time(count_tables(eyeHairColor, cache = FALSE))
#'
#'
#' library(gmp)
#' as.bigz(count_tables(eyeHairColor))
#'
#'
#'
#' # notice that even tables with small cells can have huge fibers
#' data(drugs); drugs
#' count_tables(drugs)
#'
#'
#'
#'
#' # 0-1 tables can be very hard and produce very large fibers
#' # the 4x4 table below has 154 elements in its independence fiber
#' # the 5x5 has 16830, and the compute times are on the order of
#' # 1 and 10 seconds, respectively.
#' # the following block is omited for faster R check time
#' if (FALSE) {
#' set.seed(1)
#' n <- 5
#' tab <- matrix(sample(0:1, n^2, replace = TRUE), nrow = n)
#' dimnames(tab) <- list(X = paste0("x", 1:n), Y = paste0("y", 1:n))
#' tab
#' count_tables(tab)
#' }
#'
#'
#'
#' count_tables(eyeHairColor, quiet = FALSE)
#'
#'
#'
#' }
#'
#' @export
#' @rdname count-tables
count_tables <- function(table,
A = hmat(dim(table), as.list(1:length(dim(table)))),
dir = tempdir(), quiet = TRUE, cache = TRUE, ...
){
## make column names
cellVars <- paste0("t", 1L:ncol(A))
## make the sums
margConds <- unname(apply(A, 1, function(v){
nonzero_ndcs <- unname(which(v > 0))
one_ndcs <- unname(which(v[nonzero_ndcs] == 1))
terms <- paste(v[nonzero_ndcs], cellVars[nonzero_ndcs])
terms[one_ndcs] <- str_sub(terms[one_ndcs], 3)
paste(terms, collapse = " + ")
}))
## compute the marginals
marginals <- as.integer(A %*% tab2vec(table))
## make the equalities and inqualities
margConds <- str_c(margConds, " == ", marginals)
nonnegConds <- str_c(cellVars, " >= 0")
## count
f <- if(cache) latte::latte_count else latte::latte_fcount
f(c(margConds, nonnegConds), dir, quiet, ...)
}
countTables <- function(...) {
.Deprecated("count_tables")
count_tables(...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.