R/latex.s

Defines functions htmlSN latexSN dvigv.latex dvips.latex dvigv.dvi dvips.dvi dvigv dvips dvi print.latex print.dvi show.latex show.dvi dvi.latex optionsCmds latex latexTranslate latex.list latexVerbatim latex.function latex.default format.df first.word

Documented in dvi dvigv dvigv.dvi dvigv.latex dvi.latex dvips dvips.dvi dvips.latex first.word format.df htmlSN latex latex.default latex.function latex.list latexSN latexTranslate latexVerbatim optionsCmds print.dvi print.latex show.dvi show.latex

first.word <- function(x, i=1, expr=substitute(x)) {
  words <- if(! missing(x)) as.character(x)[1]
           else
             as.character(unlist(expr))[1]
  
  if(i > 1) stop('i > 1 not implemented')
  
  chars <- substring(words, 1 : nchar(words), 1 : nchar(words))
  legal.chars <- c(letters, LETTERS, '.',
                   '0','1','2','3','4','5','6','7','8','9')
  non.legal.chars <- (1 : length(chars))[chars %nin% legal.chars]
  if(! any(non.legal.chars)) return(words)
  
  if(non.legal.chars[1] == 1) return(character(0))
  
  substring(words, 1, non.legal.chars[1] - 1)
}


##1. if x is a data.frame, then do each component separately.
##2. if x is a matrix, but not a data.frame, make it a data.frame
##   with individual components for the columns.
##3. if a component x$x is a matrix, then do all columns the same.
##4. Use right justify by default for numeric columns.
##5. Use left justify for non-numeric columns.

## The following are made complicated by matrix components of data.frames:
##6. vector cdec must have number of items equal to number of columns
##   of input x.
##7. matrix dec must have number of columns equal to number of columns
##   of input x.
##8. scalar dec is expanded to a vector cdec with number of items equal
##   to number of columns of input x.
##9. vector rdec must have number of items equal to number of rows of input x.
##   rdec is expanded to matrix dec.
##10. col.just must have number of columns equal to number of columns
##    of output cx.

## Value:
## character matrix with character images of properly rounded x.
## matrix components of input x are now just sets of columns of character matrix.
## attr(,col.just) repeats input col.just when provided.
##	Otherwise, recommended justification for columns of output.
##	Default is "l" for characters and factors, "r" for numeric.
##	When dcolumn==T, numerics will have ".".


## FEH 21May96 - changed default for numeric.dollar to cdot
## FEH  5Jun96 - re-written to not rely on as.data.frame,
##               converted data frames to matrices the slow way
##               added matrix.sep 
##     12Aug99 - allowed # decimal places=NA (no rounding, just use format())
##    27May02 - added booktabs FEH
## 13Dec02 - added ctable   FEH
## arguments included check.names=TRUE 23jan03
##
## 16Jan15 (A. Kiermeier) pass "..." to formt() and format()

