R/tabular.R

In tables: Formula-Driven Table Generation

factors <- function(e) {
    if (is.name(e) || typeof(e) == "closure") list(e)
    else switch(deparse(e[[1]]),
    	"*" = c(factors(e[[2]]),factors(e[[3]])),
    	"(" = factors(e[[2]]),
    	list(e))
}

term2table <- function(rowterm, colterm, env, n) {
    rowargs <- factors(rowterm)
    colargs <- factors(colterm)
    allargs <- c(rowargs, colargs)
    rowsubset <- TRUE
    colsubset <- TRUE
    dropcell <- FALSE
    droprow <- FALSE
    dropcol <- FALSE
    pctdenom <- NULL
    pctsubset <- TRUE
    values <- NULL
    summary <- NULL
    arguments <- NULL
    format <- NA
    justification <- NA
    for (i in seq_along(allargs)) {
        e <- allargs[[i]]
        fn <- ""
        if (is.call(e) && (fn <- deparse(e[[1]])) == ".Format")
            format <- e[[2]]
        else if (fn == "Justify") 
            justification <- as.character(e[[if (length(e) > 2) 3 else 2]])
        else if (fn == "Percent") {
            env1 <- new.env(parent=env)
            percent <- function(x, y) 100*length(x)/length(y)
            env1$Equal <- env1$Unequal <- function(...) sys.call()
            env1$Percent <- function(denom="all", fn=percent) {
              if (is.null(summary)) {
                if (identical(denom, "all")) summary <<- function(x) fn(x, values)
                else if (identical(denom, "row")) summary <<- function(x) fn(x, values[rowsubset])
                else if (identical(denom, "col")) summary <<- function(x) fn(x, values[colsubset])
                else if (is.call(denom) && deparse(denom[[1]]) %in% c("Equal", "Unequal")) { 
                    summary <<- local({
                        pctdenom <<- sapply(as.list(denom), deparse, width.cutoff = 500L)
             		pctsubset <<- pctdenom[1] == "Equal"
                    	function(x) {
			    fn(x, values[pctsubset])
			}})
		} else if (is.logical(denom)) summary <<- function(x) fn(x, values[denom])
		else summary <<- function(x) fn(x, denom)
                summaryname <<- "Percent"
              } else
    	        stop("Summary fn not allowed with 'Percent'")
            }
            eval(e, env1)
	} else if (fn == "Arguments") {
	    if (is.null(arguments)) 
	      arguments <- e
	    else
	      stop(gettextf("Duplicate Arguments list: %s and %s", deparse(arguments), deparse(e)))
        } else if (fn == "DropEmpty") {
            env1 <- new.env(parent = env)
            env1$DropEmpty <- function(empty = "", which = c("row", "col", "cell")) {
              good <- which %in% c("row", "col", "cell")
              if (!all(good))
              	stop(gettextf("bad 'which' value(s):  %s in %s", 
                              paste0("'", which[!good], "'", collapse = ","), deparse(e)), 
                     call. = FALSE)
              dropcell <<- "cell" %in% which
              droprow <<- "row" %in% which
              dropcol <<- "col" %in% which
              empty <<- empty
            }
            empty <- NULL
            eval(e, env1)
        } else if (fn != "Heading" && !identical(e, 1)) {
    	    arg <- eval(e, env)
    	    asis <- inherits(arg, "AsIs")
    	    if (asis || is.vector(arg) || inherits(arg, "labelledSubset")) {
    	    	if (missing(n)) n <- length(arg)
    	    	else if (n != length(arg))
    	    	    stop(gettextf("Argument '%s' is not length %d", deparse(e), n))
    	    }
    	    
    	    if (!asis && is.logical(arg)) {
    	    	arg <- arg & !is.na(arg)
    	    	if (i <= length(rowargs))
    	    	    rowsubset <- rowsubset & arg
    	    	else
    	    	    colsubset <- colsubset & arg
    	    } else if (asis || is.atomic(arg)) {
    	    	if (is.null(values)) {
    	    	    values <- arg
    	    	    valuename <- e
    	    	} else 
    	    	    stop(gettextf("Duplicate values: %s and %s", deparse(valuename),
    	    	         deparse(e)))
    	    } else if (is.function(arg)) {
    	    	if (is.null(summary)) {
    	    	    summary <- arg
    	    	    summaryname <- e
    	    	} else
    	    	    stop(gettextf("Duplicate summary fn: %s and %s", deparse(summaryname),
    	    	         deparse(e)))
    	    } else 
    	    	stop(gettextf("Unrecognized entry '%s'", deparse(e)))
        } 
    }
    if (!is.null(pctdenom)) { # We need a second pass to find the subsets
	for (i in seq_along(allargs)) {
	    e <- allargs[[i]]
	    fn <- ""
	    if (is.call(e)) 
	    	fn <- deparse(e[[1]])
	    if (!(fn %in% c(".Format", "Justify", "Percent", "Heading"))
	        && !identical(e, 1)) {
	        arg <- eval(e, env)
	        asis <- inherits(arg, "AsIs")
	        if (!asis && is.logical(arg)) {
	            if (inherits(arg, "labelledSubset")) {
	    		argexpr <- attr(arg, "label")
	    	    	arg <- arg & !is.na(arg)
	    	    	if (pctdenom[1] == "Equal" && argexpr %in% pctdenom[-1])
	    	    	    pctsubset <- pctsubset & arg
	    	    	else if (pctdenom[1] == "Unequal" && argexpr %in% pctdenom[-1])
	    	    	    pctsubset <- pctsubset | !arg
	    	    } else
	    	    	pctsubset <- pctsubset & !is.na(arg) & arg
	        }
	    }
	}
    }
    	
    if (missing(n))
    	stop(gettextf("Length of %s ~ %s is indeterminate", deparse(rowterm), 
    		      deparse(colterm)))    
    if (is.null(summary)) {
	if (!is.null(arguments))
	    stop(gettextf("'%s specified without summary function", deparse(arguments)))
        summary <- length
    }
    if (is.null(values) && is.null(arguments)) values <- rep(NA, n)
    subset <- rowsubset & colsubset 
    if (is.null(arguments)) 
	value <- summary(values[subset])
    else {
	arguments[[1]] <- summary
	for (i in seq_along(arguments)[-1]) {
	    arg <- eval(arguments[[i]], env)
	    if (length(arg) == n) 
		arg <- arg[subset]
	    arguments[[i]] <- arg
	}
	if (!is.null(values)) {
	    named <- !is.null(names(arguments))
	    for (i in rev(seq_along(arguments)[-1])) {
		arguments[[i+1]] <- arguments[[i]]
		if (named) names(arguments)[i+1] <- names(arguments)[i]
	    }
	    arguments[[2]] <- values[subset]
	    if (named) names(arguments)[2] <- ""
	}
	value <- eval(arguments, env)
    }
    if (length(value) != 1) {
	warning(gettextf("Summary statistic is length %d", length(value)), call. = FALSE)
    	value <- value[1]
    }
    structure(list(value), n=n, format=format, 
              justification=justification,
    	      dropcell = ifelse(dropcell && !any(subset), empty, NA_character_),
    	      droprow = droprow && !any(rowsubset), 
    	      dropcol = dropcol && !any(colsubset))
}

