R/html.tabular.R

In tables: Formula-Driven Table Generation

htmlNumeric <- function(chars,
                        minus = TRUE,
                        leftpad = TRUE,
                        rightpad = TRUE) {
  regexp <- "^( *)([-]?)([^ -][^ ]*)( *)$"
  leadin <- sub(regexp, "\\1", chars)
  sign <- sub(regexp, "\\2", chars)
  rest <- sub(regexp, "\\3", chars)
  tail <- sub(regexp, "\\4", chars)
  
  figurespace <- "&#x2007;"
  minussign <- "&minus;"
  
  if (minus && any(neg <- sign == "-")) {
    if (any(leadin[!neg] == ""))
      leadin <- sub("^", " ", leadin)
    leadin[!neg] <- sub(" ", "", leadin[!neg])
    sign[!neg] <- figurespace
    sign[neg] <- minussign
  }
  if (leftpad && any(ind <- leadin != ""))
    leadin[ind] <- gsub(" ", figurespace, leadin[ind])
  
  if (rightpad && any(ind <- tail != ""))
    tail[ind] <- gsub(" ", figurespace, tail[ind])
  
  paste(leadin, sign, rest, tail, sep = "")
}

CSSclassname <- function(just)
  ifelse(just == "l", "left", ifelse(just == "c", "center", ifelse(just == "r", "right", just)))

toHTML <- function(object,
                   file = "",
                   options = NULL,
                   id = NULL,
                   append = FALSE,
                   browsable = TRUE,
                   ...) {
  if (!is.null(options)) {
    saveopts <- do.call(table_options, options)
    on.exit(table_options(saveopts), add = TRUE)
  }
  opts <- table_options()
  
  output <- character()
  
  mycat <- function(...)
    output <<- c(output, unlist(list(...)))
  
  escape <- opts$escape
  
  do_escape <- function(x) {
    if (escape) 
      x <- htmlify(x)
    x
  }
  
  defjust <- opts$justification
  blankhead <- "  <th>&nbsp;</th>\n"
  
  classes <- chars <- format(
    object,
    html = TRUE,
    minus = opts$HTMLminus,
    leftpad = opts$HTMLleftpad,
    rightpad = opts$HTMLrightpad,
    escape = escape,
    ...
  ) # format without justification
  classes[] <- ""
  
  vjust <- attr(object, "justification")
  vjust[is.na(vjust)] <- defjust
  ind <- vjust != defjust
  classes[ind] <- sprintf(' class="%s"', CSSclassname(vjust[ind]))
  chars[chars == ""] <- "&nbsp;"
  chars[] <- sprintf("  <td%s>%s</td>\n", classes, chars)
  
  rowClasses <- rowLabels <- do_escape(attr(object, "rowLabels"))
  rowClasses[] <- ""
  nleading <- ncol(rowLabels)
  rowLabels[is.na(rowLabels)] <- "&nbsp;"
  rjust <- attr(rowLabels, "justification")
  rjust[is.na(rjust)] <- opts$rowlabeljustification
  ind <- rjust != defjust
  rowClasses[ind] <- sprintf(' class="%s"', CSSclassname(rjust[ind]))
  rowLabels[] <- sprintf("  <th%s>%s</th>\n", rowClasses, rowLabels)
  
  colnamejust <- attr(rowLabels, "colnamejust")
  colnamejust <- rep(colnamejust, length.out = nleading)
  colnameClasses <- colnames(rowLabels)
  colnameClasses[] <- ""
  ind <- is.na(colnamejust)
  colnamejust[ind] <- defjust
  ind <- colnamejust != defjust
  colnameClasses[ind] <- sprintf(' class="%s"', CSSclassname(colnamejust[ind]))
  colnames(rowLabels) <- sprintf("  <th%s>%s</th>\n", colnameClasses, do_escape(colnames(rowLabels)))
  
  clabels <- do_escape(attr(object, "colLabels"))
  cjust <- attr(clabels, "justification")
  ind <- is.na(cjust)
  cjust[ind] <- defjust
  
  multi <- matrix(0, nrow(clabels), ncol(clabels))
  prevmulti <- rep(0, nrow(multi))
  for (i in rev(seq_len(ncol(multi)))) {
    ind <- is.na(clabels[, i])
    multi[!ind, i] <- 1 + prevmulti[!ind]
    prevmulti[ind] <- 1 + prevmulti[ind]
    prevmulti[!ind] <- 0
  }
  colspan <- ifelse(multi < 2, "", sprintf(' colspan="%d"', multi))
  class <-   ifelse(cjust == defjust |
                      multi == 0,
                    "",
                    sprintf(' class="%s"', CSSclassname(cjust)))
  clabels[clabels == ""] <- "&nbsp;"
  clabels <- ifelse(multi == 0,
                    "",
                    sprintf('  <th%s%s>%s</th>\n', colspan, class, clabels))
  
  rowLabelHeadings <- matrix(blankhead, nrow(clabels), ncol(rowLabels))
  rowLabelHeadings[nrow(clabels), ] <- colnames(rowLabels)
  
  if (opts$doHTMLheader) {
    head <- sub("CHARSET", localeToCharset(), opts$HTMLhead, fixed = TRUE)
    mycat(head)
  }
  
  if (opts$doCSS) {
    if (is.null(id))
      css <- gsub("#ID ", "", opts$CSS, fixed = TRUE)
    else
      css <- gsub("#ID", paste0("#", id), opts$CSS, fixed = TRUE)
    mycat(css)
  }
  
  if (opts$doHTMLbody)
    mycat(opts$HTMLbody)
  
  if (opts$doBegin) {
    if (is.null(id))
      id <- ""
    else
      id <- sprintf(' id="%s"', id)
    mycat(sprintf('<table%s %s>\n', id, opts$HTMLattributes))
  }
  if (!is.null(opts$HTMLcaption))
    mycat(sprintf('<caption>%s</caption>\n', opts$HTMLcaption))
  
  if (opts$doHeader) {
    rows <- apply(cbind(rowLabelHeadings, clabels), 1, paste0, collapse = "")
    mycat('<thead>\n')
    mycat(sprintf('<tr class="%s">\n%s</tr>\n', CSSclassname(defjust), rows))
    mycat('</thead>\n')
  }
  if (opts$doFooter && !is.null(opts$HTMLfooter)) {
    mycat('<tfoot>\n')
    mycat(opts$HTMLfooter)
    mycat('</tfoot>\n')
  }
  if (opts$doBody) {
    rows <- apply(cbind(rowLabels, chars), 1, paste0, collapse = "")
    mycat('<tbody>\n')
    mycat(sprintf('<tr class="%s">\n%s</tr>\n', CSSclassname(defjust), rows))
    mycat('</tbody>\n')
  }
  if (opts$doEnd)
    mycat("</table>\n")
  
  result <- browsable(HTML(output), value = browsable)
  if (!identical(file, "")) {
    if (is.character(file)) {
      file <- file(file, open = if (append)
        "at"
        else
          "wt")
      on.exit(close(file))
    }
    writeLines(output, file)
    invisible(result)
  } else
    result
}

html.tabular <- function(object, ...) {
  toHTML(object, ...)
}

writeCSS <- function(CSS = htmloptions()$CSS, id = NULL) {
  if (is.null(id))
    css <- gsub("#ID ", "", CSS, fixed = TRUE)
  else
    css <- gsub("#ID", paste0("#", id), CSS, fixed = TRUE)
  cat(css)
}