Revision 1f43af8328d17a1e798556dff65148fe3dcc9dd0 authored by Frank E Harrell Jr on 02 March 2014, 00:00:00 UTC, committed by Gabor Csardi on 02 March 2014, 00:00:00 UTC
1 parent bfdcc04
latex.s
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
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,
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)
string[k] <- gsub('<', paste(sl, sl, 'textless ', sep=''), string[k])
string[k] <- gsub('>', paste(sl, sl, 'textgreater ', sep=''), string[k])
string
}
if(numeric.dollar == TRUE && dcolumn == TRUE)
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=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==TRUE && numeric.dollar==TRUE)
paste(sl,sl,'cdotp',sl,sl,'!',sep='')
else '.'
decimal.point <- if(cdot==TRUE && dcolumn==TRUE)
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)
}
if(math.col.names) {
nams <- paste('$', nams, '$', sep='')
} else {
nams <- cleanLatex(nams)
}
if(math.row.names) {
rnams <- paste('$', rnams, '$', sep='')
} else {
rnams <- 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 {
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 for k
}#end for 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, math.col.names=FALSE,
hyperref=NULL,
...)
{
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, math.col.names=math.col.names,
double.slash=double.slash, ...)
if (missing(rowname))
rowname <- dimnames(cx)[[1]]
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) {
eol <- paste(sl, 'NN\n', sep='')
eog <- ""
} 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 there are column groups, add a blank column
## of formats between the groups.
if (length(cgroup) & length(cellTexCmds)) {
my.index <- split(1:NCOL(cellTexCmds), rep(cumsum(n.cgroup), times=n.cgroup))
new.index <- NULL
new.col <- dim(cx)[2] + 1
for (i in my.index)
new.index <- c(new.index, i, new.col)
new.index <- new.index[-length(new.index)]
cellTexCmds <- cbind(cellTexCmds, "")[, new.index]
}
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 <- rep("", dim(cx)[1] * dim(cx)[2])
dim(cellTexCmds) <- 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 (!vbar && length(cgroup)) {
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 <- list()
for (i in seq(along=col.subs))
cxi[[i]] <- cx[,col.subs[[i]],drop=FALSE]
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
}
vbar <- ifelse(vbar, "|", "")
if(!append)
cat("", file=file) #start new file
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 == 'none') '\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',
afterEndtabular = if(! table.env) insert.bottom,
beforeEndtable = if(table.env) insert.bottom)
latex.end <- attr(latex.begin, 'close')
} else {
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, '')
latex.end <- attr(latex.begin, 'close')
}
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="")
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 <- 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 <- paste(header, eol, paste(extracolheads, collapse='&'), sep='')
}
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!='')
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 <dcalvelo@minag.gob.pe> 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=width, length=length)
on.exit(options(old))
}
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='')
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, ...)
{
text <- 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) ##17Nov00
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 1:length(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(' ',',',')',']','\\','$')
## Following 3 lines 31aug02
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='') # 25May01
}
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) ## 17Nov00
}
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
}
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')
sc <-
if(.Platform$OS.type == 'unix') {
'&&'
} else {
'&' # DOS command separator
}
sys(paste('cd',shQuote(tempdir()),sc,optionsCmds('latex'),
'-interaction=scrollmode', shQuote(tmp)), output=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),...))
html <- function(object, ...) UseMethod('html')
html.latex <- function(object, file, ...)
{
fi <- object$file
sty <- object$style
if(length(sty))
sty <- paste('\\usepackage{',sty,'}',sep='')
## pre <- tempfile(); post <- tempfile() 1dec03
tmp <- tempfile()
tmptex <- paste(tmp,'tex',sep='.') # 5dec03
infi <- readLines(fi)
cat('\\documentclass{report}', sty, '\\begin{document}', infi,
'\\end{document}\n', file=tmptex, sep='\n')
sc <-
if(.Platform$OS.type == 'unix')
';'
else
'&' # 7feb03
## Create system call to hevea to convert temporary latex file to html.
cmd <-
if(missing(file)) {
paste(optionsCmds('hevea'), shQuote(tmptex))
} else {
paste(optionsCmds('hevea'), '-o', file, shQuote(tmptex))
}
## perform system call
sys(cmd)
## 24nov03 dQuote
## Check to see if .html tag exist and add it if
## if does not
if(missing(file)) {
file <- paste(tmp,'html',sep='.')
} else {
if(!length(grep(".*\\.html", file))) {
file <- paste(file, 'html', sep='.')
}
}
structure(list(file=file), class='html')
}
html.data.frame <-
function(object,
file=paste(first.word(deparse(substitute(object))),
'html',sep='.'),
append=FALSE, link=NULL, linkCol=1,
linkType=c('href','name'), ...)
{
linkType <- match.arg(linkType)
x <- as.matrix(object)
for(i in 1:ncol(x))
{
xi <- x[,i]
if(is.numeric(object[,i]))
x[,i] <- paste('<div align=right>',xi,'</div>',sep='')
}
if(length(r <- dimnames(x)[[1]]))
x <- cbind(Name=as.character(r), x)
cat('<TABLE BORDER>\n', file=file, append=append)
cat('<tr>', paste('<td><h3>', dimnames(x)[[2]], '</h3></td>',sep=''), '</tr>\n',
sep='', file=file, append=file!='')
if(length(link)) {
if(is.matrix(link))
x[link!=''] <- paste('<a ',linkType,'="', link[link!=''],'">',
x[link!=''],'</a>',sep='') else
x[,linkCol] <- ifelse(link=='',x[,linkCol],
paste('<a ',linkType,'="',link,'">',
x[,linkCol],'</a>',sep=''))
}
for(i in 1:nrow(x))
cat('<tr>',paste('<td>',x[i,],'</td>',sep=''),'</tr>\n',
sep='', file=file, append=file!='')
cat('</TABLE>\n', file=file, append=file!='')
structure(list(file=file), class='html')
}
html.default <- function(object,
file=paste(first.word(deparse(substitute(object))),
'html',sep='.'),
append=FALSE,
link=NULL, linkCol=1, linkType=c('href','name'),
...)
{
html.data.frame(object, file=file, append=append, link=link,
linkCol=linkCol, linkType=linkType, ...)
}
show.html <- function(object)
{
browser <- .Options$help.browser
if(!length(browser))
browser <- .Options$browser
if(!length(browser))
browser <- 'netscape'
sys(paste(browser, object, if(.Platform$OS.type == 'unix') '&'))
invisible()
}
print.html <- function(x, ...) show.html(x)
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
}
Computing file changes ...