# This moves column names into their own column
moveColnames <- function(labels, do_move = (names != "")) {
    attrs <- attributes(labels)
    names <- colnames(labels)
    colnamejust <- attrs$colnamejust
    justification <- attrs$justification
    dropcell <- attrs$dropcell
    for (i in rev(seq_along(do_move))) {
    	if (do_move[i]) {
	    before <- seq_len(i-1)
	    after <- seq_len(ncol(labels) - i + 1) + i - 1
    	    labels <- cbind(labels[,before,drop=FALSE], "", labels[,after,drop=FALSE])
	    labels[1,i] <- names[i]
	    names <- c(names[before], "", "", names[after][-1])
	    if (length(colnamejust)) {
	    	colnamejust <- c(colnamejust[before], NA_character_, colnamejust[after])
	    }
	    if (length(justification)) 
	    	justification <- cbind(justification[,before,drop=FALSE], 
	    	    NA_character_, justification[,after,drop=FALSE])
	    if (length(dropcell))
	    	dropcell <- cbind(dropcell[,before,drop=FALSE],
	    			  NA_character_, dropcell[,after,drop=FALSE])
	}
    }
    attrs$colnamejust <- colnamejust
    attrs$justification <- justification
    attrs$dropcell <- dropcell
    attrs$dim <- dim(labels)
    attrs$dimnames[[2]] <- names
    attributes(labels) <- attrs
    labels
}
    	