format.df <- function(x,
                      digits, dec=NULL, rdec=NULL, cdec=NULL,
                      numeric.dollar=! dcolumn, na.blank=FALSE,
                      na.dot=FALSE, blank.dot=FALSE, col.just=NULL,
                      cdot=FALSE, dcolumn=FALSE, matrix.sep=' ',
                      scientific=c(-4,4),
                      math.row.names=FALSE,
                      already.math.row.names=FALSE,
                      math.col.names=FALSE,
                      already.math.col.names=FALSE,
                      double.slash=FALSE,
                      format.Date='%m/%d/%Y',
                      format.POSIXt="%m/%d/%Y %H:%M:%OS", ...)
{
  sl <- ifelse(double.slash, "\\\\", "\\")

  cleanLatex <- function(string) {
    if(! is.character(string))
      string <- as.character(string)
    
    ## Find strings not in math mode (surrounded by $)
    s <- gsub("(^[[:space:]]+)|([[:space:]]+$)", "", string)
    k <- ! (substring(s, 1, 1) == '$' & substring(s, nchar(s)) == '$')
    k <- k & ! is.na(k)
    
    if(! any(k)) return(string)

    inn <- c('< =', '> =', '<=', '>=', '<', '>',
             '\\\\%', '%', 
             '\\\\&', '&')
    out <- c('<=',
             '>=',
             paste('$', sl, sl, 'leq$', sep=''),
             paste('$', sl, sl, 'geq$', sep=''),
             paste(sl, sl, 'textless ', sep=''),
             paste(sl, sl, 'textgreater ', sep=''),
             '%', paste(sl, sl, '%', sep=''),
             '&', paste(sl, sl, '&', sep=''))
    for(i in 1 : length(inn))
      string[k] <- gsub(inn[i], out[i], string[k])
    string
  }

  if(numeric.dollar && dcolumn)
    stop('cannot have both numeric.dollar=TRUE and dcolumn=TRUE')
  
  if(missing(digits))
    digits <- NULL
  
  if((! length(digits))+(! length(dec))+(! length(rdec))+(! length(cdec)) < 3)
    stop('only one of digits, dec, rdec, cdec may be given')
  
  if(! length(digits) && ! length(dec) && ! length(rdec) && ! length(cdec)) {
    digits <- 15
  }

  if(length(digits)) {
	oldopt <- options('digits')
    options(digits=digits)
    on.exit(options(oldopt))
  }
  
  formt <- function(x, decimal.mark='.', nsmall=0,
                    scientific=c(-4,4), digits=NULL, na.blank=FALSE, ...) {
    y <- format(x, nsmall=nsmall, decimal.mark=decimal.mark,
                digits=digits, ...)
    if(decimal.mark != '.') y <- gsub('\\.', decimal.mark, y)
    if(na.blank) y <- ifelse(is.na(x), '', y)
    y
  }
  
  dot <- if(cdot && numeric.dollar)
    paste(sl,sl,'cdotp',sl,sl,'!',sep='')
  else '.'
  
  decimal.point <- if(cdot && dcolumn)
    paste(sl,'cdot',sep='')
  else dot

  if(is.data.frame(x)) x <- unclass(x)
  
  xtype <- if(is.list(x)) 1 else if(length(dim(x))) 2 else 3
  
  ncx  <- if(xtype == 1) length(x) else if(xtype == 2) ncol(x) else 1
  
  nams <- if(xtype == 1) names(x)  else if(xtype == 2) dimnames(x)[[2]] else ''

  if(! missing(col.just) && (length(col.just) < ncx))
    stop('col.just needs the same number of elements as number of columns')
  
  if(! length(nams)) nams <- rep('', ncx)
  
  nrx <-
    if(xtype == 1) {
      if(length(d <- dim(x[[1]]))) d[1] else length(x[[1]])
    } else if(xtype == 2) nrow(x)
    else
      length(x)
  
  rnams <- if(xtype == 1) attr(x,'row.names') else if(xtype == 2)
      dimnames(x)[[1]] else names(x)
  
  if(length(dec) + length(rdec) + length(cdec)  ==  0) rtype <- 1
  
  if(length(rdec)) {
    rtype <- 2
    dec <- matrix(rdec, nrow=nrx, ncol=ncx)
  }
  
  if(length(dec)) {
    rtype <- 3
    if(length(dec) == 1) cdec <- rep(dec, ncx)
  }
  
  if(length(cdec)) rtype <- 4
  
  cx    <- NULL
  nam   <- NULL
  cjust <- NULL
  
  if(blank.dot) sas.char <- function(x) {
    n.x <- nchar(x)
    blanks.x <-
      sapply(n.x, function(n.x.i) paste(rep(" ", n.x.i), collapse=""))
    ifelse(x == blanks.x, ".", x)
  }

  nams <- if(math.col.names) paste('$', nams, '$', sep='')
   else if(already.math.col.names) nams else cleanLatex(nams)

  rnams <- if(math.row.names) paste('$', rnams, '$', sep='')
   else if(already.math.row.names) rnams else cleanLatex(rnams)

  for(j in 1 : ncx) {
    xj <- if(xtype == 1) x[[j]] else if(xtype == 2) x[,j] else x
    
    num <- is.numeric(xj) || all(is.na(xj))
    if(testDateTime(xj)) num <- FALSE
    
    ## using xtype avoids things like as.matrix changing special characters 
    ncxj <- max(1, dim(xj)[2], na.rm=TRUE)

    for(k in 1 : ncxj) {
      xk <-
        if(ld <- length(dim(xj)) == 2) xj[, k] else xj
      
      names(xk) <- NULL
      ## gets around bug in format.default when 
      ## nsmall is given and there are NAs
      
      namk <-
        if(ld) {
          dn <- dimnames(xj)[[2]][k]
          if(length(dn) == 0)
            dn <- as.character(k)
          
          if(math.row.names) {
            paste('$', dn, '$', sep='')
          } else if(already.math.row.names) dn else cleanLatex(dn)
        } else ''
      
      namk <- paste(nams[j],
                    if(nams[j] != '' && namk != '')
                      matrix.sep
                    else '',
                    namk, sep='')
      
      if(num) {
        cj <-
          if(length(col.just))
            col.just[j]
          else 'r'

        if(rtype == 1)
          cxk <- formt(xk, decimal.mark=dot, scientific=scientific,
                       digits=digits, na.blank=na.blank, ...)
        else if(rtype == 3) {
          cxk <- character(nrx)
          for(i in 1 : nrx)
            cxk[i] <-
              if(is.na(dec[i,j]))
                formt(xk[i], decimal.mark=dot, scientific=scientific,
                      digits=digits, na.blank=na.blank, ...)
              else
                formt(round(xk[i], dec[i,j]), decimal.mark=dot,
                      digits=digits, nsmall=dec[i,j], scientific=scientific,
                      na.blank=na.blank, ...)
        } else if(rtype == 4)
          cxk <-
            if(is.na(cdec[j]))
              formt(xk, decimal.mark=dot, scientific=scientific, digits=digits,
                    na.blank=na.blank, ...)
            else
              formt(round(xk, cdec[j]), decimal.mark=dot, nsmall=cdec[j],
                    digits=digits, scientific=scientific,
                    na.blank=na.blank, ...)
        
        if(na.dot) cxk[is.na(xk)] <- '.'  # SAS-specific
        
        if(blank.dot) cxk <- sas.char(cxk)
        
        if(numeric.dollar) cxk <- paste("$",cxk,"$",sep="")
        
        ## These columns get real minus signs in LaTeX, not hyphens,
        ## but lose alignment unless their col.just="r"
        if(dcolumn | (length(col.just) && col.just[j] == 'c')) {
          cxk <- sedit(cxk, " ", "~")
          if(dcolumn)
            cj <- paste("D{.}{",decimal.point,"}{-1}",sep='')
        } 
      } else {   #ended if(num)
        cj <-
          if(length(col.just))
            col.just[j]
          else 'l'
        
        if(inherits(xk, "Date")) {
          cxk <- cleanLatex(format(xk, format=format.Date))
        } else if(inherits(xk, "POSIXt")) {
          cxk <- cleanLatex(format(xk, format=format.POSIXt))
        } else {
          cxk <- cleanLatex(xk)
        }
        if(na.blank) cxk <- ifelse(is.na(xk), '', cxk)
      }
      
      cx    <- cbind(cx, cxk)
      nam   <- c(nam, namk)
      cjust <- c(cjust, cj)
    }    # end k
  } #end j

  dimnames(cx)        <- list(rnams, nam)
  attr(cx,"col.just") <- cjust
  cx
}


##first.hline.double added FEH 11Jun95
##Usage:
##	latex(x) # for x any S object

##Value is a file object of class=c("latex","file") which is
##automatically printed by print.latex(), which constructs a file objecT
##of class=c("dvi","file"), and automatically prints it using
##print.dvi().  print.latex() returns an invisible file object.


