#' @encoding UTF-8
#' @title Untable an Aggregated Data Frame
#'
#' @description A method for recovering a \code{data.frame} out of summarized data, i.e. contingency table or aggregated data.
#' @param x the table object as a data.frame, table, or, matrix.
#' @param freq the column name of count values.
#' @param row.names row names to add to \code{data.frame} if any.
#' @param \dots Extra parameters ignored.
#' @seealso \code{\link{expand.grid}}, \code{\link{gl}}.
#' @examples
#' gss <- data.frame(
#' expand.grid(sex=c("female", "male"),
#' party=c("dem", "indep", "rep")),
#' count=c(279,165,73,47,225,191))
#'
#' print(gss) # aggregated data.frame
#'
#' # Then expand it:
#' GSS <- untable(gss, freq="count")
#' head(GSS)
#'
#' # Expand from a table or xtable object:
#' # Fisher's Tea-Tasting Experiment data
#' tea <- table(poured=c("Yes", "Yes", "Yes", "No","Yes","No", "No", "No"),
#' guess=c("Yes", "Yes", "Yes", "Yes", "No", "No","No","No"))
#'
#' untable(tea)
#'
#' # Expand with a vector of weights
#' untable(c(3,3,3), dimnames=list(c("Brazil","Colombia","Argentina")))
#'
#' @rdname untable
#' @export
`untable` <- function(x, ...) {
UseMethod("untable")
}
NULL
#' @rdname untable
#' @export
`untable.data.frame` <-
function(x,
freq = "Freq",
row.names = NULL,
...) {
if (all(is.na(match(freq, names(x)))))
stop(gettextf("Frequency column %s does not exist!", freq))
res <-
x[untable(x[, freq], type = "as.numeric")[, ],-grep(freq, names(x))]
rownames(res) <- row.names
class(res) <- c("untable", "data.frame")
return(res)
}
NULL
#' @param dimnames set the dimnames of object if required.
#' @param type the type of variable. If NULL, ordered factor is returned.
#' @param col.names column names to add to the data.frame.
#' @rdname untable
#' @export
`untable.default` <-
function(x,
dimnames = NULL,
type = NULL,
row.names = NULL,
col.names = NULL,
...) {
# coerce to table, such as also be able to handle vectors
x <- as.table(x)
if (!is.null(dimnames))
dimnames(x) <- dimnames
if (is.null(dimnames) &&
identical(type, "as.numeric"))
dimnames(x) <- list(seq_along(x))
# set a title for the table if it does not have one
# if(is.null(names(dimnames(x)))) names(dimnames(x)) <- ""
# if(length(dim(x))==1 && names(dimnames(x))=="") names(dimnames(x)) <- "Var1"
# replaced 26.3.2013
for (i in 1:length(dimnames(x)))
if (is.null(names(dimnames(x)[i])) ||
names(dimnames(x)[i]) == "")
if (length(dimnames(x)) == 1)
names(dimnames(x)) <- gettextf("Var%s", i)
else
names(dimnames(x)[i]) <- gettextf("Var%s", i)
res <-
as.data.frame(expand.grid(dimnames(x))[rep(1:prod(dim(x)), as.vector(x)), ])
row.names(res) <- NULL
if (!all(names(dimnames(x)) == ""))
colnames(res) <- names(dimnames(x))
# return ordered factors, if wanted...
if (is.null(type))
type <- "as.factor"
# recycle type:
if (length(type) < ncol(res))
type <- rep(type, length.out = ncol(res))
for (i in 1:ncol(res)) {
if (type[i] == "as.numeric") {
res[, i] <- as.numeric(as.character(res[, i]))
} else {
res[, i] <- eval(parse(text = gettextf("%s(res[,i])", type[i])))
}
}
# overwrite the dimnames, if requested
if (!is.null(row.names))
rownames(res) <- row.names
if (!is.null(colnames))
colnames(res) <- col.names
class(res) <- c("untable", "data.frame")
return(res)
}### end -- untable function
NULL
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.