getLabels <- function(e, rows=TRUE, justify=NA, head=NULL, suppress=0,
		      env) {
    op <- ""
    justification <- NULL
    colnamejust <- character(0)
    Heading <- head
    result <- if (rows) matrix(NA, ncol=0, nrow=1)
    	      else      matrix(NA, ncol=1, nrow=0)
    nrl <- ncl <- leftjustify <- leftheading <- leftsuppress <- 
           leftjustification <- leftcolnamejust <- 
           nrr <- ncr <- rightjustify <- rightheading <- rightsuppress <-
           rightjustification <- rightcolnamejust <- NULL
    nearData <- leftnearData <- rightnearData <- TRUE
    getLeft <- function() {
	nrl <<- nrow(leftLabels)
	ncl <<- ncol(leftLabels)
	leftjustify <<- attr(leftLabels, "justify")
        leftheading <<- attr(leftLabels, "Heading")
	leftsuppress <<- attr(leftLabels, "suppress")
	leftjustification <<- attr(leftLabels, "justification")
	leftcolnamejust <<- attr(leftLabels, "colnamejust")
	leftnearData <<- attr(leftLabels, "nearData")
    }
    getRight <- function() {
	nrr <<- nrow(rightLabels)
	ncr <<- ncol(rightLabels)
	rightjustify <<- attr(rightLabels, "justify")
        rightheading <<- attr(rightLabels, "Heading")
	rightsuppress <<- attr(rightLabels, "suppress")
	rightjustification <<- attr(rightLabels, "justification")
	rightcolnamejust <<- attr(rightLabels, "colnamejust")
	rightnearData <<- attr(rightLabels, "nearData")
    }
    if (is.call(e) && (op <- deparse(e[[1]])) == "*")  {
        leftLabels <- getLabels(e[[2]], rows, justify, head, suppress, env)
        getLeft()
	# Heading and justify are the settings to carry on to later terms
	# justification is the matrix of justifications for
	# each label
	righthead <- Heading <- leftheading
	suppress <- leftsuppress
	nearData <- leftnearData
	if (!is.null(leftjustify))
	    justify <- leftjustify

	rightLabels <- getLabels(e[[3]], rows, justify, righthead, suppress, env)
	getRight()
	Heading <- rightheading
	suppress <- rightsuppress
	
	if (!is.null(rightjustify))
	    justify <- rightjustify

	if (rows) {
	    result <- justification <- matrix(NA_character_, nrl*nrr, ncl + ncr)
	    colnames(result) <- c(colnames(leftLabels), colnames(rightLabels))
	    colnamejust <- c(leftcolnamejust, rightcolnamejust)
	    for (i in seq_len(nrl)) {
		j <- 1 + (i-1)*nrr
		k <- seq_len(ncl)
		result[j, k] <- leftLabels[i,]
		if (!is.null(leftjustification))
		    justification[j, k] <- leftjustification[i,]
		j <- (i-1)*nrr + seq_len(nrr)
		k <- ncl+seq_len(ncr)
		result[j, k] <- rightLabels
		if (!is.null(rightjustification))
		    justification[j, k] <- rightjustification
	    }
	} else {
	    result <- justification <- matrix(NA_character_, nrl + nrr, ncl*ncr)
	    for (i in seq_len(ncl)) {
		j <- seq_len(nrl)
		k <- 1 + (i-1)*ncr
		result[j, k] <- leftLabels[,i]
		if (!is.null(leftjustification))
		    justification[j,k] <- leftjustification[,i]
		j <- nrl+seq_len(nrr)
		k <- (i-1)*ncr + seq_len(ncr)
		result[j, k] <- rightLabels
		if (!is.null(rightjustification))
		    justification[j,k] <- rightjustification
	    }
	}
    } else if (op == "+") {
        leftLabels <- getLabels(e[[2]], rows, justify, NULL, suppress, env)
        getLeft()
	Heading <- leftheading

	rightLabels <- getLabels(e[[3]], rows, justify, NULL, suppress, env)
	getRight()
	Heading <- rightheading
	suppress <- rightsuppress
	neardata <- leftnearData & rightnearData # neardata=FALSE is needed for Hline

	if (rows) {
	    # Here we have a problem:  we need to stack two things, each of which
	    # may have column names.  We use the following rule:
	    #  - if the column names for both things match, just use them.
	    #  - if the left one has a name, and the right doesn't, use the left name
	    #  - if both have names that don't match, add them as extra column(s)
	    #  - if the right has a name, and the left doesn't, treat as unmatched names
	    
	    leftnames <- colnames(leftLabels)
	    if (is.null(leftnames)) leftnames <- rep("", ncl)
	    rightnames <- colnames(rightLabels)
	    if (is.null(rightnames)) rightnames <- rep("", ncr)
	    if (!identical(rightnames, rep("", ncr)) &&
	        !identical(leftnames, rightnames)) {
	        rightLabels <- moveColnames(rightLabels)
		# some properties may have changed; just get them again
	        getRight()
	        leftLabels <- moveColnames(leftLabels)
	        getLeft()
		Heading <- rightheading
	        rightnames <- rep("", ncr)
	        leftnames <- rep("", ncl)
	    }    
	    cols <- max(ncl, ncr)
	    # Pad all to same width
	    padblank <- rep("", abs(ncr - ncl))
	    padNA    <- rep(NA_character_, abs(ncr - ncl))
	    if (ncl < ncr) {
	    	padblankmat <- matrix("", nrl, abs(ncr - ncl))
	    	padNAmat <- matrix(NA_character_, NROW(leftjustification), abs(ncr - ncl)) 
	    	if (leftnearData) {
	    	    leftnames <- c(padblank, leftnames)
	    	    if (length(leftcolnamejust)) 
	    	        leftcolnamejust <- c(padNA, leftcolnamejust)
	    	    leftLabels <- cbind(padblankmat, leftLabels)
	    	    if (!is.null(leftjustification)) 
	    	        leftjustification <- cbind(padNA, leftjustification)
	    	} else {
	    	    leftnames <- c(leftnames, padblank)
	    	    if (length(leftcolnamejust)) 
	    		leftcolnamejust <- c(leftcolnamejust, padNA)
	    	    leftLabels <- cbind(leftLabels, padblankmat)
	    	    if (!is.null(leftjustification)) 
	    		leftjustification <- cbind(leftjustification, padNAmat)
	    	}
	    	ncl <- ncr
	    } else if (ncl > ncr) {
	    	padblankmat <- matrix("", nrr, abs(ncr - ncl))
	    	padNAmat <- matrix(NA_character_, NROW(rightjustification), abs(ncr - ncl)) 
	    	if (rightnearData) {
	    	    rightnames <- c(padblank, rightnames)
	    	    if (length(rightcolnamejust)) 
	    		rightcolnamejust <- c(padNA, rightcolnamejust)
	    	    rightLabels <- cbind(padblankmat, rightLabels)
	    	    if (!is.null(rightjustification)) 
	    		rightjustification <- cbind(padNAmat, rightjustification)
	    	} else {
	    	    rightnames <- c(rightnames, padblank)
	    	    if (length(rightcolnamejust))
	    	  	rightcolnamejust <- c(rightcolnamejust, padNA)
	    	    rightLabels <- cbind(rightLabels, padblankmat)
	    	    if (!is.null(rightjustification)) 
	    	    	rightjustification <- cbind(rightjustification, padNAmat)
	    	}
	    	ncr <- ncl
	    }
	    result <- matrix("", nrl + nrr, cols)
	    justification <- matrix(NA_character_, nrl + nrr, cols)
	    colnames <- rep("", cols)
	    colnamejust <- rep(NA_character_, cols)
	    j <- seq_len(nrl)
	    result[j, ] <- leftLabels
	    colnames <- leftnames
	    if (length(leftcolnamejust))
	        colnamejust <- leftcolnamejust	    
	    if (length(leftjustification))
		justification[j, ] <- leftjustification

	    j <- nrl+seq_len(nrr)
	    result[j, ] <- rightLabels
	    
	    if (!is.null(rightjustification))
		justification[j, ] <- rightjustification 
	    if (!is.null(head)) {
		colnames[1] <- head
		head <- NULL
	    }
	    colnames(result) <- colnames
	} else {
	    nrows <- max(nrl, nrr)
	    result <- matrix("", nrows, ncl + ncr)
	    justification <- matrix(NA_character_, nrows, ncl + ncr)
	    j <- seq_len(nrl)
	    if (leftnearData)
	    	j <- j + (nrows - nrl)
	    k <- seq_len(ncl)
	    result[j, k] <- leftLabels
	    if (!is.null(leftjustification))
		justification[j, k] <- leftjustification
	    j <- seq_len(nrr)
	    if (rightnearData)
	    	j <- j + (nrows - nrr)
	    k <- ncl+seq_len(ncr)
	    result[j,k] <- rightLabels
	    if (!is.null(rightjustification))
		justification[j, k] <- rightjustification
	    if (!is.null(head)) {
		result <- rbind(rep(NA_character_, ncol(result)),
				result)
		result[1,1] <- head
		justification <- rbind(justification[1,], justification)
	    }
	}
    } else if (op == "(") {
    	return(getLabels(e[[2]], rows, justify, head, suppress, env))
    } else if (op == ".Format") {
    	result <- if (rows) matrix(NA, ncol=0, nrow=1)
    		  else      matrix(NA, ncol=1, nrow=0)
    } else if (op == "Heading") {
    	env1 <- new.env(parent = env)
    	env1$Heading <- function(name = NULL, override = TRUE, character.only = FALSE,
    				 nearData = TRUE) {
    	    if (missing(name))
    	    	suppress <<- suppress + 1
    	    else {
    	        if (!character.only)
    	    	    name <- as.character(substitute(name))
    	        if (!is.logical(override) || is.na(override))
    	            stop(gettextf("'%s' argument in '%s' must be TRUE or FALSE",
    	            	      "override", deparse(e)), call. = FALSE)
    	        if (suppress <= 0 && (is.null(Heading) || override)) {
    	            Heading <<- as.character(name)
    	            suppress <<- 0
    	        } else
    	            suppress <<- suppress - 1
    	        nearData <<- nearData
    	    }
    	}
    	eval(e, env1)
    } else if (op == "Justify") {
    	justify <- as.character(e[[2]])
    } else if (op == "Arguments") {
	#suppress <- suppress + 1
    } else if (suppress > 0) {  # The rest just add a single label; suppress it
    	suppress <- suppress - 1
    } else if (!is.null(head)) {
    	result <- matrix(head, 1,1, dimnames=list(NULL, ""))
    	Heading <- NULL
    } else if (op == "Percent") {
        result <- matrix(gettext("Percent"), 1,1, dimnames=list(NULL, ""))
    } else if (op == "DropEmpty") { # do nothing
    } else if (identical(e, 1)) 
    	result <- matrix(gettext("All"), 1,1, dimnames=list(NULL, ""))
    else
    	result <- matrix(deparse(e), 1,1, dimnames=list(NULL, ""))
    if (is.null(justification))
    	justification <- matrix(justify, nrow(result), ncol(result))
    stopifnot(identical(dim(result), dim(justification)))
    structure(result, justification = justification, 
    	colnamejust = colnamejust, justify = justify,
   	Heading = Heading, suppress = suppress,
   	nearData = nearData)
}