## dcolumn numeric.dollar cdot
##
## dc cd nd  format.df latex.default  # comment
## F  F  T	   $		     # LaTeX usage
## F  T  T   \cdot! $		     # LaTeX usage
## T  F  F   . ~	      .	    dcolumn  # LaTeX usage
## T  T  F   . ~	      \cdot dcolumn  # LaTeX usage
##        
## F  F  F    			     # non-TeX (hyphens in TeX)
##        
## F  T  F   \cdot!		     # TeX errors, hyphens
## T  F  T   . ~	   $  .	    dcolumn  # TeX errors
## T  T  T   . ~	   $  \cdot dcolumn  # TeX errors
latex.default <-
  function(object,
           title=first.word(deparse(substitute(object))),
           file=paste(title, ".tex", sep=""),
           append=FALSE, label=title,
           rowlabel=title, rowlabel.just="l",
           cgroup=NULL, n.cgroup=NULL,
           rgroup=NULL, n.rgroup=NULL,
           cgroupTexCmd="bfseries",
           rgroupTexCmd="bfseries",
           rownamesTexCmd=NULL, 
           colnamesTexCmd=NULL,
           cellTexCmds=NULL,
           rowname, cgroup.just=rep("c", length(n.cgroup)),
           colheads=NULL,
           extracolheads=NULL, extracolsize='scriptsize',
           dcolumn=FALSE, numeric.dollar=! dcolumn, cdot=FALSE,
           longtable=FALSE, draft.longtable=TRUE, ctable=FALSE, booktabs=FALSE,
           table.env=TRUE, here=FALSE, lines.page=40,
           caption=NULL, caption.lot=NULL, caption.loc=c('top','bottom'),
           star=FALSE,
           double.slash=FALSE,
           vbar=FALSE, collabel.just=rep("c",nc), na.blank=TRUE,
           insert.bottom=NULL, insert.bottom.width=NULL,
           insert.top=NULL,
           first.hline.double=! (booktabs | ctable),
           where='!tbp', size=NULL,
           center=c('center','centering','centerline','none'),
           landscape=FALSE,
           multicol=TRUE, ## to remove multicolumn if no need
           math.row.names=FALSE,
           already.math.row.names=FALSE,
           math.col.names=FALSE,
           already.math.col.names=FALSE,
           hyperref=NULL, continued='continued',
           ...)
{
  if(length(hyperref)) hyperref <- sprintf('\\hyperref[%s]{', hyperref)
  center <- match.arg(center)
  caption.loc <- match.arg(caption.loc)
  cx <- format.df(object, dcolumn=dcolumn, na.blank=na.blank,
                  numeric.dollar=numeric.dollar, cdot=cdot,
                  math.row.names=math.row.names,
                  already.math.row.names=already.math.row.names,
                  math.col.names=math.col.names,
                  already.math.col.names=already.math.col.names,
                  double.slash=double.slash, ...)

  if(missing(rowname)) rowname <- dimnames(cx)[[1]]

  nocolheads <- length(colheads) == 1 && is.logical(colheads) && ! colheads
  
  if (! length(colheads)) colheads <- dimnames(cx)[[2]]

  col.just <- attr(cx, "col.just")
  nc       <- ncol(cx)
  nr       <- nrow(cx)

  if (length(cgroup)) {
    k <- length(cgroup)
    if(! length(n.cgroup))
      n.cgroup <- rep(nc / k, k)
    
    if(sum(n.cgroup) != nc)
      stop("sum of n.cgroup must equal number of columns")
    
    if(length(n.cgroup) != length(cgroup))
      stop("cgroup and n.cgroup must have same lengths")
  }

  if(! length(rowname)) rgroup <- NULL
  
  if(! length(n.rgroup) && length(rgroup))
    n.rgroup <- rep(nr / length(rgroup), length(rgroup))
  
  if(length(n.rgroup) && sum(n.rgroup) != nr)
    stop("sum of n.rgroup must equal number of rows in object")
  
  if(length(rgroup) && length(n.rgroup) && (length(rgroup) != length(n.rgroup)))
    stop("lengths of rgroup and n.rgroup must match")
  
  if (length(rgroup) && rowlabel.just == "l")
    rowname <- paste("~~", rowname, sep="")

  sl <- ifelse(double.slash, "\\\\", "\\")

  if(ctable && !booktabs) {
      eol <- paste(sl, 'NN\n', sep='')
      eog <- ""
    } else if(ctable) {
      eol <- paste(sl, 'NN\n', sep='')
      eog <- paste(sl, 'NN\n', sep='')
    } else if(longtable && length(n.rgroup)) {
      eol <- paste(sl,"tabularnewline*\n", sep='')
      eog <- paste(sl, "tabularnewline\n", sep='')
    } else {
      eol <- paste(sl,"tabularnewline\n",  sep='')
      eog <- paste(sl, "tabularnewline\n", sep='')      
  }
  
  if(booktabs) {
    toprule    <- paste(sl, "toprule\n",sep="")
    midrule    <- paste(sl, "midrule\n",sep="")
    bottomrule <- paste(sl, "bottomrule\n",sep="")
  } else if(ctable) {
    toprule    <- paste(sl, 'FL\n', sep='')
    midrule    <- paste(sl, 'ML\n', sep='')
    bottomrule <- paste(sl, 'LL\n', sep='')
  } else {
    toprule <-
      if(first.hline.double)
        paste(sl, "hline", sl, "hline\n", sep="")
      else
        paste(sl, "hline\n", sep="")
    
    midrule <- bottomrule <- paste(sl, "hline\n", sep="")
  }


  ## ################ CELL AND ROWNAMES FORMATS ###################
  ## If no formats are specified for the rownames and cells there is
  ## nothing to do. If only one is specified then the other must
  ## faked. But rownamesTexCmd should only be faked if rownames is
  ## not NULL.

  ## Check to make sure the dimensions of the cell formats
  ## match the dimensions of the object to be formatted.
  if (length(cellTexCmds) &
      ! (all(dim(cx) == dim(cellTexCmds)) &
        length(dim(cx)) == length(dim(cellTexCmds)))) {
    msg  <- "The dimensions of cellTexCmds must be:"
    msg1 <- paste(dim(cx), collapse=" x ")
    msg  <- paste(msg, msg1)
    msg  <- paste(msg, ", but you gave me: ")
    msg1 <- paste(dim(cellTexCmds), collapse=" x ")
    msg  <- paste(msg, msg1, sep="")
    stop(msg)
  }
  
  if (length(cellTexCmds) | length(rownamesTexCmd)) {
    ## LaTeX commands have been specified for either the rownames or
    ## the cells.
    ## Fake rownamesTexCmd if it is NULL and if rowname exists.
    if (! length(rownamesTexCmd) & length(rowname))
      rownamesTexCmd <- rep("", nr)
    
    ## Fake cellTexCmds if it is NULL.
    if (! length(cellTexCmds)) cellTexCmds <- array('', dim=dim(cx))
    
    ## Create a combined rowname and cell format object
    rcellTexCmds <- cbind(rownamesTexCmd, cellTexCmds)
    thisDim <- dim(rcellTexCmds)
    ## Prefix the latex commands with slashes.
    rcellTexCmds <- paste(sl, rcellTexCmds, sep="")
    ## Remove slashes from elements where no format was specified.
    rcellTexCmds[rcellTexCmds == sl] <- ""
    ## Restore the dimensions of the matrix (paste loses them).
    dim(rcellTexCmds) <- thisDim
  } else rcellTexCmds <- NULL

  

################ END OF CELL AND ROWNAMES FORMATS ###############
  
  
  if (length(cgroup)) {
    last.col    <- cumsum(n.cgroup)
    first.col   <- c(1, 1 + last.col[- length(last.col)])
    cgroup.cols <- cbind(first.col,last.col)
    col.subs    <- split(seq(length.out=nc),
                         rep.int(seq_along(n.cgroup), times=n.cgroup))
    
    cxi <- rctci <- list()
    ## Initialize with row name column and first column group:
    rctcx <- if(length(rcellTexCmds)) rcellTexCmds[, 1]
#    rctci <- if(length(rcellTexCmds))
#               list(cbind(rcellTexCmds[, 1], rcellTexCmds[1 + col.subs[[1]]
    for (i in seq(along=col.subs)) {
      cxi[[i]] <- cx[, col.subs[[i]], drop=FALSE]
      if(length(rctcx))
        rctcx <- cbind(rctcx, rcellTexCmds[, 1 + col.subs[[i]], drop=FALSE],
                       if(i < length(col.subs)) '')
    }
    if(length(rctcx)) rcellTexCmds <- rctcx
    
    cxx             <- cxi[[1]]
    col.justxx      <- col.just[col.subs[[1]]]
    collabel.justxx <- collabel.just[col.subs[[1]]]
    colheadsxx      <- colheads[col.subs[[1]]]
    extracolheadsxx <- extracolheads[col.subs[[1]]]

    cgroupxx   <- cgroup[1]
    n.cgroupxx <- n.cgroup[1]
    for(i in seq(along=col.subs)[-1]) {
      cxx <- cbind(cxx, "", cxi[[i]])
      col.justxx <- c(col.justxx, "c", col.just[col.subs[[i]]])
      collabel.justxx <- c(collabel.justxx, "c",
                           collabel.just[col.subs[[i]]])
      cgroupxx   <- c(cgroupxx,   "", cgroup[i])
      n.cgroupxx <- c(n.cgroupxx,  1, n.cgroup[i])
      colheadsxx <- c(colheadsxx, "", colheads[col.subs[[i]]])
      if(length(extracolheads))
        extracolheadsxx <- c(extracolheadsxx, "",
                             extracolheads[col.subs[[i]]])
    }
    
    cgroup.colsxx <- cgroup.cols + 0 : (nrow(cgroup.cols) - 1)

    cx            <- cxx
    col.just      <- col.justxx
    collabel.just <- collabel.justxx
    n.cgroup      <- n.cgroupxx
    cgroup.cols   <- cgroup.colsxx[cgroup != "", , drop=FALSE]
    cgroup        <- cgroupxx
    colheads      <- colheadsxx
    extracolheads <- extracolheadsxx
    nc <- ncol(cx)
  }

  cline <- NULL
  if (length(rowname)) {
    cx       <- cbind(rowname, cx)
    col.just <- c(rowlabel.just, col.just)

    if(length(extracolheads)) extracolheads <- c('', extracolheads)
    
    collabel.just <- c(rowlabel.just, collabel.just)
    if (length(cgroup) == 0L)
      colheads <- c(rowlabel, colheads)
    else {
      colheads <- c('', colheads)
      cgroup   <- c(rowlabel, cgroup)

      rlj <- ifelse(rowlabel.just == "l", "l", "c")
      cgroup.just <- c(rlj, cgroup.just)
      n.cgroup <- c(1, n.cgroup)
      cgroup.cols <- 1+cgroup.cols
      cline <- paste(sl, "cline{", cgroup.cols[,1],"-", cgroup.cols[,2], "}",
                     sep="", collapse=" ")
    }
    
    nc <- 1 + nc
  } else if(length(cgroup) > 0L) {
      cline <- paste0(sl, "cline{", cgroup.cols[,1], "-", cgroup.cols[,2], "}", collapse=" ")
  }

  vbar <- ifelse(vbar, "|", "")

  if(! append) cat("", file=file)	#start new file

  ## pandoc used by R Markdown gets fooled by LaTeX comments
  olc <- getOption('omitlatexcom')
  if(! length(olc) || ! olc)
    cat("%", deparse(sys.call()), "%\n", file=file, append=file != '', sep='')

  if(dcolumn) {
    decimal.point <- ifelse(cdot, paste(sl, "cdot", sep=""), ".")
    cat(sl,"newcolumntype{.}{D{.}{",decimal.point,"}{-1}}\n",
        sep="", file=file, append=file != '')
  }

  { # tabular.cols
    tabular.cols <- paste(vbar, col.just, sep="")
    if (! length(n.cgroup))
      tabular.cols <- c(tabular.cols, vbar)
    else {
      vv2 <- cumsum(n.cgroup)
      tabular.cols[vv2] <- paste(tabular.cols[vv2],vbar,sep="")
    }
    
    tabular.cols <- paste(tabular.cols, collapse="")
  }

  intop <- function() {
    if(! length(insert.top)) return(NULL)
    paste(if(center == 'none') '\n\\vspace{1ex}\n\n',
          paste('\\textbf{', insert.top, '}', sep=''),
 #         if(center %in% c('centerline', 'centering')) '\\\\',
          if(center != 'center') '\n\\vspace{1ex}\n\n', sep='')
  }
  
  if(length(caption) && ! ctable) {
    caption <- paste(sl, "caption",
                     if(length(caption.lot))
                       paste("[", caption.lot, "]", sep=""),
                     "{", caption,
                     if(! longtable)
                       paste(sl, "label{", label, "}", sep=""),
                     "}", sep="")
    
    table.env <- TRUE
  }

  if(ctable) {
    latex.begin <-
      latexBuild(
        if(length(size)) paste('{', sl, size, sep=''), '{',
        intop(), '',
        paste(sl, 'ctable[', sep=''), '',
        if(length(caption) && caption.loc == 'bottom') 'botcap,', '',
        if(length(caption)) paste('caption={', caption, '},', sep=''),
         '',
        if(length(caption.lot)) paste('cap={', caption.lot, '},',
                                      sep=''), '',
        if(length(caption)) paste('label=', label, ',', sep=''), '',
        if (star) 'star, ', '',
        if(! landscape) paste('pos=', where, ',', sep=''), '',
        if(landscape) 'sideways', '',
        paste(']{', tabular.cols, '}', sep=''), '',
        if(length(insert.bottom)) 
         paste('{',
              paste(sl,'tnote[]{',
                    sedit(insert.bottom,'\\\\',' '),'}',
                    sep='', collapse=''),
              '}',
              sep=''), '',
        if(! length(insert.bottom)) '{}', '',
        ## tnote does not allow \\ in its argument
        paste('{', toprule, sep=''), '{')
    
    latex.end <- attr(latex.begin, 'close')
    
  } else if(! longtable) {
    latex.begin <-
      latexBuild(
        if(landscape) paste(sl, "begin{landscape}", sep=""), 'landscape',
        if(table.env) paste(sl, "begin{table}", if(here) "[H]"
         else paste('[', where, ']', sep=''), "\n", sep=""), 'table',
        if(length(size)) paste('{', sl, size, '\n', sep=''), '{',
        if(caption.loc == 'top' && length(caption)) paste(caption, "\n"), '',
        intop(), '',
        if(center == 'center') paste(sl, "begin{center}\n", sep=""), 'center',
        if(center == 'centering') paste('{', sl, 'centering\n', sep=''), '{',
        if(center == 'centerline') paste(sl, 'centerline{', sep=''),'{',
        hyperref, '{',
        paste(sl, "begin{tabular}{", tabular.cols, "}\n", toprule, sep=""),
         'tabular',
        insert=list(if(! table.env && length(insert.bottom))
                      list('tabular', 'after', paste('\\par', insert.bottom)),
                    if(table.env)
                      list('table',   'before', paste(insert.bottom, collapse = ' ')),
                    if(caption.loc == 'bottom' && length(caption))
                      list('tabular', 'after', caption)
                   ) )
    
    latex.end <- attr(latex.begin, 'close')

  } else {           ## longtable, not ctable
    latex.begin <-
      latexBuild(
        if(! draft.longtable) 
          paste(sl,"let",sl,"LTmulticolumn=",sl,"multicolumn", sep=""),
          '',
        paste(sl, "setlongtables", sep=""), '',
        if(landscape) paste(sl, "begin{landscape}",sep=""), 'landscape',
        if(length(size)) paste('{', sl, size, '\n', sep=''), '{',
        intop(), '',
        paste(sl,"begin{longtable}{", tabular.cols, "}", sep=""),
          'longtable',
        if(caption.loc == 'top' && length(caption)) paste(caption, eog),
          '',
        toprule, '',
        insert=list(
          if(caption.loc == 'bottom' && length(caption))
           list('longtable', 'after', caption) ) )
    
    latex.end <- attr(latex.begin, 'close')
    if(! length(caption))
      latex.end <- paste(latex.end, '\\addtocounter{table}{-1}', sep='\n')
  }
  cat(latex.begin, file=file, append=file != '')
  
  cgroupheader <- NULL
  if(length(cgroup)) {
    cvbar <- paste(cgroup.just, vbar, sep="")
    cvbar[1] <- paste(vbar, cvbar[1], sep="")
    cvbar[-length(cvbar)] <- paste(cvbar[-length(cvbar)], vbar, sep="")
    slmc <- paste(sl, "multicolumn{", sep="")
    if (length(cgroupTexCmd))
      labs <- paste(sl, cgroupTexCmd, " ", cgroup, sep="")
    else
      labs <- cgroup
    
    if(multicol)
      labs <- paste(slmc, n.cgroup, "}{", cvbar, "}{", labs, "}", sep="")

    cgroupheader <- paste(labs, collapse="&")
    
    if (! length(cline)) {
      inr <- as.numeric(length(rowname))
      cline <- paste(sl, "cline{", 1 + inr, "-", nc, "}", sep="")
    }

    cgroupheader <- paste(cgroupheader, eol, cline, "\n", sep="")
    cat(cgroupheader, file=file, append=file != '')
  }


  { # column labels
    cvbar <- paste(collabel.just, vbar, sep="")
    cvbar[1] <- paste(vbar, cvbar[1], sep="")
    if (length(n.cgroup)) {
      vv2 <- cumsum(n.cgroup[-length(n.cgroup)])
      cvbar[vv2] <- paste(cvbar[vv2], vbar, sep="")
    }
    slmc1 <- paste(sl, "multicolumn{1}{", sep="")

    labs <- colheads
    if (length(colnamesTexCmd))
      labs <- paste(sl, colnamesTexCmd, " ", labs, sep="")
    if(nocolheads) colheads <- labs <- NULL
    header <- NULL
    if(length(labs)) {
      if(! length(extracolheads)) {
        heads <- get2rowHeads(labs)
        colheads <- heads[[1]]
        if(any(heads[[2]] != ''))
          extracolheads <- heads[[2]]
      }
      
      if(multicol)
        colheads <- paste(slmc1, cvbar, "}{", colheads, "}", sep="")
      
      header <- if(length(colheads)) paste(colheads, collapse='&')
      if(length(extracolheads)) {
        extracolheads <- ifelse(extracolheads == ''| extracolsize == '',
                                extracolheads,
                                paste('{',sl,extracolsize,' ',
                                      extracolheads,'}',sep=''))
        
        if(multicol)
          extracolheads <- ifelse(extracolheads == '',extracolheads,
                                  paste(slmc1,cvbar,'}{',extracolheads,'}',sep=''))
        else
          extracolheads <- ifelse(extracolheads == '',extracolheads,
                                  paste(extracolheads,sep=''))
        
        header <- if(length(header))
          paste(header, eol, paste(extracolheads, collapse='&'), sep='')
      }
    
      if(length(header)) cat(header, eog, file=file, sep='', append=file != '')

      if(ctable)
        cat(midrule, file=file, append=file != '')
      else
        cat(midrule, file=file, append=file != '')
    }
  }

  if(longtable) {
    if(! length(caption))
      cat(sl,"endhead\n",midrule,sl,"endfoot\n",sep="",
          file=file,append=file != '')
    else {
      cat(sl,"endfirsthead", sep="",file=file, append=file != '')
      cat(sl,"caption[]{\\em (", continued, ")} ", eol,
          sep="",file=file, append=file != '')
      cat(midrule, sep="",file=file, append=file != '')
      if(length(cgroupheader))
        cat(cgroupheader, file=file, append=file != '')
      if(length(header)) cat(header, file=file, sep="&", append=file != '')
      cat(eog, midrule, sl, "endhead", '\n', midrule,
          sep="", file=file, append=file != '')
      if(length(insert.bottom)) {
        if(length(insert.bottom.width) == 0) {
            insert.bottom.width = paste0(sl, "linewidth")
        }
        
        cat(paste(sl, 'multicolumn{', nc, '}{', "p{",insert.bottom.width,'}}{', 
                  insert.bottom, '}', eol, sep='', collapse='\n'),
                  sep="", file=file, append=file != '')
      }
    
      cat(sl,"endfoot\n", sep="",file=file, append=file != '')
      cat(sl,"label{", label, "}\n", sep="", file=file, append=file != '')
    }
  }

  { # individual lines, grouped if appropriate, longtable if appropriate
    if (length(n.rgroup)) {
      rg.end   <- cumsum(n.rgroup)
      rg.start <- rg.end-n.rgroup+1
      if(! length(rgroup)) {
        rgroup <- rep("",length(n.rgroup))
      } else {
        if (length(rgroupTexCmd)) {
          rgroup <- paste("{",sl, rgroupTexCmd, " ", rgroup,"}",sep="") 
        } else rgroup <- paste("{", rgroup,"}",sep="") 
      }
      
      seq.rgroup <- seq(along=n.rgroup)
    } else {
      seq.rgroup <- 1
      rg.end <- nr
      rg.start <- 1
    }

    linecnt <- 0
    for (j in seq.rgroup) {
      if (length(n.rgroup)) {
        if(longtable && linecnt > 0 &&
           (linecnt + n.rgroup[j] + (n.rgroup[j] > 1)) > lines.page) {
          cat(sl, "newpage\n", sep="", file=file, append=file != '')
          linecnt <- 0
        }
        
        cat(rgroup[j], rep("", nc - 1), sep="&", file=file, append=file != '')
        cat(eol, sep="",file=file, append=file != '')
        linecnt <- linecnt + 1
      }

      ## Write the object (and it's formatting instructions)
      ## to the output.
      ## Loop through the rows of the object.
      for(i in rg.start[j] : rg.end[j]) {
        if (! length(n.rgroup)) {
          if(longtable && linecnt > 0 && (linecnt + 1 > lines.page)) {
            cat(sl, "newpage\n", sep="", file=file, append=file != '')
            linecnt <- 0						
          }
        }

        ## Loop through the columns of the object
        ## write each value (and it's format if there
        ## is one)
        
        if (length(rcellTexCmds)) {
          num.cols <- ncol(cx)
          for (colNum in 1 : num.cols) {
            cat(rcellTexCmds[i, colNum], " ", cx[i, colNum],
                file=file, append=file != '')
            if (colNum < num.cols)
              cat("&", file=file, append=file != '')
          }
        } else {
          ## Original code that writes object to output.
          cat(cx[i, ], file=file, sep="&", append=file != '')
        }
        
        cat(if(i == rg.end[j] || (! ctable && ! length(n.rgroup)))
              eog
            else if(i < rg.end[j])
              eol,
            sep="", file=file, append=file != '')
        
        linecnt <- linecnt+1
      }  ## End of for loop that writes the object.

      if(length(n.rgroup) > j)
        cat(midrule, sep = "", file=file, append=file != '')
      else
        cat(bottomrule, sep="",file=file, append=file != '')
    }
  }

  cat(latex.end, file=file, sep='\n', append=file != '')

  sty <- c("longtable"[longtable], "here"[here], "dcolumn"[dcolumn],
           "ctable"[ctable], "booktabs"[booktabs],
           if(landscape && ! ctable) "lscape")
  
  structure(list(file=file, style=sty), class='latex')
}


