Nothing
#' Convert table to huxtable
#'
#' This function converts a \code{etable} object to a \code{huxtable}.
#' The \code{\link[huxtable]{huxtable-package}} needs to be installed to use this function.
#'
#' \code{huxtable} allows to export formated tables to LaTeX, HTML, Microsoft Word,
#' Microsoft Excel, Microsoft Powerpoint, RTF and Markdown.
#'
#' Tables in knitr or rmarkdown documents of type LaTeX or Word
#' are converted by default.
#'
#'
#' @export
#' @rdname as_huxtable
#' @param x etable. Table to convert to a huxtable.
#' @param ... arguments passed on to \link[huxtable]{huxtable}.
#' @examples
#' \dontrun{
#' library(huxtable)
#' data(mtcars)
#' mtcars = apply_labels(mtcars,
#' mpg = "Miles/(US) gallon",
#' cyl = "Number of cylinders",
#' disp = "Displacement (cu.in.)",
#' hp = "Gross horsepower",
#' drat = "Rear axle ratio",
#' wt = "Weight (1000 lbs)",
#' qsec = "1/4 mile time",
#' vs = "Engine",
#' vs = c("V-engine" = 0,
#' "Straight engine" = 1),
#' am = "Transmission",
#' am = c("Automatic" = 0,
#' "Manual"=1),
#' gear = "Number of forward gears",
#' carb = "Number of carburetors"
#' )
#'
#' tab = mtcars %>%
#' tab_cols(total(), am %nest% vs) %>%
#' tab_cells(mpg, hp) %>%
#' tab_stat_mean() %>%
#' tab_cells(cyl) %>%
#' tab_stat_cpct() %>%
#' tab_pivot() %>%
#' set_caption("Table 1. Some variables from mtcars dataset.")
#'
#' ht = as_huxtable(tab)
#' ht
#' }
#' @rawNamespace if(getRversion() >= "3.6.0") {
#' S3method(huxtable::as_huxtable, etable)
#' S3method(huxtable::as_hux, etable)
#' } else {
#' export(as_huxtable.etable)
#' export(as_hux.etable)
#' }
as_huxtable.etable = function(x, ...) {
# is table empty?
if(NCOL(x)==0) {
ht <- huxtable::hux()
#huxtable::set_caption(ht, "Table is empty")
return(ht)
}
# Assign correct type to data columns (counts to integer)
xt <- as.data.frame(lapply(x, type.convert, as.is = TRUE),
optional = FALSE,
check.names = FALSE,
cut.names = FALSE,
col.names = names(x),
fix.empty.names = FALSE,
stringsAsFactors = FALSE
)
# start with default huxtable
ht <- huxtable::as_huxtable(xt, ...)[-1,] # delete first row with old columnnames
# Split row_labels of merged cells and save matrix
rown = character(0)
if(length(ht[[1]])>0) {
rown = as.matrix(do.call("rbind", strsplit(ht[[1]], "\\|")))
}
# Delete old row_labels
ht[,1] <- NULL
coln = character(0)
if(NCOL(ht)>0){
# Split column labels of merged cells
coln <- t(do.call("rbind", strsplit(names(ht), "\\|")))
top_left_corner = matrix("", nrow = NROW(coln), ncol = NCOL(rown))
coln = cbind(top_left_corner, coln)
}
# Atttach splitted row_labels
if(length(rown)>0) {
if(NCOL(ht) > 0) {
ht <- cbind(rown, ht)
} else {
ht <- huxtable::as_huxtable(rown, ...)
}
}
# Attach splitted column names
if(length(coln)>0) {
# Remove default data.frame names (V1, V2, ...)
coln[coln %in% paste0("V", seq_len(NCOL(ht)))] <- ""
if(NROW(ht)!=0) {
ht <- rbind(coln, ht)
} else {
ht <- huxtable::as_huxtable(coln, ...)
}
}
## Merge columns
# Iterate over rows
for(j in seq_len(NROW(ht))) {
# Add new labels and merge cells
# Restriction on row and column labels
if (j <= NROW(coln)) { # if in column with row labels
colnlab <- unique(ht[j, ])
} else { # if else, stay in rows with column labels
colnlab <- unique(ht[j, seq_len(NCOL(rown))])
}
for(r in colnlab) {
mergel <- which(ht[j, ] == r)
# Dom't merge comeplety, if row above is splitted
if (j > 1) {
rowabove <- attr(ht, "colspan")[j-1,]
} else {
rowabove <- rep(0, max(mergel))
}
# If row before is merged
if(any(rowabove[mergel] > 1)) {
# Get merged cells
limit <- rowabove[mergel]
limits <- limit[limit > 1]
# Merge cells only within merged cells above
start <- 1
for(l in limits) {
# If alternating labels exist, do nothing
if(isTRUE(all.equal(min(mergel):max(mergel), mergel))) {
ht <- huxtable::merge_cells(ht, j, na.omit(mergel[start:(start+l-1)]))
start <- start + l
}
}
} else {
# If alternating labels exist, do nothing
if(isTRUE(all.equal(min(mergel):max(mergel), mergel))) {
ht <- huxtable::merge_cells(ht, j, mergel)
}
}
}
}
# Merge rows
# Check which cells are already merged
tmp <- attr(ht, "colspan")
mergemat <- NULL # keep results here
for(j in seq_len(NROW(tmp))){
row <- rep(FALSE, length(tmp[j,]))
start <- 1
while(start < NCOL(tmp)) {
m <- tmp[j,][start]
if(m > 1) {
row[start:(start + m -1)] <- T
start <- start + m
} else {
start <- start + 1
}
}
mergemat <- rbind(mergemat, row)
}
#, merge columns
# Iterate over columns
for(j in seq_len(NCOL(ht))) {
# Add new labels and merge cells
# Restriction on row and column labels
if (j <= NCOL(ht)) { # if in column with column labels
rownlab <- na.omit(unique(ht[[j]]))
} else { # if in column without column labels
rownlab <- na.omit(unique(ht[[j]][seq_len(NROW(coln))]))
}
for(r in rownlab) {
mergel <- which(ht[[j]] == r)
if (j > 1) {
colbefore <- attr(ht, "rowspan")[,j-1]
} else {
colbefore <- rep(0, max(mergel))
}
# If col before is merged
if(any(colbefore[mergel] > 1)) {
# Get merged cells
limit <- colbefore[mergel]
limits <- limit[limit > 1]
start <- 1
for(l in limits) {
# If alternating labels exist and col is not merged , do nothing
if(isTRUE(all.equal(min(mergel):max(mergel), mergel)) & !any(mergemat[,j][mergel])) {
ht <- huxtable::merge_cells(ht, na.omit(mergel[start:(start+l-1)]), j)
start <- start + l
}
}
} else {
# If alternating labels exist and col is not merged , do nothing
if(isTRUE(all.equal(min(mergel):max(mergel), mergel)) & !any(mergemat[,j][mergel])) {
ht <- huxtable::merge_cells(ht, mergel, j)
}
}
}
}
# top-left corner
# corner_width = ncol(split_labels(x[[1]]))
# corner_height = ncol(split_labels(colnames(x)))
# ht = huxtable::merge_cells(ht, c(1, corner_height), 1)
# Check for caption
if(!is.null(attr(x, "caption")))
ht <- huxtable::set_caption(ht, attr(x, "caption"))
# set width to 100%
huxtable::width(ht) <- 1
if(NROW(coln)>0){
ht = huxtable::set_header_rows(ht, seq_len(NROW(coln)), TRUE)
if(NCOL(rown)>0){
ht = huxtable::merge_cells(
huxtable::set_colspan(ht, seq_len(NROW(coln)), seq_len(NCOL(rown)), 1),
seq_len(NROW(coln)), seq_len(NCOL(rown)))
}
}
return(ht)
}
#' @rdname as_huxtable
as_hux.etable = as_huxtable.etable
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.