R/print.summarytools.R

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()[[sys.nframe() - 1]][2]), "x[[i]]()") ||
       any(grepl(pattern = "fn_call = FUN(x = X[[i]]",
                 x = deparse(sys.calls()[[sys.nframe() - 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 <- 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 = "&thinsp;<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 <- 0
      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(
        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 <- 0
      format_args_tmp$nsmall <- 0
    } else {
      format_args_tmp <- format_args
      format_args_tmp$digits <- max(
        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("<", "&lt;", cn, fixed = TRUE)
      cn <- sub(">", "&gt;", 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("<", "&lt;", rn, fixed = TRUE)
          rn <- sub(">", "&gt;", 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>&nbsp;&#935;<sup>2</sup></strong> = ",
          sub("\\.", format_args$decimal.mark, sprintf("%.4f", chisq[[1]])),
          "&nbsp;&nbsp;&nbsp;<strong>df</strong> = ", chisq[[2]],
          "&nbsp;&nbsp;&nbsp;<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>&nbsp;&nbsp;(",
          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>&nbsp;&nbsp;(",
          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("<", "&le;", rows[2])
      rows[3] <- gsub("<", "&le;", rows[3]) # alternative to &le; is &#8828;
    }

    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("!", "!&thinsp;", 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("!", "&thinsp;!", vals)
        vals <- sub("(\\d)$", "\\1&thinsp;&thinsp;", 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 = "((&#0183;)+)",
           replacement = "&thinsp;<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))])
}

Try the summarytools package in your browser

Any scripts or data that you put into this service are public.

summarytools documentation built on May 20, 2022, 9:06 a.m.