## Re-written by Daniel Calvelo Aros <[email protected]> to not use
## S.sty  18Feb04
latex.function <- function(object,
                           title=first.word(deparse(substitute(object))),
                           file=paste(title, ".tex", sep=""),
                           append=FALSE, assignment=TRUE,
                           type=c('example','verbatim','Sinput'),
                           width.cutoff=70, size='', ...)
{
  type <- match.arg(type)
  fctxt <- deparse(object, width.cutoff=width.cutoff)
  if(assignment) fctxt[1] <- paste(title , '<-', fctxt[1]) 
  environment <- ifelse(type == 'example', "alltt", "verbatim")
  environment <- c(example='alltt', verbatim='verbatim',
                   Sinput=paste('Sinput',size,sep=''))[type]
  preamble <- paste("\\begin{",environment,"}\n",sep="")
  cat(preamble, file=file, append=file != "")

  if(type == 'Sinput') cat(fctxt, sep='\n')
  else {
    rxs <-
      if(type == 'example')
        c("\t=>    ",
          "\\\\=>\\\\(\\\\backslash\\\\)",
          "([{}])=>\\\\\\1",
          "<-=>\\\\(\\\\leftarrow\\\\)",
          "#(.*?$)=>{\\\\rm\\\\scriptsize\\\\#\\1}"
          )
      else c("\t=>    ")
    
    substitute <- strsplit( rxs, "=>" )
    for(line in fctxt) {
      for( subst in substitute ) {
        line <- gsub( subst[1], subst[2], line, perl=TRUE )
      }
      
      line <- paste(line,"\n",sep="")
      cat(line, file=file, append=file != "")
    }
  }
  
  postamble <- paste("\\end{",environment,"}\n", sep="")
  cat(postamble, file=file, append=file != '')
  
  structure(list(file=file, style=if(type == 'example')'alltt'), class='latex')
}