expandExpressions <- function(e, env) {
    if (is.call(e)) {
	if ((op <- deparse(e[[1]])) %in% c("*", "+", "~", "(", "=") ) {
	    e[[2]] <- expandExpressions(e[[2]], env)
	    if (length(e) > 2)
		e[[3]] <- expandExpressions(e[[3]], env)
	} else if (op == "Format" || op == ".Format" 
	        || op == "Heading" || op == "Justify"
	        || op == "Percent" || op == "Arguments"
		|| op == "DropEmpty")
	    e
	else {
	    v <- eval(e, envir=env)
	    if (is.language(v)) 
		e <- expandExpressions(v, env)
	}
    }
    e
}

collectFormats <- function(table) {
    formats <- list()
    recurse <- function(e) {
    	if (is.call(e)) {
    	    if ((op <- deparse(e[[1]])) %in% c("*", "+", "~", "(") ) {
    	    	e[[2]] <- recurse(e[[2]])
    	    	if (length(e) > 2)
	    	    e[[3]] <- recurse(e[[3]])
    	    } else if (op == c("Format")) {
    	    	if (length(e) == 2 && is.null(names(e))) {
    	    	    if (is.language(e[[c(2,1)]]))
    	    	    	e[[c(2,1)]] <- eval(e[[c(2,1)]], environment(table))
    	    	    formats <<- c(formats, list(e[[2]]))
    	    	} else {
    	    	    e[[1]] <- format
    	    	    formats <<- c(formats, list(e))
    	    	}    
    	    	e <- call(".Format", length(formats))
    	    }
    	}
    	e
    }
    result <- recurse(table)
    structure(result, fmtlist=formats)
}

