#' Coerce an R Object To a Tidy Table
#'
#' Coerces R objects to a tidy tabular format. Recognized inputs include
#' tables from \code{Q}, arrays, matrices, data.frames, and pasted
#' tables (character matrices). Output will always be named and always
#' be either a vector or matrix.
#' @param x An object to be coerced to a tidy table.
#' @param ... Additional arguments passed to
#' \code{\link[flipTransformations]{ParseUserEnteredTable}} in the
#' case that \code{x} has character entries.
#' @return A \strong{named} matrix or
#' vector; a tidy version of \code{x}
#' @importFrom utils modifyList
#' @importFrom flipTransformations AsNumeric ParseUserEnteredTable ProcessQVariables
#' @importFrom stats setNames
#' @details \code{factors} will automatically be converted to numeric
#' variables (with a warning) using
#' \code{\link[flipTransformations]{AsNumeric}}.
#' @seealso \code{\link[flipTransformations]{AsNumeric}}
#' @importFrom flipU IsQTable
#' @export
AsTidyTabularData <- function(x, ...)
{
old.attrs <- attributes(x)
old.attrs <- old.attrs[!names(old.attrs) %in% c("dimnames", "dim", "row.names",
"names", "class")]
if (IsQTable(x))
{
x <- qTableToTidyTable(x)
if (!is.null(attr(x, "statistic")))
old.attrs$statistic <- attr(x, "statistic") # update if dropped extra stats
if (length(dim(x)) == 1L) # convert 1D array to named vector
x <- setNames(as.numeric(x), dimnames(x)[[1L]])
}else if (is.character(x))
{ # assume raw user-entered table
x <- as.matrix(x) # ParseEnteredData fails for vectors (since user-entered
## data is always a matrix
dots <- list(...)
dots$raw.matrix <- x
if (is.null(dots$want.data.frame))
dots$want.data.frame <- FALSE
x <- do.call("ParseUserEnteredTable", dots)
x <- AsNumeric(x)
}else if (is.data.frame(x))
{
## convert data.frame default row names to tidy table default Row 1, Row 2, etc.
#if (identical(attr(x, "row.names"), seq_len(nrow(x))))
# row.names(x) <- paste0("Row ", seq_len(nrow(x)))
x <- ProcessQVariables(x)
x <- as.matrix(AsNumeric(x, binary = FALSE, remove.first = FALSE))
}else if (is.factor(x))
{
tmp.names <- names(x)
if (is.null(tmp.names))
tmp.names <- paste0("Row ", seq_along(x))
x <- as.matrix(AsNumeric(data.frame(x, row.names = tmp.names),
binary = FALSE, remove.first = FALSE))
}else if (is.numeric(x))
{ # make sure has dimnames and is <= 2D
dims <- dim(x)
n.dim <- length(dims)
if (n.dim > 4)
{
stop("Cannot coerce an array of greater than four dimensions to a tidy table.")
}else if (n.dim == 4 || n.dim == 3)
{ # Make sure there are sensible dimnames, a statistic attribute,
# and flatten as if a QTable
x <- createArrayNames(x)
if (is.null(old.attrs$statistic))
old.attrs$statistic <- "UNKNOWN"
x <- do.call(paste0("flatten", n.dim, "DQTable"), list(x))
}else if (n.dim == 1L) # convert 1D array to named vector
x <- setNames(as.numeric(x), dimnames(x)[[1L]])
}else if (inherits(x, "CorrelationMatrix"))
{
corr.mat <- x$cor
attr(corr.mat, "statistic") <- "Correlation"
return(corr.mat)
}else
{
classes <- paste(class(x), collapse = ", ")
stop(gettextf("Cannot coerce object of type (%s) to a tidy table.",
sQuote(classes)))
}
#x <- setDimNames(x) # set labels
if (length(old.attrs) && length(attributes(x)))
attributes(x) <- modifyList(old.attrs, attributes(x))
if (is.null(dim(x)))
x <- AsNumeric(x)
else if (length(dim(x)) == 1L)
class(x) <- "numeric"
else if (!is.data.frame(x))
class(x) <- "matrix"
x
}
#' Converts a QTable to a tidy table
#' @param x a QTable (an array with attributes \code{"name"}, \code{"statistic"},
#' and \code{"questions"} and named dimensions)
#' @details If a Qtable contains multiple statistics, only the first will be used to
#' create the basic table
#' @return a matrix or vector with the same attributes (aside from possibly modified
#' dimensions and \code{dimnames}
#' @noRd
#' @importFrom flipU IsQTable
#' @keywords internal
qTableToTidyTable <- function(x)
{
stopifnot(IsQTable(x))
dims <- dim(x)
n.dim <- length(dims)
dim.names <- dimnames(x)
stat <- attr(x, "statistic")
has.only.one.stat <- !is.null(stat)
if (!has.only.one.stat && n.dim > 1)
{
stat <- dim.names[[n.dim]][1]
warning(gettextf("Multiple statistics detected; only the first in the table (%s) will be used.",
dQuote(stat)))
x <- GetFirstStat(x)
dims <- dim(x)
n.dim <- length(dims)
dim.names <- dimnames(x)
}
out <- if (length(dims) == 4L) # Two group variables
flatten4DQTable(x)
else if (length(dims) == 3L)
flatten3DQTable(x)
else
x
## convert to numeric
if (is.character(out))
{
if (all(out == "" | is.na(out) | !is.na(suppressWarnings(as.numeric(out)))))
storage.mode(out) <- "numeric"
else
warning("the supplied QTable contains character entries which could not be converted to numeric")
}
if (!has.only.one.stat) # need to update statistic attribute
attr(out, "statistic") <- stat
out
}
#' Get First Statistic From A QTable
#'
#' Drops any statistics from the array beyond the first
#' @param x a QTable
#' @return an array; the first statistic in the QTable; i.e. \code{x} with
#' only the first element of the last dimension returned
#' @details the statistics are assumed to be
#' contained in the last dimension of the array
#' @section Warning the subsetting into the array will results in length-1
#' dimensions of \code{x} will be dropped in the returned array
#' @noRd
#' @keywords internal
GetFirstStat <- function(x)
{
# QTables with this attribute always have only 1 statistic
if (!is.null(attr(x, "statistic")))
return(x)
text <- paste0("x[", paste(rep(",", length(dim(x))-1), collapse = ""), 1, "]")
eval(parse(text = text))
}
#' Flatten a 4D QTable to a matrix
#'
#' Takes a four-dimensional QTable (array) and flattens
#' it two a matrix. The dimensions are combined in a way
#' that mimics what is done in \code{Q}.
#' @param a a four dimensional array with all dimensions named.
#' @return a matrix with rownames and column names of dimension
#' \eqn{d1*d3 \times d2*d4} where \code{a} is \eqn{d1\times d2\times d3\times d4}
#' @examples
#' ta <- array(1:24, dim = 2:4)
#' dimnames(ta) <- list(c("one", "two"), letters[1:3], LETTERS[1:4])
#' out <- flipTables:::flatten3DQTable(ta)
#' all.equal(out["one: B", "c"], ta["one", "c", "B"])
#' @noRd
#' @keywords internal
flatten3DQTable <- function(a)
{
## Loop for 3D case
## d1 <- dim(a)[1]
## d2 <- dim(a)[2]
## d3 <- dim(a)[3]
## m <- matrix(0, d1*d3, d2)
## for ( i in 1:d1){
## for (j in 1:d2){
## for (k in 1:d3){
## m[(i-1)*d3 + k, j] = a[i, j, k]
## }
## }
## }
## m
dnames <- dimnames(a)
## Weird use of t below is to replicate Q behaviour
## The code:
## matrix(a, nrow = d1*d3, ncol = d3)
## would not result in same output as Q (the first dim
## is populated first/varies fastest in R, in Q the third
## dim is populated first/varies fastest)
out <- apply(a, 2L, t)
dimnames(out) <- list(combineNames(dnames[c(3, 1)]), dnames[[2]])
out
}
#' Flatten a 4D QTable to a matrix
#'
#' Takes a four-dimensional QTable (array) and flattens
#' it two a matrix. The dimensions are combined in a way
#' that mimics what is done in \code{Q}.
#' @param a a four dimensional array with all dimensions named.
#' @return a matrix with rownames and column names of dimension
#' \eqn{d1*d3 \times d2*d4} where \code{a} is \eqn{d1\times d2\times d3\times d4}
#' @examples
#' ta <- array(1:120, dim = 2:5)
#' dimnames(ta) <- list(c("one", "two"), letters[1:3], LETTERS[1:4], paste0("d", 1:5))
#' out <- flipTables:::flatten4DQTable(ta)
#' all.equal(out["C: two", "a: d3"], ta["two", "a", "C", "d3"])
#' @keywords internal
#' @noRd
flatten4DQTable <- function(a)
{
dnames <- dimnames(a)
## Commented out code below results in valid 2D table, but
## with wrong dimensions combined compared to Q output
## out <- apply(a, 2:3, t)
## out <- apply(aperm(out, c(2, 1, 3)), 2, t)
## dimnames(out) <- list(combineNames(dnames[c(3, 2)]),
## combineNames(dnames[c(4, 1)]))
out <- apply(a, c(2, 4), c)
tnames <- combineNames(dnames[c(3, 1)], flip = TRUE)
out <- t(apply(out, 1, t))
dimnames(out) <- list(combineNames(dnames[c(3, 1)], flip = TRUE),
combineNames(dnames[c(4, 2)], flip = FALSE))
out
}
#' Combine two lists of variable names
#'
#' Uses \code{\link[base]{expand.grid}} to create new
#' variable names from a two combined \code{QTable} dimensions
#' @param name.list list of length 2 containing character vectors
#' of possibly differing lengths; e.g. the result of \code{dimnames} on a
#' two-dimensional array
#' @return character vector of new names of length
#' \code{length(name.list[[1]])*length(name.list[[2]])}
#' @noRd
#' @keywords internal
combineNames <- function(name.list, flip = FALSE)
{
if (flip)
name.list <- rev(name.list)
name.grid <- expand.grid(name.list)
paste(name.grid$Var2, name.grid$Var1, sep = ": ")
}
#' Tries to create sensible row and column names if collapsing a
#' non-QTable 3D or 4D array
#' @param x a three or four dimensional array
#' @return a three or four dimensional array with all dimensions named
#' @seealso \code{\link{provideDimnames}}
#' @noRd
#' @keywords internal
createArrayNames <- function(x)
{
dim.names <- dimnames(x)
n.dim <- length(dim(x))
null.idx <- if (is.null(dim.names))
seq_len(n.dim)
else
which((vapply(dim.names, is.null, logical(1L))))
if (!length(null.idx))
return(x)
warning(gettextf("dimnames are missing for some dimensions of %s; creating some before proceeding",
deparse(substitute(x))), call. = FALSE)
base <- as.list(paste0("Dim", seq_len(n.dim)))
provideDimnames(x, base = base, sep = "_", unique = TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.