latexVerbatim <- function(x,
                          title=first.word(deparse(substitute(x))),
                          file=paste(title, ".tex", sep=""),
                          append=FALSE, size=NULL, hspace=NULL,
                          width=.Options$width,
                          length=.Options$length, ...)
{
  if(! missing(width) || ! missing(length)) {
	old <- options('width', 'length')
    options(width=width, length=length)
    on.exit(options(old))
  }

  if(file != '') sink(file, append=append)
  cat('\\setbox0=\\vbox{\n',
      if(length(size))
        c('\\',size,'\n'),
      '\\begin{verbatim}\n', sep='')
  
  print(x, ...)
  cat('\\end{verbatim}\n}\n',
      if(length(hspace))
        c('\\hspace{',hspace,'}'),
      '{\\makebox[\\textwidth]{\\box0}}\n', sep='')

  if(file == '') return(invisible())
  sink()
  structure(list(file=file, style=NULL), class='latex')
}

latex.list <- function(object,
                       title=first.word(deparse(substitute(object))),
                       file=paste(title, ".tex", sep=""), append=FALSE,
                       label,
                       caption, caption.lot,
                       caption.loc=c('top','bottom'),
                       ...)
{
  caption.loc <- match.arg(caption.loc)
  nx <-	names(object)
  if (! length(nx))
    nx <- paste(title, "[[", seq(along=object), "]]", sep="")
  
  tmp <- latex(object=object[[1]],
               caption=nx[1], label=nx[1], append=append, title=title,
               file=file, caption.lot=NULL,
               caption.loc=caption.loc, ...)
  
  tmp.sty <- tmp$style
  for (i in seq(along=object)[-1]) {
    tmp <- latex(object=object[[i]],
                 caption=nx[i], label=nx[i], append=file != '', title=title, file=file,
                 caption.lot=NULL, caption.loc=caption.loc, ...)
    
    tmp.sty <- c(tmp.sty, tmp$style)
  }
  
  sty <-
    if(length(tmp.sty))
      unique(tmp.sty)
    else
      NULL
  
  structure(list(file=file, style=sty), class='latex')
}


