#' Prepares a matrix for \code{htmlTable} from a list
#'
#' By putting all the output from the \code{\link{getDescriptionStatsBy}}
#' into a list, naming each element that we want in an \code{rgroup} we can
#' automatically merge everything and create an object ready for the
#' \code{\link[htmlTable]{htmlTable}}.
#'
#' @section The \code{rgroup} value:
#'
#' The value for the \code{rgroup} is by default the name of the list element. If you have
#' passed a list without a name for that particular element or if you have passed a
#' matrix it will look for a label set by the \pkg{Hmisc}\code{::\link[Hmisc]{label}} function.
#' For those elements that have only one row no \code{rgroup} is set, and the naming sequence
#' is the same as above but with an additional \code{\link[base:colnames]{rownames}} if the previous
#' two turn out empty. All this behavior is exemplified in the example.
#'
#' The \code{rgroup} value can be overridden by simply specifying a custom \code{rgroup} when
#' calling the \code{\link{htmlTable}} function.
#'
#' @section The \code{colnames} of the matrix:
#'
#' The function chooses the \code{\link[base]{colnames}} from the first element in
#' the \code{tlist}.
#'
#' @param ... One or more elements coming from \code{\link{getDescriptionStatsBy}}.
#' You can also provide pure output from the \code{\link{getDescriptionStatsBy}} function
#' and have the function merge this together with the \code{...} argument.
#' \emph{Note} that all elements must have the same \code{by} argument or you
#' will not be able to merge it into a list.
#' @param htmlTable_args Any arguments that should be passed to
#' \code{\link[htmlTable]{htmlTable}} function. The default is to remove
#' any css formatting for the \code{rgroup}.
#' @return \code{matrix} Returns a matrix object of class descList
#' @export
#' @example inst/examples/getDescriptionStatsBy_example.R
#' @importFrom utils tail
#' @family table functions
mergeDesc <- function(..., htmlTable_args = list()) {
tlist <- list()
dots <- list(...)
if (length(dots) > 0) {
for (i in 1:length(dots)) {
add_lst <- dots[[i]]
if (!is.list(add_lst)) {
add_lst <- list(add_lst)
if (!is.null(names(dots)) &&
names(dots)[i] != "") {
names(add_lst) <- names(dots)[i]
}
}
tlist <- append(
tlist,
add_lst
)
}
}
mx <- NULL
rgroup <- n.rgroup <- c()
pvals_rgroup <- list()
for (i in 1:length(tlist)) {
n <- names(tlist)[i]
if (is.null(n) || n == "") {
if (label(tlist[[i]]) != "") {
n <- label(tlist[[i]])
} else if (nrow(tlist[[i]]) == 1) {
n <- rownames(tlist[[i]])
} else {
n <- ""
}
}
mx <- rbind(
mx,
tlist[[i]]
)
if (nrow(tlist[[i]]) > 1) {
rgname <- n
rgno <- nrow(tlist[[i]])
if (tolower(tail(colnames(mx), 1)) == "p-value") {
pval <- list(mx[
nrow(mx) - nrow(tlist[[i]]) + 1,
ncol(mx)
])
mx[
nrow(mx) - nrow(tlist[[i]]) + 1,
ncol(mx)
] <- ""
names(pval)[1] <- as.character(i)
pvals_rgroup <- c(
pvals_rgroup,
pval
)
}
} else {
rownames(mx)[NROW(mx)] <- n
rgname <- ""
rgno <- 1
}
if (rgno != "") {
rgroup <- c(
rgroup,
rgname
)
n.rgroup <- c(
n.rgroup,
rgno
)
} else {
if (length(rgroup) == 0) {
rgroup <- ""
n.rgroup <- rgno
} else {
if (tail(rgroup, 1) == rgname) {
n.rgroup[length(n.rgroup)] <-
n.rgroup[length(n.rgroup)] + rgno
} else {
rgroup <- c(
rgroup,
rgname
)
n.rgroup <- c(
n.rgroup,
rgno
)
}
}
}
}
colnames(mx) <- colnames(tlist[[1]])
if (any(rgroup %in% names(htmlTable_args)) ||
any(n.rgroup %in% names(htmlTable_args))) {
stop(
"You have provided rgroup elements within",
" htmlTable_args argument and these will conflict",
" with the autogenerated rgroups."
)
}
if ("rgroup" %in% names(htmlTable_args) &
"n.rgroup" %in% names(htmlTable_args)) {
rgroup <- htmlTable_args$rgroup
n.rgroup <- htmlTable_args$n.rgroup
htmlTable_args$rgroup <- NULL
htmlTable_args$n.rgroup <- NULL
if ("P-value" %in% colnames(mx) & length(pvals_rgroup) != length(rgroup)) {
replacement_pvals <- rep(NA, length(rgroup))
replacement_pvals[n.rgroup > 1] <- pvals_rgroup
replacement_pvals[n.rgroup == 1] <- mx[, "P-value"][mx[, "P-value"] != ""]
mx[, "P-value"] <- ""
pvals_rgroup <- replacement_pvals
}
}
if (length(pvals_rgroup) > 0) {
attr(rgroup, "add") <- pvals_rgroup
}
if (length(htmlTable_args) > 0 && is.null(names(htmlTable_args))) {
stop("The htmlTable_args has to be a list or a vector with named elements")
}
if (!is.list(htmlTable_args)) {
htmlTable_args <- as.list(htmlTable_args)
}
structure(mx,
rgroup = rgroup,
n.rgroup = n.rgroup,
htmlTable_args = htmlTable_args,
class = c("descMrg", class(mx))
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.