Nothing
#' Outputting HTML tables in RStudio viewer/R Notebooks
#'
#' This is method for rendering results of \link{fre}/\link{cro}/\link{tables}
#' in Shiny/RMarkdown/Jupyter notebooks and etc. For detailed description of
#' function and its arguments see \link[htmlTable]{htmlTable}. You can pack your
#' tables in the list and render them all simultaneously. See examples. You may
#' be interested in \code{expss_output_viewer()} for automatical rendering
#' tables in the RStudio viewer or \code{expss_output_rnotebook()} for
#' rendering in the R notebooks. See \link{expss.options}. \code{repr_html} is
#' method for rendering table in the Jupyter notebooks and \code{knit_print} is
#' method for rendering table in the \code{knitr} HTML-documents. Jupyter
#' notebooks and \code{knitr} documents are supported automatically but in the R
#' notebooks it is needed to set output to notebook via
#' \code{expss_output_rnotebook()}.
#'
#' @param x a data object of class 'etable' - result of \link{fre}/\link{cro} and etc.
#' @param obj a data object of class 'etable' - result of \link{fre}/\link{cro} and etc.
#' @param digits integer By default, all numeric columns are rounded to one digit after
#' decimal separator. Also you can set this argument by setting option 'expss.digits'
#' - for example, \code{expss_digits(2)}. If it is NA than all
#' numeric columns remain unrounded.
#' @param escape.html logical: should HTML characters be escaped? Defaults to FALSE.
#' @param ... further parameters for \link[htmlTable]{htmlTable}.
#' @param row_groups logical Should we create row groups? TRUE by default.
#' @param gap character Separator between tables if we output list of
#' tables. By default it is line break '<br>'.
#' @param header Ignored.
#' @param rnames Ignored.
#' @param rowlabel Ignored.
#' @param caption See manual for \link[htmlTable]{htmlTable}.
#' @param tfoot See manual for \link[htmlTable]{htmlTable}.
#' @param label See manual for \link[htmlTable]{htmlTable}.
#' @param rgroup Ignored.
#' @param n.rgroup Ignored.
#' @param cgroup Ignored.
#' @param n.cgroup Ignored.
#' @param tspanner See manual for \link[htmlTable]{htmlTable}.
#' @param n.tspanner See manual for \link[htmlTable]{htmlTable}.
#' @param total See manual for \link[htmlTable]{htmlTable}.
#' @param ctable See manual for \link[htmlTable]{htmlTable}.
#' @param compatibility See manual for \link[htmlTable]{htmlTable}.
#' @param cspan.rgroup See manual for \link[htmlTable]{htmlTable}.
#' @return Returns a string of class htmlTable
#' @export
#'
#' @examples
#' \dontrun{
#' 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"
#' )
#'
#' expss_output_viewer()
#' 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.")
#'
#' # several tables in a list
#' list(
#' cross_cpct(mtcars, list(am, vs, cyl), list(total(), am))
#' %>% set_caption("Table 1. Percent."),
#' cross_mean_sd_n(mtcars, list(mpg, hp, qsec), list(total(), am))
#' %>% set_caption("Table 2. Means.")
#' ) %>%
#' htmlTable()
#'
#' expss_output_default()
#'
#' }
htmlTable.etable = function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL,
tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL,
cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL,
total = NULL, ctable = TRUE,
compatibility = getOption("htmlTableCompat", "LibreOffice"),
cspan.rgroup = "all", escape.html = FALSE, ...,
digits = get_expss_digits(), row_groups = TRUE){
# old signature - function(x, digits = get_expss_digits(), escape.html = FALSE, ..., row_groups = TRUE)
if(NCOL(x) == 0){
return(htmlTable(setNames(sheet("Table is empty"), " "), escape.html = escape.html, ...))
}
# because rowlabels and column names never escaped
dollar = "$"
na_str = "<NA>"
nb_space = " "
# escape <NA>
colnames(x) = gsub("<NA>", na_str, colnames(x), fixed = TRUE)
colnames(x) = gsub("$", dollar, colnames(x), fixed = TRUE)
if(is.character(x[[1]]) || is.factor(x[[1]])){
x[[1]] = gsub("<NA>", na_str, x[[1]], fixed = TRUE)
x[[1]] = gsub("$", dollar, x[[1]], fixed = TRUE)
}
if(escape.html){
na_str = "<NA>"
dollar = "$"
nb_space = ""
}
digits = if_null(digits, 1)
if(!is.na(digits)){
x = round_dataframe(x, digits = digits)
not_total = !get_total_rows_indicator(x, total_marker = "#")
# no first column
for(i in seq_len(NCOL(x))[-1]){
curr_col = x[[i]][not_total]
if(is.numeric(curr_col) && any(grepl("\\.|,", curr_col, perl = TRUE))){
x[[i]][not_total] = trimws(format(curr_col, nsmall = digits, justify = "right"))
x[[i]][not_total][is.na(curr_col)] = ""
}
## for significance marks
if(is.character(curr_col) || is.factor(curr_col)){
x[[i]] = gsub("^[\\s\\t]+$", " ", x[[i]], perl = TRUE )
x[[i]] = gsub("$", dollar, x[[i]], fixed = TRUE )
x[[i]] = gsub("<NA>", na_str, x[[i]], fixed = TRUE)
has_symbols = grepl("[^\\s^\\t]", x[[i]], perl = TRUE)
x[[i]][has_symbols] = gsub("\\s$", nb_space,
x[[i]][has_symbols], perl = TRUE)
x[[i]] = gsub("([\\d])$", paste0("\\1",nb_space), x[[i]], perl = TRUE)
}
}
}
if(!row_groups){
return(html_table_no_row_groups(x = x
,caption = caption
,rowlabel = rowlabel
,tfoot = tfoot
,label = label
,tspanner = tspanner
,n.tspanner = n.tspanner
,total = total
,ctable = ctable
,compatibility = compatibility
,cspan.rgroup = cspan.rgroup
,escape.html = escape.html
,...
)
)
}
first_lab = colnames(x)[1]
if(first_lab == "row_labels") first_lab = ""
row_labels = x[[1]]
x[[1]] = NULL # remove first column. This method is needed to prevent column names damaging
header = t(split_labels(colnames(x), split = "|", fixed = TRUE, remove_repeated = FALSE))
header_last_row = t(split_labels(colnames(x),
split = "|",
fixed = TRUE,
remove_repeated = TRUE))[NROW(header), , drop = FALSE]
for(each in seq_len(NCOL(header))){
curr_col = header[, each]
ok = !is.na(curr_col) & curr_col!=""
header[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
for(each in seq_len(NCOL(header_last_row))){
curr_col = header_last_row[, each]
ok = !is.na(curr_col) & curr_col!=""
header_last_row[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
if(NCOL(header)>0){
html_header = header_last_row
if(NROW(header)>1){
cgroup_list = matrix_to_cgroup(header[-NROW(header), ,drop = FALSE])
cgroup = cgroup_list[["cgroup"]]
n.cgroup = cgroup_list[["n.cgroup"]]
} else {
cgroup = matrix(character(0), 0, 0)
n.cgroup = matrix(0, 1, 1)
}
} else {
html_header = character(0)
cgroup = matrix(character(0), 0, 0)
n.cgroup = matrix(0, 1, 1)
}
align = rep("r", NCOL(x))
row_labels = split_labels(row_labels, split = "|", fixed = TRUE)
for(each in seq_len(NCOL(row_labels))){
curr_col = row_labels[, each]
ok = !is.na(curr_col) & curr_col!=""
row_labels[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
if(NCOL(row_labels)==0) row_labels = matrix("", 1, 1)
if(NCOL(row_labels) == 1){
rnames = row_labels[,1]
rgroup = NULL
n.rgroup = NULL
} else {
if(NCOL(row_labels) > 2){
x = sheet(row_labels[, -(1:2)], x)
html_header = c(rep("", NCOL(row_labels) - 2), html_header)
align = c(rep("l", NCOL(row_labels) - 2), align)
if(NROW(cgroup)>0){
if(NCOL(header)>0){
cgroup = cbind("", cgroup)
n.cgroup = cbind(NCOL(row_labels) - 2, n.cgroup)
} else {
cgroup = matrix("", 1, 1)
n.cgroup = matrix(NCOL(row_labels) - 2, 1, 1)
}
}
}
rnames = row_labels[,2]
temp = row_labels[,1]
for(each in seq_along(temp)[-1]) {
if(temp[each]=="") temp[each] = temp[each-1]
}
temp = rle(temp)
rgroup = temp$values
n.rgroup = temp$lengths
}
# cgroup = cgroup[-NROW(cgroup), ,drop = FALSE]
# n.cgroup = n.cgroup[-NROW(n.cgroup), , drop = FALSE]
html_table_args = list()
if(NCOL(x)>0){
html_table_args$x = as.sheet(x)
html_table_args$header = html_header
html_table_args$align = align
if(NROW(cgroup)>0){
html_table_args$cgroup = cgroup[,colSums(!is.na(cgroup))>0, drop = FALSE]
html_table_args$n.cgroup = n.cgroup[,colSums(!is.na(n.cgroup))>0, drop = FALSE]
}
} else {
x = rep("", NROW(x))
html_table_args$x = as.sheet(x)
html_table_args$header = ""
}
html_table_args$rnames = rnames
html_table_args$rgroup = rgroup
html_table_args$n.rgroup = n.rgroup
html_table_args$rowlabel = first_lab
supplied_args = list(caption = caption
,rowlabel = rowlabel
,tfoot = tfoot
,label = label
,tspanner = tspanner
,n.tspanner = n.tspanner
,total = total
,ctable = ctable
,compatibility = compatibility
,cspan.rgroup = cspan.rgroup
,escape.html = escape.html
,...)
supplied_args = supplied_args[!sapply(supplied_args, is.null)]
html_table_args = html_table_args %n_d% names(supplied_args)
html_table_args = c(html_table_args, supplied_args)
do.call(htmlTable, html_table_args)
}
#' @export
#' @rdname htmlTable.etable
htmlTable.with_caption = function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL,
tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL,
cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL,
total = NULL, ctable = TRUE,
compatibility = getOption("htmlTableCompat", "LibreOffice"),
cspan.rgroup = "all", escape.html = FALSE, ...,
digits = get_expss_digits(), row_groups = TRUE){
if(is.null(caption)) caption = get_caption(x)
x = set_caption(x, NULL)
html_table_args = list(x = x
,caption = caption
,rowlabel = rowlabel
,tfoot = tfoot
,label = label
,tspanner = tspanner
,n.tspanner = n.tspanner
,total = total
,ctable = ctable
,compatibility = compatibility
,cspan.rgroup = cspan.rgroup
,escape.html = escape.html
,...
,digits = digits
,row_groups = row_groups)
html_table_args = html_table_args[!sapply(html_table_args, is.null)]
do.call(htmlTable, html_table_args)
}
#' @export
#' @rdname htmlTable.etable
htmlTable.list = function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL,
tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL,
cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL,
total = NULL, ctable = TRUE,
compatibility = getOption("htmlTableCompat", "LibreOffice"),
cspan.rgroup = "all", escape.html = FALSE, ...,
digits = get_expss_digits(), row_groups = TRUE, gap = "<br>"){
html_table_args = list(x = NA # just placeholder
,caption = caption
,rowlabel = rowlabel
,tfoot = tfoot
,label = label
,tspanner = tspanner
,n.tspanner = n.tspanner
,total = total
,ctable = ctable
,compatibility = compatibility
,cspan.rgroup = cspan.rgroup
,escape.html = escape.html
,...
,digits = digits
,row_groups = row_groups)
html_table_args = html_table_args[!sapply(html_table_args, is.null)]
res = lapply(x, function(item){
html_table_args[["x"]] = item
do.call(htmlTable, html_table_args)
})
res = do.call(paste, c(res, list(sep = gap)))
class(res) = c("htmlTable", "character")
res
}
matrix_to_cgroup = function(header){
rle_list = list()
if(NCOL(header)>1){
for(i in seq_len(nrow(header))){
y = colSums((header[1:i,-1L, drop = FALSE] != header[1:i, -ncol(header), drop = FALSE]))>0
changes = c(which(y | is.na(y)), ncol(header))
rle_list[[i]] = structure(list(lengths = diff(c(0L, changes)),
values = header[i, changes]))
}
} else {
for(i in seq_len(nrow(header))){
rle_list[[i]] = structure(list(lengths = 1,
values = header[i, ])
)
}
}
cgroup = lapply(rle_list, "[[", "values")
n.cgroup = lapply(rle_list, "[[", "lengths")
max_cgroup_length = max(lengths(cgroup))
for(each in seq_along(cgroup)){
if(length(cgroup[[each]])<max_cgroup_length){
cgroup[[each]][max_cgroup_length] = NA
n.cgroup[[each]][max_cgroup_length] = NA
}
}
list(cgroup = do.call(rbind, cgroup), n.cgroup = do.call(rbind, n.cgroup))
}
#' @rawNamespace if(getRversion() >= "3.6.0") {
#' S3method(knitr::knit_print, etable)
#' S3method(knitr::knit_print, with_caption)
#' S3method(repr::repr_html, etable)
#' S3method(repr::repr_html, with_caption)
#' S3method(repr::repr_text, etable)
#' S3method(repr::repr_text, with_caption)
#' } else {
#' export(knit_print.etable)
#' export(knit_print.with_caption)
#' export(repr_html.etable)
#' export(repr_html.with_caption)
#' export(repr_text.etable)
#' export(repr_text.with_caption)
#' }
#' @rdname htmlTable.etable
knit_print.etable = function(x, ..., digits = get_expss_digits(), escape.html = FALSE){
# Get type of document
type = knitr::is_html_output()
# Check if huxtable is available
hux_available = requireNamespace("huxtable", quietly = TRUE)
hux_output = identical(getOption("expss.output"), "huxtable")
# For html or markdown use htmlTable, for latex and docx huxtable (if available)
if((type || !hux_available) & !hux_output) {
knitr::knit_print(htmlTable.etable(x, digits = digits,
escape.html = escape.html,
..., row_groups = TRUE))
} else {
knitr::knit_print(huxtable::as_hux(x), ...)
}
}
#' @rdname htmlTable.etable
knit_print.with_caption = function(x, ..., digits = get_expss_digits(), escape.html = FALSE){
# Get type of document
type = knitr::is_html_output()
# Check if huxtable is available
hux_available = requireNamespace("huxtable", quietly = TRUE)
hux_output = identical(getOption("expss.output"), "huxtable")
# For html or markdown use htmlTable, for latex and docx huxtable (if available)
if((type || !hux_available) & !hux_output) {
knitr::knit_print(htmlTable.with_caption(x, digits = digits,
escape.html = escape.html,
..., row_groups = TRUE))
} else {
knitr::knit_print(huxtable::as_hux(x), ...)
}
}
#' @rdname htmlTable.etable
repr_html.etable = function(obj, ..., digits = get_expss_digits(), escape.html = FALSE){
htmlTable(obj, digits = digits, escape.html = escape.html, ..., row_groups = FALSE)
}
#' @rdname htmlTable.etable
repr_html.with_caption = function(obj, ..., digits = get_expss_digits(), escape.html = FALSE){
htmlTable(obj, digits = digits, escape.html = escape.html, ..., row_groups = FALSE)
}
#' @rdname htmlTable.etable
repr_text.etable = function(obj, ..., digits = get_expss_digits()){
curr_output = getOption("expss.output")
if(!("raw" %in% curr_output)){
obj = split_all_in_etable_for_print(obj,
digits = digits,
remove_repeated = TRUE)
}
if("commented" %in% curr_output){
if(NROW(obj)>0 && NCOL(obj)>0){
obj = cbind("#" = "#", obj)
colnames(obj) = rep("", length(obj))
}
}
width = getOption("width")
on.exit(options(width = width))
options(width = 1000)
paste(capture.output(print.data.frame(obj, ..., right = TRUE, row.names = FALSE)),
collapse = "\n")
}
#' @rdname htmlTable.etable
repr_text.with_caption = function(obj, ..., digits = get_expss_digits()){
width = getOption("width")
on.exit(options(width = width))
options(width = 1000)
paste(capture.output(print(obj, digits = digits, ...)),
collapse = "\n")
}
## for Jupyter notebooks where row headings are not rendered correctly
html_table_no_row_groups = function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL,
tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL,
cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL,
total = NULL, ctable = TRUE,
compatibility = getOption("htmlTableCompat", "LibreOffice"),
cspan.rgroup = "all", escape.html = FALSE, ...){
if(!escape.html){
nb_space = " "
} else {
nb_space = ""
}
first_lab = colnames(x)[1]
if(first_lab == "row_labels") first_lab = ""
row_labels = x[[1]]
x[[1]] = NULL # remove first column. This method is needed to prevent column names damaging
header = t(split_labels(colnames(x), split = "|", fixed = TRUE, remove_repeated = FALSE))
header_last_row = t(split_labels(colnames(x),
split = "|",
fixed = TRUE,
remove_repeated = TRUE))[NROW(header), , drop = FALSE]
for(each in seq_len(NCOL(header))){
curr_col = header[, each]
ok = !is.na(curr_col) & curr_col!=""
header[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
for(each in seq_len(NCOL(header_last_row))){
curr_col = header_last_row[, each]
ok = !is.na(curr_col) & curr_col!=""
header_last_row[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
if(NCOL(header)>0){
html_header = header_last_row
if(NROW(header)>1){
cgroup_list = matrix_to_cgroup(header[-NROW(header), ,drop = FALSE])
cgroup = cgroup_list[["cgroup"]]
n.cgroup = cgroup_list[["n.cgroup"]]
} else {
cgroup = matrix(character(0), 0, 0)
n.cgroup = matrix(0, 1, 1)
}
} else {
html_header = character(0)
cgroup = matrix(character(0), 0, 0)
n.cgroup = matrix(0, 1, 1)
}
align = rep("r", NCOL(x))
row_labels = split_labels(row_labels, split = "|", fixed = TRUE)
for(each in seq_len(NCOL(row_labels))){
curr_col = row_labels[, each]
ok = !is.na(curr_col) & curr_col!=""
row_labels[ok, each] =
paste0(nb_space, curr_col[ok], nb_space)
}
if(NCOL(row_labels)==0) row_labels = matrix("", 1, 1)
if(NCOL(row_labels) == 1){
rnames = row_labels[,1]
} else {
if(NCOL(row_labels) > 1){
x = sheet(row_labels[, -1], x)
html_header = c(rep("", NCOL(row_labels) - 1), html_header)
align = c(rep("l", NCOL(row_labels) - 1), align)
if(NROW(cgroup)>0){
if(NCOL(header)>0){
cgroup = cbind("", cgroup)
n.cgroup = cbind(NCOL(row_labels) - 1, n.cgroup)
} else {
cgroup = matrix("", 1, 1)
n.cgroup = matrix(NCOL(row_labels) - 1, 1, 1)
}
}
}
rnames = row_labels[,1]
}
# cgroup = cgroup[-NROW(cgroup), ,drop = FALSE]
# n.cgroup = n.cgroup[-NROW(n.cgroup), , drop = FALSE]
html_table_args = list()
if(NCOL(x)>0){
html_table_args$x = as.sheet(x)
html_table_args$header = html_header
html_table_args$align = align
if(NROW(cgroup)>0){
html_table_args$cgroup = cgroup[,colSums(!is.na(cgroup))>0, drop = FALSE]
html_table_args$n.cgroup = n.cgroup[,colSums(!is.na(n.cgroup))>0, drop = FALSE]
}
} else {
x = rep("", NROW(x))
html_table_args$x = as.sheet(x)
html_table_args$header = ""
}
html_table_args$rnames = rnames
html_table_args$rowlabel = first_lab
supplied_args = list(caption = caption
,rowlabel = rowlabel
,tfoot = tfoot
,label = label
,tspanner = tspanner
,n.tspanner = n.tspanner
,total = total
,ctable = ctable
,compatibility = compatibility
,cspan.rgroup = cspan.rgroup
,escape.html = escape.html
,...)
supplied_args = supplied_args[!sapply(supplied_args, is.null)]
html_table_args = html_table_args %n_d% names(supplied_args)
html_table_args = c(html_table_args, supplied_args)
do.call(htmlTable, html_table_args)
}
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.