#' Data frame and Tables Pretty Formatting
#'
#' @param x A data frame. May also be a list of data frames, to export multiple
#' data frames into multiple tables.
#' @param sep Column separator.
#' @param header Header separator. Can be `NULL`.
#' @param cross Character that is used where separator and header lines cross.
#' @param empty_line Separator used for empty lines. If `NULL`, line remains
#' empty (i.e. filled with whitespaces).
#' @param format Name of output-format, as string. If `NULL` (or `"text"`),
#' returned output is used for basic printing. Can be one of `NULL` (the
#' default) resp. `"text"` for plain text, `"markdown"` (or
#' `"md"`) for markdown and `"html"` for HTML output.
#' @param title,caption,subtitle Table title (same as caption) and subtitle, as strings. If `NULL`,
#' no title or subtitle is printed, unless it is stored as attributes (`table_title`,
#' or its alias `table_caption`, and `table_subtitle`). If `x` is a list of
#' data frames, `caption` may be a list of table captions, one for each table.
#' @param footer Table footer, as string. For markdown-formatted tables, table
#' footers, due to the limitation in markdown rendering, are actually just a
#' new text line under the table. If `x` is a list of data frames, `footer`
#' may be a list of table captions, one for each table.
#' @param align Column alignment. For markdown-formatted tables, the default
#' `align = NULL` will right-align numeric columns, while all other
#' columns will be left-aligned. If `format = "html"`, the default is
#' left-align first column and center all remaining. May be a string to
#' indicate alignment rules for the complete table, like `"left"`,
#' `"right"`, `"center"` or `"firstleft"` (to left-align first
#' column, center remaining); or maybe a string with abbreviated alignment
#' characters, where the length of the string must equal the number of columns,
#' for instance, `align = "lccrl"` would left-align the first column, center
#' the second and third, right-align column four and left-align the fifth
#' column. For HTML-tables, may be one of `"center"`, `"left"` or
#' `"right"`.
#' @param by Name of column in `x` that indicates grouping for tables.
#' Only applies when `format = "html"`. `by` is passed down to
#' `gt::gt(groupname_col = by)`.
#' @param width Refers to the width of columns (with numeric values). Can be
#' either `NULL`, a number or a named numeric vector. If `NULL`, the width for
#' each column is adjusted to the minimum required width. If a number, columns
#' with numeric values will have the minimum width specified in `width`. If
#' a named numeric vector, value names are matched against column names, and
#' for each match, the specified width is used (see 'Examples'). Only applies
#' to text-format (see `format`).
#' @param table_width Numeric, or `"auto"`, indicating the width of the complete
#' table. If `table_width = "auto"` and the table is wider than the current
#' width (i.e. line length) of the console (or any other source for textual
#' output, like markdown files), the table is split into two parts. Else,
#' if `table_width` is numeric and table rows are larger than `table_width`,
#' the table is split into two parts.
#' @param ... Currently not used.
#' @inheritParams format_value
#' @inheritParams get_data
#'
#' @note The values for `caption`, `subtitle` and `footer` can also be provided
#' as attributes of `x`, e.g. if `caption = NULL` and `x` has attribute
#' `table_caption`, the value for this attribute will be used as table caption.
#' `table_subtitle` is the attribute for `subtitle`, and `table_footer` for
#' `footer`.
#'
#' @inherit format_table seealso
#'
#' @return A data frame in character format.
#' @examples
#' export_table(head(iris))
#' export_table(head(iris), cross = "+")
#' export_table(head(iris), sep = " ", header = "*", digits = 1)
#'
#' # split longer tables
#' export_table(head(iris), table_width = 30)
#'
#' \donttest{
#' # colored footers
#' data(iris)
#' x <- as.data.frame(iris[1:5, ])
#' attr(x, "table_footer") <- c("This is a yellow footer line.", "yellow")
#' export_table(x)
#'
#' attr(x, "table_footer") <- list(
#' c("\nA yellow line", "yellow"),
#' c("\nAnd a red line", "red"),
#' c("\nAnd a blue line", "blue")
#' )
#' export_table(x)
#'
#' attr(x, "table_footer") <- list(
#' c("Without the ", "yellow"),
#' c("new-line character ", "red"),
#' c("we can have multiple colors per line.", "blue")
#' )
#' export_table(x)
#' }
#'
#' # column-width
#' d <- data.frame(
#' x = c(1, 2, 3),
#' y = c(100, 200, 300),
#' z = c(10000, 20000, 30000)
#' )
#' export_table(d)
#' export_table(d, width = 8)
#' export_table(d, width = c(x = 5, z = 10))
#' export_table(d, width = c(x = 5, y = 5, z = 10), align = "lcr")
#' @export
export_table <- function(x,
sep = " | ",
header = "-",
cross = NULL,
empty_line = NULL,
digits = 2,
protect_integers = TRUE,
missing = "",
width = NULL,
format = NULL,
title = NULL,
caption = title,
subtitle = NULL,
footer = NULL,
align = NULL,
by = NULL,
zap_small = FALSE,
table_width = NULL,
verbose = TRUE,
...) {
# check args
if (is.null(format)) {
format <- "text"
}
# handle alias
if (format == "md") {
format <- "markdown"
}
# validation check
if (is.null(x) || (is.data.frame(x) && nrow(x) == 0) || is_empty_object(x)) {
if (isTRUE(verbose)) {
format_alert("Can't export table to ", format, ", data frame is empty.")
}
return(NULL)
}
# if we have a list of data frames and HTML format, create a single
# data frame now. HTML format needs a single data frame. Sub tables
# are split by their group-column later, see code below
# "gt(final, groupname_col = group_by_columns)".
if (identical(format, "html") && !is.data.frame(x) && is.list(x)) {
x <- do.call(rbind, lapply(x, function(i) {
attr_name <- .check_caption_attr_name(i)
i$Component <- attr(i, attr_name)[1]
i
}))
}
# check for indention
indent_groups <- attributes(x)$indent_groups
indent_rows <- attributes(x)$indent_rows
# table from single data frame --------------------------------------------
if (is.data.frame(x)) {
# check default attributes for caption, sub-title and footer
if (!is.null(title)) {
caption <- title
}
if (is.null(caption)) {
attr_name <- .check_caption_attr_name(x)
caption <- attributes(x)[[attr_name]]
}
if (is.null(subtitle)) {
subtitle <- attributes(x)$table_subtitle
}
if (is.null(footer)) {
footer <- attributes(x)$table_footer
}
# convert data frame into specified output format
out <- .export_table(
x = x,
sep = sep,
header = header,
cross = cross,
digits = digits,
protect_integers = protect_integers,
missing = missing,
width = width,
format = format,
caption = caption,
subtitle = subtitle,
footer = footer,
align = align,
group_by = by,
zap_small = zap_small,
empty_line = empty_line,
indent_groups = indent_groups,
indent_rows = indent_rows,
table_width = table_width
)
} else if (is.list(x)) {
# table from list of data frames -----------------------------------------
# remove empty elements
l <- compact_list(x)
# list of data frames
tmp <- lapply(seq_along(l), function(element) {
i <- l[[element]]
# use individual footer for each list element...
t_footer <- attributes(i)$table_footer
# ...unless we have a footer-argument.
# Then use this as last (final) footer
if (element == length(l) && is.null(attributes(i)$table_footer) && !is.null(footer) && !is.list(footer)) {
t_footer <- footer
}
# if we still have no footer, check if user provided a list of titles
if (is.null(t_footer) && !is.null(footer) && is.list(footer) && length(footer) == length(l)) {
t_footer <- footer[[element]]
}
# for lists of data frame, each list element may have
# an own attribute for the title, to have "subheadings"
# for each table
attr_name <- .check_caption_attr_name(i)
# if only alias "title" is provided, copy it to caption-variable
if (!is.null(title) && is.null(caption)) {
caption <- title
}
# use individual title for each list element...
t_title <- attributes(i)[[attr_name]]
# ...unless we have a title-argument.
# Then use this as first (main) header
if (element == 1 && is.null(attributes(i)[[attr_name]]) && !is.null(caption) && !is.list(caption)) {
t_title <- caption
}
# if we still have no title, check if user provided a list of titles
if (is.null(t_title) && !is.null(caption) && is.list(caption) && length(caption) == length(l)) {
t_title <- caption[[element]]
}
# convert data frame into specified output format
.export_table(
x = i,
sep = sep,
header = header,
cross = cross,
digits = digits,
protect_integers = protect_integers,
missing = missing,
width = width,
format = format,
caption = t_title,
subtitle = attributes(i)$table_subtitle,
footer = t_footer,
align = align,
group_by = by,
zap_small = zap_small,
empty_line = empty_line,
indent_groups = indent_groups,
indent_rows = indent_rows,
table_width = table_width
)
})
# insert new lines between tables, but this is only needed
# for text or markdown tables
out <- NULL
if (format == "text") {
for (i in seq_along(tmp)) {
out <- paste0(out, tmp[[i]], "\n")
}
out <- substr(out, 1, nchar(out) - 1)
} else if (format == "markdown") {
for (i in seq_along(tmp)) {
out <- c(out, tmp[[i]], "")
}
out <- out[1:(length(out) - 1)]
}
} else {
# for all invalid inputs, return NULL
return(NULL)
}
# add specific knitr-attribute for proper printing inside rmarkdown
if (format == "markdown") {
attr(out, "format") <- "pipe"
class(out) <- c("knitr_kable", "character")
} else if (format == "text") {
class(out) <- c("insight_table", class(out))
}
out
}
# methods -----------------------------------
#' @export
print.insight_table <- function(x, ...) {
cat(x)
invisible(x)
}
# small helper ----------------------
# check whether "table_caption" or its alias "table_title" is used as attribute
.check_caption_attr_name <- function(x) {
attr_name <- "table_caption"
if (is.null(attr(x, attr_name, exact = TRUE)) && !is.null(attr(x, "table_title", exact = TRUE))) {
attr_name <- "table_title"
}
attr_name
}
# work horse: create matrix of raw table layout --------------------
.export_table <- function(x,
sep = " | ",
header = "-",
cross = NULL,
digits = 2,
protect_integers = TRUE,
missing = "",
width = NULL,
format = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
group_by = NULL,
zap_small = FALSE,
empty_line = NULL,
indent_groups = NULL,
indent_rows = NULL,
table_width = NULL) {
tabledata <- as.data.frame(x)
# check width argument, for format value. cannot have
# named vector of length > 1 here
if (is.null(width) || length(width) == 1) {
col_width <- width
} else {
col_width <- NULL
}
# round all numerics, and convert to character
col_names <- names(tabledata)
tabledata[] <- lapply(tabledata, function(i) {
if (is.numeric(i)) {
out <- format_value(i,
digits = digits, protect_integers = protect_integers,
missing = missing, width = col_width, zap_small = zap_small
)
} else {
out <- i
}
as.character(out)
})
# add back column names
names(tabledata) <- col_names
tabledata[is.na(tabledata)] <- as.character(missing)
if (identical(format, "html")) {
# html formatting starts here, needs less preparation of table matrix
out <- .format_html_table(
tabledata,
caption = caption,
subtitle = subtitle,
footer = footer,
align = align,
group_by = group_by,
indent_groups = indent_groups,
indent_rows = indent_rows
)
# text and markdown go here...
} else {
# Add colnames as first row to the data frame
tabledata <- rbind(colnames(tabledata), tabledata)
# Initial alignment for complete data frame is right-alignment
aligned <- format(tabledata, justify = "right")
# default alignment
col_align <- rep("right", ncol(tabledata))
# first row definitely right alignment, fixed width
first_row <- as.character(aligned[1, ])
for (i in seq_along(first_row)) {
aligned[1, i] <- format(
trim_ws(first_row[i]),
width = nchar(first_row[i], type = "width"),
justify = "right"
)
}
final <- as.matrix(aligned)
# left-align first column (if a character or a factor)
if (!is.numeric(x[, 1])) {
final[, 1] <- format(trim_ws(final[, 1]), justify = "left")
col_align[1] <- "left"
}
if (format == "text") {
# go for simple text output
out <- .format_basic_table(
final,
header,
sep,
cross,
caption = caption,
subtitle = subtitle,
footer = footer,
align = align,
empty_line = empty_line,
indent_groups = indent_groups,
indent_rows = indent_rows,
col_names = col_names,
col_width = width,
col_align = col_align,
table_width = table_width
)
} else if (format == "markdown") {
# markdown is a bit different...
out <- .format_markdown_table(
final,
x,
caption = caption,
subtitle = subtitle,
footer = footer,
align = align,
indent_groups = indent_groups,
indent_rows = indent_rows
)
}
}
out
}
# plain text formatting ------------------------
.format_basic_table <- function(final,
header,
sep,
cross = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
empty_line = NULL,
indent_groups = NULL,
indent_rows = NULL,
col_names = NULL,
col_width = NULL,
col_align = NULL,
table_width = NULL) {
# align table, if requested. unlike the generic aligments that have been done
# previously, we now look for column-specific alignments. we furthermore save
# the alignments in "col_align", which we may need later when we set a fixed
# column width for specific columns across multiple tables, and have to
# re-align the columns again.
if (!is.null(align) && length(align) == 1) {
for (i in seq_len(ncol(final))) {
align_char <- ""
if (!align %in% c("left", "right", "center", "firstleft")) {
align_char <- substr(align, i, i)
}
# left alignment, or at least first line only left?
if (align == "left" || (align == "firstleft" && i == 1) || align_char == "l") {
final[, i] <- format(trim_ws(final[, i]), justify = "left")
col_align[i] <- "left"
# right-alignment
} else if (align == "right" || align_char == "r") {
final[, i] <- format(trim_ws(final[, i]), justify = "right")
col_align[i] <- "right"
# else, center
} else {
final[, i] <- format(trim_ws(final[, i]), justify = "centre")
col_align[i] <- "centre"
}
}
}
# indent groups? export_table() allows to indent specific rows,
# which might be useful when we have tables of regression coefficients,
# and some coefficients are grouped together, which is visually emphasized
# by indention...
if (!is.null(indent_groups) && any(grepl(indent_groups, final[, 1], fixed = TRUE))) {
final <- .indent_groups(final, indent_groups)
} else if (!is.null(indent_rows) && any(grepl("# ", final[, 1], fixed = TRUE))) {
final <- .indent_rows(final, indent_rows)
}
# check for fixed column widths. usually, column width is aligned to the
# widest element in that column. for multiple tables, this may result in
# columns which do not have the the same width across tables, despite
# having the same "meaning" (e.g., zero-inflated models that have a table
# for the count and the zero-inflated model components: both have columns
# for SE or CI, but one column may be 10 chars wide, the same column in
# the other table could be 9 or 11 chars) - with this option, we can set a
# fixed width for specific columns across all tables.
if (!is.null(col_width) && length(col_width) > 1 && !is.null(names(col_width))) {
matching_columns <- stats::na.omit(match(names(col_width), col_names))
if (length(matching_columns)) {
for (i in matching_columns) {
w <- as.vector(col_width[col_names[i]])
final[, i] <- format(trim_ws(final[, i]), width = w, justify = col_align[i])
}
}
}
# we can split very wide table into maximum three parts
# this is currently hardcoded, not flexible, so we cannot allow
# more than three parts of one wide table
final2 <- NULL
final3 <- NULL
# check if user requested automatic width-adjustment of tables, or if a
# given width is required
if (identical(table_width, "auto") || (!is.null(table_width) && is.numeric(table_width))) {
# define the length of a table line. if specific table width is defined
# (i.e. table_width is numeric), use that to define length of table lines.
# else, if "auto", check the current width of the user console and use that
# to flexibly adjust table width to the width of the console window.
if (is.numeric(table_width)) {
line_width <- table_width
} else {
line_width <- options()$width
}
# width of first table row of complete table. Currently, "final" is still
# a matrix, so we need to paste the columns of the first row into a string
row_width <- nchar(paste0(final[1, ], collapse = sep), type = "width")
# possibly first split - all table columns longer than "line_width"
# (i.e. first table row) go into a second string
if (row_width > line_width) {
i <- 1
# determine how many columns fit into the first line
while (nchar(paste0(final[1, 1:i], collapse = sep), type = "width") < line_width) {
i <- i + 1
}
# copy first column, and all columns that did not fit into the first line
# into the second table matrix
if (i > 2 && i < ncol(final)) {
final2 <- final[, c(1, i:ncol(final))]
final <- final[, 1:(i - 1)]
}
}
# width of first table row of remaing second table part
row_width <- nchar(paste0(final2[1, ], collapse = sep), type = "width")
# possibly second split - all table columns longer than "line_width"
# (i.e. first table row) go into a third string - we repeat the same
# procedure as above
if (row_width > line_width) {
i <- 1
while (nchar(paste0(final2[1, 1:i], collapse = sep), type = "width") < line_width) {
i <- i + 1
}
if (i > 2 && i < ncol(final2)) {
final3 <- final2[, c(1, i:ncol(final2))]
final2 <- final2[, 1:(i - 1)]
}
}
}
# Transform table matrix into a string value that can be printed
rows <- .table_parts(NULL, final, header, sep, cross, empty_line)
# if we have over-lengthy tables that are split into two parts,
# print second table here
if (!is.null(final2)) {
rows <- .table_parts(paste0(rows, "\n"), final2, header, sep, cross, empty_line)
}
# if we have over-lengthy tables that are split into two parts,
# print second table here
if (!is.null(final3)) {
rows <- .table_parts(paste0(rows, "\n"), final3, header, sep, cross, empty_line)
}
# if caption is available, add a row with a headline
if (!is.null(caption) && caption[1] != "") {
# if we have a colour value, make coloured ansi-string
if (length(caption) == 2 && .is_valid_colour(caption[2])) {
caption <- .colour(caption[2], caption[1])
}
if (is.null(subtitle)) {
subtitle <- ""
} else if (length(subtitle) == 2 && .is_valid_colour(subtitle[2])) {
# if we have a colour value, make coloured ansi-string
subtitle <- .colour(subtitle[2], subtitle[1])
}
# paste everything together and remove unnecessary double spaces
title_line <- trim_ws(paste0(caption[1], " ", subtitle[1]))
title_line <- gsub(" ", " ", title_line, fixed = TRUE)
rows <- paste0(title_line, "\n\n", rows)
}
# if footer is available, add a row with a footer. footers may
# also be provided as list of character vectors, so each footer
# line can get its own color
if (!is.null(footer)) {
if (is.list(footer)) {
for (i in footer) {
rows <- .paste_footers(i, rows)
}
} else {
rows <- .paste_footers(footer, rows)
}
}
rows
}
# helper to prepare table body for text output ---------------------
.table_parts <- function(rows, final, header, sep, cross, empty_line) {
# "final" is a matrix here. we now paste each row into a character string,
# add separator chars etc.
for (row in seq_len(nrow(final))) {
# create a string for each row, where cells from original matrix are
# separated by the separator char
final_row <- paste0(final[row, ], collapse = sep)
# check if we have an empty row, and if so, fill with an
# "empty line separator", if requested by user
if (!is.null(empty_line) && !any(nzchar(trim_ws(final[row, ])))) {
# check whether user wants to have a "cross" char where vertical and
# horizontal lines (from empty line separator) cross. But don't add
# a "cross" when the empty line is the last row in the table...
empty_line_with_cross <- .insert_cross(
# the empty line, which is just empty cells with separator char,
# will now be replaced by the "empty line char", so we have a
# clean separator line
paste0(rep_len(empty_line, nchar(final_row, type = "width")), collapse = ""),
cross, sep, final_row,
is_last_row = row == nrow(final)
)
rows <- paste0(rows, empty_line_with_cross, "\n")
} else {
rows <- paste0(rows, final_row, "\n")
}
# After first row, we might have a separator row
if (row == 1 && !is.null(header)) { # check if we have any separator for the header row
# check whether user wants to have a "cross" char where vertical and
# horizontal lines (from header line) cross.
header_line <- .insert_cross(
paste0(rep_len(header, nchar(final_row, type = "width")), collapse = ""),
cross, sep, final_row,
is_last_row = row == nrow(final)
)
# add separator row after header line
rows <- paste0(rows, header_line, "\n")
}
}
rows
}
.insert_cross <- function(row, cross, sep, pattern, is_last_row) {
# check if at places where row and column "lines" cross, we need a
# special char. E.g., if columns are separated with "|" and header line
# with "-", we might have a "+" to have properly "crossed lines"
if (!is.null(cross) && !is_last_row) {
cross_position <- unlist(gregexpr(trim_ws(sep), pattern, fixed = TRUE), use.names = FALSE)
for (pp in cross_position) {
substr(row, pp, pp) <- cross
}
}
row
}
# helper ----------------
.paste_footers <- function(footer, rows) {
if (.is_empty_string(footer)) {
return(rows)
}
# if we have a colour value, make coloured ansi-string
if (length(footer) == 2 && .is_valid_colour(footer[2])) {
footer <- .colour(footer[2], footer[1])
}
paste0(rows, footer[1])
}
.indent_groups <- function(final, indent_groups) {
# check length of indent string
whitespace <- sprintf("%*s", nchar(indent_groups, type = "width"), " ")
# find start index of groups
grps <- grep(indent_groups, final[, 1], fixed = TRUE)
# create index for those rows that should be indented
grp_rows <- seq(grps[1], nrow(final))
grp_rows <- grp_rows[!grp_rows %in% grps]
# indent
final[grp_rows, 1] <- paste0(whitespace, final[grp_rows, 1])
# remove indent token
final[, 1] <- gsub(indent_groups, "", final[, 1], fixed = TRUE)
# trim whitespace at end
final[, 1] <- trimws(final[, 1], which = "right")
# move group name (indent header) to left
final[, 1] <- format(final[, 1], justify = "left", width = max(nchar(final[, 1], type = "width")))
final
}
.indent_rows <- function(final, indent_rows, whitespace = " ") {
# create index for those rows that should be indented
# for text format, first row is column names, so we need a +1 here
grp_rows <- indent_rows + 1
# indent
final[grp_rows, 1] <- paste0(whitespace, final[grp_rows, 1])
# find rows that should not be indented
non_grp_rows <- seq_len(nrow(final))
non_grp_rows <- non_grp_rows[!non_grp_rows %in% grp_rows]
# paste whitespace at end, to ensure equal width for each string
final[non_grp_rows, 1] <- paste0(final[non_grp_rows, 1], whitespace)
# remove indent token
grps <- grep("# ", final[, 1], fixed = TRUE)
final[, 1] <- gsub("# ", "", final[, 1], fixed = TRUE)
# move group name (indent header) to left
final[grps, 1] <- format(final[grps, 1], justify = "left", width = max(nchar(final[, 1], type = "width")))
final
}
.indent_rows_html <- function(final, indent_rows, whitespace = "") {
# create index for those rows that should be indented
grp_rows <- indent_rows
# indent
final[grp_rows, 1] <- paste0(whitespace, final[grp_rows, 1])
# find rows that should not be indented
non_grp_rows <- seq_len(nrow(final))
non_grp_rows <- non_grp_rows[!non_grp_rows %in% grp_rows]
# remove indent token
final[, 1] <- gsub("# ", "", final[, 1], fixed = TRUE)
final
}
# markdown formatting -------------------
.format_markdown_table <- function(final,
x,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
indent_groups = NULL,
indent_rows = NULL) {
column_width <- nchar(final[1, ])
n_columns <- ncol(final)
first_row_leftalign <- (!is.null(align) && align == "firstleft")
## create header line for markdown table -----
header <- "|"
# indention? than adjust column width for first column
if (!is.null(indent_rows) || !is.null(indent_groups)) {
column_width[1] <- column_width[1] + 2
}
# go through all columns of the data frame
for (i in 1:n_columns) {
# create separator line for current column
tablecol <- paste0(rep_len("-", column_width[i]), collapse = "")
# check if user-defined alignment is requested, and if so, extract
# alignment direction and save to "align_char"
align_char <- ""
if (!is.null(align) && !align %in% c("left", "right", "center", "firstleft")) {
align_char <- substr(align, i, i)
}
# auto-alignment?
if (is.null(align)) {
# if so, check if string in column starts with
# whitespace (indicating right-alignment) or not.
if (grepl("^\\s", final[2, i])) {
tablecol <- paste0(tablecol, ":")
final[, i] <- format(final[, i], width = column_width[i] + 1, justify = "right")
} else {
tablecol <- paste0(":", tablecol)
final[, i] <- format(final[, i], width = column_width[i] + 1, justify = "left")
}
# left alignment, or at least first tablecol only left?
} else if (align == "left" || (first_row_leftalign && i == 1) || align_char == "l") {
tablecol <- paste0(":", tablecol)
final[, i] <- format(final[, i], width = column_width[i] + 1, justify = "left")
# right-alignment
} else if (align == "right" || align_char == "r") {
tablecol <- paste0(tablecol, ":")
final[, i] <- format(final[, i], width = column_width[i] + 1, justify = "right")
# else, center
} else {
tablecol <- paste0(":", tablecol, ":")
final[, i] <- format(final[, i], width = column_width[i] + 2, justify = "centre")
}
# finally, we have our header-line that indicates column alignments
header <- paste0(header, tablecol, "|")
}
# indent groups?
if (!is.null(indent_groups) && any(grepl(indent_groups, final[, 1], fixed = TRUE))) {
final <- .indent_groups(final, indent_groups)
} else if (!is.null(indent_rows) && any(grepl("# ", final[, 1], fixed = TRUE))) {
final <- .indent_rows(final, indent_rows)
}
# Transform to character
rows <- NULL
for (row in seq_len(nrow(final))) {
final_row <- paste0("|", paste0(final[row, ], collapse = "|"), "|", collapse = "")
rows <- c(rows, final_row)
# First row separation
if (row == 1) {
rows <- c(rows, header)
}
}
if (!is.null(caption)) {
if (!is.null(subtitle)) {
caption[1] <- paste0(caption[1], " ", subtitle[1])
}
rows <- c(paste0("Table: ", trim_ws(caption[1])), "", rows)
}
if (!is.null(footer)) {
if (is.list(footer)) {
for (i in footer) {
if (!.is_empty_string(i)) {
rows <- c(rows, i[1])
}
}
} else if (!.is_empty_string(footer)) {
rows <- c(rows, footer[1])
}
}
rows
}
# html formatting ---------------------------
.format_html_table <- function(final,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = "center",
group_by = NULL,
indent_groups = NULL,
indent_rows = NULL) {
check_if_installed("gt")
if (is.null(align)) {
align <- "firstleft"
}
group_by_columns <- c(intersect(c("Group", "Response", "Effects", "Component"), names(final)), group_by)
if (length(group_by_columns)) {
# remove columns with only 1 unique value - this *should* be safe to
# remove, but we may check if all printed sub titles look like intended
for (i in group_by_columns) {
if (n_unique(final[[i]]) <= 1) {
final[[i]] <- NULL
}
}
} else {
group_by_columns <- NULL
}
# indent groups?
if (!is.null(indent_rows) && any(grepl("# ", final[, 1], fixed = TRUE))) {
final <- .indent_rows_html(final, indent_rows)
}
# validation check - clean caption, subtitle and footer from ansi-colour codes,
# which only work for text format... But if user occidentally provides colours
# for HTML format as well, remove those colour codes, so they don't appear as
# text in the table header and footer. Furthermore, in footers, we need to
# remove newline-characters
if (!is.null(caption)) {
if (is.list(caption)) {
caption <- lapply(caption, function(i) {
i[1]
})
} else {
caption <- caption[1]
}
}
if (!is.null(subtitle)) {
if (is.list(subtitle)) {
subtitle <- lapply(subtitle, function(i) {
i[1]
})
} else {
subtitle <- subtitle[1]
}
}
if (!is.null(footer)) {
if (is.list(footer)) {
footer <- lapply(footer, function(i) {
gsub("\n", "", i[1], fixed = TRUE)
})
} else {
footer <- footer[1]
}
}
tab <- gt::gt(final, groupname_col = group_by_columns)
header <- gt::tab_header(tab, title = caption, subtitle = subtitle)
footer <- gt::tab_source_note(header, source_note = gt::html(footer))
out <- gt::cols_align(footer, align = "center")
# align columns
if (!is.null(out[["_boxhead"]]) && !is.null(out[["_boxhead"]]$column_align)) {
if (align == "firstleft") {
out[["_boxhead"]]$column_align[1] <- "left"
} else {
col_align <- NULL
for (i in 1:nchar(align)) {
col_align <- c(
col_align,
switch(substr(align, i, i),
l = "left",
r = "right",
"center"
)
)
}
out[["_boxhead"]]$column_align <- col_align
}
}
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.