checkDenomExprs <- function(e, subsetLabels) {
    if (is.call(e)) 
	if ((op <- deparse(e[[1]])) %in% c("*", "+", "~", "(", "=") ) {
	    checkDenomExprs(e[[2]], subsetLabels)
	    if (length(e) > 2)
		checkDenomExprs(e[[3]], subsetLabels)
	} else if (op == "Percent") {
	    e <- match.call(Percent, e)[["denom"]]
	    if (is.call(e) && deparse(e[[1]]) %in% c("Equal", "Unequal"))
		for (i in seq_along(e)[-1])
		    if (!(deparse(e[[i]]) %in% subsetLabels))
			stop(gettextf("In %s\n'%s' is not a subset label.  Legal labels are\n%s",
				      deparse(e), deparse(e[[i]]),
			              paste(subsetLabels, collapse=", ")), call. = FALSE)
	}
}

collectSubsets <- function(e) {
    result <- c()
    if (is.call(e)) {
	if ((op <- deparse(e[[1]])) %in%  c("*", "+", "~", "(", "=") ) {
	    result <- c(result, collectSubsets(e[[2]]))
	    if (length(e) > 2)
		result <- c(result, collectSubsets(e[[3]]))
	} else if (op == "labelSubset") 
	    result <- c(result, match.call(labelSubset, e)[["label"]])
    }
    result
}

