R/tableHTML.R
In LyzandeR/tableHTML: A Tool to Create HTML Tables
Defines functions
print.tableHTML
tableHTML
Documented in
print.tableHTML
tableHTML
#' Create an easily css-ible HTML table
#'
#' The purpose of \code{tableHTML} is to create easily css-ible HTML tables
#' that are compatible with R shiny. The exported HTML table will contain separate ids
#' or classes for headers, columns, second headers (if any) and the table itself
#' (in case you have multiple tables) in order to create a
#' complex css file very easily. ids and classes are explained in detail in
#' the details section.
#'
#' \code{tableHTML} will create an HTML table with defined ids and classes for rows and columns.
#' In particular:
#' \itemize{
#' \item \strong{Table:} Will get the class from the class argument in the function.
#' \item \strong{Columns:} Will get an id which will be of the form tableHTML_column_x (where x
#' is the column position). If rownames exist these will get the tableHTML_rownames id. If
#' row groups exist these will get the tableHTML_row_groups id. Check the \code{add_css_column}
#' function for examples.
#' \item \strong{Headers:} Will get an id of the form tableHTML_header_x (where x is the header position).
#' For example the first header will have the id tableHTML_header_1, the second header
#' will have tableHTLM_header_2 and so on. If rownames exist these will get the tableHTML_header_0 id.
#' \item \strong{Second_Header:} Will get an id of the form tableHTML_second_header_x (where x is the
#' second header position). For example the first second_header will have the id tableHTML_second_header_1,
#' the second header will have tableHTML_second_header_2 and so on.
#' }
#'
#' Notice that rows do not get a specific id or class.
#'
#' If you would like to use a non-collapsed table i.e. leave spacing between cells, then
#' you would need to use the \code{collapse} argument. Setting it to separate would create a
#' non-collapsed table. However, this choice will not work in shiny. The reason is that shiny
#' uses \code{table {border-collapse: collapse; border-spacing:0;}} in its css by default through
#' bootstrap 3. In order to overcome this problem in shiny, \code{collapse} needs to be set to
#' separate_shiny instead of separate. By setting collapse to separate_shiny tableHTML uses
#' \code{!important} in order to overwrite the standard behaviour of bootstrap 3. \code{!important}
#' needs to be used with caution since it overwrites css styles, so unless you are using shiny
#' (or any other place where the above css is automatically loaded) you should be using
#' \code{collapse = 'separate'}.
#'
#' Printing the table will result in rendering it in R studio's viewer
#' with the print.tableHTML method if using Rstudio otherwise it will use the default
#' browser. Use \code{print(tableHTML(obj), viewer = FALSE)} or \code{str(tableHTML(obj))}
#' to view the actual html code.
#'
#' @param obj Needs to be a data.frame or a matrix or an arbitrary object that has the
#' data.frame class and can be coersible to a data.frame (e.g data.table, tbl, etc.)
#'
#' @param rownames Can be TRUE or FALSE. Defaults to TRUE. Whether the obj's rownames
#' will be inlcuded.
#'
#' @param class Character string. Specifies the table's class. Convinient if you have multiple
#' tables. Default is table_xxxx (random 4-digit number).
#'
#' @param headers character vector. The headers for the HTML table. If not provided the original
#' data.frame headers will be used.
#'
#' @param widths Needs to be a numeric atomic vector with the column widths. Widths are in pixels.
#'
#' @param second_headers A list of two elements of the same length. The first element will contain
#' the column spans (i.e. a numeric atomic vector) whereas the second element will contain the
#' names (i.e. a character atomic vector). See the examples for more info. Defauls to NULL.
#'
#' @param row_groups A list of two elements of the same length. The first element will contain
#' the row spans (i.e. a numeric atomic vector) whereas the second element will contain the
#' names (i.e. a character atomic vector). See the examples for more info. Defauls to NULL.
#'
#' @param caption Character string. The table's caption.
#'
#' @param footer Character string. The table's footer. This gets added below the table and it
#' should not be confused with tfooter.
#'
#' @param border An integer. Specifies the border of the table. Defaults to 1. 0 removes borders
#' from the table. The higher the number the thicker the table's outside border.
#'
#' @param collapse Whether to collapse the table or not. By default the tables are collapsed. The
#' choices for this argument are 'collapse', 'separate' and 'separate_shiny'. Check the details
#' about which one to use.
#'
#' @param spacing Character string. This is only used if collapse is either separate or
#' separate_shiny and sets the spacing between the table's cells. It defaults to 2px. Can be one
#' or two length values (provided as a string). If two length values are provided the first one
#' sets the horizontal spacing whereas the second sets the vertical spacing. See the examples.
#'
#' @param escape Can be TRUE or FALSE. Defaults to TRUE. Escapes characters < and > because they
#' can close (or open) the table's HTML tags if they exist within the data.frame's text. This
#' means that all < and > characters within the tableHTML will be converted to < and >
#' respectively.
#'
#' @param round An integer specifying the number of decimals of numbers of
#' numeric columns only. Defaults to NULL which means no rounding.
#'
#' @param replace_NA A sting that specifies with what to replace NAs in character
#' or factor columns only. Defaults to NULL which means NAs will be printed.
#'
#' @param x A tableHTML object created from the \code{tableHTML} function.
#'
#' @param ... Optional arguments to print.
#'
#' @param viewer TRUE or FALSE. Defaults to TRUE. Whether or not to render the HTML table. If
#' you are working on Rstudio (interactively) the table will be printed or Rstudio's viewer.
#' If you are working on Rgui (interactively) the table will be printed on your default browser.
#' If you set this to FALSE the HTML code will be printed on screen.
#'
#' @param add_data TRUE or FALSE. Defaults to TRUE. If set to true, the data.frame or matrix passed in
#' \code{obj} will be added to the attributes. If set to FALSE, the object will be smaller, but
#' \code{add_css_conditional_column} would not be applicable.
#'
#' @param theme Argument is Deprecated. Please use the add_theme function instead.
#'
#' @return A tableHTML object.
#'
#' @examples
#' tableHTML(mtcars)
#' tableHTML(mtcars, rownames = FALSE)
#' tableHTML(mtcars, class = 'table1')
#' tableHTML(mtcars, second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars,
#' widths = c(rep(50, 6), rep(100, 6)),
#' second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars, caption = 'This is a caption', footer = 'This is a footer')
#' tableHTML(mtcars,
#' row_groups = list(c(10, 10, 12), c('Group 1', 'Group 2', 'Group 3')),
#' widths = c(200, rep(50, 5), rep(100, 6)),
#' rownames = FALSE)
#' tableHTML(mtcars,
#' rownames = FALSE,
#' widths = c(140, rep(50, 11)),
#' row_groups = list(c(10, 10, 12), c('Group 1', 'Group 2', 'Group 3')),
#' second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars, collapse = 'separate_shiny', spacing = '5px')
#' tableHTML(mtcars, collapse = 'separate', spacing = '5px 2px')
#'
#' @export
tableHTML <- function(obj,
rownames = TRUE,
class = paste0('table_', sample(1000:9999, 1)),
widths = NULL,
headers = NULL,
second_headers = NULL,
row_groups = NULL,
caption = NULL,
footer = NULL,
border = 1,
collapse = c('collapse', 'separate', 'separate_shiny'),
spacing = '2px',
escape = TRUE,
round = NULL,
replace_NA = NULL,
add_data = TRUE,
theme = NULL) {
#CHECKS----------------------------------------------------------------------------------------
#adding checks for obj
if (is.matrix(obj)) {
obj <- as.data.frame(obj)
} else if (inherits(obj, 'data.frame')) {
obj <- as.data.frame(obj)
} else {
stop('obj needs to be either a data.frame or a matrix')
}
if (!is.null(theme)) {
stop('Argument is Deprecated. Please use the add_theme function instead.')
}
#need to capture the column classes at the very beginning ----Pausing checks for a line
col_classes <- unname(sapply(obj, function(x) class(x)))
#checks for rownames
if (!rownames %in% c(TRUE, FALSE)) {
stop('rownames argument needs to be either TRUE or FALSE')
}
#checks for second header
if (!is.null(second_headers)) {
if (!is.list(second_headers)) {
stop('second_headers needs to be a list')
}
if (length(second_headers) != 2L) {
stop('second_headers needs to be a list of length two')
}
if (!is.numeric(second_headers[[1]])) {
stop("second_headers\'s first element needs to be numeric")
}
if (!is.character(second_headers[[2]])) {
stop("second_headers\'s second element needs to be character")
}
if (length(second_headers[[1]]) != length(second_headers[[2]])) {
stop("second_headers\'s elements need to have the same length")
}
}
#checks for widths
if (rownames == TRUE & !is.null(widths) & is.null(row_groups)) {
if (length(widths) != ncol(obj) + 1) stop('widths must have the same length as the columns + 1')
} else if (rownames == FALSE & !is.null(widths) & is.null(row_groups)) {
if (length(widths) != ncol(obj)) stop('widths must have the same length as the columns')
} else if (rownames == TRUE & !is.null(widths) & !is.null(row_groups)) {
if (length(widths) != ncol(obj) + 2) stop('widths must have the same length as the columns + 2')
} else if (rownames == FALSE & !is.null(widths) & !is.null(row_groups)) {
if (length(widths) != ncol(obj) + 1) stop('widths must have the same length as the columns + 1')
}
#check for the border argument
if (!is.numeric(border)) stop('border needs to be an integer')
border <- as.integer(border)
#make sure collapse has the right argument
collapse <- match.arg(collapse)
#check the add_data argument
##TEST
if (!is.logical(add_data) | !length(add_data) == 1) {
stop("add_data must be either TRUE or FALSE")
}
#make sure the first character of spacing is a number
if (collapse %in% c('separate', 'separate_shiny')) {
distances <- gsub('\\s+', ' ', spacing)
distances <- strsplit(distances, ' ')[[1]]
for (i in distances) {
if (is.na(as.numeric(sub('[[:alpha:]]+', '', i)))) {
stop('distances in spacing need to start with a number e.g. "1px 2px"')
}
}
}
if (!is.null(headers)) {
if (length(headers) != length(names(obj))) {
stop('The length of the headers needs to be the same as number of columns of the data.frame')
}
}
#------
#taking care of headers
if (is.null(headers)) {
headers <- names(obj)
}
#------
#escape character > and < in the data and headers because it will close or open tags
if (escape) {
obj[sapply(obj, is.fachar)] <- lapply(obj[sapply(obj, is.fachar)], function(x) {
if (is.factor(x)) {
temp_levels <- levels(x)
x <- gsub('>', '>', x)
x <- gsub('<', '<', x)
temp_levels <- gsub('>', '>', temp_levels)
temp_levels <- gsub('<', '<', temp_levels)
factor(x, levels = temp_levels)
} else {
x <- gsub('>', '>', x)
x <- gsub('<', '<', x)
x
}
})
headers <- gsub('>', '>', force(headers))
headers <- gsub('<', '<', force(headers))
}
#make sure headers do not contain empty string
headers[headers == ''] <- ' '
#make sure headers do not contain duplicates
#we fix that by adding white spaces which are ignored
#in html
headers <- fix_header_dupes(headers)
#headers to be exported
headers_exported <- headers
#rounding numeric columns
if (!is.null(round)) {
if (!is.numeric(round)) stop('round needs to be an integer.')
obj[sapply(obj, is.numeric)] <- lapply(obj[sapply(obj, is.numeric)], function(x) {
x <- round(x, round)
x
})
}
#replacing NA values for character and factor columns
if (!is.null(replace_NA)) {
obj[sapply(obj, is.fachar)] <- lapply(obj[sapply(obj, is.fachar)], function(x) {
if(is.factor(x)) {
levels(x) <- c(levels(x), replace_NA)
temp_levels <- levels(x)
x[is.na(x)] <- replace_NA
temp_levels[is.na(temp_levels)] <- replace_NA
factor(x, levels = temp_levels)
}
x[is.na(x)] <- replace_NA
x
})
}
#HEADERS---------------------------------------------------------------------------------------
#taking into account rownames
if (rownames == TRUE) {
headers <- paste('<tr>',
' <th id="tableHTML_header_1"> </th>',
paste(vapply(seq_along(headers) + 1, function(x) {
paste0(' <th id="tableHTML_header_', x, '">',
headers[x - 1],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
} else {
headers <- paste('<tr>',
paste(vapply(seq_along(headers), function(x) {
paste0(' <th id="tableHTML_header_', x, '">',
headers[x],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
}
#SECOND HEADERS--------------------------------------------------------------------------------
#adding second headers if available
if (!is.null(second_headers)) {
over_header <-
paste('<tr>',
paste(vapply(seq_along(second_headers[[1]]), function(x) {
paste0(' <th colspan=',
second_headers[[1]][x],
' id="tableHTML_second_header_',
x,
'">',
second_headers[[2]][x],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
} else {
over_header <- NULL
}
#TABLE'S BODY----------------------------------------------------------------------------------
#adding body - using headers_exported here because headers is of length 1
content <- lapply(seq_along(headers_exported), function(x) {
paste0(' <td id="tableHTML_column_', x, '">', obj[[x]], '</td>\n')
})
#adding rownames in the body
if (rownames == TRUE) {
content <- c(list(paste0(' <td id="tableHTML_rownames">',
row.names(obj),
'</td>\n')),
content)
}
content <- cbind('<tr>\n', do.call(cbind, content), '</tr>')
content <- paste(apply(content, 1, paste, collapse = ''), collapse = '\n')
#WIDTHS----------------------------------------------------------------------------------------
#setting column widths if any
if (!is.null(widths)) {
colwidths <- paste(
vapply(widths, function(x) {
paste0('<col width="', x, '">')
}, FUN.VALUE = character(1)),
collapse = '\n')
colwidths <- paste0(colwidths, '\n')
} else {
colwidths <- NULL
}
#CAPTION---------------------------------------------------------------------------------------
#adding a caption
if (!is.null(caption)) {
caption <- paste0('<caption>', caption, '</caption>\n')
}
#FOOTER----------------------------------------------------------------------------------------
#adding a footer
if (!is.null(footer)) {
footer <- paste0('<caption id="footer" align="bottom">', footer, '</caption>\n')
}
#PUTTING IT ALL TOGETHER-----------------------------------------------------------------------
#adding all the components in one html table
htmltable <-
htmltools::HTML(paste0('\n<table style="border-collapse:collapse;" class=',
class,
' border=',
border,
'>\n',
caption,
footer,
colwidths,
'<thead>\n',
over_header,
headers,
'</thead>\n',
'<tbody>\n',
content,
'\n',
'</tbody>\n',
'</table>',
collapse = ''))
#ADDING ROW GROUPS-----------------------------------------------------------------------------
#adding row groups in table
if (!is.null(row_groups)) {
htmltable <-
sub('<tr>\n <th id="tableHTML_header_1">',
'<tr>\n <th id="tableHTML_header_0"></th>\n <th id="tableHTML_header_1">',
htmltable)
rows <- Reduce('+', row_groups[[1]], accumulate = TRUE)
rows <- c(1, rows[-length(rows)] + 1)
if (!is.null(second_headers)) {
rows <- rows + 3
} else {
rows <- rows + 2
}
splits <- strsplit(htmltable, '<tr')
splits[[1]][2:length(splits[[1]])] <-
vapply(splits[[1]][2:length(splits[[1]])], function(x) paste0('<tr', x),
FUN.VALUE = character(1))
splits[[1]][rows] <-
mapply(function(x, y, z) {
x <- sub('<tr>\n',
paste0('<tr>\n <td id="tableHTML_row_groups" rowspan="',
z,
'">',
y,
'</td>\n'
),
x)},
splits[[1]][rows],
row_groups[[2]],
row_groups[[1]]
)
htmltable <- paste(splits[[1]], collapse = '')
htmltable <- htmltools::HTML(htmltable)
}
#ADDING CLASS AND RETURNING--------------------------------------------------------------------
#add class and attribute and then return htmltable
class(htmltable) <- c('tableHTML', class(htmltable))
attr(htmltable, 'headers') <- headers_exported
attr(htmltable, 'nrows') <- nrow(obj)
attr(htmltable, 'ncols') <- ncol(obj)
attr(htmltable, 'col_classes') <- col_classes
attr(htmltable, 'rownames') <- rownames
attr(htmltable, 'row_groups') <- !is.null(row_groups)
attr(htmltable, 'row_groups_data') <- row_groups
attr(htmltable, 'second_headers') <- !is.null(second_headers)
attr(htmltable, 'second_headers_data') <- second_headers
attr(htmltable, 'table_class') <- class
attr(htmltable, 'file_loc') <- tempfile(fileext = ".html")
if (add_data) attr(htmltable, 'data') <- obj
#Adding Collapse arg------------------------------------------------------------------------
#Collapse table according to collapse argument
if (collapse == 'separate') {
htmltable <- replace_html(htmltable,
'style="border-collapse:collapse;"',
paste0('style="border-collapse:separate;border-spacing:',
spacing,
';"'))
}
if (collapse == 'separate_shiny') {
htmltable <- replace_html(
htmltable,
'style="border-collapse:collapse;"',
paste0('style="border-collapse:separate !important;border-spacing:',
spacing,
'; !important"'))
}
#return
htmltable
}
#DECLARING S3 METHOD FOR PRINT-----------------------------------------------------------------
#' @rdname tableHTML
#' @export
print.tableHTML <- function(x, viewer = TRUE, ...) {
if (interactive() & viewer == TRUE) {
rstudioviewer <- getOption("viewer")
if (!is.null(attr(x, 'file_loc'))) {
file <- attr(x, 'file_loc')
} else {
file <- tempfile(fileext = ".html")
}
htmlfile <- htmltools::HTML(paste('<html>\n<body>',
x,
'</body>\n</html>',
sep = '\n'))
cat(htmlfile, file = file)
if (is.function(rstudioviewer)) {
rstudioviewer(file)
} else {
utils::browseURL(file)
}
} else if (viewer == FALSE | !interactive()) {
cat(x, ...)
}
invisible(x)
}
LyzandeR/tableHTML documentation built on April 17, 2023, 3:57 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions print.tableHTML tableHTML
Documented in print.tableHTML tableHTML
#' Create an easily css-ible HTML table
#'
#' The purpose of \code{tableHTML} is to create easily css-ible HTML tables
#' that are compatible with R shiny. The exported HTML table will contain separate ids
#' or classes for headers, columns, second headers (if any) and the table itself
#' (in case you have multiple tables) in order to create a
#' complex css file very easily. ids and classes are explained in detail in
#' the details section.
#'
#' \code{tableHTML} will create an HTML table with defined ids and classes for rows and columns.
#' In particular:
#' \itemize{
#' \item \strong{Table:} Will get the class from the class argument in the function.
#' \item \strong{Columns:} Will get an id which will be of the form tableHTML_column_x (where x
#' is the column position). If rownames exist these will get the tableHTML_rownames id. If
#' row groups exist these will get the tableHTML_row_groups id. Check the \code{add_css_column}
#' function for examples.
#' \item \strong{Headers:} Will get an id of the form tableHTML_header_x (where x is the header position).
#' For example the first header will have the id tableHTML_header_1, the second header
#' will have tableHTLM_header_2 and so on. If rownames exist these will get the tableHTML_header_0 id.
#' \item \strong{Second_Header:} Will get an id of the form tableHTML_second_header_x (where x is the
#' second header position). For example the first second_header will have the id tableHTML_second_header_1,
#' the second header will have tableHTML_second_header_2 and so on.
#' }
#'
#' Notice that rows do not get a specific id or class.
#'
#' If you would like to use a non-collapsed table i.e. leave spacing between cells, then
#' you would need to use the \code{collapse} argument. Setting it to separate would create a
#' non-collapsed table. However, this choice will not work in shiny. The reason is that shiny
#' uses \code{table {border-collapse: collapse; border-spacing:0;}} in its css by default through
#' bootstrap 3. In order to overcome this problem in shiny, \code{collapse} needs to be set to
#' separate_shiny instead of separate. By setting collapse to separate_shiny tableHTML uses
#' \code{!important} in order to overwrite the standard behaviour of bootstrap 3. \code{!important}
#' needs to be used with caution since it overwrites css styles, so unless you are using shiny
#' (or any other place where the above css is automatically loaded) you should be using
#' \code{collapse = 'separate'}.
#'
#' Printing the table will result in rendering it in R studio's viewer
#' with the print.tableHTML method if using Rstudio otherwise it will use the default
#' browser. Use \code{print(tableHTML(obj), viewer = FALSE)} or \code{str(tableHTML(obj))}
#' to view the actual html code.
#'
#' @param obj Needs to be a data.frame or a matrix or an arbitrary object that has the
#' data.frame class and can be coersible to a data.frame (e.g data.table, tbl, etc.)
#'
#' @param rownames Can be TRUE or FALSE. Defaults to TRUE. Whether the obj's rownames
#' will be inlcuded.
#'
#' @param class Character string. Specifies the table's class. Convinient if you have multiple
#' tables. Default is table_xxxx (random 4-digit number).
#'
#' @param headers character vector. The headers for the HTML table. If not provided the original
#' data.frame headers will be used.
#'
#' @param widths Needs to be a numeric atomic vector with the column widths. Widths are in pixels.
#'
#' @param second_headers A list of two elements of the same length. The first element will contain
#' the column spans (i.e. a numeric atomic vector) whereas the second element will contain the
#' names (i.e. a character atomic vector). See the examples for more info. Defauls to NULL.
#'
#' @param row_groups A list of two elements of the same length. The first element will contain
#' the row spans (i.e. a numeric atomic vector) whereas the second element will contain the
#' names (i.e. a character atomic vector). See the examples for more info. Defauls to NULL.
#'
#' @param caption Character string. The table's caption.
#'
#' @param footer Character string. The table's footer. This gets added below the table and it
#' should not be confused with tfooter.
#'
#' @param border An integer. Specifies the border of the table. Defaults to 1. 0 removes borders
#' from the table. The higher the number the thicker the table's outside border.
#'
#' @param collapse Whether to collapse the table or not. By default the tables are collapsed. The
#' choices for this argument are 'collapse', 'separate' and 'separate_shiny'. Check the details
#' about which one to use.
#'
#' @param spacing Character string. This is only used if collapse is either separate or
#' separate_shiny and sets the spacing between the table's cells. It defaults to 2px. Can be one
#' or two length values (provided as a string). If two length values are provided the first one
#' sets the horizontal spacing whereas the second sets the vertical spacing. See the examples.
#'
#' @param escape Can be TRUE or FALSE. Defaults to TRUE. Escapes characters < and > because they
#' can close (or open) the table's HTML tags if they exist within the data.frame's text. This
#' means that all < and > characters within the tableHTML will be converted to < and >
#' respectively.
#'
#' @param round An integer specifying the number of decimals of numbers of
#' numeric columns only. Defaults to NULL which means no rounding.
#'
#' @param replace_NA A sting that specifies with what to replace NAs in character
#' or factor columns only. Defaults to NULL which means NAs will be printed.
#'
#' @param x A tableHTML object created from the \code{tableHTML} function.
#'
#' @param ... Optional arguments to print.
#'
#' @param viewer TRUE or FALSE. Defaults to TRUE. Whether or not to render the HTML table. If
#' you are working on Rstudio (interactively) the table will be printed or Rstudio's viewer.
#' If you are working on Rgui (interactively) the table will be printed on your default browser.
#' If you set this to FALSE the HTML code will be printed on screen.
#'
#' @param add_data TRUE or FALSE. Defaults to TRUE. If set to true, the data.frame or matrix passed in
#' \code{obj} will be added to the attributes. If set to FALSE, the object will be smaller, but
#' \code{add_css_conditional_column} would not be applicable.
#'
#' @param theme Argument is Deprecated. Please use the add_theme function instead.
#'
#' @return A tableHTML object.
#'
#' @examples
#' tableHTML(mtcars)
#' tableHTML(mtcars, rownames = FALSE)
#' tableHTML(mtcars, class = 'table1')
#' tableHTML(mtcars, second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars,
#' widths = c(rep(50, 6), rep(100, 6)),
#' second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars, caption = 'This is a caption', footer = 'This is a footer')
#' tableHTML(mtcars,
#' row_groups = list(c(10, 10, 12), c('Group 1', 'Group 2', 'Group 3')),
#' widths = c(200, rep(50, 5), rep(100, 6)),
#' rownames = FALSE)
#' tableHTML(mtcars,
#' rownames = FALSE,
#' widths = c(140, rep(50, 11)),
#' row_groups = list(c(10, 10, 12), c('Group 1', 'Group 2', 'Group 3')),
#' second_headers = list(c(3, 4, 5), c('col1', 'col2', 'col3')))
#' tableHTML(mtcars, collapse = 'separate_shiny', spacing = '5px')
#' tableHTML(mtcars, collapse = 'separate', spacing = '5px 2px')
#'
#' @export
tableHTML <- function(obj,
rownames = TRUE,
class = paste0('table_', sample(1000:9999, 1)),
widths = NULL,
headers = NULL,
second_headers = NULL,
row_groups = NULL,
caption = NULL,
footer = NULL,
border = 1,
collapse = c('collapse', 'separate', 'separate_shiny'),
spacing = '2px',
escape = TRUE,
round = NULL,
replace_NA = NULL,
add_data = TRUE,
theme = NULL) {
#CHECKS----------------------------------------------------------------------------------------
#adding checks for obj
if (is.matrix(obj)) {
obj <- as.data.frame(obj)
} else if (inherits(obj, 'data.frame')) {
obj <- as.data.frame(obj)
} else {
stop('obj needs to be either a data.frame or a matrix')
}
if (!is.null(theme)) {
stop('Argument is Deprecated. Please use the add_theme function instead.')
}
#need to capture the column classes at the very beginning ----Pausing checks for a line
col_classes <- unname(sapply(obj, function(x) class(x)))
#checks for rownames
if (!rownames %in% c(TRUE, FALSE)) {
stop('rownames argument needs to be either TRUE or FALSE')
}
#checks for second header
if (!is.null(second_headers)) {
if (!is.list(second_headers)) {
stop('second_headers needs to be a list')
}
if (length(second_headers) != 2L) {
stop('second_headers needs to be a list of length two')
}
if (!is.numeric(second_headers[[1]])) {
stop("second_headers\'s first element needs to be numeric")
}
if (!is.character(second_headers[[2]])) {
stop("second_headers\'s second element needs to be character")
}
if (length(second_headers[[1]]) != length(second_headers[[2]])) {
stop("second_headers\'s elements need to have the same length")
}
}
#checks for widths
if (rownames == TRUE & !is.null(widths) & is.null(row_groups)) {
if (length(widths) != ncol(obj) + 1) stop('widths must have the same length as the columns + 1')
} else if (rownames == FALSE & !is.null(widths) & is.null(row_groups)) {
if (length(widths) != ncol(obj)) stop('widths must have the same length as the columns')
} else if (rownames == TRUE & !is.null(widths) & !is.null(row_groups)) {
if (length(widths) != ncol(obj) + 2) stop('widths must have the same length as the columns + 2')
} else if (rownames == FALSE & !is.null(widths) & !is.null(row_groups)) {
if (length(widths) != ncol(obj) + 1) stop('widths must have the same length as the columns + 1')
}
#check for the border argument
if (!is.numeric(border)) stop('border needs to be an integer')
border <- as.integer(border)
#make sure collapse has the right argument
collapse <- match.arg(collapse)
#check the add_data argument
##TEST
if (!is.logical(add_data) | !length(add_data) == 1) {
stop("add_data must be either TRUE or FALSE")
}
#make sure the first character of spacing is a number
if (collapse %in% c('separate', 'separate_shiny')) {
distances <- gsub('\\s+', ' ', spacing)
distances <- strsplit(distances, ' ')[[1]]
for (i in distances) {
if (is.na(as.numeric(sub('[[:alpha:]]+', '', i)))) {
stop('distances in spacing need to start with a number e.g. "1px 2px"')
}
}
}
if (!is.null(headers)) {
if (length(headers) != length(names(obj))) {
stop('The length of the headers needs to be the same as number of columns of the data.frame')
}
}
#------
#taking care of headers
if (is.null(headers)) {
headers <- names(obj)
}
#------
#escape character > and < in the data and headers because it will close or open tags
if (escape) {
obj[sapply(obj, is.fachar)] <- lapply(obj[sapply(obj, is.fachar)], function(x) {
if (is.factor(x)) {
temp_levels <- levels(x)
x <- gsub('>', '>', x)
x <- gsub('<', '<', x)
temp_levels <- gsub('>', '>', temp_levels)
temp_levels <- gsub('<', '<', temp_levels)
factor(x, levels = temp_levels)
} else {
x <- gsub('>', '>', x)
x <- gsub('<', '<', x)
x
}
})
headers <- gsub('>', '>', force(headers))
headers <- gsub('<', '<', force(headers))
}
#make sure headers do not contain empty string
headers[headers == ''] <- ' '
#make sure headers do not contain duplicates
#we fix that by adding white spaces which are ignored
#in html
headers <- fix_header_dupes(headers)
#headers to be exported
headers_exported <- headers
#rounding numeric columns
if (!is.null(round)) {
if (!is.numeric(round)) stop('round needs to be an integer.')
obj[sapply(obj, is.numeric)] <- lapply(obj[sapply(obj, is.numeric)], function(x) {
x <- round(x, round)
x
})
}
#replacing NA values for character and factor columns
if (!is.null(replace_NA)) {
obj[sapply(obj, is.fachar)] <- lapply(obj[sapply(obj, is.fachar)], function(x) {
if(is.factor(x)) {
levels(x) <- c(levels(x), replace_NA)
temp_levels <- levels(x)
x[is.na(x)] <- replace_NA
temp_levels[is.na(temp_levels)] <- replace_NA
factor(x, levels = temp_levels)
}
x[is.na(x)] <- replace_NA
x
})
}
#HEADERS---------------------------------------------------------------------------------------
#taking into account rownames
if (rownames == TRUE) {
headers <- paste('<tr>',
' <th id="tableHTML_header_1"> </th>',
paste(vapply(seq_along(headers) + 1, function(x) {
paste0(' <th id="tableHTML_header_', x, '">',
headers[x - 1],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
} else {
headers <- paste('<tr>',
paste(vapply(seq_along(headers), function(x) {
paste0(' <th id="tableHTML_header_', x, '">',
headers[x],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
}
#SECOND HEADERS--------------------------------------------------------------------------------
#adding second headers if available
if (!is.null(second_headers)) {
over_header <-
paste('<tr>',
paste(vapply(seq_along(second_headers[[1]]), function(x) {
paste0(' <th colspan=',
second_headers[[1]][x],
' id="tableHTML_second_header_',
x,
'">',
second_headers[[2]][x],
'</th>')
},
FUN.VALUE = character(1)),
collapse = '\n'),
'</tr>\n',
sep = '\n')
} else {
over_header <- NULL
}
#TABLE'S BODY----------------------------------------------------------------------------------
#adding body - using headers_exported here because headers is of length 1
content <- lapply(seq_along(headers_exported), function(x) {
paste0(' <td id="tableHTML_column_', x, '">', obj[[x]], '</td>\n')
})
#adding rownames in the body
if (rownames == TRUE) {
content <- c(list(paste0(' <td id="tableHTML_rownames">',
row.names(obj),
'</td>\n')),
content)
}
content <- cbind('<tr>\n', do.call(cbind, content), '</tr>')
content <- paste(apply(content, 1, paste, collapse = ''), collapse = '\n')
#WIDTHS----------------------------------------------------------------------------------------
#setting column widths if any
if (!is.null(widths)) {
colwidths <- paste(
vapply(widths, function(x) {
paste0('<col width="', x, '">')
}, FUN.VALUE = character(1)),
collapse = '\n')
colwidths <- paste0(colwidths, '\n')
} else {
colwidths <- NULL
}
#CAPTION---------------------------------------------------------------------------------------
#adding a caption
if (!is.null(caption)) {
caption <- paste0('<caption>', caption, '</caption>\n')
}
#FOOTER----------------------------------------------------------------------------------------
#adding a footer
if (!is.null(footer)) {
footer <- paste0('<caption id="footer" align="bottom">', footer, '</caption>\n')
}
#PUTTING IT ALL TOGETHER-----------------------------------------------------------------------
#adding all the components in one html table
htmltable <-
htmltools::HTML(paste0('\n<table style="border-collapse:collapse;" class=',
class,
' border=',
border,
'>\n',
caption,
footer,
colwidths,
'<thead>\n',
over_header,
headers,
'</thead>\n',
'<tbody>\n',
content,
'\n',
'</tbody>\n',
'</table>',
collapse = ''))
#ADDING ROW GROUPS-----------------------------------------------------------------------------
#adding row groups in table
if (!is.null(row_groups)) {
htmltable <-
sub('<tr>\n <th id="tableHTML_header_1">',
'<tr>\n <th id="tableHTML_header_0"></th>\n <th id="tableHTML_header_1">',
htmltable)
rows <- Reduce('+', row_groups[[1]], accumulate = TRUE)
rows <- c(1, rows[-length(rows)] + 1)
if (!is.null(second_headers)) {
rows <- rows + 3
} else {
rows <- rows + 2
}
splits <- strsplit(htmltable, '<tr')
splits[[1]][2:length(splits[[1]])] <-
vapply(splits[[1]][2:length(splits[[1]])], function(x) paste0('<tr', x),
FUN.VALUE = character(1))
splits[[1]][rows] <-
mapply(function(x, y, z) {
x <- sub('<tr>\n',
paste0('<tr>\n <td id="tableHTML_row_groups" rowspan="',
z,
'">',
y,
'</td>\n'
),
x)},
splits[[1]][rows],
row_groups[[2]],
row_groups[[1]]
)
htmltable <- paste(splits[[1]], collapse = '')
htmltable <- htmltools::HTML(htmltable)
}
#ADDING CLASS AND RETURNING--------------------------------------------------------------------
#add class and attribute and then return htmltable
class(htmltable) <- c('tableHTML', class(htmltable))
attr(htmltable, 'headers') <- headers_exported
attr(htmltable, 'nrows') <- nrow(obj)
attr(htmltable, 'ncols') <- ncol(obj)
attr(htmltable, 'col_classes') <- col_classes
attr(htmltable, 'rownames') <- rownames
attr(htmltable, 'row_groups') <- !is.null(row_groups)
attr(htmltable, 'row_groups_data') <- row_groups
attr(htmltable, 'second_headers') <- !is.null(second_headers)
attr(htmltable, 'second_headers_data') <- second_headers
attr(htmltable, 'table_class') <- class
attr(htmltable, 'file_loc') <- tempfile(fileext = ".html")
if (add_data) attr(htmltable, 'data') <- obj
#Adding Collapse arg------------------------------------------------------------------------
#Collapse table according to collapse argument
if (collapse == 'separate') {
htmltable <- replace_html(htmltable,
'style="border-collapse:collapse;"',
paste0('style="border-collapse:separate;border-spacing:',
spacing,
';"'))
}
if (collapse == 'separate_shiny') {
htmltable <- replace_html(
htmltable,
'style="border-collapse:collapse;"',
paste0('style="border-collapse:separate !important;border-spacing:',
spacing,
'; !important"'))
}
#return
htmltable
}
#DECLARING S3 METHOD FOR PRINT-----------------------------------------------------------------
#' @rdname tableHTML
#' @export
print.tableHTML <- function(x, viewer = TRUE, ...) {
if (interactive() & viewer == TRUE) {
rstudioviewer <- getOption("viewer")
if (!is.null(attr(x, 'file_loc'))) {
file <- attr(x, 'file_loc')
} else {
file <- tempfile(fileext = ".html")
}
htmlfile <- htmltools::HTML(paste('<html>\n<body>',
x,
'</body>\n</html>',
sep = '\n'))
cat(htmlfile, file = file)
if (is.function(rstudioviewer)) {
rstudioviewer(file)
} else {
utils::browseURL(file)
}
} else if (viewer == FALSE | !interactive()) {
cat(x, ...)
}
invisible(x)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.