## Function to translate several expressions to LaTeX form, many of
## which require to be put in math mode.
## Arguments inn and out specify additional input and translated
## strings over the usual defaults.
## If pb=T, also translates [()] to math mode using \left, \right
## Assumes that input text always has matches, e.g. [) [] (] (), and
## that surrounding  by $$ is OK
## latexTranslate is used primarily by summary.formula
latexTranslate <- function(object, inn=NULL, out=NULL, pb=FALSE,
                           greek=FALSE, na='', ...)
{
  text <- ifelse(is.na(object), na, as.character(object))
  
  inn <- c("|",  "%",  "#",   "<=",     "<",  ">=",     ">",  "_", "\\243",
           "&", inn, 
           if(pb)
             c("[", "(", "]", ")"))

  out <- c("$|$", "\\%", "\\#", "$\\leq$", "$<$", "$\\geq$", "$>$", "\\_",
           "\\pounds", "\\&", out, 
           if(pb)
             c("$\\left[", "$\\left(", "\\right]$", "\\right)$"))

  text <- sedit(text, '$', 'DOLLARS', wild.literal=TRUE)
  text <- sedit(text, inn, out)

  ##See if string contains an ^ - superscript followed by a number
  ## (number condition added 31aug02)

  dig <- c('0','1','2','3','4','5','6','7','8','9')

  for(i in seq_along(text)) {
    lt <- nchar(text[i])
    x <- substring(text[i], 1 : lt, 1 : lt)
    j <- x == '^'
    if(any(j)) {
      is <- ((1 : lt)[j])[1]  #get first ^
      remain <- x[-(1 : is)]
      k <- remain %in% c(' ',',',')',']','\\','$')
      if(remain[1] %in% dig ||
         (length(remain) > 1 && remain[1] == '-' && remain[2] %in% dig))
        k[-1] <- k[-1] | remain[-1] %nin% dig
      
      ie <- if(any(k)) is + ((1 : length(remain))[k])[1]
        else
          length(x)+1
      
      ##See if math mode already turned on (odd number of $ to left of ^)
      dol <- if(sum(x[1 : is] == '$') %% 2) ''
        else '$'
      
      substring2(text[i],is,ie-1) <-
        paste(dol, '^{', substring(text[i], is + 1, ie - 1), '}', dol,sep='')
    }
    
    if(greek) {
      gl <- c('alpha','beta','gamma','delta','epsilon','varepsilon','zeta',
              'eta','theta','vartheta','iota','kappa','lambda','mu','nu',
              'xi','pi','varpi','rho','varrho','sigma','varsigma','tau',
              'upsilon','phi','carphi','chi','psi','omega','Gamma','Delta',
              'Theta','Lambda','Xi','Pi','Sigma','Upsilon','Phi','Psi','Omega')
      for(w in gl)
        text[i] <- gsub(paste('\\b', w, '\\b', sep=''),
                        paste('$\\\\',w,'$',   sep=''),
                        text[i])
    }
  }
  
  sedit(text, 'DOLLARS', '\\$', wild.literal=TRUE)
}