# This both expands factors and rewrites "bindings"

expandFactors <- function(e, env) {
    op <- ""
    if (is.call(e) && (op <- deparse(e[[1]])) %in% c("*", "+") ) 
    	call(op, expandFactors(e[[2]],env),expandFactors(e[[3]],env))
    else if (op == "(")
    	expandFactors(e[[2]],env)
    else if (op == "=") {
    	rhs <- expandFactors(e[[3]], env)
    	if (is.call(rhs) && deparse(rhs[[1]]) == "*"
    	 && is.call(rhs[[2]]) && deparse(rhs[[c(2,1)]]) == "Heading") {
    	    rhs[[c(2,2)]] <- as.name(deparse(e[[2]]))
    	    rhs
    	} else
    	    call("*", call("Heading", as.name(deparse(e[[2]]))), rhs)
    } else if (op == ".Format" || op == "Heading" || 
               op == "Justify" || op == "Percent" || 
    	       op == "Arguments" || op == "DropEmpty")
    	e
    else {
    	v <- eval(e, envir=env)
    	if (is.factor(v) & !inherits(v, "AsIs")) 
    	    e <- Factor(v, expr=e, override=FALSE)
    	e
    }
}


# A sum of products is a list whose elements are atoms or products of atoms.

sumofprods <- function(e) {
    if (!is.language(e)) return(list(e))
    if (is.expression(e)) e <- e[[1]]
    if (is.name(e)) result <- list(e)
    else {
	chr <- deparse(e[[1]])
	if (chr == "+") result <- c(sumofprods(e[[2]]),sumofprods(e[[3]]))
    	else if (chr == "*") {
	    left <- sumofprods(e[[2]])
	    right <- sumofprods(e[[3]])
	    result <- list()
	    for (i in 1:length(left)) 
	       for (j in 1:length(right)) 
		    result <- c(result, list(call("*", left[[i]], right[[j]])))
    	} else if (chr == "(") result <- sumofprods(e[[2]])
    	else if (chr == "~") stop("Nested formulas not supported")
    	else result <- list(e)

    }    	
    result
}

tabledims <- function(e) {
    if (identical(e,1)) return(list(1))
    if (!is.language(e)) stop('Need an expression')
    if (is.expression(e)) e <- e[[1]]
    if (is.name(e)) result <- list(e)
    else {
        result <- list()
	chr <- deparse(e[[1]])
	if (chr == "~") {
	    if (length(e) == 2)
		result <- c(result, tabledims(e[[2]]))
	    else
	    	result <- c(result, tabledims(e[[2]]),tabledims(e[[3]]))
    	} else result <- list(e)
    }    	
    if (length(result) > 2) stop("Only 2 dim tables supported")
    result
}

tabular <- function(table, ...) 
    UseMethod("tabular")
    
tabular.default <- function(table, ...) {
    tabular.formula(as.formula(table, env=parent.frame()), ...)
}

