#' Tabular data representations
#'
#' HTML, LaTeX, and Markdown representations of Matrix-like objects
#'
#' @param obj The matrix or data.frame to create a representation for
#' @param ... ignored
#' @param rows The maximum number of rows displayed. The default is given by the option \code{repr.matrix.max.rows}
#' @param cols The maximum number of columns displayed. The default is given by the option \code{repr.matrix.max.cols}
#' @param colspec The colspec for the LaTeX table. The default is given by the option \code{repr.matrix.latex.colspec}
#'
#' @seealso \link{repr-options} for \code{repr.matrix.latex.colspec}
#'
#' @importFrom pillar type_sum
#' @name repr_*.matrix/data.frame
#' @include utils.r
NULL
# There is currently a problem on windows which can't display chars in th
# text/plain output, which are not available in the current locale.
# See https://github.com/IRkernel/repr/issues/28#issuecomment-208574856
#' @importFrom utils capture.output
.char_fallback <- function(char, default) {
real_len <- nchar(char)
r_len <- nchar(capture.output(cat(char)))
if (real_len == r_len) char else default
}
chars <- new.env()
onload_chars <- function() {
chars$ellip_h <- .char_fallback('\u22EF', '...')
chars$ellip_v <- .char_fallback('\u22EE', '...')
chars$ellip_d <- .char_fallback('\u22F1', '')
chars$times_s <- .char_fallback('\u00D7', 'x')
}
arr_partition <- function(a, rows, cols) {
stopifnot(rows >= 2L, cols >= 2L)
# create sequences of indices to bisect rows and columns
part_r <- partition(nrow(a), rows)
part_c <- partition(ncol(a), cols)
# assign a list of parts that can be coerced to strings
if (!is.null(part_r) && !is.null(part_c)) {
structure(list(
ul = a[part_r$start, part_c$start], ll = a[part_r$end, part_c$start],
ur = a[part_r$start, part_c$end ], lr = a[part_r$end, part_c$end ]),
omit = 'both')
} else if (!is.null(part_r)) {
structure(list(
upper = a[part_r$start, , drop = FALSE],
lower = a[part_r$end, , drop = FALSE]),
omit = 'rows')
} else if (!is.null(part_c)) {
structure(list(
left = a[, part_c$start, drop = FALSE],
right = a[, part_c$end, drop = FALSE]),
omit = 'cols')
} else {
structure(list(full = a), omit = 'none')
}
}
# unpack tibble and coerce to data.frame
arr_part_unpack_tbl <- function(tbl) {
tbl_col_format <- function(col, prefix = '') {
if (is.data.frame(col)) {
res <- mapply(tbl_col_format, col, names(col), SIMPLIFY = FALSE, USE.NAMES = FALSE)
res <- do.call(cbind.data.frame, res)
names(res) <- paste0(prefix, '$', names(res))
return(res)
} else {
res <- data.frame(col)
names(res) <- prefix
return(res)
}
}
res <- mapply(tbl_col_format, tbl, names(tbl), SIMPLIFY = FALSE, USE.NAMES = FALSE)
do.call(cbind.data.frame, res)
}
arr_parts_format <- function(parts) structure(lapply(parts, arr_part_format), omit = attr(parts, 'omit'))
arr_part_format <- function(part) {
if (inherits(part, 'tbl')) {
part <- arr_part_unpack_tbl(part)
}
f_part <- if (is.data.frame(part)) {
vapply(part, function(col) {
if (is.matrix(col)) apply(apply(col, 2L, format), 1L, paste, collapse = ', ')
else format(col)
}, character(nrow(part)))
} else {
# format(part) would work, but e.g. would left-pad *both* rows of matrix(7:10, 2L) instead of one
apply(part, 2L, format)
}
# vapply returns a vector for 1-column dfs
dim(f_part) <- dim(part)
dimnames(f_part) <- dimnames(part)
f_part
}
#' @importFrom utils head tail
arr_parts_combine <- function(parts, rownms, colnms) {
omit <- attr(parts, 'omit')
mat <- switch(omit,
rows = rbind(parts$upper, chars$ellip_v, parts$lower, deparse.level = 0L),
cols = cbind(parts$left, chars$ellip_h, parts$right, deparse.level = 0L),
none = parts$full,
both = rbind(
cbind(parts$ul, chars$ellip_h, parts$ur, deparse.level = 0L),
c(rep(chars$ellip_v, ncol(parts$ul)), chars$ellip_d, rep(chars$ellip_v, ncol(parts$ur))),
cbind(parts$ll, chars$ellip_h, parts$lr, deparse.level = 0L)))
# If there were no dimnames before, as is often true for matrices, don't assign them.
if (omit %in% c('rows', 'both') && !is.null(rownms)) {
# everything except ellip_v is to fix rownames for tbls, which explicitly set them to 1:n when subsetting
rownames(mat) <- c(head(rownms, nrow(parts[[1]])), chars$ellip_v, tail(rownms, nrow(parts[[2]])))
}
if (omit %in% c('cols', 'both') && !is.null(colnms)) {
colnames(mat)[[ncol(parts[[1]]) + 1L]] <- chars$ellip_h
}
mat
}
# returns a character array with optionally a section of columns and rows in the middle replaced by ellipses
ellip_limit_arr <- function(
a,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols')
) {
parts <- arr_partition(a, rows, cols)
stopifnot(match('ll', names(parts)) %in% c(NA, 2L)) # lower has to come second if available
f_parts <- arr_parts_format(parts)
arr_parts_combine(f_parts, rownames(a), colnames(a))
}
# HTML --------------------------------------------------------------------
repr_matrix_generic <- function(
x,
wrap,
header_wrap, headline_wrap, corner, head,
body_wrap, row_wrap, row_head,
cell,
escape_fun = identity,
...,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols'),
caption_override = NULL
) {
has_rownames <- has_row_names(x)
has_colnames <- !is.null(colnames(x)) && ncol(x) > 0
if (!has_rownames && !has_colnames && 0L %in% dim(x))
return('')
# Get infos for caption and type headers
is_matrix <- !is.list(x)
cls <-
if (!is.null(caption_override)) caption_override
else if (class(x)[[1]] == 'tbl_df') 'tibble'
else class(x)[[1]]
dims <- dim(x)
types <- if (is_matrix) type_sum(as.vector(x)) else {
type_vec <- sprintf('<%s>', sapply(x, type_sum))
# A row limit of 3 is the minimal choice, but we only have 1 anyway
as.vector(ellip_limit_arr(matrix(type_vec, nrow = 1L), 3L, cols))
}
# TODO: ineffective to flatten the whole thing
# But when are we encountering huge nested arrays?
x <- ellip_limit_arr(flatten(x), rows, cols)
header <- ''
if (has_colnames) {
headers <- escape_fun(colnames(x))
typehds <- escape_fun(types)
header_raw <-
if (is_matrix || is.null(headline_wrap)) {
# if we have a data frame but no wrapper for header lines,
# we just concatenate each column name with its type.
headers <- sprintf(head, if (is_matrix) headers else paste(headers, typehds))
if (has_rownames) headers <- c(corner, headers)
headline <- paste(headers, collapse = '')
if (is.null(headline_wrap)) headline else sprintf(headline_wrap, headline)
} else {
# else we create one line for names and one for types.
headers <- sprintf(head, headers)
typehds <- sprintf(head, typehds)
if (has_rownames) {
headers <- c(corner, headers)
typehds <- c(corner, typehds)
}
headline <- sprintf(headline_wrap, paste(headers, collapse = ''))
typeline <- sprintf(headline_wrap, paste(typehds, collapse = ''))
paste0(headline, typeline)
}
header <- sprintf(header_wrap, header_raw)
stopifnot(length(header) == 1L)
}
rows <- lapply(seq_len(nrow(x)), function(r) {
row <- escape_fun(slice_row(x, r))
cells <- sprintf(cell, row)
if (has_rownames) {
row_head <- sprintf(row_head, escape_fun(rownames(x)[[r]]))
cells <- c(row_head, cells)
}
sprintf(row_wrap, paste(cells, collapse = ''))
})
body <- sprintf(body_wrap, paste(rows, collapse = ''))
caption <- sprintf('A %s: %s %s %s', escape_fun(cls), dims[[1]], chars$times_s, dims[[2]])
if (is.null(caption_override) && is_matrix) caption <- sprintf('%s of type %s', caption, escape_fun(types))
sprintf(wrap, caption, header, body)
}
#' @name repr_*.matrix/data.frame
#' @export
repr_html.matrix <- function(
obj,
...,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols')
) repr_matrix_generic(
obj,
'<table class="dataframe">\n<caption>%s</caption>\n%s%s</table>\n',
'<thead>\n%s</thead>\n', '\t<tr>%s</tr>\n', '<th></th>',
'<th scope=col>%s</th>',
'<tbody>\n%s</tbody>\n', '\t<tr>%s</tr>\n', '<th scope=row>%s</th>',
'<td>%s</td>',
escape_fun = html_escape_vec,
rows = rows, cols = cols,
...)
#' @name repr_*.matrix/data.frame
#' @export
repr_html.data.frame <- repr_html.matrix
# LaTeX -------------------------------------------------------------------
#' @name repr_*.matrix/data.frame
#' @export
repr_latex.matrix <- function(
obj,
...,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols'),
colspec = getOption('repr.matrix.latex.colspec')
) {
cols_spec <- paste0(paste(rep(colspec$col, min(cols + 1L, ncol(obj))), collapse = ''), colspec$end)
if (has_row_names(obj)) {
row_head <- colspec$row_head
if (is.null(row_head)) row_head <- colspec$row.head # backwards compat
cols_spec <- paste0(colspec$row_head, cols_spec)
}
r <- repr_matrix_generic(
obj,
# todo: captionof or so
sprintf('%%s\n\\begin{tabular}{%s}\n%%s%%s\\end{tabular}\n', cols_spec),
'%s\\hline\n', '%s\\\\\n', ' &', ' %s &',
'%s', '\t%s\\\\\n', '%s &',
' %s &',
escape_fun = latex_escape_vec,
rows = rows, cols = cols,
...)
#TODO: remove this quick’n’dirty post processing
gsub(' &\\', '\\', r, fixed = TRUE)
}
#' @name repr_*.matrix/data.frame
#' @export
repr_latex.data.frame <- repr_latex.matrix
# Markdown -------------------------------------------------------------------
#' @name repr_*.matrix/data.frame
#' @export
repr_markdown.matrix <- function(
obj,
...,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols')
) {
obj <- flatten(obj)
out_cols <- min(ncol(obj), cols + 1L) + as.integer(has_row_names(obj))
underline <- paste(rep('---', out_cols), collapse = '|')
repr_matrix_generic(
obj,
'\n%s\n\n%s%s\n',
sprintf('|%%s\n|%s|\n', underline), NULL, ' <!--/--> |', ' %s |',
'%s', '|%s\n', ' %s |',
' %s |',
escape_fun = markdown_escape,
rows = rows, cols = cols,
...)
}
#' @name repr_*.matrix/data.frame
#' @export
repr_markdown.data.frame <- repr_markdown.matrix
# Text -------------------------------------------------------------------
#' @name repr_*.matrix/data.frame
#' @importFrom utils capture.output
#' @export
repr_text.matrix <- function(
obj,
...,
rows = getOption('repr.matrix.max.rows'),
cols = getOption('repr.matrix.max.cols')
) {
if (inherits(obj, c('data.table'))) {
# Coerce to data.frame to avoid special printing in data.table.
obj <- as.data.frame(obj)
}
limited_obj <- ellip_limit_arr(obj, rows, cols)
print_output <- capture.output(print(limited_obj, quote = FALSE))
paste(print_output, collapse = '\n')
}
#' @name repr_*.matrix/data.frame
#' @export
repr_text.data.frame <- repr_text.matrix
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.