latex <- function(object, ...)
{
  ## added title= 25May01
  if (! length(class(object)))
    class(object) <- data.class(object)
  
  UseMethod("latex")
}


optionsCmds <- function(pgm)
{
  optionName <- paste(pgm, 'cmd', sep='')
  v <- .Options[[optionName]]
  if(pgm == 'xdvi' && .Platform$OS.type != 'unix' && ! length(v))
    v <- 'yap'  # MikTeX
  if(length(v) && v != '') pgm <- v
  pgm
}


## From Rich Heiberger 2014-12-04:
## The original function in Hmisc_3.14-5 doesn't work on Windows.
## system doesn't handle DOS internal commands such as 'cd'
## I switched it to 'shell' on Windows.

## This revision works on Windows and Macintosh without setting options.
## On Windows yap displays the dvi file and gives a warning I don't understand
## on Mac X displays the dvi file.

## For pdflatex, we need options
## Windows and Macintosh
## options(latexcmd='pdflatex')
## options(dviExtension='pdf')

## Windows with pdflatex
## options(xdvicmd='c:\\progra~1\\Adobe\\Reader~1.0\\Reader\\AcroRd32.exe') ## 32-bit
## options(xdvicmd='c:\\progra~2\\Adobe\\Reader~1.0\\Reader\\AcroRd32.exe') ## 64 bit windows
## Adobe opens correctly and displays the file, but it also gives a warning that
## I don't understand.