tabular.formula <- function(table, data=NULL, n, suppressLabels=0, ...) {
    formula <- table
    if (length(list(...)))
	warning(gettextf("extra argument(s) %s will be disregarded",
			 paste(sQuote(names(list(...))), collapse = ", ")),
		domain = NA)
    if (missing(n) && inherits(data, "data.frame"))
    	n <- nrow(data)
    if (is.null(data))
    	data <- environment(table)
    else if (is.list(data))
    	data <- list2env(data, parent=environment(table))
    else if (!is.environment(data))
    	stop("'data' must be a dataframe, list or environment")
    	
    table <- expandExpressions(table, data)
    table <- collectFormats(table)
    dims <- tabledims(table)
    if (length(dims) == 1) dims <- c(list(quote((` `=1))), dims)
    dims[[1]] <- expandFactors(dims[[1]], data)
    rlabels <- getLabels(dims[[1]], rows=TRUE, suppress=suppressLabels, env = data)
    suppressLabels <- attr(rlabels, "suppress")
    justify <- attr(rlabels, "justify")
    dims[[2]] <- expandFactors(dims[[2]], data)
    clabels <- getLabels(dims[[2]], rows=FALSE, justify=justify,
			 suppress=suppressLabels, env = data)
    
    # Check if the Percent calls name nonexistent terms
    subsetLabels <- unique(c(collectSubsets(dims[[1]]), collectSubsets(dims[[2]])))
    checkDenomExprs(dims[[1]], subsetLabels)
    checkDenomExprs(dims[[2]], subsetLabels)    
    
    rows <- sumofprods(dims[[1]])
    cols <- sumofprods(dims[[2]])

    result <- NULL
    formats <- NULL
    justifications <- NULL
    dropcells <- NULL
    
    droprow <- rep(TRUE, length(rows))
    dropcol <- rep(TRUE, length(cols))
    for (i in seq_along(rows)) {
    	row <- NULL
    	rowformats <- NULL
    	rowjustification <- NULL
    	rowdropcell <- NULL
    	for (j in seq_along(cols)) {
    	    # term2table checks that n matches across calls
    	    term <- term2table(rows[[i]], cols[[j]], data, n)
    	    n <- attr(term, "n")
    	    format <- attr(term, "format")
    	    justification <- attr(term, "justification")
    	    dropcell <- attr(term, "dropcell")
    	    droprow[i] <- droprow[i] && attr(term, "droprow")
    	    dropcol[j] <- dropcol[j] && attr(term, "dropcol")
    	    row <- cbind(row, term)
    	    rowformats <- cbind(rowformats, format)
    	    rowjustification <- cbind(rowjustification, justification)
    	    rowdropcell <- cbind(rowdropcell, dropcell)
    	}
    	result <- rbind(result, row)
    	formats <- rbind(formats, rowformats)
    	justifications <- rbind(justifications, rowjustification)
    	dropcells <- rbind(dropcells, rowdropcell)
    }
    if (any(c(droprow, dropcol))) {
    	result <- result[!droprow, !dropcol, drop = FALSE]
    	formats <- formats[!droprow, !dropcol]
    	justifications <- justifications[!droprow, !dropcol, drop = FALSE]
    	dropcells <- dropcells[!droprow, !dropcol, drop = FALSE]
    	save <- oldClass(rlabels)
    	oldClass(rlabels) <- c("tabularRowLabels", save)
    	rlabels <- rlabels[!droprow,, drop = FALSE]
    	oldClass(rlabels) <- save
    	save <- oldClass(clabels)
    	oldClass(clabels) <- c("tabularColLabels", save)
    	clabels <- clabels[, !dropcol, drop = FALSE]
    	oldClass(clabels) <- save
    }
    structure(result, formula=formula, rowLabels=rlabels, colLabels=clabels, table=table,
    	      formats = formats, justification = justifications, dropcells = dropcells,
    	      class = "tabular")
}

justify <- function(x, justification="c", width=max(nchar(x))) {
    justification <- rep(justification, len=length(x))
    change <- justification %in% c("c", "l", "r")
    if (!any(change)) return(x)
    y <- x[change]
    justification <- justification[change]
    y <- sub("^ *", "", y)
    y <- sub(" *$", "", y)
    width <- rep(width, len=length(x))
    width <- width[change]
    lens <- nchar(y)
    ind <- justification == "c"
    if (any(ind)) {
    	left <- (width[ind] - lens[ind]) %/% 2
    	right <- width[ind] - lens[ind] - left
    	y[ind] <- sprintf("%*s%s%*s", left, "", y[ind], right, "")
    }
    ind <- justification == "l"
    if (any(ind)) {
    	right <- width[ind] - lens[ind]
    	y[ind] <- sprintf("%s%*s", y[ind], right, "")
    }
    ind <- justification == "r"
    if (any(ind)) {
    	left <- width[ind] - lens[ind]
    	y[ind] <- sprintf("%*s%s", left, "", y[ind])
    }
    x[change] <- y
    x
}

