R/print.summarytools.R
In dcomtois/summarytools: Tools to Quickly and Neatly Summarize Data
Defines functions
build_heading_html
build_heading_pander
print_dfs
print_descr
print_ctable
print_freq
print.summarytools
Documented in
print.summarytools
#' print.summarytools
#'
#' Display \code{summarytools} objects in the console, in Web Browser or in
#' \emph{RStudio}'s Viewer, or write content to file.
#'
#' @usage
#' \method{print}{summarytools}(x, method = "pander", file = "",
#' append = FALSE, report.title = NA, table.classes = NA,
#' bootstrap.css = st_options('bootstrap.css'),
#' custom.css = st_options('custom.css'), silent = FALSE,
#' footnote = st_options('footnote'), max.tbl.height = Inf,
#' collapse = 0, escape.pipe = st_options("escape.pipe"), \dots)
#'
#' @param x A \emph{summarytools} object, created by one of the four core
#' functions (\code{\link{freq}}, \code{\link{descr}}, \code{\link{ctable}},
#' or \code{\link{dfSummary}}).
#' @param method Character. One of \dQuote{pander}, \dQuote{viewer},
#' \dQuote{browser}, or \dQuote{render}. Default value for the \code{print()}
#' method is \dQuote{pander}; for \code{view()}/\code{stview()}, default is
#' \dQuote{viewer} if session is running in \emph{RStudio}, \dQuote{browser}
#' otherwise. The main use for \dQuote{render} is in \emph{R Markdown}
#' documents.
#' @param file Character. File name to write output to. Defaults to \dQuote{}.
#' @param append Logical. Append output to existing file (specified using the
#' \emph{file} argument). \code{FALSE} by default.
#' @param report.title Character. For \emph{html} reports, this goes into the
#' \code{<title>} tag. When left to \code{NA} (default), the first line of the
#' heading section is used (\emph{e.g.}: \dQuote{Data Frame Summary}).
#' @param table.classes Character. Additional \emph{html} classes to assign to
#' output tables. \emph{Bootstrap css} classes can be used. User-defined
#' classes (see the \emph{custom.css} argument) are also specified here. See
#' \emph{details} section. \code{NA} by default.
#' @param bootstrap.css Logical. When generating an \emph{html} document,
#' include the \dQuote{\emph{includes/stylesheets/bootstrap.min.css"}} file
#' content inside a \code{<style type="text/css">} tag in the document's
#' \code{<head>}. \code{TRUE} by default. Can be set globally with
#' \code{\link{st_options}}.
#' @param custom.css Character. Path to a custom \emph{.css} file. Classes
#' defined in this must also appear in the \code{table.classes} parameter
#' in order to be applied to the table(s). Can be set globally with
#' \code{\link{st_options}}. \code{NA} by default.
#' @param silent Logical. Set to \code{TRUE} to hide console messages
#' (\emph{e.g.}: ignored variables or \code{NaN} to \code{NA}
#' transformations). \code{FALSE} by default.
#' @param footnote Character. Text to display just after \emph{html} output
#' tables. The default value (\dQuote{\emph{default}}) produces a two-line
#' footnote indicating the package's name and version, the R version, and
#' the current date. Has no effect on \emph{ascii} or \emph{markdown}
#' content. Can contain standard \emph{html} tags. Set to \code{NA} to omit.
#' Can be set globally with \code{\link{st_options}}.
#' @param max.tbl.height Numeric. Maximum table height \emph{in pixels} allowed
#' in rendered \code{dfSummary()} tables. When this argument is used, results
#' will show up in a \code{<div>} with the specified height and a scroll bar.
#' Intended to be used in \emph{Rmd} documents with \code{method = "render"}.
#' \code{Inf} by default.
#' @param collapse Numeric. \code{0} by default. Set to \code{1} to make
#' \code{freq()} sections collapsible (when clicking on the variable name).
#' Future versions might provide alternate collapsing options.
#' @param escape.pipe Logical. Set to \code{TRUE} when \code{style="grid"}
#' and \code{file} argument is supplied if the intent is to generate a text
#' file that can be converted to other formats using \emph{Pandoc}. Can be
#' set globally with \code{\link{st_options}}.
#' @param \dots Additional arguments used to override attributes stored in the
#' object, or to change formatting via \code{\link[base]{format}} or
#' \code{\link[pander]{pander}}. See \emph{Details}.
#'
#' @return \code{NULL} when \code{method="pander"}; A file path returned
#' invisibly when \code{method="viewer"} or \code{"browser"}. In the
#' latter case, the file path is also passed to \code{shell.exec}
#' (\emph{Windows}) or \code{\link{system}} (\emph{*nix}), causing
#' the document to be opened in default Web browser.
#'
#' @details
#' \code{Ascii} and \emph{markdown} tables are generated using
#' \code{\link[pander]{pander}}.
#'
#' The following arguments can be used to override formatting attributes stored
#' in the object:
#' \itemize{
#' \item \code{style}
#' \item \code{round.digits} (except for \emph{dfSummary} objects)
#' \item \code{plain.ascii}
#' \item \code{justify}
#' \item \code{split.tables}
#' \item \code{headings}
#' \item \code{display.labels}
#' \item \code{varnumbers} (\code{\link{dfSummary}} objects only)
#' \item \code{labels.col} (\code{\link{dfSummary}} objects only)
#' \item \code{graph.col} (\code{\link{dfSummary}} objects only)
#' \item \code{valid.col} (\code{\link{dfSummary}} objects only)
#' \item \code{na.col} (\code{\link{dfSummary}} objects only)
#' \item \code{col.widths} (\code{\link{dfSummary}} objects only)
#' \item \code{keep.grp.vars} (\code{\link{dfSummary}} objects only)
#' \item \code{report.nas} (\code{\link{freq}} objects only)
#' \item \code{display.type} (\code{\link{freq}} objects only)
#' \item \code{missing} (\code{\link{freq}} objects only)
#' \item \code{totals} (\code{\link{freq}} and \code{\link{ctable}} objects)
#' \item \code{caption} (\code{\link{freq}} and \code{\link{ctable}} objects)
#' }
#'
#' The following arguments can be used to override heading elements:
#'
#' \itemize{
#' \item \code{Data.frame}
#' \item \code{Data.frame.label}
#' \item \code{Variable}
#' \item \code{Variable.label}
#' \item \code{Group}
#' \item \code{date}
#' \item \code{Weights} (\code{\link{freq}} & \code{\link{descr}} objects)
#' \item \code{Data.type} (\code{\link{freq}} objects only)
#' \item \code{Row.variable} (\code{\link{ctable}} objects only)
#' \item \code{Col.variable} (\code{\link{ctable}} objects only)
#' }
#'
#' @method print summarytools
#'
#' @references
#' \href{https://www.rstudio.com/}{RStudio}
#' \href{https://github.com/dcomtois/summarytools/}{Summarytools on GitHub}
#' \href{http://rapporter.github.io/pander/#general-options/}{List of pander options}
#' \href{https://getbootstrap.com/docs/4.3/getting-started/introduction/}{Bootstrap Cascading Stylesheets}
#'
#' @author Dominic Comtois, \email{dominic.comtois@@gmail.com}
#'
#' @seealso
#' \code{\link[pander]{pander}}
#'
#' @examples
#' \dontrun{
#' data(tobacco)
#' view(dfSummary(tobacco), footnote = NA)
#' }
#' data(exams)
#' print(freq(exams$gender), style = 'rmarkdown')
#' print(descr(exams), headings = FALSE)
#'
#' @keywords print methods
#' @import htmltools
#' @importFrom pander pander panderOptions
#' @importFrom utils capture.output packageVersion head
#' @importFrom checkmate test_logical test_path_for_output test_choice
#' test_string check_file_exists
#' @export
print.summarytools <- function(x,
method = "pander",
file = "",
append = FALSE,
report.title = NA,
table.classes = NA,
bootstrap.css = st_options("bootstrap.css"),
custom.css = st_options("custom.css"),
silent = FALSE,
footnote = st_options("footnote"),
max.tbl.height = Inf,
collapse = 0,
escape.pipe = st_options("escape.pipe"),
...) {
# For list objects (generally created in one of the following ways:
# - using lapply(df, FUN), where FUN is [ctable() | descr() | dfSummary()]
# - using freq(x) where x is a data frame
# - using dplyr::group_by() %>% FUN, FUN in [ctable(), descr(), dfSummary()]
#
# ... we dispatch x [possibly back] to view()
if (is.list(x) &&
!attr(x, "st_type") %in% c("ctable", "descr", "dfSummary")) {
view(x,
method = method,
file = file,
append = append,
report.title = report.title,
table.classes = table.classes,
bootstrap.css = bootstrap.css,
custom.css = custom.css,
silent = silent,
footnote = footnote,
collapse = collapse,
escape.pipe = escape.pipe,
...)
return(invisible())
}
knitr.auto.asis.value <- panderOptions("knitr.auto.asis")
panderOptions("knitr.auto.asis", FALSE)
on.exit(panderOptions("knitr.auto.asis", knitr.auto.asis.value))
dotArgs <- list(...)
# Recuperate internal arguments passed from view() if present ----------------
if ("open.doc" %in% names(dotArgs)) {
open.doc <- eval(dotArgs[["open.doc"]])
dotArgs$open.doc <- NULL
} else {
open.doc <- FALSE
}
if ("group.only" %in% names(dotArgs)) {
attr(x, "format_info")$group.only <- eval(dotArgs[["group.only"]])
dotArgs$group.only <- NULL
}
if ("var.only" %in% names(dotArgs)) {
attr(x, "format_info")$var.only <- eval(dotArgs[["var.only"]])
dotArgs$var.only <- NULL
}
# Set st_option(lang) to the language that was active when the object was
# created (as indicated by attr(x, "lang")
if (isTRUE(st_options("lang") != attr(x, "lang"))) {
current_lang <- st_options("lang")
st_options(lang = attr(x, "lang"))
on.exit(st_options(lang = current_lang), add = TRUE)
}
method <- switch(tolower(substr(method, 1, 1)),
p = "pander",
b = "browser",
v = "viewer",
r = "render")
# Change method to browser when file name has .html extension
if (grepl("\\.html$", file, ignore.case = TRUE, perl = TRUE) &&
!grepl(pattern = tempdir(), x = file, fixed = TRUE) &&
method == "pander") {
method <- "browser"
# message("Switching method to 'browser'")
}
# Parameter validation -------------------------------------------------------
mc <- match.call()
errmsg <- check_args_print(mc)
if (length(errmsg) > 0) {
stop(paste(errmsg, collapse = "\n "))
}
# Display message if list object is being printed (console) with base print()
# (thus not taking advantage of print.summarytools() which makes results
# much cleaner in the console)
if (method == "pander" &&
(identical(deparse(sys.calls()[[max(sys.nframe() - 1, 1)]][2]), "x[[i]]()") ||
any(grepl(pattern = "fn_call = FUN(x = X[[i]]",
x = deparse(sys.calls()[[max(sys.nframe() - 1, 1)]]), fixed = TRUE)))) {
message("For best results printing list objects with summarytools, ",
"use print(x); if by() was used, use stby() instead")
}
# Apply / override parameters - first deal with "meta" information -----------
# date is a stand-alone attribute so we treat it separately
if ("date" %in% names(dotArgs)) {
attr(x, "date") <- dotArgs[["date"]]
dotArgs$date <- NULL
}
# Check for elements with modified names - will be removed in next release
if ("dataframe" %in% tolower(names(dotArgs))) {
attr(x, "data_info")$Data.frame <- dotArgs$Dataframe
dotArgs$Dataframe <- NULL
message("Attribute 'Dataframe' has been renamed to 'Data.frame'; ",
"please use the latter in the future")
}
if ("dataframe.label" %in% tolower(names(dotArgs))) {
attr(x, "data_info")$Data.frame.label <- dotArgs$Dataframe.label
dotArgs$Dataframe.label <- NULL
message("Attribute 'Dataframe.label' has been renamed to ",
"'Data.frame.label'; please use the latter in the future")
}
# Scan "dotArgs" for metadata elements
overrided_data_info <- character()
data_info_elements <- c("Data.frame", "Data.frame.label", "Variable",
"Variable.label", "Data.type", "Group", "Weights",
"Row.variable", "Col.variable")
for (data_info_element in data_info_elements) {
if (length(dotArgs) > 0) {
if (tolower(data_info_element) %in% tolower(names(dotArgs))) {
# Get matching index if present
elem_ind <- grep(paste0("^", data_info_element, "$"),
names(dotArgs), ignore.case = TRUE)
if (length(elem_ind) > 0) {
elem_ind_last <- tail(elem_ind, 1) # take last if more than one match
# Display message if argument not spelled exactly as supposed
if (names(dotArgs)[elem_ind_last] != data_info_element) {
message("Argument ", data_info_element, " misspelled as ",
names(dotArgs)[elem_ind_last])
names(dotArgs)[elem_ind_last] <- data_info_element
}
attr(x, "data_info")[[data_info_element]] <- dotArgs[[elem_ind_last]]
for (ind in elem_ind) {
dotArgs[[elem_ind]] <- NULL
}
overrided_data_info <- c(overrided_data_info, data_info_element)
}
}
}
}
# Assume all remaining arguments have to do with formatting. Put everything
# into a list and eliminate redundant items, keeping only the last one,
# giving priority to
#
# 1. "dotArgs", then to
# 2. explicit arguments used when creating the object, as given by the
# 'fn_call' attribute.
#
# The remaining arguments will be obtained from the st_options() function
# so that changes in summarytools options made after the object's creation
# will be applied.
format_info <-
append(list(scientific = FALSE,
decimal.mark = getOption("OutDec"),
keep.line.breaks = TRUE,
max.tbl.height = max.tbl.height,
collapse = collapse),
attr(x, "format_info"))
if (length(attr(x, "user_fmt")) > 0) {
format_info <- append(format_info, attr(x, "user_fmt"))
}
if (length(dotArgs) > 0) {
format_info <- append(format_info, dotArgs)
}
# Keep only last instance of repeated items
format_info <- format_info[which(!duplicated(names(format_info),
fromLast = TRUE))]
# For parameters that were not explicit, get their value from
# st_options().
list_fmt_elements <- c("style", "plain.ascii", "round.digits", "headings",
"display.labels")
for (format_element in list_fmt_elements) {
if (!format_element %in% c(names(attr(x, "fn_call")), names(dotArgs))) {
if (!(format_element == "style" &&
attr(x, "st_type") == "dfSummary") &&
!(format_element == "round.digits" &&
attr(x, "st_type") == "ctable")) {
format_info[[format_element]] <- st_options(format_element)
}
}
}
# Global options specific to the type of st object being printed
prefix <- paste0(attr(x, "st_type"), ".")
for (format_element in sub(prefix, "",
grep(prefix, names(st_options()), value = TRUE,
fixed = TRUE),
fixed = TRUE)) {
if (!format_element %in% c(names(attr(x, "fn_call")), names(dotArgs))) {
format_info[[format_element]] <-
st_options(paste0(prefix, format_element))
}
}
# When style == 'rmarkdown', set plain.ascii to FALSE unless
# explicitly specified otherwise
if (method == "pander" && format_info$style == "rmarkdown" &&
isTRUE(format_info$plain.ascii) &&
(!"plain.ascii" %in% (names(dotArgs)))) {
format_info$plain.ascii <- FALSE
}
# Evaluate formatting attributes that are symbols at this stage (F, T)
for (i in seq_along(format_info)) {
if (is.symbol(format_info[[i]])) {
format_info[[i]] <- eval(format_info[[i]])
}
}
# Fix the value of justify - default depends on method
if (method == "pander") {
format_info$justify <- switch(tolower(substring(format_info$justify, 1, 1)),
l = "left",
c = "center",
d = "right",
r = "right")
} else {
format_info$justify <- switch(tolower(substring(format_info$justify, 1, 1)),
l = "left",
c = "center",
d = "center",
r = "right")
}
format_info$missing <- ifelse("missing" %in% names(format_info),
format_info$missing, "NA")
# Keep last when multiple values
format_info <- format_info[which(!duplicated(names(format_info),
fromLast = TRUE))]
# Add nsmall and digits to format_info if not already there
if (!"nsmall" %in% names(format_info)) {
format_info$nsmall <- format_info$round.digits
}
if (!"digits" %in% names(format_info)) {
format_info$digits <- max(c(1, format_info$round.digits))
}
# Put modified attributes back into x
attr(x, "format_info") <- format_info
format_args <-
format_info[which(names(format_info) %in% names(formals(format.default)))]
format_args$justify <- sub("center", "centre", format_args$justify)
attr(x, "format_args") <- format_args
pander_args <- append(
format_info[which(names(format_info) %in%
c(sub("^table\\.", "", names(panderOptions())),
"style", "caption", "justify", "missing",
"split.tables", "split.cells", "keep.line.breaks"))],
attr(x, "user_fmt"))
attr(x, "pander_args") <-
pander_args[which(!duplicated(names(pander_args), fromLast = TRUE))]
# Build default footnote
if (method %in% c("browser", "viewer", "render") && footnote == "default") {
footnote <-
paste0(
conv_non_ascii(trs("generated.by")),
" <a href='https://github.com/dcomtois/summarytools'>",
"summarytools</a> ", packageVersion(pkg = "summarytools"),
" (<a href='https://www.r-project.org/'>R</a> ", trs("version"), " ",
getRversion(), ")", "<br/>", strftime(attr(x, "date"), trs("date.fmt"))
)
}
# Concatenate data frame + $ + variable name where appropriate
if (!("Variable" %in% overrided_data_info) &&
length(attr(x, "data_info")$Data.frame) == 1 &&
"Variable" %in% names(attr(x, "data_info")) &&
!("by_var_special" %in% names(attr(x, "data_info")))) {
attr(x, "data_info")$Variable <- paste(attr(x, "data_info")$Data.frame,
attr(x, "data_info")$Variable,
sep = "$")
}
# Dispatch to the right function for preparing output ------------------------
if (attr(x, "st_type") == "freq") {
res <- print_freq(x, method)
if (is.na(report.title)) {
if (!("Weights" %in% names(attr(x, "data_info")))) {
report.title <- trs("title.freq")
} else {
report.title <- trs("title.freq.weighted")
}
}
} else if (attr(x, "st_type") == "ctable") {
res <- print_ctable(x, method)
if (is.na(report.title)) {
report.title <- trs("title.ctable")
}
} else if (attr(x, "st_type") == "descr") {
res <- print_descr(x, method)
if (is.na(report.title)) {
if (!("Weights" %in% names(attr(x, "data_info")))) {
report.title <- trs("title.descr")
} else {
report.title <- trs("title.descr.weighted")
}
}
} else if (attr(x, "st_type") == "dfSummary") {
res <- print_dfs(x, method)
if (is.na(report.title)) {
report.title <- trs("title.dfSummary")
}
}
# Print or write to file - pander --------------------------------------------
if (method == "pander") {
# Remove double-linefeeds
res[[length(res)]] <-
sub("^\\n\\n", "\n", res[[length(res)]])
file <- normalizePath(file, mustWork = FALSE)
cat(do.call(paste0, res), file = file, append = append)
if (file != "" && !isTRUE(silent)) {
if (isTRUE(append))
message("Output file appended: ", file)
else
message("Output file written: ", file)
return(invisible())
}
} else {
# Print or write to file - html --------------------------------------------
if (isTRUE(append)) {
f <- file(file, open = "r", encoding = "utf-8")
html_content_in <- paste(readLines(f, warn = FALSE, encoding = "utf-8"),
collapse = "\n")
close(f)
top_part <- sub("(^.+)(</body>.+)", "\\1", html_content_in)
bottom_part <- sub("(^.+)(</body>.+)", "\\2", html_content_in)
insert_part <-
iconv(paste(capture.output(tags$div(class = "container st-container",
res)),
collapse = "\n"), to = "utf-8")
html_content <- paste(capture.output(cat(top_part, insert_part,
bottom_part)), collapse = "\n")
} else {
if (method %in% c("browser", "viewer")) {
html_content <-
tags$div(
class = "container st-container",
tags$head(
includeHTML(system.file(
package = "summarytools", "includes/favicon.html"
)),
tags$title(HTML(conv_non_ascii(report.title))),
if (collapse)
includeScript(system.file(
"includes/scripts/jquery-3.4.0.slim.min.js",
package = "summarytools"
)),
if (collapse)
includeScript(system.file(
"includes/scripts/bootstrap.min.js",
package = "summarytools"
)),
if (isTRUE(bootstrap.css))
includeCSS(system.file(
"includes/stylesheets/bootstrap.min.css",
package = "summarytools"
)),
includeCSS(system.file(
"includes/stylesheets/summarytools.css",
package = "summarytools"
)),
if (!is.na(custom.css))
includeCSS(path = custom.css)
),
res)
} else {
# method == "render"
html_content <-
tags$div(
class = "container st-container",
tags$head(
includeCSS(system.file(package = "summarytools",
"includes/stylesheets/summarytools.css")),
if (!is.na(custom.css))
includeCSS(path = custom.css)
),
res)
}
}
if (method == "render") {
return(html_content)
}
outfile_path <- ifelse(file == "", paste0(tempfile(),".html"), file)
outfile_path <- normalizePath(outfile_path, mustWork = FALSE)
if (isTRUE(append)) {
capture.output(cat(html_content, "\n"), file = outfile_path)
} else {
save_html(html = html_content, file = outfile_path)
}
if (method == "viewer") {
if (file == "" || isTRUE(open.doc)) {
if (.Platform$GUI == "RStudio") {
viewer <- getOption("viewer")
if (!is.null(viewer)) {
viewer(outfile_path)
} else {
message("To view html content in RStudio, please install ",
"the 'rstudioapi' package")
message("Switching method to 'browser'")
method <- "browser"
}
} else {
message("Switching method to 'browser'")
method <- "browser"
}
}
}
# For method "browser", we don't use utils::browseURL() because of
# compatibility issues with RStudio
if (method == "browser") {
if (file == "" || isTRUE(open.doc)) {
switch(.st_env$sysname,
Windows = {shell.exec(file = paste0("file:///", outfile_path))},
Linux = {system(paste("/usr/bin/xdg-open", outfile_path),
wait = FALSE, ignore.stdout = TRUE)},
Darwin = {system(paste("open", outfile_path), wait = FALSE,
ignore.stderr = TRUE)})
}
}
# return file path and update tmpfiles vector when method = browser / viewer
if (file == "" && method %in% c("browser", "viewer")) {
.st_env$tmpfiles <- c(.st_env$tmpfiles, outfile_path)
if (!silent) {
message("Output file written: ", outfile_path)
}
return(invisible(outfile_path))
} else if (file != "") {
if (!silent) {
if (isTRUE(append)) {
message("Output file appended: ", outfile_path)
} else {
message("Output file written: ", outfile_path)
}
}
return(invisible())
}
}
}
# Prepare freq objects for printing --------------------------------------------
#' @import htmltools
print_freq <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
if (!isTRUE(parent.frame()$silent) && !isTRUE(format_info$group.only) &&
(!"by_first" %in% names(data_info) ||
isTRUE(as.logical(data_info$by_first))) &&
"ignored" %in% names(attributes(x))) {
message("Non-categorical variable(s) ignored: ",
paste(attr(x, "ignored"), collapse = ", "))
}
if (!isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
# Subtract NA counts from total
x[nrow(x), 1] <- x[nrow(x), 1] - x[nrow(x) - 1, 1]
# Remove NA row and keep only desired columns
x <- x[-(nrow(x) - 1), 1:2]
colnames(x) <- c(trs("freq"), trs("pct"))
} else if (!isTRUE(format_info$report.nas) && isTRUE(format_info$cumul)) {
# Subtract NA counts from total
x[nrow(x), 1] <- x[nrow(x), 1] - x[nrow(x) - 1, 1]
# Remove NA row and keep only desired columns
x <- x[-(nrow(x) - 1), 1:3]
colnames(x) <- c(trs("freq"), trs("pct"), trs("pct.cum"))
} else if (isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
x <- x[ ,-c(3,5)]
colnames(x) <- c(trs("freq"), trs("pct.valid.f"), trs("pct.total"))
}
if (!isTRUE(format_info$totals)) {
x <- x[-nrow(x),]
}
# Use format() on row names when x is numeric
if (data_info$Data.type == trs("numeric")) {
temp_rownames <- suppressWarnings(as.numeric(rownames(x)))
temp_rownames_nas <- which(is.na(temp_rownames))
# Check if all row names are integers (if so, decimals will be removed)
rownames_are_int <- all(as.integer(temp_rownames) == temp_rownames,
na.rm = TRUE)
if (rownames_are_int) {
temp_rownames <- do.call(format, append(format_args,
list(x = quote(temp_rownames))))
temp_rownames <- sub(paste0("^(.+)\\", format_info$decimal.mark,
# "0+$"),
"(0(0|\\D)*$)"),
"\\1", temp_rownames)
} else {
temp_rownames <- format(rownames(x), justify = format_args$justify)
}
temp_rownames[temp_rownames_nas] <- rownames(x)[temp_rownames_nas]
row.names(x) <- temp_rownames
}
if (method == "pander") {
# Escape "<" and ">" when used in pairs in rownames
if (!isTRUE(pander_args$plain.ascii)) {
row.names(x) <- gsub(pattern = "\\<(.*)\\>",
replacement = "\\\\<\\1\\\\>",
x = row.names(x), perl = TRUE)
}
# Translate the "(Other)" category (when "rows" was used to filter out
# some values
rownames(x)[which(rownames(x) == "(Other)")] <- trs("other")
# set encoding to native to allow proper display of accentuated characters
if (parent.frame()$file == "") {
row.names(x) <- enc2native(row.names(x))
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
is_na_x <- is.na(x)
x <- do.call(format, append(format_args, x = quote(x)))
if (!"Weights" %in% names(data_info)) {
x[ ,1] <- sub(paste0("\\", format_info$decimal.mark, "0+$"), "", x[ ,1])
}
x[is_na_x] <- format_info$missing
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <- gsub("\\|","\\\\|",
main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_freq -- html method ------------------------------------------------
table_head <- list()
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list()
for (co in seq_len(ncol(x))) {
cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
if (co == 1) {
table_row %+=% list(tags$th(trimws(row.names(x)[ro]),
align = "center",
class = "st-protect-top-border"))
if (!"Weights" %in% names(data_info)) {
cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
}
table_row %+=% list(tags$td(cell, align = format_info$justify))
next
}
if (is.na(x[ro,co])) {
table_row %+=% list(tags$td(format_info$missing,
align = format_info$justify))
} else {
table_row %+=% list(tags$td(cell, align = format_info$justify))
}
if (co == ncol(x)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
if (isTRUE(format_info$report.nas) && isTRUE(format_info$cumul)) {
table_head[[1]] <- list(tags$th("", colspan = 2),
tags$th(HTML(conv_non_ascii(trs("valid"))),
colspan = 2, align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("total"))),
colspan = 2, align = "center",
class = "st-protect-top-border"))
table_head[[2]] <- list(tags$th(HTML(conv_non_ascii(
sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center"))
freq_table_html <-
tags$table(
tags$thead(tags$tr(table_head[[1]]),
tags$tr(table_head[[2]])),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-freq-table",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
} else {
if (isTRUE(format_info$cumul) && !isTRUE(format_info$report.nas)) {
# No NA reporting
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center",
class = "st-protect-top-border"))
} else if (isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
# No cumulative proportions
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.valid.f"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.total"))),
align = "center",
class = "st-protect-top-border"))
} else {
# No cumulative proportions, no NA reporting
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct")))))
}
freq_table_html <-
tags$table(
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-freq-table-nomiss",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
}
# Encapsulate the table in a collapsible div if necessary
if (format_info$collapse) {
div_id <- paste0(sample(c(letters, LETTERS), size = 1),
paste(sample(c(letters, LETTERS, 0:9), size = 11),
collapse = ""))
freq_table_html <- div(freq_table_html,
class = "collapse show",
id = div_id)
} else {
div_id <- NA
}
# Cleanup extra spacing and linefeeds in html to correct layout issues
freq_table_html <- gsub(pattern = "</span>\\s*</span>",
replacement = "</span></span>",
x = freq_table_html,
perl = TRUE)
# Change visual aspect of "white space" symbol
freq_table_html <-
gsub(pattern = paste0("(",intToUtf8(183),"+)"),
replacement = " <span class='st-ws-char'>\\1</span>",
x = freq_table_html,
perl = TRUE)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method, div_id)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = conv_non_ascii(freq_table_html)))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare ctable objects for printing ------------------------------------------
#' @import htmltools
#' @keywords internal
print_ctable <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
# Use format() on row names when x is numeric
if (data_info$Data.type.x %in% c(trs("numeric"), trs("integer"))) {
temp_rownames <- suppressWarnings(as.numeric(rownames(x[[1]])))
temp_rownames_nas <- which(is.na(temp_rownames))
# Check if all row names are integers (if so, decimals will be removed)
rownames_are_int <- all(as.integer(temp_rownames) == temp_rownames,
na.rm = TRUE)
if (rownames_are_int) {
format_args_tmp <- format_args
format_args_tmp$digits <- 1
format_args_tmp$nsmall <- 0
} else {
# Make sure no decimals are lost b/c of format options
format_args_tmp <- format_args
format_args_tmp$digits <- max(
c(1, nchar(sub(".+\\.(.*)0*", "\\1", temp_rownames))),
na.rm = TRUE
)
format_args_tmp$nsmall <- format_args_tmp$digits
}
temp_rownames <- do.call(
format,
append(format_args_tmp, list(x = quote(temp_rownames)))
)
# Replace non-numeric names by original values
temp_rownames[temp_rownames_nas] <- rownames(x[[1]])[temp_rownames_nas]
row.names(x[[1]]) <- temp_rownames
if (!is.null(x[[2]])) {
row.names(x[[2]]) <- temp_rownames
}
}
# Use format() on col names when y is numeric
if (data_info$Data.type.y %in% c(trs("numeric"), trs("integer"))) {
temp_colnames <- suppressWarnings(as.numeric(colnames(x[[1]])))
temp_colnames_nas <- which(is.na(temp_colnames))
# Check if all row names are integers (if so, decimals will be removed)
colnames_are_int <- all(as.integer(temp_colnames) == temp_colnames,
na.rm = TRUE)
if (colnames_are_int) {
format_args_tmp <- format_args
format_args_tmp$digits <- 1
format_args_tmp$nsmall <- 0
} else {
format_args_tmp <- format_args
format_args_tmp$digits <- max(
c(1, nchar(sub(".+\\.(.*)0*", "\\1", temp_rownames))),
na.rm = TRUE
)
format_args_tmp$nsmall <- format_args_tmp$digits
}
temp_colnames <- do.call(
format,
append(format_args_tmp, list(x = quote(temp_colnames)))
)
# Replace non-numeric names with original values
temp_colnames[temp_colnames_nas] <- colnames(x[[1]])[temp_colnames_nas]
colnames(x[[1]]) <- temp_colnames
if (!is.null(x[[2]])) {
colnames(x[[2]]) <- temp_colnames
}
}
# align_numbers() ------------------------------------------------------------
# Create vertically aligned strings for counts and proportions
align_numbers <- function(counts, props) {
res <- sapply(seq_len(ncol(counts)), function(colnum) {
if ("Weights" %in% names(data_info)) {
counts_fmted <- do.call(
format, append(format_args, list(x = counts[ ,colnum]))
)
} else {
counts_fmted <- do.call(
format, append(format_args[-which(names(format_args) == "nsmall")],
list(x = counts[ ,colnum])) # use quote? list(x = quote(counts[,colnum]
)
}
props_fmted <- do.call(
format,
append(format_args, list(x = props[ ,colnum] * 100))
)
return(
paste0(
pad(counts_fmted, max(nchar(counts_fmted))),
" (",
pad(props_fmted, max(nchar(props_fmted))),
"%)"
)
)
})
dim(res) <- dim(counts)
dimnames(res) <- dimnames(counts)
return(res)
}
if (!isTRUE(format_info$totals)) {
x$cross_table <-
x$cross_table[which(rownames(x$cross_table) != trs("total")),
which(colnames(x$cross_table) != trs("total"))]
if (data_info$Proportions != "None") {
x$proportions <-
x$proportions[which(rownames(x$proportions) != trs("total")),
which(colnames(x$proportions) != trs("total"))]
}
}
if (data_info$Proportions %in% c("Row", "Column", "Total")) {
cross_table <- align_numbers(x$cross_table, x$proportions)
} else {
cross_table <- x$cross_table
}
# print_ctable -- pander method ----------------------------------------------
if (method == "pander") {
# Escape "<" and ">" when used in pairs in rownames or colnames
if (!isTRUE(pander_args$plain.ascii)) {
row.names(cross_table) <-
gsub(pattern = "\\<(.*)\\>", replacement = "\\\\<\\1\\\\>",
x = row.names(cross_table), perl = TRUE)
colnames(cross_table) <-
gsub(pattern = "\\<(.*)\\>", replacement = "\\\\<\\1\\\\>",
x = colnames(cross_table), perl = TRUE)
}
main_sect <- build_heading_pander()
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args,
list(x = quote(ftable(cross_table)))))
),
collapse = "\n")
if (isTRUE(format_info$headings) && pander_args$style != "grid") {
main_sect[[length(main_sect)]] <- sub("^\n", "\n\n",
main_sect[[length(main_sect)]])
}
if ("chisq" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
c(format(attr(x, "chisq")["Chi.squared"],
decimal.mark = format_args$decimal.mark),
format(attr(x, "chisq")["df"]),
format(attr(x, "chisq")["p.value"],
decimal.mark = format_args$decimal.mark)
)
)
),
collapse = "\n"
)
}
if ("OR" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
#do.call(format, append(format_args, list(x = attr(x, "OR"))))
format(attr(x, "OR"), digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
)
),
collapse = "\n"
)
}
if ("RR" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
#do.call(format, append(format_args, list(x = attr(x, "RR"))))
format(attr(x, "RR"), digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark)
)
),
collapse = "\n"
)
}
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_ctable -- html method ----------------------------------------------
dnn <- names(dimnames(cross_table))
table_head <- list()
table_rows <- list()
has_prop <- length(x$proportions) > 0
table_head[[1]] <-
list(tags$th(""),
tags$th(
dnn[2],
colspan = (1 + has_prop*3) *
(ncol(cross_table) - as.numeric(isTRUE(format_info$totals))),
align = "center", class = "st-protect-top-border"
)
)
if (isTRUE(format_info$totals)) {
table_head[[1]][[3]] <- tags$th("", colspan = (1 + has_prop*3))
}
table_head[[2]] <- list(tags$td(tags$strong(dnn[1]), align = "center"))
for (cn in colnames(cross_table)) {
flag_split <- FALSE
if (nchar(cn) > st_options("char.split")) {
flag_split <- TRUE
}
cn <- sub("<", "<", cn, fixed = TRUE)
cn <- sub(">", ">", cn, fixed = TRUE)
if (isTRUE(flag_split)) {
cn <- smart_split(cn, st_options("char.split"))
}
table_head[[2]][[length(table_head[[2]]) + 1]] <-
tags$th(HTML(conv_non_ascii(cn)),
colspan = (1 + has_prop*3), align = "center")
}
table_rows <- list()
for (ro in seq_len(nrow(cross_table))) {
table_row <- list()
for (co in seq_len(ncol(cross_table))) {
if (co == 1) {
rn <- row.names(cross_table)[ro]
rn <- sub("<", "<", rn, fixed = TRUE)
rn <- sub(">", ">", rn, fixed = TRUE)
table_row %+=%
list(
tags$td(
tags$strong(
HTML(conv_non_ascii(rn)),
align = "center"
)
)
)
}
# No proportions
if (!isTRUE(has_prop)) {
cell <- cross_table[ro,co]
table_row %+=% list(tags$td(tags$span(cell)))
} else {
cell <- gsub(" ", "", cross_table[ro,co])
cell <- sub(")$", "", cell)
cell <- strsplit(cell, "\\(")[[1]]
table_row %+=% list(
tags$td(
cell[1],
align = "right",
style = "padding:0 0 0 15px;border-right:0;text-align:right"
)
)
table_row %+=% list(
tags$td(
"(", align = "left",
style = paste0("padding:0 1px 0 4px;border-left:0;",
"border-right:0;text-align:left")
)
)
table_row %+=% list(
tags$td(
HTML(cell[2]),
align = "left",
style = "padding:0;border-left:0;border-right:0;text-align:right"
)
)
table_row %+=% list(
tags$td(")",
align = "left",
style = "padding:0 15px 0 1px;border-left:0;text-align:right"
)
)
}
# On last col, insert row into list
if (co == ncol(cross_table)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
# Build table footer containing stats
if (any(c("chisq", "OR", "RR") %in% names(attributes(x)))) {
stats_str <- ""
if ("chisq" %in% names(attributes(x))) {
chisq <- attr(x, "chisq")
stats_str <- paste0(
stats_str,
"<em><strong> Χ<sup>2</sup></strong> = ",
sub("\\.", format_args$decimal.mark, sprintf("%.4f", chisq[[1]])),
" <strong>df</strong> = ", chisq[[2]],
" <strong>p</strong> = ",
sub("^0\\.", format_args$decimal.mark,
sprintf("%.4f", chisq[[3]])), "</em><br/>"
)
}
if ("OR" %in% names(attributes(x))) {
OR <- attr(x, "OR")
stats_str <- paste0(
stats_str,
"<em><strong>O.R. </strong>(",
attr(x, "OR-level")*100, "% C.I.) = <strong>",
format(OR[[1]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
"</strong> (",
format(OR[[2]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
" - ",
format(OR[[3]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
")</em><br/>
")
}
if ("RR" %in% names(attributes(x))) {
RR <- attr(x, "RR")
stats_str <- paste0(
stats_str,
"<em><strong>R.R. </strong>(",
attr(x, "RR-level")*100, "% C.I.) = <strong>",
format(RR[[1]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
"</strong> (",
format(RR[[2]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
" - ",
format(RR[[3]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
")</em>")
}
}
cross_table_html <-
tags$table(
tags$thead(
tags$tr(table_head[[1]]),
tags$tr(table_head[[2]])
),
tags$tbody(
table_rows
),
if (exists("stats_str"))
tags$tfoot(tags$tr(tags$td(HTML(stats_str), colspan = 100))),
class = paste(
"table table-bordered st-table st-table-bordered st-cross-table",
ifelse(is.na(parent.frame()$table.classes), "",
parent.frame()$table.classes)
)
)
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(cross_table_html)
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare descr objects for printing -------------------------------------------
#' @import htmltools
#' @keywords internal
print_descr <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
# determine whether to display message re: ignored variables
display_msg <- FALSE
if ("ignored" %in% names(attributes(x)) &&
(("by_first" %in% names(data_info) && isTRUE(data_info$by_first)) ||
!"by_first" %in% names(data_info))) {
if ("silent" %in% names(parent.frame())) {
if (!isTRUE(parent.frame()$silent)) {
display_msg <- TRUE
}
} else {
if (!isTRUE(st_options("descr.silent"))) {
display_msg <- TRUE
}
}
}
if (display_msg) {
message("Non-numerical variable(s) ignored: ",
paste(attr(x, "ignored"), collapse = ", "))
}
if (method == "pander") {
# print_descr -- pander method ---------------------------------------------
# set encoding to native to allow proper display of accentuated characters
if (parent.frame()$file == "") {
row.names(x) <- enc2native(row.names(x))
if (!is.null(colnames(x)))
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
x <- round(x, format_info$digits)
x <- do.call(format, append(format_args, list(x = quote(x))))
#if (!"Weights" %in% names(data_info)) {
# row_ind <- which(trs("n.valid") == rownames(x))
# x[row_ind, ] <- sub("\\.0+", "", x[row_ind, ])
#}
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_descr -- html method -----------------------------------------------
x <- round(x, format_info$digits)
table_head <- list(tags$th(""))
for (cn in colnames(x)) {
if (nchar(cn) > st_options("char.split")) {
cn <- smart_split(cn, st_options("char.split"))
}
table_head %+=% list(tags$th(HTML(cn), align = "center",
class = "st-protect-top-border"))
}
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list(tags$td(tags$strong(rownames(x)[ro])))
for (co in seq_len(ncol(x))) {
# cell is NA
if (is.na(x[ro,co])) {
table_row %+=% list(tags$td(format_info$missing))
} else {
# When not NA format cell content
cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
if ((rownames(x)[ro] == trs("n.valid") ||
colnames(x)[co] == trs("n.valid")) &&
!"Weights" %in% names(data_info)) {
cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
}
table_row %+=% list(tags$td(tags$span(cell)))
}
# On last column, insert row to table_rows list
if (co == ncol(x)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
descr_table_html <-
tags$table(
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-bordered table-striped",
"st-table st-table-bordered st-table-striped st-descr-table",
ifelse(is.na(parent.frame()$table.classes), "",
parent.frame()$table.classes))
)
# Cleanup some extra spacing & html linefeeds to avoid weirdness in layout
# of source code
descr_table_html <- as.character(descr_table_html)
descr_table_html <- gsub(pattern = "\\s*(\\-?\\d*)\\s*(<span|</td>)",
replacement = "\\1\\2", x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = "</span>\\s*</span>",
replacement = "</span></span>",
x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = "<strong>\\s*</strong>",
replacement = "",
x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = '(<td align="right">)\\s+(<)',
replacement = "\\1\\2",
x = descr_table_html,
perl = TRUE)
descr_table_html <- conv_non_ascii(descr_table_html)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = descr_table_html))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare dfSummary objects for printing ---------------------------------------
#' @import htmltools
#' @keywords internal
print_dfs <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
if (!isTRUE(parent.frame()$silent) &&
"png_message" %in% names(attributes(x)) &&
method != "render" &&
!isTRUE(format_info$group.only) &&
(!"by_first" %in% names(data_info) ||
isTRUE(as.logical(data_info$by_first)))) {
message("text graphs are displayed; set 'tmp.img.dir' ",
"parameter to activate png graphs")
}
# make_vals_cell -------------------------------------------------------------
# Function to split lines of the values cell into table rows and return
# the table which will become the td (cell content). By doing this, we make
# sure its content is well aligned with the freqs cell since it has the same
# number of rows. If we don't do this, free text with line breaks will
# sometimes use more or less vertical space than a table with the same
# number of rows as it has line breaks.
make_vals_cell <- function(cell) {
if (!grepl("\\n", cell)) {
return(HTML(paste0('<td align="left">', cell, '</td>')))
}
rows <- strsplit(cell, "\\n")[[1]]
rows <- gsub("\\\\$", "", rows)
# replace the "<" in "min < med < max:" line for the lte (<=) html code
mmmstr <- tolower(paste0("^", trs("min"), " < ",
trs("med.short"), " < ",
trs("max"), ":$"))
if (any(grepl(mmmstr, rows)) && grep(mmmstr, rows) == 2) {
rows[2] <- gsub("<", "≤", rows[2])
rows[3] <- gsub("<", "≤", rows[3]) # alternative to ≤ is ≼
}
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0;margin:0;border:0" align="left">'
), #padding:0 5px 0 7px
rows,
'</td></tr>',
collapse = "")
return(HTML(
paste0('<td align="left" style="padding:8;vertical-align:middle">',
'<table style="border-collapse:collapse;border:none;margin:0">',
cell, '</table></td>')
))
}
# make_freq_cell -------------------------------------------------------------
# Function to align the freqs / proportions in html outputs
# A table is built to fit in a single cell in the final table
make_freq_cell <- function(cell) {
if (identical(cell, conv_non_ascii(trs("all.nas")))) {
return(HTML(paste0('<td align="left">', cell, '</td>')))
}
rows <- strsplit(cell, "\\\n")[[1]]
rows <- gsub("\\", "", rows, fixed = TRUE)
rows <- gsub(" " , "", rows, fixed = TRUE)
rows <- gsub(")$", "", rows)
rows <- strsplit(rows, "[(:]")
if (grepl(":", cell)) {
# notice for rounded values
notice <- NA
if (length(rows[[length(rows)]]) == 1) {
notice <- sub("!", "! ", rows[[length(rows)]])
length(rows) <- length(rows) - 1
}
vals <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 1)
cnts <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 2)
prps <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 3)
if (!is.na(notice)) {
vals <- sub("!", " !", vals)
vals <- sub("(\\d)$", "\\1  ", vals)
}
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0 2px 0 7px;margin:0;border:0" align="right">'
),
vals,
paste0(
'</td><td style="padding:0 2px;border:0;" align="left">:</td>',
'<td style="padding:0 4px 0 6px;margin:0;border:0" align="right">'
),
cnts,
paste0(
'</td><td style="padding:0;border:0" align="left">(</td>',
'<td style="padding:0 2px;margin:0;border:0" align="right">'
),
prps,
paste0('</td><td style="padding:0 4px 0 0;border:0" align="left">)',
'</td></tr>'
),
collapse = ""
)
if (!is.na(notice)) {
cell <-
paste0(cell, '<tr style="background-color:transparent">',
'<td style="padding:0 0 0 7px;border:0;margin:0" colspan="5">',
notice, "</td></tr>", collapse = "")
}
} else {
cnts <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 1)
prps <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 2)
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0 5px 0 7px;margin:0;border:0" align="right">'
),
cnts,
paste0(
'</td><td style="padding:0 2px 0 0;border:0;" align="left">(</td>',
'<td style="padding:0;border:0" align="right">'
),
prps,
'</td><td style="padding:0 4px 0 2px;border:0" align="left">)</td></tr>',
collapse = ""
)
}
return(
HTML(
paste0(
'<td align="left" style="padding:0;vertical-align:middle">',
'<table style="border-collapse:collapse;border:none;margin:0">',
cell, '</table></td>'
)
)
)
}
# Remove Var number ("No") column if specified in call to print/view
if (trs("no") %in% names(x) &&
"varnumbers" %in% names(format_info) &&
!isTRUE(format_info$varnumbers)) {
x <- x[ ,-which(names(x) == trs("no"))]
}
# Remove Label column if specified in call to print/view
if (trs("label") %in% names(x) &&
"labels.col" %in% names(format_info) &&
!isTRUE(format_info$labels.col)) {
x <- x[ ,-which(names(x) == trs("label"))]
}
# Remove Valid column if specified in call to print/view
if (trs("valid") %in% names(x) &&
"valid.col" %in% names(format_info) &&
!isTRUE(format_info$valid.col)) {
x <- x[ ,-which(names(x) == trs("valid"))]
}
# Remove Missing column if specified in call to print/view
if (trs("missing") %in% names(x) &&
"na.col" %in% names(format_info) &&
!isTRUE(format_info$na.col)) {
x <- x[ ,-which(names(x) == trs("missing"))]
}
# Remove grouping variable rows when appropriate
if ("keep.grp.vars" %in% names(format_info) &&
!isTRUE(format_info$keep.grp.vars) &&
"by_var" %in% names(data_info)) {
x <- x[-grep(paste0("\\b", data_info$by_var, "\\b", collapse = "|"),
x[[trs("variable")]]),]
row.names(x) <- NULL
}
# print_dfSummary - pander method --------------------------------------------
if (method == "pander") {
# remove html graphs
if (trs("graph") %in% names(x)) {
x <- x[ ,-which(names(x) == trs("graph"))]
}
# Remove graph if specified in call to print/view
if ("text.graph" %in% names(x) && "graph.col" %in% names(format_info) &&
!isTRUE(format_info$graph.col)) {
x <- x[ ,-which(names(x) == "text.graph")]
} else {
colnames(x)[which(names(x) == "text.graph")] <- trs("graph")
}
# Check that style is not "simple" or "rmarkdown"
if (isTRUE(pander_args$style %in% c("simple", "rmarkdown"))) {
pander_args$style <- "multiline"
}
if (!isTRUE(pander_args$plain.ascii)) {
# Escape symbols for words between <>'s to allow <NA> or factor
# levels such as <ABC> to be rendered correctly
if (trs("label") %in% names(x)) {
x[[trs("label")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("label")]], perl = TRUE)
}
x[[trs("stats.values")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("stats.values")]], perl = TRUE)
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
# Remove leading characters used for alignment in plain.ascii
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "^\\\\ *", replacement = "",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "\\n\\\\ *", replacement = "\n",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
}
# set column names encoding to native to allow proper display of non-ascii
if (parent.frame()$file == "") {
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_dfs - html method --------------------------------------------------
# remove text graph
if ("text.graph" %in% names(x)) {
x <- x[ ,-which(names(x) == "text.graph")]
}
# Remove graph if specified in call to print/view
# or if use.x11 set to FALSE
if (trs("graph") %in% names(x) &&
("graph.col" %in% names(format_info) &&
!isTRUE(format_info$graph.col)) ||
isFALSE(st_options("use.x11"))) {
x <- x[ ,-which(names(x) == trs("graph"))]
}
table_head <- list()
for (cn in colnames(x)) {
table_head %+=% list(tags$th(tags$strong(HTML(conv_non_ascii(cn))),
align = "center",
class = "st-protect-top-border"))
}
colgroup <- NA
if ("col.widths" %in% names(format_info)) {
if (length(format_info$col.widths) != ncol(x)) {
stop("Number of elements in 'col.widths', (",
(length(format_info$col.widths)), ") is not equal to number of ",
"columns to display (", ncol(x), ")")
}
colgroup <- tags$colgroup()
if (is.numeric(format_info$col.widths)) {
for (i in format_info$col.widths) {
colgroup <- tagAppendChild(
colgroup, tags$col(style = paste0("width:", i, "px"))
)
}
} else {
for (i in format_info$col.widths) {
colgroup <- tagAppendChild(
colgroup, tags$col(style = paste("width", i, sep = ":"))
)
}
}
}
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list()
for (co in seq_len(ncol(x))) {
cell <- x[ro,co]
cell <- gsub("\\\\\n", "\n", cell)
if (colnames(x)[co] %in% c(trs("no"), trs("valid"), trs("missing"))) {
table_row %+=% list(tags$td(HTML(conv_non_ascii(cell)),
align = "center"))
} else if (colnames(x)[co] == trs("label")) {
cell <- gsub("(\\d+)\\\\\\.", "\\1.", cell)
cell <- paste(strwrap(cell, width = format_info$split.cells,
simplify = TRUE), collapse = "\n")
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left")
)
} else if (colnames(x)[co] == trs("variable")){
cell <- gsub("[ \t]{2,}", " ", cell)
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left")
)
} else if (colnames(x)[co] == trs("stats.values")) {
cell <- gsub("(\\d+)\\\\\\.", "\\1.", cell)
table_row %+=% list(make_vals_cell(conv_non_ascii(cell)))
} else if (colnames(x)[co] == trs("freqs.pct.valid")) {
if (grepl(paste0("(",trs("distinct.value"), "|",
trs("distinct.values"), ")"), cell) || cell == "") {
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left",
style = "vertical-align:middle")
)
} else {
table_row %+=% list(make_freq_cell(conv_non_ascii(cell)))
}
} else if (colnames(x)[co] == trs("graph")) {
table_row %+=% list(
tags$td(HTML(cell), align = "left",
style = paste0("vertical-align:middle;padding:0;",
"background-color:transparent;"))
)
}
}
table_rows %+=% list(tags$tr(table_row))
}
if (is.infinite(format_info$max.tbl.height)) {
dfs_table_html <-
tags$table(
if (!identical(colgroup, NA))
colgroup,
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-multiline",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
} else {
dfs_table_html <-
tags$div(
tags$table(
if (!identical(colgroup, NA))
colgroup,
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-multiline",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
), style = paste0("max-height:", format_info$max.tbl.height,
"px;overflow-y:scroll;margin:10px 2px")
)
}
# cleanup source html for redundant space
dfs_table_html <-
gsub(pattern = "(<th.*?>)\\s+(<strong>.*?</strong>)\\s+(</th>)",
replacement = "\\1\\2\\3",
x = dfs_table_html)
# Change visual aspect of "white space" symbol
dfs_table_html <-
gsub(pattern = "((·)+)",
replacement = " <div class='st-ws-char'>\\1</div>",
x = dfs_table_html,
perl = TRUE)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = dfs_table_html))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Build headings (pander) ------------------------------------------------------
#' @keywords internal
build_heading_pander <- function() {
format_info <- parent.frame()$format_info
data_info <- parent.frame()$data_info
caller <- as.character(sys.call(-1))[1]
head1 <- NA # Main title (e.g. "Data Frame Summary")
head2 <- NA # The data frame, the variable, or the 2 variables for ctable
head3 <- NA # Additional elements (includes Variable exceptionnaly when
# headings = FALSE and by() or lapply() were used
add_markup <- function(str, h = 0) {
if (!isTRUE(format_info$plain.ascii)) {
if (h == 0) {
re <- paste0("^(\\s*\\n)(.+)\\s", trs("by"), "\\s(.+)$")
if (grepl(re, str, perl = TRUE)) {
str <- sub(re, paste0("\\1**", "\\2** ", trs("by"), " **\\3**"),
str, perl = TRUE)
} else {
str <- sub(pattern = "^(\\s*)(.+?)((:)\\s(.+))?\\s*$",
replacement = "\\1**\\2\\4** \\5",
x = str, perl = TRUE)
}
} else {
str <- paste(paste0(rep(x = "#", times = h), collapse = ""), str)
}
}
return(str)
}
append_items <- function(items, h = 0) {
appended <- c()
for (item in items) {
if (names(item) %in% names(data_info)) {
if ((grepl(pattern = "label", names(item)) &&
isTRUE(format_info$display.labels)) ||
(names(item) == "Data.type" &&
isTRUE(format_info$display.type)) ||
!grepl("(label|Data\\.type)", names(item))) {
# Apply formatting to numeric values
value <- data_info[[names(item)]]
tmpargs <- c("big.mark", "small.mark", "decimal.mark",
"small.interval", "big.interval")
if (isTRUE(is.numeric(value)) &&
any(names(format_info) %in% tmpargs)) {
value <- do.call(
format,
append(format_info[which(names(format_info) %in% tmpargs)],
x = quote(value))
)
if (names(item) == "Dimensions") {
value <- paste(trimws(value[1]), trimws(value[2]), sep = " x ")
}
}
# Create pairing (example: "N: 500") when both name and value exist
# and add markup characters
if (item != "") {
appended <- append(
appended,
paste0(add_markup(paste(item, value, sep = ": "), h),
" \n")
)
} else {
appended <- append(appended, paste0(add_markup(value, h), " \n"))
}
}
}
}
return(paste(appended, collapse = ""))
}
# Special cases where no primary heading (title) is needed
if (isTRUE(format_info$var.only)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options('subtitle.emphasis')), 4, 0)
)
head2 <- paste0("\n", enc2native(head2))
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(N.obs = trs("n"))))
}
if (!is.na(head3)) {
head3 <- enc2native(head3)
}
tmp <- list(head2, head3)
return(tmp[which(!is.na(tmp))])
} else if (isTRUE(format_info$group.only)) {
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Group = trs("group")),
c(N.Obs = trs("n")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
} else {
head3 <- append_items(list(c(Group = trs("group"))))
}
head3[[1]] <- paste0("\n", enc2native(head3[[1]]))
return(list(head3))
} else if (!isTRUE(format_info$headings)) {
if ("var.only" %in% names(format_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options('subtitle.emphasis')), 4, 0))
return(list(enc2native(head2)))
} else if ("Group" %in% names(data_info)) {
head3 <- append_items(list(c(Group = trs("group"))))
return(list(enc2native(head3)))
} else {
return(list())
}
}
# (End special cases)
# Regular cases - Build the 3 heading elementss
if (caller == "print_freq") {
if ("Weights" %in% names(data_info)) {
if (trs("title.freq.weighted") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.freq.weighted"), h = 3), " \n")
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.freq"), h = 3), " \n")
}
}
if ("Variable" %in% names(data_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(Weights = trs("weights")),
c(Group = trs("group"))))
}
} else if (caller == "print_ctable") {
head1 <- paste(
add_markup(
switch(data_info$Proportions,
Row = paste(trs("title.ctable"), trs("title.ctable.row"),
sep = ", "),
Column = paste(trs("title.ctable"), trs("title.ctable.col"),
sep = ", "),
Total = paste(trs("title.ctable"), trs("title.ctable.tot"),
sep = ", "),
None = trs("title.ctable")),
h = 3),
" \n")
if (grepl("^#*\\s*,", head1))
head1 <- NA
head2 <- append_items(
list(c(Row.x.Col = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Data.frame.label = trs("label")),
c(Group = trs("group"))))
} else if (caller == "print_descr") {
if ("Weights" %in% names(data_info)) {
if (trs("title.descr.weighted") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.descr.weighted"), h = 3), " \n")
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.descr"), h = 3), " \n")
}
}
if ("by_var_special" %in% names(data_info)) {
head2 <- paste(
add_markup(
paste(data_info$Variable, trs("by"), data_info$by_var_special),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)),
" \n")
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Variable" %in% names(data_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Data.frame" %in% names(data_info)) {
head2 <- append_items(
list(c(Data.frame = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
}
} else if (caller == "print_dfs") {
head1 <- paste(add_markup(trs("title.dfSummary"), h = 3), " \n")
if ("Data.frame" %in% names(data_info)) {
head2 <- append_items(
list(c(Data.frame = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Group = trs("group")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
}
if (!is.na(head1) &&
length(setdiff(unique(strsplit(head1, "")[[1]]), c(" ", "\r", "\n")))) {
head1 <- enc2native(head1)
} else {
head1 <- NA
}
if (!is.na(head2) &&
length(setdiff(unique(strsplit(head2, "")[[1]]), c(" ", "\r", "\n")))) {
head2 <- enc2native(head2)
} else {
head2 <- NA
}
if (!is.na(head3) &&
length(setdiff(unique(strsplit(head3, "")[[1]]), c(" ", "\r", "\n")))) {
head3 <- enc2native(head3)
} else {
head3 <- NA
}
tmp <- list(head1, head2, head3)
return(tmp[which(!is.na(tmp))])
}
# Build headings (html) --------------------------------------------------------
#' @keywords internal
#' @import htmltools
build_heading_html <- function(format_info, data_info, method, div_id = NA) {
caller <- as.character(sys.call(-1))[1]
head1 <- NA # uses h3()
head2 <- NA # uses h4() or <strong> (see option subtitle.emphasis)
head3 <- NA # uses <strong>...</strong>
append_items <- function(items) {
appended <- character()
for (item in items) {
if (names(item) %in% names(data_info)) {
if ((grepl(pattern = "label", names(item)) &&
isTRUE(format_info$display.labels)) ||
(names(item) == "Data.type" &&
isTRUE(format_info$display.type)) ||
!grepl("(label|Data\\.type)", names(item))) {
value <- data_info[[names(item)]]
tmpargs <- c("big.mark", "small.mark", "decimal.mark",
"small.interval", "big.interval")
if (isTRUE(is.numeric(value)) && any(names(format_info) %in% tmpargs)) {
value <-
do.call(format, append(format_info[which(names(format_info) %in% tmpargs)],
x = quote(value)))
if (names(item) == "Dimensions") {
value <- paste(trimws(value[1]), trimws(value[2]), sep = " x ")
}
}
div_str_item <-
paste(paste0("<strong>", HTML(conv_non_ascii(item)), "</strong>"),
ifelse(is.character(value), conv_non_ascii(value), value),
sep = ": ")
if (identical(appended, character())) {
appended <- div_str_item
} else {
appended <- paste(appended,
div_str_item,
sep = "\n <br/>")
}
}
}
}
if (identical(appended, character())) {
return(NA)
}
return(HTML(appended))
}
# Special cases where no primary heading (title) is needed
if (isTRUE(format_info$var.only)) {
if (!isTRUE(format_info$headings)) {
return(list())
} else {
if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
if (!is.na(div_id)) {
head2 <-
h4(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
}
} else {
if (!is.na(div_id)) {
head2 <-
strong(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
}
}
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type"))))
tmp <- list(head2, head3)
return(tmp[which(!is.na(tmp))])
}
} else if (isTRUE(format_info$group.only)) {
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Group = trs("group")),
c(N.Obs = trs("n")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
} else {
head3 <- append_items(list(c(Group = trs("group"))))
}
return(list(head3))
} else if (!isTRUE(format_info$headings)) {
if ("Group" %in% names(data_info)) {
head3 <- append_items(list(c(Group = trs("group"))))
return(list(head3))
} else {
return(list())
}
}
# Regular cases - Build the 3 heading elements
if (caller == "print_freq") {
if ("Weights" %in% names(data_info)) {
if (trs("title.freq.weighted") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.freq.weighted"))))
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.freq"))))
}
}
if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
if (!is.na(div_id)) {
head2 <-
h4(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
}
} else {
if (!is.na(div_id)) {
head2 <-
strong(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
}
}
if ("var.only" %in% names(format_info)) {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type"))))
} else {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(Weights = trs("weights")),
c(Group = trs("group"))))
}
} else if (caller == "print_ctable") {
head1 <- switch(data_info$Proportions,
Row = paste(trs("title.ctable"), trs("title.ctable.row"),
sep = ", "),
Column = paste(trs("title.ctable"), trs("title.ctable.col"),
sep = ", "),
Total = paste(trs("title.ctable"), trs("title.ctable.tot"),
sep = ", "),
None = trs("title.ctable"))
# Check that head1 is not empty (if define_keywords was used)
head1 <- sub("^, ", "", head1)
if (head1 == ", ") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(head1)))
}
if ("Row.x.Col" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Row.x.Col)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Row.x.Col)), br())
}
}
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Data.frame.label = trs("label")),
c(Group = trs("group"))))
} else if (caller == "print_descr") {
if ("Weights" %in% names(data_info)) {
if (trs("title.descr.weighted") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.descr.weighted"))))
}
} else {
if (trs("title.descr") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.descr"))))
}
}
if ("by_var_special" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- HTML(paste("<h4>", conv_non_ascii(data_info$Variable),
conv_non_ascii(trs("by")),
conv_non_ascii(data_info$by_var_special),
"</h4>"))
} else {
head2 <- HTML(paste("<strong>", conv_non_ascii(data_info$Variable),
"</strong>", conv_non_ascii(trs("by")), "<strong>",
conv_non_ascii(data_info$by_var_special),
"</strong><br/>"))
}
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else {
if ("Data.frame" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Data.frame)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Data.frame)), br())
}
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
}
} else if (caller == "print_dfs") {
if (trs("title.dfSummary") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.dfSummary"))))
}
if ("Data.frame" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Data.frame)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Data.frame)), br())
}
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Group = trs("group")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
}
tmp <- list(head1, head2, head3)
return(tmp[which(!is.na(tmp))])
}
dcomtois/summarytools documentation built on Nov. 16, 2023, 5:29 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 build_heading_html build_heading_pander print_dfs print_descr print_ctable print_freq print.summarytools
Documented in print.summarytools
#' print.summarytools
#'
#' Display \code{summarytools} objects in the console, in Web Browser or in
#' \emph{RStudio}'s Viewer, or write content to file.
#'
#' @usage
#' \method{print}{summarytools}(x, method = "pander", file = "",
#' append = FALSE, report.title = NA, table.classes = NA,
#' bootstrap.css = st_options('bootstrap.css'),
#' custom.css = st_options('custom.css'), silent = FALSE,
#' footnote = st_options('footnote'), max.tbl.height = Inf,
#' collapse = 0, escape.pipe = st_options("escape.pipe"), \dots)
#'
#' @param x A \emph{summarytools} object, created by one of the four core
#' functions (\code{\link{freq}}, \code{\link{descr}}, \code{\link{ctable}},
#' or \code{\link{dfSummary}}).
#' @param method Character. One of \dQuote{pander}, \dQuote{viewer},
#' \dQuote{browser}, or \dQuote{render}. Default value for the \code{print()}
#' method is \dQuote{pander}; for \code{view()}/\code{stview()}, default is
#' \dQuote{viewer} if session is running in \emph{RStudio}, \dQuote{browser}
#' otherwise. The main use for \dQuote{render} is in \emph{R Markdown}
#' documents.
#' @param file Character. File name to write output to. Defaults to \dQuote{}.
#' @param append Logical. Append output to existing file (specified using the
#' \emph{file} argument). \code{FALSE} by default.
#' @param report.title Character. For \emph{html} reports, this goes into the
#' \code{<title>} tag. When left to \code{NA} (default), the first line of the
#' heading section is used (\emph{e.g.}: \dQuote{Data Frame Summary}).
#' @param table.classes Character. Additional \emph{html} classes to assign to
#' output tables. \emph{Bootstrap css} classes can be used. User-defined
#' classes (see the \emph{custom.css} argument) are also specified here. See
#' \emph{details} section. \code{NA} by default.
#' @param bootstrap.css Logical. When generating an \emph{html} document,
#' include the \dQuote{\emph{includes/stylesheets/bootstrap.min.css"}} file
#' content inside a \code{<style type="text/css">} tag in the document's
#' \code{<head>}. \code{TRUE} by default. Can be set globally with
#' \code{\link{st_options}}.
#' @param custom.css Character. Path to a custom \emph{.css} file. Classes
#' defined in this must also appear in the \code{table.classes} parameter
#' in order to be applied to the table(s). Can be set globally with
#' \code{\link{st_options}}. \code{NA} by default.
#' @param silent Logical. Set to \code{TRUE} to hide console messages
#' (\emph{e.g.}: ignored variables or \code{NaN} to \code{NA}
#' transformations). \code{FALSE} by default.
#' @param footnote Character. Text to display just after \emph{html} output
#' tables. The default value (\dQuote{\emph{default}}) produces a two-line
#' footnote indicating the package's name and version, the R version, and
#' the current date. Has no effect on \emph{ascii} or \emph{markdown}
#' content. Can contain standard \emph{html} tags. Set to \code{NA} to omit.
#' Can be set globally with \code{\link{st_options}}.
#' @param max.tbl.height Numeric. Maximum table height \emph{in pixels} allowed
#' in rendered \code{dfSummary()} tables. When this argument is used, results
#' will show up in a \code{<div>} with the specified height and a scroll bar.
#' Intended to be used in \emph{Rmd} documents with \code{method = "render"}.
#' \code{Inf} by default.
#' @param collapse Numeric. \code{0} by default. Set to \code{1} to make
#' \code{freq()} sections collapsible (when clicking on the variable name).
#' Future versions might provide alternate collapsing options.
#' @param escape.pipe Logical. Set to \code{TRUE} when \code{style="grid"}
#' and \code{file} argument is supplied if the intent is to generate a text
#' file that can be converted to other formats using \emph{Pandoc}. Can be
#' set globally with \code{\link{st_options}}.
#' @param \dots Additional arguments used to override attributes stored in the
#' object, or to change formatting via \code{\link[base]{format}} or
#' \code{\link[pander]{pander}}. See \emph{Details}.
#'
#' @return \code{NULL} when \code{method="pander"}; A file path returned
#' invisibly when \code{method="viewer"} or \code{"browser"}. In the
#' latter case, the file path is also passed to \code{shell.exec}
#' (\emph{Windows}) or \code{\link{system}} (\emph{*nix}), causing
#' the document to be opened in default Web browser.
#'
#' @details
#' \code{Ascii} and \emph{markdown} tables are generated using
#' \code{\link[pander]{pander}}.
#'
#' The following arguments can be used to override formatting attributes stored
#' in the object:
#' \itemize{
#' \item \code{style}
#' \item \code{round.digits} (except for \emph{dfSummary} objects)
#' \item \code{plain.ascii}
#' \item \code{justify}
#' \item \code{split.tables}
#' \item \code{headings}
#' \item \code{display.labels}
#' \item \code{varnumbers} (\code{\link{dfSummary}} objects only)
#' \item \code{labels.col} (\code{\link{dfSummary}} objects only)
#' \item \code{graph.col} (\code{\link{dfSummary}} objects only)
#' \item \code{valid.col} (\code{\link{dfSummary}} objects only)
#' \item \code{na.col} (\code{\link{dfSummary}} objects only)
#' \item \code{col.widths} (\code{\link{dfSummary}} objects only)
#' \item \code{keep.grp.vars} (\code{\link{dfSummary}} objects only)
#' \item \code{report.nas} (\code{\link{freq}} objects only)
#' \item \code{display.type} (\code{\link{freq}} objects only)
#' \item \code{missing} (\code{\link{freq}} objects only)
#' \item \code{totals} (\code{\link{freq}} and \code{\link{ctable}} objects)
#' \item \code{caption} (\code{\link{freq}} and \code{\link{ctable}} objects)
#' }
#'
#' The following arguments can be used to override heading elements:
#'
#' \itemize{
#' \item \code{Data.frame}
#' \item \code{Data.frame.label}
#' \item \code{Variable}
#' \item \code{Variable.label}
#' \item \code{Group}
#' \item \code{date}
#' \item \code{Weights} (\code{\link{freq}} & \code{\link{descr}} objects)
#' \item \code{Data.type} (\code{\link{freq}} objects only)
#' \item \code{Row.variable} (\code{\link{ctable}} objects only)
#' \item \code{Col.variable} (\code{\link{ctable}} objects only)
#' }
#'
#' @method print summarytools
#'
#' @references
#' \href{https://www.rstudio.com/}{RStudio}
#' \href{https://github.com/dcomtois/summarytools/}{Summarytools on GitHub}
#' \href{http://rapporter.github.io/pander/#general-options/}{List of pander options}
#' \href{https://getbootstrap.com/docs/4.3/getting-started/introduction/}{Bootstrap Cascading Stylesheets}
#'
#' @author Dominic Comtois, \email{dominic.comtois@@gmail.com}
#'
#' @seealso
#' \code{\link[pander]{pander}}
#'
#' @examples
#' \dontrun{
#' data(tobacco)
#' view(dfSummary(tobacco), footnote = NA)
#' }
#' data(exams)
#' print(freq(exams$gender), style = 'rmarkdown')
#' print(descr(exams), headings = FALSE)
#'
#' @keywords print methods
#' @import htmltools
#' @importFrom pander pander panderOptions
#' @importFrom utils capture.output packageVersion head
#' @importFrom checkmate test_logical test_path_for_output test_choice
#' test_string check_file_exists
#' @export
print.summarytools <- function(x,
method = "pander",
file = "",
append = FALSE,
report.title = NA,
table.classes = NA,
bootstrap.css = st_options("bootstrap.css"),
custom.css = st_options("custom.css"),
silent = FALSE,
footnote = st_options("footnote"),
max.tbl.height = Inf,
collapse = 0,
escape.pipe = st_options("escape.pipe"),
...) {
# For list objects (generally created in one of the following ways:
# - using lapply(df, FUN), where FUN is [ctable() | descr() | dfSummary()]
# - using freq(x) where x is a data frame
# - using dplyr::group_by() %>% FUN, FUN in [ctable(), descr(), dfSummary()]
#
# ... we dispatch x [possibly back] to view()
if (is.list(x) &&
!attr(x, "st_type") %in% c("ctable", "descr", "dfSummary")) {
view(x,
method = method,
file = file,
append = append,
report.title = report.title,
table.classes = table.classes,
bootstrap.css = bootstrap.css,
custom.css = custom.css,
silent = silent,
footnote = footnote,
collapse = collapse,
escape.pipe = escape.pipe,
...)
return(invisible())
}
knitr.auto.asis.value <- panderOptions("knitr.auto.asis")
panderOptions("knitr.auto.asis", FALSE)
on.exit(panderOptions("knitr.auto.asis", knitr.auto.asis.value))
dotArgs <- list(...)
# Recuperate internal arguments passed from view() if present ----------------
if ("open.doc" %in% names(dotArgs)) {
open.doc <- eval(dotArgs[["open.doc"]])
dotArgs$open.doc <- NULL
} else {
open.doc <- FALSE
}
if ("group.only" %in% names(dotArgs)) {
attr(x, "format_info")$group.only <- eval(dotArgs[["group.only"]])
dotArgs$group.only <- NULL
}
if ("var.only" %in% names(dotArgs)) {
attr(x, "format_info")$var.only <- eval(dotArgs[["var.only"]])
dotArgs$var.only <- NULL
}
# Set st_option(lang) to the language that was active when the object was
# created (as indicated by attr(x, "lang")
if (isTRUE(st_options("lang") != attr(x, "lang"))) {
current_lang <- st_options("lang")
st_options(lang = attr(x, "lang"))
on.exit(st_options(lang = current_lang), add = TRUE)
}
method <- switch(tolower(substr(method, 1, 1)),
p = "pander",
b = "browser",
v = "viewer",
r = "render")
# Change method to browser when file name has .html extension
if (grepl("\\.html$", file, ignore.case = TRUE, perl = TRUE) &&
!grepl(pattern = tempdir(), x = file, fixed = TRUE) &&
method == "pander") {
method <- "browser"
# message("Switching method to 'browser'")
}
# Parameter validation -------------------------------------------------------
mc <- match.call()
errmsg <- check_args_print(mc)
if (length(errmsg) > 0) {
stop(paste(errmsg, collapse = "\n "))
}
# Display message if list object is being printed (console) with base print()
# (thus not taking advantage of print.summarytools() which makes results
# much cleaner in the console)
if (method == "pander" &&
(identical(deparse(sys.calls()[[max(sys.nframe() - 1, 1)]][2]), "x[[i]]()") ||
any(grepl(pattern = "fn_call = FUN(x = X[[i]]",
x = deparse(sys.calls()[[max(sys.nframe() - 1, 1)]]), fixed = TRUE)))) {
message("For best results printing list objects with summarytools, ",
"use print(x); if by() was used, use stby() instead")
}
# Apply / override parameters - first deal with "meta" information -----------
# date is a stand-alone attribute so we treat it separately
if ("date" %in% names(dotArgs)) {
attr(x, "date") <- dotArgs[["date"]]
dotArgs$date <- NULL
}
# Check for elements with modified names - will be removed in next release
if ("dataframe" %in% tolower(names(dotArgs))) {
attr(x, "data_info")$Data.frame <- dotArgs$Dataframe
dotArgs$Dataframe <- NULL
message("Attribute 'Dataframe' has been renamed to 'Data.frame'; ",
"please use the latter in the future")
}
if ("dataframe.label" %in% tolower(names(dotArgs))) {
attr(x, "data_info")$Data.frame.label <- dotArgs$Dataframe.label
dotArgs$Dataframe.label <- NULL
message("Attribute 'Dataframe.label' has been renamed to ",
"'Data.frame.label'; please use the latter in the future")
}
# Scan "dotArgs" for metadata elements
overrided_data_info <- character()
data_info_elements <- c("Data.frame", "Data.frame.label", "Variable",
"Variable.label", "Data.type", "Group", "Weights",
"Row.variable", "Col.variable")
for (data_info_element in data_info_elements) {
if (length(dotArgs) > 0) {
if (tolower(data_info_element) %in% tolower(names(dotArgs))) {
# Get matching index if present
elem_ind <- grep(paste0("^", data_info_element, "$"),
names(dotArgs), ignore.case = TRUE)
if (length(elem_ind) > 0) {
elem_ind_last <- tail(elem_ind, 1) # take last if more than one match
# Display message if argument not spelled exactly as supposed
if (names(dotArgs)[elem_ind_last] != data_info_element) {
message("Argument ", data_info_element, " misspelled as ",
names(dotArgs)[elem_ind_last])
names(dotArgs)[elem_ind_last] <- data_info_element
}
attr(x, "data_info")[[data_info_element]] <- dotArgs[[elem_ind_last]]
for (ind in elem_ind) {
dotArgs[[elem_ind]] <- NULL
}
overrided_data_info <- c(overrided_data_info, data_info_element)
}
}
}
}
# Assume all remaining arguments have to do with formatting. Put everything
# into a list and eliminate redundant items, keeping only the last one,
# giving priority to
#
# 1. "dotArgs", then to
# 2. explicit arguments used when creating the object, as given by the
# 'fn_call' attribute.
#
# The remaining arguments will be obtained from the st_options() function
# so that changes in summarytools options made after the object's creation
# will be applied.
format_info <-
append(list(scientific = FALSE,
decimal.mark = getOption("OutDec"),
keep.line.breaks = TRUE,
max.tbl.height = max.tbl.height,
collapse = collapse),
attr(x, "format_info"))
if (length(attr(x, "user_fmt")) > 0) {
format_info <- append(format_info, attr(x, "user_fmt"))
}
if (length(dotArgs) > 0) {
format_info <- append(format_info, dotArgs)
}
# Keep only last instance of repeated items
format_info <- format_info[which(!duplicated(names(format_info),
fromLast = TRUE))]
# For parameters that were not explicit, get their value from
# st_options().
list_fmt_elements <- c("style", "plain.ascii", "round.digits", "headings",
"display.labels")
for (format_element in list_fmt_elements) {
if (!format_element %in% c(names(attr(x, "fn_call")), names(dotArgs))) {
if (!(format_element == "style" &&
attr(x, "st_type") == "dfSummary") &&
!(format_element == "round.digits" &&
attr(x, "st_type") == "ctable")) {
format_info[[format_element]] <- st_options(format_element)
}
}
}
# Global options specific to the type of st object being printed
prefix <- paste0(attr(x, "st_type"), ".")
for (format_element in sub(prefix, "",
grep(prefix, names(st_options()), value = TRUE,
fixed = TRUE),
fixed = TRUE)) {
if (!format_element %in% c(names(attr(x, "fn_call")), names(dotArgs))) {
format_info[[format_element]] <-
st_options(paste0(prefix, format_element))
}
}
# When style == 'rmarkdown', set plain.ascii to FALSE unless
# explicitly specified otherwise
if (method == "pander" && format_info$style == "rmarkdown" &&
isTRUE(format_info$plain.ascii) &&
(!"plain.ascii" %in% (names(dotArgs)))) {
format_info$plain.ascii <- FALSE
}
# Evaluate formatting attributes that are symbols at this stage (F, T)
for (i in seq_along(format_info)) {
if (is.symbol(format_info[[i]])) {
format_info[[i]] <- eval(format_info[[i]])
}
}
# Fix the value of justify - default depends on method
if (method == "pander") {
format_info$justify <- switch(tolower(substring(format_info$justify, 1, 1)),
l = "left",
c = "center",
d = "right",
r = "right")
} else {
format_info$justify <- switch(tolower(substring(format_info$justify, 1, 1)),
l = "left",
c = "center",
d = "center",
r = "right")
}
format_info$missing <- ifelse("missing" %in% names(format_info),
format_info$missing, "NA")
# Keep last when multiple values
format_info <- format_info[which(!duplicated(names(format_info),
fromLast = TRUE))]
# Add nsmall and digits to format_info if not already there
if (!"nsmall" %in% names(format_info)) {
format_info$nsmall <- format_info$round.digits
}
if (!"digits" %in% names(format_info)) {
format_info$digits <- max(c(1, format_info$round.digits))
}
# Put modified attributes back into x
attr(x, "format_info") <- format_info
format_args <-
format_info[which(names(format_info) %in% names(formals(format.default)))]
format_args$justify <- sub("center", "centre", format_args$justify)
attr(x, "format_args") <- format_args
pander_args <- append(
format_info[which(names(format_info) %in%
c(sub("^table\\.", "", names(panderOptions())),
"style", "caption", "justify", "missing",
"split.tables", "split.cells", "keep.line.breaks"))],
attr(x, "user_fmt"))
attr(x, "pander_args") <-
pander_args[which(!duplicated(names(pander_args), fromLast = TRUE))]
# Build default footnote
if (method %in% c("browser", "viewer", "render") && footnote == "default") {
footnote <-
paste0(
conv_non_ascii(trs("generated.by")),
" <a href='https://github.com/dcomtois/summarytools'>",
"summarytools</a> ", packageVersion(pkg = "summarytools"),
" (<a href='https://www.r-project.org/'>R</a> ", trs("version"), " ",
getRversion(), ")", "<br/>", strftime(attr(x, "date"), trs("date.fmt"))
)
}
# Concatenate data frame + $ + variable name where appropriate
if (!("Variable" %in% overrided_data_info) &&
length(attr(x, "data_info")$Data.frame) == 1 &&
"Variable" %in% names(attr(x, "data_info")) &&
!("by_var_special" %in% names(attr(x, "data_info")))) {
attr(x, "data_info")$Variable <- paste(attr(x, "data_info")$Data.frame,
attr(x, "data_info")$Variable,
sep = "$")
}
# Dispatch to the right function for preparing output ------------------------
if (attr(x, "st_type") == "freq") {
res <- print_freq(x, method)
if (is.na(report.title)) {
if (!("Weights" %in% names(attr(x, "data_info")))) {
report.title <- trs("title.freq")
} else {
report.title <- trs("title.freq.weighted")
}
}
} else if (attr(x, "st_type") == "ctable") {
res <- print_ctable(x, method)
if (is.na(report.title)) {
report.title <- trs("title.ctable")
}
} else if (attr(x, "st_type") == "descr") {
res <- print_descr(x, method)
if (is.na(report.title)) {
if (!("Weights" %in% names(attr(x, "data_info")))) {
report.title <- trs("title.descr")
} else {
report.title <- trs("title.descr.weighted")
}
}
} else if (attr(x, "st_type") == "dfSummary") {
res <- print_dfs(x, method)
if (is.na(report.title)) {
report.title <- trs("title.dfSummary")
}
}
# Print or write to file - pander --------------------------------------------
if (method == "pander") {
# Remove double-linefeeds
res[[length(res)]] <-
sub("^\\n\\n", "\n", res[[length(res)]])
file <- normalizePath(file, mustWork = FALSE)
cat(do.call(paste0, res), file = file, append = append)
if (file != "" && !isTRUE(silent)) {
if (isTRUE(append))
message("Output file appended: ", file)
else
message("Output file written: ", file)
return(invisible())
}
} else {
# Print or write to file - html --------------------------------------------
if (isTRUE(append)) {
f <- file(file, open = "r", encoding = "utf-8")
html_content_in <- paste(readLines(f, warn = FALSE, encoding = "utf-8"),
collapse = "\n")
close(f)
top_part <- sub("(^.+)(</body>.+)", "\\1", html_content_in)
bottom_part <- sub("(^.+)(</body>.+)", "\\2", html_content_in)
insert_part <-
iconv(paste(capture.output(tags$div(class = "container st-container",
res)),
collapse = "\n"), to = "utf-8")
html_content <- paste(capture.output(cat(top_part, insert_part,
bottom_part)), collapse = "\n")
} else {
if (method %in% c("browser", "viewer")) {
html_content <-
tags$div(
class = "container st-container",
tags$head(
includeHTML(system.file(
package = "summarytools", "includes/favicon.html"
)),
tags$title(HTML(conv_non_ascii(report.title))),
if (collapse)
includeScript(system.file(
"includes/scripts/jquery-3.4.0.slim.min.js",
package = "summarytools"
)),
if (collapse)
includeScript(system.file(
"includes/scripts/bootstrap.min.js",
package = "summarytools"
)),
if (isTRUE(bootstrap.css))
includeCSS(system.file(
"includes/stylesheets/bootstrap.min.css",
package = "summarytools"
)),
includeCSS(system.file(
"includes/stylesheets/summarytools.css",
package = "summarytools"
)),
if (!is.na(custom.css))
includeCSS(path = custom.css)
),
res)
} else {
# method == "render"
html_content <-
tags$div(
class = "container st-container",
tags$head(
includeCSS(system.file(package = "summarytools",
"includes/stylesheets/summarytools.css")),
if (!is.na(custom.css))
includeCSS(path = custom.css)
),
res)
}
}
if (method == "render") {
return(html_content)
}
outfile_path <- ifelse(file == "", paste0(tempfile(),".html"), file)
outfile_path <- normalizePath(outfile_path, mustWork = FALSE)
if (isTRUE(append)) {
capture.output(cat(html_content, "\n"), file = outfile_path)
} else {
save_html(html = html_content, file = outfile_path)
}
if (method == "viewer") {
if (file == "" || isTRUE(open.doc)) {
if (.Platform$GUI == "RStudio") {
viewer <- getOption("viewer")
if (!is.null(viewer)) {
viewer(outfile_path)
} else {
message("To view html content in RStudio, please install ",
"the 'rstudioapi' package")
message("Switching method to 'browser'")
method <- "browser"
}
} else {
message("Switching method to 'browser'")
method <- "browser"
}
}
}
# For method "browser", we don't use utils::browseURL() because of
# compatibility issues with RStudio
if (method == "browser") {
if (file == "" || isTRUE(open.doc)) {
switch(.st_env$sysname,
Windows = {shell.exec(file = paste0("file:///", outfile_path))},
Linux = {system(paste("/usr/bin/xdg-open", outfile_path),
wait = FALSE, ignore.stdout = TRUE)},
Darwin = {system(paste("open", outfile_path), wait = FALSE,
ignore.stderr = TRUE)})
}
}
# return file path and update tmpfiles vector when method = browser / viewer
if (file == "" && method %in% c("browser", "viewer")) {
.st_env$tmpfiles <- c(.st_env$tmpfiles, outfile_path)
if (!silent) {
message("Output file written: ", outfile_path)
}
return(invisible(outfile_path))
} else if (file != "") {
if (!silent) {
if (isTRUE(append)) {
message("Output file appended: ", outfile_path)
} else {
message("Output file written: ", outfile_path)
}
}
return(invisible())
}
}
}
# Prepare freq objects for printing --------------------------------------------
#' @import htmltools
print_freq <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
if (!isTRUE(parent.frame()$silent) && !isTRUE(format_info$group.only) &&
(!"by_first" %in% names(data_info) ||
isTRUE(as.logical(data_info$by_first))) &&
"ignored" %in% names(attributes(x))) {
message("Non-categorical variable(s) ignored: ",
paste(attr(x, "ignored"), collapse = ", "))
}
if (!isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
# Subtract NA counts from total
x[nrow(x), 1] <- x[nrow(x), 1] - x[nrow(x) - 1, 1]
# Remove NA row and keep only desired columns
x <- x[-(nrow(x) - 1), 1:2]
colnames(x) <- c(trs("freq"), trs("pct"))
} else if (!isTRUE(format_info$report.nas) && isTRUE(format_info$cumul)) {
# Subtract NA counts from total
x[nrow(x), 1] <- x[nrow(x), 1] - x[nrow(x) - 1, 1]
# Remove NA row and keep only desired columns
x <- x[-(nrow(x) - 1), 1:3]
colnames(x) <- c(trs("freq"), trs("pct"), trs("pct.cum"))
} else if (isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
x <- x[ ,-c(3,5)]
colnames(x) <- c(trs("freq"), trs("pct.valid.f"), trs("pct.total"))
}
if (!isTRUE(format_info$totals)) {
x <- x[-nrow(x),]
}
# Use format() on row names when x is numeric
if (data_info$Data.type == trs("numeric")) {
temp_rownames <- suppressWarnings(as.numeric(rownames(x)))
temp_rownames_nas <- which(is.na(temp_rownames))
# Check if all row names are integers (if so, decimals will be removed)
rownames_are_int <- all(as.integer(temp_rownames) == temp_rownames,
na.rm = TRUE)
if (rownames_are_int) {
temp_rownames <- do.call(format, append(format_args,
list(x = quote(temp_rownames))))
temp_rownames <- sub(paste0("^(.+)\\", format_info$decimal.mark,
# "0+$"),
"(0(0|\\D)*$)"),
"\\1", temp_rownames)
} else {
temp_rownames <- format(rownames(x), justify = format_args$justify)
}
temp_rownames[temp_rownames_nas] <- rownames(x)[temp_rownames_nas]
row.names(x) <- temp_rownames
}
if (method == "pander") {
# Escape "<" and ">" when used in pairs in rownames
if (!isTRUE(pander_args$plain.ascii)) {
row.names(x) <- gsub(pattern = "\\<(.*)\\>",
replacement = "\\\\<\\1\\\\>",
x = row.names(x), perl = TRUE)
}
# Translate the "(Other)" category (when "rows" was used to filter out
# some values
rownames(x)[which(rownames(x) == "(Other)")] <- trs("other")
# set encoding to native to allow proper display of accentuated characters
if (parent.frame()$file == "") {
row.names(x) <- enc2native(row.names(x))
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
is_na_x <- is.na(x)
x <- do.call(format, append(format_args, x = quote(x)))
if (!"Weights" %in% names(data_info)) {
x[ ,1] <- sub(paste0("\\", format_info$decimal.mark, "0+$"), "", x[ ,1])
}
x[is_na_x] <- format_info$missing
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <- gsub("\\|","\\\\|",
main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_freq -- html method ------------------------------------------------
table_head <- list()
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list()
for (co in seq_len(ncol(x))) {
cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
if (co == 1) {
table_row %+=% list(tags$th(trimws(row.names(x)[ro]),
align = "center",
class = "st-protect-top-border"))
if (!"Weights" %in% names(data_info)) {
cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
}
table_row %+=% list(tags$td(cell, align = format_info$justify))
next
}
if (is.na(x[ro,co])) {
table_row %+=% list(tags$td(format_info$missing,
align = format_info$justify))
} else {
table_row %+=% list(tags$td(cell, align = format_info$justify))
}
if (co == ncol(x)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
if (isTRUE(format_info$report.nas) && isTRUE(format_info$cumul)) {
table_head[[1]] <- list(tags$th("", colspan = 2),
tags$th(HTML(conv_non_ascii(trs("valid"))),
colspan = 2, align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("total"))),
colspan = 2, align = "center",
class = "st-protect-top-border"))
table_head[[2]] <- list(tags$th(HTML(conv_non_ascii(
sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center"))
freq_table_html <-
tags$table(
tags$thead(tags$tr(table_head[[1]]),
tags$tr(table_head[[2]])),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-freq-table",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
} else {
if (isTRUE(format_info$cumul) && !isTRUE(format_info$report.nas)) {
# No NA reporting
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.cum"))),
align = "center",
class = "st-protect-top-border"))
} else if (isTRUE(format_info$report.nas) && !isTRUE(format_info$cumul)) {
# No cumulative proportions
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.valid.f"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct.total"))),
align = "center",
class = "st-protect-top-border"))
} else {
# No cumulative proportions, no NA reporting
table_head <-
list(tags$th(HTML(conv_non_ascii(sub("^.*\\$(.+)$", "\\1",
data_info$Variable))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("freq"))),
align = "center",
class = "st-protect-top-border"),
tags$th(HTML(conv_non_ascii(trs("pct")))))
}
freq_table_html <-
tags$table(
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-freq-table-nomiss",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
}
# Encapsulate the table in a collapsible div if necessary
if (format_info$collapse) {
div_id <- paste0(sample(c(letters, LETTERS), size = 1),
paste(sample(c(letters, LETTERS, 0:9), size = 11),
collapse = ""))
freq_table_html <- div(freq_table_html,
class = "collapse show",
id = div_id)
} else {
div_id <- NA
}
# Cleanup extra spacing and linefeeds in html to correct layout issues
freq_table_html <- gsub(pattern = "</span>\\s*</span>",
replacement = "</span></span>",
x = freq_table_html,
perl = TRUE)
# Change visual aspect of "white space" symbol
freq_table_html <-
gsub(pattern = paste0("(",intToUtf8(183),"+)"),
replacement = " <span class='st-ws-char'>\\1</span>",
x = freq_table_html,
perl = TRUE)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method, div_id)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = conv_non_ascii(freq_table_html)))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare ctable objects for printing ------------------------------------------
#' @import htmltools
#' @keywords internal
print_ctable <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
# Use format() on row names when x is numeric
if (data_info$Data.type.x %in% c(trs("numeric"), trs("integer"))) {
temp_rownames <- suppressWarnings(as.numeric(rownames(x[[1]])))
temp_rownames_nas <- which(is.na(temp_rownames))
# Check if all row names are integers (if so, decimals will be removed)
rownames_are_int <- all(as.integer(temp_rownames) == temp_rownames,
na.rm = TRUE)
if (rownames_are_int) {
format_args_tmp <- format_args
format_args_tmp$digits <- 1
format_args_tmp$nsmall <- 0
} else {
# Make sure no decimals are lost b/c of format options
format_args_tmp <- format_args
format_args_tmp$digits <- max(
c(1, nchar(sub(".+\\.(.*)0*", "\\1", temp_rownames))),
na.rm = TRUE
)
format_args_tmp$nsmall <- format_args_tmp$digits
}
temp_rownames <- do.call(
format,
append(format_args_tmp, list(x = quote(temp_rownames)))
)
# Replace non-numeric names by original values
temp_rownames[temp_rownames_nas] <- rownames(x[[1]])[temp_rownames_nas]
row.names(x[[1]]) <- temp_rownames
if (!is.null(x[[2]])) {
row.names(x[[2]]) <- temp_rownames
}
}
# Use format() on col names when y is numeric
if (data_info$Data.type.y %in% c(trs("numeric"), trs("integer"))) {
temp_colnames <- suppressWarnings(as.numeric(colnames(x[[1]])))
temp_colnames_nas <- which(is.na(temp_colnames))
# Check if all row names are integers (if so, decimals will be removed)
colnames_are_int <- all(as.integer(temp_colnames) == temp_colnames,
na.rm = TRUE)
if (colnames_are_int) {
format_args_tmp <- format_args
format_args_tmp$digits <- 1
format_args_tmp$nsmall <- 0
} else {
format_args_tmp <- format_args
format_args_tmp$digits <- max(
c(1, nchar(sub(".+\\.(.*)0*", "\\1", temp_rownames))),
na.rm = TRUE
)
format_args_tmp$nsmall <- format_args_tmp$digits
}
temp_colnames <- do.call(
format,
append(format_args_tmp, list(x = quote(temp_colnames)))
)
# Replace non-numeric names with original values
temp_colnames[temp_colnames_nas] <- colnames(x[[1]])[temp_colnames_nas]
colnames(x[[1]]) <- temp_colnames
if (!is.null(x[[2]])) {
colnames(x[[2]]) <- temp_colnames
}
}
# align_numbers() ------------------------------------------------------------
# Create vertically aligned strings for counts and proportions
align_numbers <- function(counts, props) {
res <- sapply(seq_len(ncol(counts)), function(colnum) {
if ("Weights" %in% names(data_info)) {
counts_fmted <- do.call(
format, append(format_args, list(x = counts[ ,colnum]))
)
} else {
counts_fmted <- do.call(
format, append(format_args[-which(names(format_args) == "nsmall")],
list(x = counts[ ,colnum])) # use quote? list(x = quote(counts[,colnum]
)
}
props_fmted <- do.call(
format,
append(format_args, list(x = props[ ,colnum] * 100))
)
return(
paste0(
pad(counts_fmted, max(nchar(counts_fmted))),
" (",
pad(props_fmted, max(nchar(props_fmted))),
"%)"
)
)
})
dim(res) <- dim(counts)
dimnames(res) <- dimnames(counts)
return(res)
}
if (!isTRUE(format_info$totals)) {
x$cross_table <-
x$cross_table[which(rownames(x$cross_table) != trs("total")),
which(colnames(x$cross_table) != trs("total"))]
if (data_info$Proportions != "None") {
x$proportions <-
x$proportions[which(rownames(x$proportions) != trs("total")),
which(colnames(x$proportions) != trs("total"))]
}
}
if (data_info$Proportions %in% c("Row", "Column", "Total")) {
cross_table <- align_numbers(x$cross_table, x$proportions)
} else {
cross_table <- x$cross_table
}
# print_ctable -- pander method ----------------------------------------------
if (method == "pander") {
# Escape "<" and ">" when used in pairs in rownames or colnames
if (!isTRUE(pander_args$plain.ascii)) {
row.names(cross_table) <-
gsub(pattern = "\\<(.*)\\>", replacement = "\\\\<\\1\\\\>",
x = row.names(cross_table), perl = TRUE)
colnames(cross_table) <-
gsub(pattern = "\\<(.*)\\>", replacement = "\\\\<\\1\\\\>",
x = colnames(cross_table), perl = TRUE)
}
main_sect <- build_heading_pander()
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args,
list(x = quote(ftable(cross_table)))))
),
collapse = "\n")
if (isTRUE(format_info$headings) && pander_args$style != "grid") {
main_sect[[length(main_sect)]] <- sub("^\n", "\n\n",
main_sect[[length(main_sect)]])
}
if ("chisq" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
c(format(attr(x, "chisq")["Chi.squared"],
decimal.mark = format_args$decimal.mark),
format(attr(x, "chisq")["df"]),
format(attr(x, "chisq")["p.value"],
decimal.mark = format_args$decimal.mark)
)
)
),
collapse = "\n"
)
}
if ("OR" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
#do.call(format, append(format_args, list(x = attr(x, "OR"))))
format(attr(x, "OR"), digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
)
),
collapse = "\n"
)
}
if ("RR" %in% names(attributes(x))) {
main_sect %+=% paste(
capture.output(
pander::pander(
#do.call(format, append(format_args, list(x = attr(x, "RR"))))
format(attr(x, "RR"), digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark)
)
),
collapse = "\n"
)
}
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_ctable -- html method ----------------------------------------------
dnn <- names(dimnames(cross_table))
table_head <- list()
table_rows <- list()
has_prop <- length(x$proportions) > 0
table_head[[1]] <-
list(tags$th(""),
tags$th(
dnn[2],
colspan = (1 + has_prop*3) *
(ncol(cross_table) - as.numeric(isTRUE(format_info$totals))),
align = "center", class = "st-protect-top-border"
)
)
if (isTRUE(format_info$totals)) {
table_head[[1]][[3]] <- tags$th("", colspan = (1 + has_prop*3))
}
table_head[[2]] <- list(tags$td(tags$strong(dnn[1]), align = "center"))
for (cn in colnames(cross_table)) {
flag_split <- FALSE
if (nchar(cn) > st_options("char.split")) {
flag_split <- TRUE
}
cn <- sub("<", "<", cn, fixed = TRUE)
cn <- sub(">", ">", cn, fixed = TRUE)
if (isTRUE(flag_split)) {
cn <- smart_split(cn, st_options("char.split"))
}
table_head[[2]][[length(table_head[[2]]) + 1]] <-
tags$th(HTML(conv_non_ascii(cn)),
colspan = (1 + has_prop*3), align = "center")
}
table_rows <- list()
for (ro in seq_len(nrow(cross_table))) {
table_row <- list()
for (co in seq_len(ncol(cross_table))) {
if (co == 1) {
rn <- row.names(cross_table)[ro]
rn <- sub("<", "<", rn, fixed = TRUE)
rn <- sub(">", ">", rn, fixed = TRUE)
table_row %+=%
list(
tags$td(
tags$strong(
HTML(conv_non_ascii(rn)),
align = "center"
)
)
)
}
# No proportions
if (!isTRUE(has_prop)) {
cell <- cross_table[ro,co]
table_row %+=% list(tags$td(tags$span(cell)))
} else {
cell <- gsub(" ", "", cross_table[ro,co])
cell <- sub(")$", "", cell)
cell <- strsplit(cell, "\\(")[[1]]
table_row %+=% list(
tags$td(
cell[1],
align = "right",
style = "padding:0 0 0 15px;border-right:0;text-align:right"
)
)
table_row %+=% list(
tags$td(
"(", align = "left",
style = paste0("padding:0 1px 0 4px;border-left:0;",
"border-right:0;text-align:left")
)
)
table_row %+=% list(
tags$td(
HTML(cell[2]),
align = "left",
style = "padding:0;border-left:0;border-right:0;text-align:right"
)
)
table_row %+=% list(
tags$td(")",
align = "left",
style = "padding:0 15px 0 1px;border-left:0;text-align:right"
)
)
}
# On last col, insert row into list
if (co == ncol(cross_table)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
# Build table footer containing stats
if (any(c("chisq", "OR", "RR") %in% names(attributes(x)))) {
stats_str <- ""
if ("chisq" %in% names(attributes(x))) {
chisq <- attr(x, "chisq")
stats_str <- paste0(
stats_str,
"<em><strong> Χ<sup>2</sup></strong> = ",
sub("\\.", format_args$decimal.mark, sprintf("%.4f", chisq[[1]])),
" <strong>df</strong> = ", chisq[[2]],
" <strong>p</strong> = ",
sub("^0\\.", format_args$decimal.mark,
sprintf("%.4f", chisq[[3]])), "</em><br/>"
)
}
if ("OR" %in% names(attributes(x))) {
OR <- attr(x, "OR")
stats_str <- paste0(
stats_str,
"<em><strong>O.R. </strong>(",
attr(x, "OR-level")*100, "% C.I.) = <strong>",
format(OR[[1]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
"</strong> (",
format(OR[[2]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
" - ",
format(OR[[3]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
")</em><br/>
")
}
if ("RR" %in% names(attributes(x))) {
RR <- attr(x, "RR")
stats_str <- paste0(
stats_str,
"<em><strong>R.R. </strong>(",
attr(x, "RR-level")*100, "% C.I.) = <strong>",
format(RR[[1]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
"</strong> (",
format(RR[[2]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
" - ",
format(RR[[3]], digits = 2, nsmall = 2,
decimal.mark = format_args$decimal.mark),
")</em>")
}
}
cross_table_html <-
tags$table(
tags$thead(
tags$tr(table_head[[1]]),
tags$tr(table_head[[2]])
),
tags$tbody(
table_rows
),
if (exists("stats_str"))
tags$tfoot(tags$tr(tags$td(HTML(stats_str), colspan = 100))),
class = paste(
"table table-bordered st-table st-table-bordered st-cross-table",
ifelse(is.na(parent.frame()$table.classes), "",
parent.frame()$table.classes)
)
)
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(cross_table_html)
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare descr objects for printing -------------------------------------------
#' @import htmltools
#' @keywords internal
print_descr <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
# determine whether to display message re: ignored variables
display_msg <- FALSE
if ("ignored" %in% names(attributes(x)) &&
(("by_first" %in% names(data_info) && isTRUE(data_info$by_first)) ||
!"by_first" %in% names(data_info))) {
if ("silent" %in% names(parent.frame())) {
if (!isTRUE(parent.frame()$silent)) {
display_msg <- TRUE
}
} else {
if (!isTRUE(st_options("descr.silent"))) {
display_msg <- TRUE
}
}
}
if (display_msg) {
message("Non-numerical variable(s) ignored: ",
paste(attr(x, "ignored"), collapse = ", "))
}
if (method == "pander") {
# print_descr -- pander method ---------------------------------------------
# set encoding to native to allow proper display of accentuated characters
if (parent.frame()$file == "") {
row.names(x) <- enc2native(row.names(x))
if (!is.null(colnames(x)))
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
x <- round(x, format_info$digits)
x <- do.call(format, append(format_args, list(x = quote(x))))
#if (!"Weights" %in% names(data_info)) {
# row_ind <- which(trs("n.valid") == rownames(x))
# x[row_ind, ] <- sub("\\.0+", "", x[row_ind, ])
#}
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_descr -- html method -----------------------------------------------
x <- round(x, format_info$digits)
table_head <- list(tags$th(""))
for (cn in colnames(x)) {
if (nchar(cn) > st_options("char.split")) {
cn <- smart_split(cn, st_options("char.split"))
}
table_head %+=% list(tags$th(HTML(cn), align = "center",
class = "st-protect-top-border"))
}
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list(tags$td(tags$strong(rownames(x)[ro])))
for (co in seq_len(ncol(x))) {
# cell is NA
if (is.na(x[ro,co])) {
table_row %+=% list(tags$td(format_info$missing))
} else {
# When not NA format cell content
cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
if ((rownames(x)[ro] == trs("n.valid") ||
colnames(x)[co] == trs("n.valid")) &&
!"Weights" %in% names(data_info)) {
cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
}
table_row %+=% list(tags$td(tags$span(cell)))
}
# On last column, insert row to table_rows list
if (co == ncol(x)) {
table_rows %+=% list(tags$tr(table_row))
}
}
}
descr_table_html <-
tags$table(
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-bordered table-striped",
"st-table st-table-bordered st-table-striped st-descr-table",
ifelse(is.na(parent.frame()$table.classes), "",
parent.frame()$table.classes))
)
# Cleanup some extra spacing & html linefeeds to avoid weirdness in layout
# of source code
descr_table_html <- as.character(descr_table_html)
descr_table_html <- gsub(pattern = "\\s*(\\-?\\d*)\\s*(<span|</td>)",
replacement = "\\1\\2", x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = "</span>\\s*</span>",
replacement = "</span></span>",
x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = "<strong>\\s*</strong>",
replacement = "",
x = descr_table_html,
perl = TRUE)
descr_table_html <- gsub(pattern = '(<td align="right">)\\s+(<)',
replacement = "\\1\\2",
x = descr_table_html,
perl = TRUE)
descr_table_html <- conv_non_ascii(descr_table_html)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = descr_table_html))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Prepare dfSummary objects for printing ---------------------------------------
#' @import htmltools
#' @keywords internal
print_dfs <- function(x, method) {
data_info <- attr(x, "data_info")
format_info <- attr(x, "format_info")
format_args <- attr(x, "format_args")
pander_args <- attr(x, "pander_args")
if (!isTRUE(parent.frame()$silent) &&
"png_message" %in% names(attributes(x)) &&
method != "render" &&
!isTRUE(format_info$group.only) &&
(!"by_first" %in% names(data_info) ||
isTRUE(as.logical(data_info$by_first)))) {
message("text graphs are displayed; set 'tmp.img.dir' ",
"parameter to activate png graphs")
}
# make_vals_cell -------------------------------------------------------------
# Function to split lines of the values cell into table rows and return
# the table which will become the td (cell content). By doing this, we make
# sure its content is well aligned with the freqs cell since it has the same
# number of rows. If we don't do this, free text with line breaks will
# sometimes use more or less vertical space than a table with the same
# number of rows as it has line breaks.
make_vals_cell <- function(cell) {
if (!grepl("\\n", cell)) {
return(HTML(paste0('<td align="left">', cell, '</td>')))
}
rows <- strsplit(cell, "\\n")[[1]]
rows <- gsub("\\\\$", "", rows)
# replace the "<" in "min < med < max:" line for the lte (<=) html code
mmmstr <- tolower(paste0("^", trs("min"), " < ",
trs("med.short"), " < ",
trs("max"), ":$"))
if (any(grepl(mmmstr, rows)) && grep(mmmstr, rows) == 2) {
rows[2] <- gsub("<", "≤", rows[2])
rows[3] <- gsub("<", "≤", rows[3]) # alternative to ≤ is ≼
}
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0;margin:0;border:0" align="left">'
), #padding:0 5px 0 7px
rows,
'</td></tr>',
collapse = "")
return(HTML(
paste0('<td align="left" style="padding:8;vertical-align:middle">',
'<table style="border-collapse:collapse;border:none;margin:0">',
cell, '</table></td>')
))
}
# make_freq_cell -------------------------------------------------------------
# Function to align the freqs / proportions in html outputs
# A table is built to fit in a single cell in the final table
make_freq_cell <- function(cell) {
if (identical(cell, conv_non_ascii(trs("all.nas")))) {
return(HTML(paste0('<td align="left">', cell, '</td>')))
}
rows <- strsplit(cell, "\\\n")[[1]]
rows <- gsub("\\", "", rows, fixed = TRUE)
rows <- gsub(" " , "", rows, fixed = TRUE)
rows <- gsub(")$", "", rows)
rows <- strsplit(rows, "[(:]")
if (grepl(":", cell)) {
# notice for rounded values
notice <- NA
if (length(rows[[length(rows)]]) == 1) {
notice <- sub("!", "! ", rows[[length(rows)]])
length(rows) <- length(rows) - 1
}
vals <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 1)
cnts <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 2)
prps <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 3)
if (!is.na(notice)) {
vals <- sub("!", " !", vals)
vals <- sub("(\\d)$", "\\1  ", vals)
}
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0 2px 0 7px;margin:0;border:0" align="right">'
),
vals,
paste0(
'</td><td style="padding:0 2px;border:0;" align="left">:</td>',
'<td style="padding:0 4px 0 6px;margin:0;border:0" align="right">'
),
cnts,
paste0(
'</td><td style="padding:0;border:0" align="left">(</td>',
'<td style="padding:0 2px;margin:0;border:0" align="right">'
),
prps,
paste0('</td><td style="padding:0 4px 0 0;border:0" align="left">)',
'</td></tr>'
),
collapse = ""
)
if (!is.na(notice)) {
cell <-
paste0(cell, '<tr style="background-color:transparent">',
'<td style="padding:0 0 0 7px;border:0;margin:0" colspan="5">',
notice, "</td></tr>", collapse = "")
}
} else {
cnts <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 1)
prps <- vapply(X = rows, FUN = `[`, FUN.VALUE = " ", 2)
cell <-
paste0(
paste0(
'<tr style="background-color:transparent">',
'<td style="padding:0 5px 0 7px;margin:0;border:0" align="right">'
),
cnts,
paste0(
'</td><td style="padding:0 2px 0 0;border:0;" align="left">(</td>',
'<td style="padding:0;border:0" align="right">'
),
prps,
'</td><td style="padding:0 4px 0 2px;border:0" align="left">)</td></tr>',
collapse = ""
)
}
return(
HTML(
paste0(
'<td align="left" style="padding:0;vertical-align:middle">',
'<table style="border-collapse:collapse;border:none;margin:0">',
cell, '</table></td>'
)
)
)
}
# Remove Var number ("No") column if specified in call to print/view
if (trs("no") %in% names(x) &&
"varnumbers" %in% names(format_info) &&
!isTRUE(format_info$varnumbers)) {
x <- x[ ,-which(names(x) == trs("no"))]
}
# Remove Label column if specified in call to print/view
if (trs("label") %in% names(x) &&
"labels.col" %in% names(format_info) &&
!isTRUE(format_info$labels.col)) {
x <- x[ ,-which(names(x) == trs("label"))]
}
# Remove Valid column if specified in call to print/view
if (trs("valid") %in% names(x) &&
"valid.col" %in% names(format_info) &&
!isTRUE(format_info$valid.col)) {
x <- x[ ,-which(names(x) == trs("valid"))]
}
# Remove Missing column if specified in call to print/view
if (trs("missing") %in% names(x) &&
"na.col" %in% names(format_info) &&
!isTRUE(format_info$na.col)) {
x <- x[ ,-which(names(x) == trs("missing"))]
}
# Remove grouping variable rows when appropriate
if ("keep.grp.vars" %in% names(format_info) &&
!isTRUE(format_info$keep.grp.vars) &&
"by_var" %in% names(data_info)) {
x <- x[-grep(paste0("\\b", data_info$by_var, "\\b", collapse = "|"),
x[[trs("variable")]]),]
row.names(x) <- NULL
}
# print_dfSummary - pander method --------------------------------------------
if (method == "pander") {
# remove html graphs
if (trs("graph") %in% names(x)) {
x <- x[ ,-which(names(x) == trs("graph"))]
}
# Remove graph if specified in call to print/view
if ("text.graph" %in% names(x) && "graph.col" %in% names(format_info) &&
!isTRUE(format_info$graph.col)) {
x <- x[ ,-which(names(x) == "text.graph")]
} else {
colnames(x)[which(names(x) == "text.graph")] <- trs("graph")
}
# Check that style is not "simple" or "rmarkdown"
if (isTRUE(pander_args$style %in% c("simple", "rmarkdown"))) {
pander_args$style <- "multiline"
}
if (!isTRUE(pander_args$plain.ascii)) {
# Escape symbols for words between <>'s to allow <NA> or factor
# levels such as <ABC> to be rendered correctly
if (trs("label") %in% names(x)) {
x[[trs("label")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("label")]], perl = TRUE)
}
x[[trs("stats.values")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("stats.values")]], perl = TRUE)
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "\\<(\\w*)\\>", replacement = "\\\\<\\1\\\\>",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
# Remove leading characters used for alignment in plain.ascii
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "^\\\\ *", replacement = "",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
x[[trs("freqs.pct.valid")]] <-
gsub(pattern = "\\n\\\\ *", replacement = "\n",
x = x[[trs("freqs.pct.valid")]], perl = TRUE)
}
# set column names encoding to native to allow proper display of non-ascii
if (parent.frame()$file == "") {
colnames(x) <- enc2native(colnames(x))
}
main_sect <- build_heading_pander()
main_sect %+=%
paste(
capture.output(
do.call(pander, append(pander_args, list(x = quote(x))))
),
collapse = "\n")
if (isTRUE(parent.frame()$escape.pipe) && format_info$style == "grid") {
main_sect[[length(main_sect)]] <-
gsub("\\|","\\\\|", main_sect[[length(main_sect)]])
}
return(main_sect)
} else {
# print_dfs - html method --------------------------------------------------
# remove text graph
if ("text.graph" %in% names(x)) {
x <- x[ ,-which(names(x) == "text.graph")]
}
# Remove graph if specified in call to print/view
# or if use.x11 set to FALSE
if (trs("graph") %in% names(x) &&
("graph.col" %in% names(format_info) &&
!isTRUE(format_info$graph.col)) ||
isFALSE(st_options("use.x11"))) {
x <- x[ ,-which(names(x) == trs("graph"))]
}
table_head <- list()
for (cn in colnames(x)) {
table_head %+=% list(tags$th(tags$strong(HTML(conv_non_ascii(cn))),
align = "center",
class = "st-protect-top-border"))
}
colgroup <- NA
if ("col.widths" %in% names(format_info)) {
if (length(format_info$col.widths) != ncol(x)) {
stop("Number of elements in 'col.widths', (",
(length(format_info$col.widths)), ") is not equal to number of ",
"columns to display (", ncol(x), ")")
}
colgroup <- tags$colgroup()
if (is.numeric(format_info$col.widths)) {
for (i in format_info$col.widths) {
colgroup <- tagAppendChild(
colgroup, tags$col(style = paste0("width:", i, "px"))
)
}
} else {
for (i in format_info$col.widths) {
colgroup <- tagAppendChild(
colgroup, tags$col(style = paste("width", i, sep = ":"))
)
}
}
}
table_rows <- list()
for (ro in seq_len(nrow(x))) {
table_row <- list()
for (co in seq_len(ncol(x))) {
cell <- x[ro,co]
cell <- gsub("\\\\\n", "\n", cell)
if (colnames(x)[co] %in% c(trs("no"), trs("valid"), trs("missing"))) {
table_row %+=% list(tags$td(HTML(conv_non_ascii(cell)),
align = "center"))
} else if (colnames(x)[co] == trs("label")) {
cell <- gsub("(\\d+)\\\\\\.", "\\1.", cell)
cell <- paste(strwrap(cell, width = format_info$split.cells,
simplify = TRUE), collapse = "\n")
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left")
)
} else if (colnames(x)[co] == trs("variable")){
cell <- gsub("[ \t]{2,}", " ", cell)
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left")
)
} else if (colnames(x)[co] == trs("stats.values")) {
cell <- gsub("(\\d+)\\\\\\.", "\\1.", cell)
table_row %+=% list(make_vals_cell(conv_non_ascii(cell)))
} else if (colnames(x)[co] == trs("freqs.pct.valid")) {
if (grepl(paste0("(",trs("distinct.value"), "|",
trs("distinct.values"), ")"), cell) || cell == "") {
table_row %+=% list(
tags$td(HTML(conv_non_ascii(cell)), align = "left",
style = "vertical-align:middle")
)
} else {
table_row %+=% list(make_freq_cell(conv_non_ascii(cell)))
}
} else if (colnames(x)[co] == trs("graph")) {
table_row %+=% list(
tags$td(HTML(cell), align = "left",
style = paste0("vertical-align:middle;padding:0;",
"background-color:transparent;"))
)
}
}
table_rows %+=% list(tags$tr(table_row))
}
if (is.infinite(format_info$max.tbl.height)) {
dfs_table_html <-
tags$table(
if (!identical(colgroup, NA))
colgroup,
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-multiline",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
)
} else {
dfs_table_html <-
tags$div(
tags$table(
if (!identical(colgroup, NA))
colgroup,
tags$thead(tags$tr(table_head)),
tags$tbody(table_rows),
class = paste(
"table table-striped table-bordered",
"st-table st-table-striped st-table-bordered st-multiline",
ifelse(is.na(parent.frame()$table.classes),
"", parent.frame()$table.classes)
)
), style = paste0("max-height:", format_info$max.tbl.height,
"px;overflow-y:scroll;margin:10px 2px")
)
}
# cleanup source html for redundant space
dfs_table_html <-
gsub(pattern = "(<th.*?>)\\s+(<strong>.*?</strong>)\\s+(</th>)",
replacement = "\\1\\2\\3",
x = dfs_table_html)
# Change visual aspect of "white space" symbol
dfs_table_html <-
gsub(pattern = "((·)+)",
replacement = " <div class='st-ws-char'>\\1</div>",
x = dfs_table_html,
perl = TRUE)
# Prepare the main "div" for the html report
div_list <- build_heading_html(format_info, data_info, method)
if (length(div_list) > 0 &&
!("shiny.tag" %in% class(div_list[[length(div_list)]]))) {
div_list %+=% list(HTML(text = "<br/>"))
}
div_list %+=% list(HTML(text = dfs_table_html))
if (parent.frame()$footnote != "") {
footn <- conv_non_ascii(parent.frame()[["footnote"]])
div_list %+=% list(HTML(text = paste0("<p>", footn, "</p>")))
}
}
return(div_list)
}
# Build headings (pander) ------------------------------------------------------
#' @keywords internal
build_heading_pander <- function() {
format_info <- parent.frame()$format_info
data_info <- parent.frame()$data_info
caller <- as.character(sys.call(-1))[1]
head1 <- NA # Main title (e.g. "Data Frame Summary")
head2 <- NA # The data frame, the variable, or the 2 variables for ctable
head3 <- NA # Additional elements (includes Variable exceptionnaly when
# headings = FALSE and by() or lapply() were used
add_markup <- function(str, h = 0) {
if (!isTRUE(format_info$plain.ascii)) {
if (h == 0) {
re <- paste0("^(\\s*\\n)(.+)\\s", trs("by"), "\\s(.+)$")
if (grepl(re, str, perl = TRUE)) {
str <- sub(re, paste0("\\1**", "\\2** ", trs("by"), " **\\3**"),
str, perl = TRUE)
} else {
str <- sub(pattern = "^(\\s*)(.+?)((:)\\s(.+))?\\s*$",
replacement = "\\1**\\2\\4** \\5",
x = str, perl = TRUE)
}
} else {
str <- paste(paste0(rep(x = "#", times = h), collapse = ""), str)
}
}
return(str)
}
append_items <- function(items, h = 0) {
appended <- c()
for (item in items) {
if (names(item) %in% names(data_info)) {
if ((grepl(pattern = "label", names(item)) &&
isTRUE(format_info$display.labels)) ||
(names(item) == "Data.type" &&
isTRUE(format_info$display.type)) ||
!grepl("(label|Data\\.type)", names(item))) {
# Apply formatting to numeric values
value <- data_info[[names(item)]]
tmpargs <- c("big.mark", "small.mark", "decimal.mark",
"small.interval", "big.interval")
if (isTRUE(is.numeric(value)) &&
any(names(format_info) %in% tmpargs)) {
value <- do.call(
format,
append(format_info[which(names(format_info) %in% tmpargs)],
x = quote(value))
)
if (names(item) == "Dimensions") {
value <- paste(trimws(value[1]), trimws(value[2]), sep = " x ")
}
}
# Create pairing (example: "N: 500") when both name and value exist
# and add markup characters
if (item != "") {
appended <- append(
appended,
paste0(add_markup(paste(item, value, sep = ": "), h),
" \n")
)
} else {
appended <- append(appended, paste0(add_markup(value, h), " \n"))
}
}
}
}
return(paste(appended, collapse = ""))
}
# Special cases where no primary heading (title) is needed
if (isTRUE(format_info$var.only)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options('subtitle.emphasis')), 4, 0)
)
head2 <- paste0("\n", enc2native(head2))
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(N.obs = trs("n"))))
}
if (!is.na(head3)) {
head3 <- enc2native(head3)
}
tmp <- list(head2, head3)
return(tmp[which(!is.na(tmp))])
} else if (isTRUE(format_info$group.only)) {
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Group = trs("group")),
c(N.Obs = trs("n")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
} else {
head3 <- append_items(list(c(Group = trs("group"))))
}
head3[[1]] <- paste0("\n", enc2native(head3[[1]]))
return(list(head3))
} else if (!isTRUE(format_info$headings)) {
if ("var.only" %in% names(format_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options('subtitle.emphasis')), 4, 0))
return(list(enc2native(head2)))
} else if ("Group" %in% names(data_info)) {
head3 <- append_items(list(c(Group = trs("group"))))
return(list(enc2native(head3)))
} else {
return(list())
}
}
# (End special cases)
# Regular cases - Build the 3 heading elementss
if (caller == "print_freq") {
if ("Weights" %in% names(data_info)) {
if (trs("title.freq.weighted") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.freq.weighted"), h = 3), " \n")
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.freq"), h = 3), " \n")
}
}
if ("Variable" %in% names(data_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(Weights = trs("weights")),
c(Group = trs("group"))))
}
} else if (caller == "print_ctable") {
head1 <- paste(
add_markup(
switch(data_info$Proportions,
Row = paste(trs("title.ctable"), trs("title.ctable.row"),
sep = ", "),
Column = paste(trs("title.ctable"), trs("title.ctable.col"),
sep = ", "),
Total = paste(trs("title.ctable"), trs("title.ctable.tot"),
sep = ", "),
None = trs("title.ctable")),
h = 3),
" \n")
if (grepl("^#*\\s*,", head1))
head1 <- NA
head2 <- append_items(
list(c(Row.x.Col = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Data.frame.label = trs("label")),
c(Group = trs("group"))))
} else if (caller == "print_descr") {
if ("Weights" %in% names(data_info)) {
if (trs("title.descr.weighted") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.descr.weighted"), h = 3), " \n")
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- paste(add_markup(trs("title.descr"), h = 3), " \n")
}
}
if ("by_var_special" %in% names(data_info)) {
head2 <- paste(
add_markup(
paste(data_info$Variable, trs("by"), data_info$by_var_special),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)),
" \n")
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Variable" %in% names(data_info)) {
head2 <- append_items(
list(c(Variable = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Data.frame" %in% names(data_info)) {
head2 <- append_items(
list(c(Data.frame = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
}
} else if (caller == "print_dfs") {
head1 <- paste(add_markup(trs("title.dfSummary"), h = 3), " \n")
if ("Data.frame" %in% names(data_info)) {
head2 <- append_items(
list(c(Data.frame = "")),
h = ifelse(isTRUE(st_options("subtitle.emphasis")), 4, 0)
)
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Group = trs("group")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
}
if (!is.na(head1) &&
length(setdiff(unique(strsplit(head1, "")[[1]]), c(" ", "\r", "\n")))) {
head1 <- enc2native(head1)
} else {
head1 <- NA
}
if (!is.na(head2) &&
length(setdiff(unique(strsplit(head2, "")[[1]]), c(" ", "\r", "\n")))) {
head2 <- enc2native(head2)
} else {
head2 <- NA
}
if (!is.na(head3) &&
length(setdiff(unique(strsplit(head3, "")[[1]]), c(" ", "\r", "\n")))) {
head3 <- enc2native(head3)
} else {
head3 <- NA
}
tmp <- list(head1, head2, head3)
return(tmp[which(!is.na(tmp))])
}
# Build headings (html) --------------------------------------------------------
#' @keywords internal
#' @import htmltools
build_heading_html <- function(format_info, data_info, method, div_id = NA) {
caller <- as.character(sys.call(-1))[1]
head1 <- NA # uses h3()
head2 <- NA # uses h4() or <strong> (see option subtitle.emphasis)
head3 <- NA # uses <strong>...</strong>
append_items <- function(items) {
appended <- character()
for (item in items) {
if (names(item) %in% names(data_info)) {
if ((grepl(pattern = "label", names(item)) &&
isTRUE(format_info$display.labels)) ||
(names(item) == "Data.type" &&
isTRUE(format_info$display.type)) ||
!grepl("(label|Data\\.type)", names(item))) {
value <- data_info[[names(item)]]
tmpargs <- c("big.mark", "small.mark", "decimal.mark",
"small.interval", "big.interval")
if (isTRUE(is.numeric(value)) && any(names(format_info) %in% tmpargs)) {
value <-
do.call(format, append(format_info[which(names(format_info) %in% tmpargs)],
x = quote(value)))
if (names(item) == "Dimensions") {
value <- paste(trimws(value[1]), trimws(value[2]), sep = " x ")
}
}
div_str_item <-
paste(paste0("<strong>", HTML(conv_non_ascii(item)), "</strong>"),
ifelse(is.character(value), conv_non_ascii(value), value),
sep = ": ")
if (identical(appended, character())) {
appended <- div_str_item
} else {
appended <- paste(appended,
div_str_item,
sep = "\n <br/>")
}
}
}
}
if (identical(appended, character())) {
return(NA)
}
return(HTML(appended))
}
# Special cases where no primary heading (title) is needed
if (isTRUE(format_info$var.only)) {
if (!isTRUE(format_info$headings)) {
return(list())
} else {
if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
if (!is.na(div_id)) {
head2 <-
h4(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
}
} else {
if (!is.na(div_id)) {
head2 <-
strong(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
}
}
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type"))))
tmp <- list(head2, head3)
return(tmp[which(!is.na(tmp))])
}
} else if (isTRUE(format_info$group.only)) {
if (isTRUE(format_info$headings)) {
head3 <- append_items(list(c(Group = trs("group")),
c(N.Obs = trs("n")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
} else {
head3 <- append_items(list(c(Group = trs("group"))))
}
return(list(head3))
} else if (!isTRUE(format_info$headings)) {
if ("Group" %in% names(data_info)) {
head3 <- append_items(list(c(Group = trs("group"))))
return(list(head3))
} else {
return(list())
}
}
# Regular cases - Build the 3 heading elements
if (caller == "print_freq") {
if ("Weights" %in% names(data_info)) {
if (trs("title.freq.weighted") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.freq.weighted"))))
}
} else {
if (trs("title.freq") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.freq"))))
}
}
if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
if (!is.na(div_id)) {
head2 <-
h4(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
}
} else {
if (!is.na(div_id)) {
head2 <-
strong(HTML(paste0(
'<p data-toggle="collapse" aria-expanded="true" ',
'aria-controls="', div_id, '" href="#', div_id, '">',
conv_non_ascii(data_info$Variable),
"</p>")))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
}
}
if ("var.only" %in% names(format_info)) {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type"))))
} else {
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Data.type = trs("type")),
c(Weights = trs("weights")),
c(Group = trs("group"))))
}
} else if (caller == "print_ctable") {
head1 <- switch(data_info$Proportions,
Row = paste(trs("title.ctable"), trs("title.ctable.row"),
sep = ", "),
Column = paste(trs("title.ctable"), trs("title.ctable.col"),
sep = ", "),
Total = paste(trs("title.ctable"), trs("title.ctable.tot"),
sep = ", "),
None = trs("title.ctable"))
# Check that head1 is not empty (if define_keywords was used)
head1 <- sub("^, ", "", head1)
if (head1 == ", ") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(head1)))
}
if ("Row.x.Col" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Row.x.Col)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Row.x.Col)), br())
}
}
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Data.frame.label = trs("label")),
c(Group = trs("group"))))
} else if (caller == "print_descr") {
if ("Weights" %in% names(data_info)) {
if (trs("title.descr.weighted") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.descr.weighted"))))
}
} else {
if (trs("title.descr") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.descr"))))
}
}
if ("by_var_special" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- HTML(paste("<h4>", conv_non_ascii(data_info$Variable),
conv_non_ascii(trs("by")),
conv_non_ascii(data_info$by_var_special),
"</h4>"))
} else {
head2 <- HTML(paste("<strong>", conv_non_ascii(data_info$Variable),
"</strong>", conv_non_ascii(trs("by")), "<strong>",
conv_non_ascii(data_info$by_var_special),
"</strong><br/>"))
}
head3 <- append_items(list(c(Data.frame = trs("data.frame")),
c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else if ("Variable" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Variable)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Variable)), br())
}
head3 <- append_items(list(c(Variable.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
} else {
if ("Data.frame" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Data.frame)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Data.frame)), br())
}
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Weights = trs("weights")),
c(Group = trs("group")),
c(N.Obs = trs("n"))))
}
} else if (caller == "print_dfs") {
if (trs("title.dfSummary") == "") {
head1 <- NA
} else {
head1 <- h3(HTML(conv_non_ascii(trs("title.dfSummary"))))
}
if ("Data.frame" %in% names(data_info)) {
if (isTRUE(st_options("subtitle.emphasis"))) {
head2 <- h4(HTML(conv_non_ascii(data_info$Data.frame)))
} else {
head2 <- strong(HTML(conv_non_ascii(data_info$Data.frame)), br())
}
}
head3 <- append_items(list(c(Data.frame.label = trs("label")),
c(Group = trs("group")),
c(Dimensions = trs("dimensions")),
c(Duplicates = trs("duplicates"))))
}
tmp <- list(head1, head2, head3)
return(tmp[which(!is.na(tmp))])
}
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.