## Macintosh with pdflatex
## options(xdvicmd='open')

dvi.latex <- function(object, prlog=FALSE,
                      nomargins=TRUE, width=5.5, height=7, ...)
{
  fi <- object$file;
  sty <- object$style

  if(length(sty))
    sty <- paste('\\usepackage{',sty,'}',sep='')
  
  if(nomargins)
    sty <-  c(sty,
              paste('\\usepackage[paperwidth=',width,
                    'in,paperheight=', height,
                    'in,noheadfoot,margin=0in]{geometry}',sep=''))
  
  ## pre <- tempfile(); post <- tempfile()  # 1dec03
  tmp <- tempfile()
  tmptex <- paste(tmp, 'tex', sep='.')
  infi <- readLines(fi, n=-1)       # Splus 7 doesn't default to read to EOF 3may05
  cat('\\documentclass{report}', sty,
      '\\begin{document}\\pagestyle{empty}', infi,
      '\\end{document}\n', file=tmptex, sep='\n')
  
  if (.Platform$OS.type == "unix")
    sys(paste("cd", shQuote(tempdir()), "&&", optionsCmds("latex"), 
              "-interaction=scrollmode", shQuote(tmp)), output = FALSE)
  else ## MS DOS
    shell(paste("cd", shQuote(tempdir()), "&", optionsCmds("latex"), 
                "-interaction=scrollmode", shQuote(tmp)), shell="CMD",
          intern = FALSE)

  
  if(prlog)
    cat(scan(paste(tmp,'log',sep='.'),list(''),sep='\n')[[1]],
        sep='\n')
  
  fi <- paste(tmp, getOption("dviExtension", "dvi"), sep='.')
  structure(list(file=fi), class='dvi')
}


show.dvi <- function(object, width=5.5, height=7)
{
  viewer <- optionsCmds('xdvi')
  cmd <-
    if(viewer == 'yap') {
      paste(viewer, object$file)
    }
    else if(viewer == 'kdvi') {
      paste(viewer, object$file)
    }
    else if(viewer == 'xdvi') {
      paste(viewer, ' -paper ',
            width, 'x', height, 'in -s 0 ',
            object$file, sep='')
    } else {
      paste(viewer, object$file)
    }

  
  system(cmd, intern = TRUE, wait=TRUE)
  invisible(NULL)
}


## enhanced show.latex 22dec02 - special treatment of file==''
show.latex <- function(object)
{
  if(object$file == '') {
    if(length(object$style)) {
      environment(show.latex)$latexStyles <-
        if(exists("latexStyles", envir=environment(show.latex)))
          unique(c(environment(show.latex)$latexStyles, object$style))
        else object$style

    }

    return(invisible())
  }
  
  show.dvi(dvi.latex(object))
}
environment(show.latex) <- new.env()

print.dvi <- function(x, ...) show.dvi(x)
print.latex <- function(x, ...) show.latex(x)
  
dvi         <- function(object, ...) UseMethod('dvi')
dvips       <- function(object, ...) UseMethod('dvips')
dvigv       <- function(object, ...) UseMethod('dvigv')
dvips.dvi   <- function(object, file, ...)
{
  cmd <-
    if(missing(file))
      paste(optionsCmds('dvips'), shQuote(object$file))
    else
      paste(optionsCmds('dvips'),'-o', file, shQuote(object$file))
  
  ## paste(optionsCmds('dvips'),'-f', object$file,' | lpr') else 5dec03
  ## 2 dQuote 26jan04
  invisible(sys(cmd))
}

dvigv.dvi   <- function(object, ...)
  invisible(sys(paste(optionsCmds('dvips'), '-f', object$file,
                      '| gv - &')))

## added ... to dvixx.dvi calls below 1dec03
dvips.latex <- function(object, ...) invisible(dvips.dvi(dvi.latex(object),...))
dvigv.latex <- function(object, ...) invisible(dvigv.dvi(dvi.latex(object),...))


latexSN <- function(x) {
  x <- format(x)
  x <- sedit(x, c('e+00','e-0*',
                  'e-*',
                  'e+0*',
                  'e+*'),
             c('',
               '\\!\\times\\!10^{-*}','\\!\\times\\!10^{-*}',
               '\\!\\times\\!10^{*}','\\!\\times\\!10^{*}'))
  x
}

htmlSN <- function(x, pretty=TRUE, ...) {
  x <- if(pretty) prettyNum(x, ...) else format(x, ...)
  times <- htmlSpecial('times')
  x <- gsub('e\\+00', '', x)
  x <- gsub('e\\+0([0-9])', '\u00D710<sup>\\1</sup>', x)
  x <- gsub('e\\+(.*)', '\u00D710<sup>\\1</sup>', x)
  x <- gsub('e-0([0-9])', '\u00D710<sup>-\\1</sup>', x)
  gsub('e-(.*)', '\u00D710<sup>-\\1</sup>', x)
}
harrelfe/Hmisc documentation built on Nov. 8, 2019, 8:12 a.m.