latexNumeric <- function(chars, minus=TRUE, leftpad=TRUE, rightpad=TRUE,
			 mathmode=TRUE) {
    regexp <- "^( *)([-]?)([^ -][^ ]*)( *)$"
    leadin <- sub(regexp, "\\1", chars)
    sign <- sub(regexp, "\\2", chars)
    rest <- sub(regexp, "\\3", chars)
    tail <- sub(regexp, "\\4", chars)
    
    if (minus && any(neg <- sign == "-")) {
    	if (any(leadin[!neg] == ""))
    	    leadin <- sub("^", " ", leadin)
    	leadin[!neg] <- sub(" ", "", leadin[!neg])
    	sign[!neg] <- "\\phantom{-}"
    }
    if (leftpad && any(ind <- leadin != "")) 
    	leadin[ind] <- paste("\\phantom{", 
    	                     gsub(" ", "0", leadin[ind]),
    	                     "}", sep="")
    if (rightpad && any(ind <- tail != ""))
    	tail[ind] <- paste("\\phantom{",
    			   gsub(" ", "0", tail[ind]),
    			   "}", sep="")
    if (mathmode)
    	paste("$", leadin, sign, rest, tail, "$", sep="")
    else
    	paste(leadin, sign, rest, tail, sep="")
}

format.tabular <- function(x, digits=4, justification="n", 
                           latex=FALSE, html=FALSE, 
                           leftpad = TRUE, rightpad = TRUE, minus = TRUE, mathmode = TRUE, ...) {
    if (latex && html) stop("Only one of 'latex' and 'html' may be requested")
    result <- unclass(x) 
    formats <- attr(x, "formats")
    table <- attr(x, "table")
    fmtlist <- attr(table, "fmtlist")
    justify <- attr(x, "justification")
    justify[is.na(justify)] <- justification
    dropcells <- attr(x, "dropcells")
    ischar <- sapply(result, is.character)
    chars <- matrix(NA_character_, nrow(result), ncol(result))
    chars[ischar] <- unlist(result[ischar])
    lengths <- lapply(result, length)
    
    for (i in seq_len(ncol(result))) {
        ind <- col(result) == i & is.na(formats) & !ischar & 
        	lengths == 1 & is.na(dropcells)
	if (any(ind)) {
            x <- do.call(c, result[ind])
    	    chars[ind] <- format(x, digits=digits, ...)
    	    if (is.numeric(x)) {
 		if (latex)
    	    	    chars[ind] <- latexNumeric(chars[ind], leftpad = leftpad, rightpad = rightpad, minus = minus, mathmode = mathmode)
    	    	else if (html)
    	    	    chars[ind] <- htmlNumeric(chars[ind], leftpad = leftpad, rightpad = rightpad, minus = minus)
    	    }
    	}
    }
    for (i in seq_along(fmtlist)) {
    	ind <- !is.na(formats) & formats == i & is.na(dropcells)
    	if (any(ind)) {        
            call <- fmtlist[[i]]
            isformat <- identical(call[[1]], format)
            if (isformat) skip <- ischar | (lengths != 1)
            else skip <- ischar & FALSE
	    last <- length(call)
       	    x <- do.call(c, result[ind & !skip])
       	    call[[last+1]] <- x
       	    names(call)[last+1] <- "x"
       	    chars[ind & !skip] <- eval(call, environment(table))
       	    if (isformat) {
       	    	if (latex) {
       	    	    if (is.numeric(x))
       	    	    	chars[ind] <- latexNumeric(chars[ind], leftpad = leftpad, rightpad = rightpad, minus = minus, mathmode = mathmode)
       	    	    else
       	    	    	chars[ind] <- texify(chars[ind])
       	    	} else if (html) {
       	    	    if (is.numeric(x))
       	    	    	chars[ind] <- htmlNumeric(chars[ind], leftpad = leftpad, rightpad = rightpad, minus = minus)
       	    	    else
       	    	    	chars[ind] <- htmlify(chars[ind])
       	    	}
       	    }
       	}
    }
    chars[!is.na(dropcells)] <- dropcells[!is.na(dropcells)]
    if (!latex && !html)
    	for (i in seq_len(ncol(result))) 
    	    chars[,i] <- justify(chars[,i], justify[,i])
    chars[]
    chars
}