Peter Dalgaard wrote:
Charles Dupont <[EMAIL PROTECTED]> writes:
Hmmmm, It works for me. Interesting.
It almost looks like the temp dir is not being created, but thats not
possible because R does that. It might be a Unicode issue with you
system shell. Can you run this statement in R
It's a Unicode issue alright. dQuote is intended for textual output,
and in UTF-8 locales it will use Unicode codepoints 0x201c and 0x201d,
which the shell is not expected to make head or tails of.
The help page would have told you, and pointed you to shQuote() as
well...
Well There be the problem.
First I have heard about shQuote. When I last looked at the help file
it didn't have the shQuote entry.
For a temporary fix source the attached file after loading the Hmisc
library. I will fix this in source for the next version.
--
Charles Dupont Computer System Analyst School of Medicine
Department of Biostatistics Vanderbilt University
##!!WRONG ARG x in !.SV4. def latex generic!
##Changed x to object inside latex() for !.SV4. (Thanks David Lovell)
##Thanks to David R. Lovell <[EMAIL PROTECTED]> CSIRO
##for scientific= 8Feb2000
first.word <- function(x, i=1, expr=substitute(x))
{
words <-
if(!missing(x))
as.character(x)[1]
else
as.character(unlist(expr))[1]
## Added !missing(x) as.char(x) 25May01
## first.letters <- substring(words, 1, 1)
## word.selector <- (match(first.letters, c(letters,LETTERS,"."), 0) > 0)
## words <- words[word.selector][i]
## if(!under.unix) {
## words <- sedit(words,'.','')
## words <- substring(words,1,8)
## }
## 8Nov00 FEH:
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=cdot, na.blank=FALSE,
na.dot=FALSE, blank.dot=FALSE, col.just=NULL,
cdot=FALSE, dcolumn=FALSE, matrix.sep=' ',
scientific=c(-4,4), ...)
{
if(cdot && dcolumn)
stop('cannot have both cdot=T and dcolumn=T')
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)) .Options$digits 6Aug00 what was that?
if(length(digits)) {
oldopt <- options(digits=digits)
on.exit(options(oldopt))
}
## For now nsmall and scientific are ignored in R 25May01
formt <-
if(!.R.)
format.default
else function(x, decimal.mark='.', nsmall=0, scientific=c(-4,4))
{
x <- format(x)
if(decimal.mark!='.')
x <- gsub('\\.',decimal.mark,x)
x
}
dot <-
if(cdot)
(if(.R.)
'\\\\cdotp\\\\!'
else
'\\cdotp\\!')
else
'.'
if(is.data.frame(x))
x <- unclass(x)
xtype <-
if(is.list(x))
1
else if(length(dim(x)))
2
else
3
##Following changed as above 10Mar01
## atx <- attributes(x)
## cl <- atx$class
## if(length(cl) && (idf <- any(cl=='data.frame')))
## attr(x,'class') <- cl[cl!='data.frame']
## xtype <- if(is.list(x))1 else if(length(atx$dim))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
''
## Added Check to see that if the user passed col.just into format.df
## that the length of col.just if >= ncx 29apr05
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) ## 19apr03
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)
rnam <-
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)
}
for(j in 1:ncx) {
xj <-
if(xtype==1)
x[[j]]
else if(xtype==2)
x[,j]
else
x
namj <- nams[j]
num <- is.numeric(xj) || all(is.na(xj)) ## 16sep03
if(testDateTime(xj))
num <- FALSE ## 16sep03
## using xtype avoids things like as.matrix changing special characters
ncxj <- max(1,dim(xj)[2], na.rm=TRUE)
## Added na.rm=T 5Jan01: SV4 makes dim(xj)=single number if x is data.frame
for(k in 1:ncxj) {
xk <-
if(ld <- length(dim(xj))==2)
xj[,k]
else
xj
## Added ==2 5Jan01
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)
dn
} else ''
namk <- paste(namj,
if(namj!='' && 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)
else if(rtype==3) {
cxk <- character(nrx) ## corrected 4Nov97 Eric Bissonette
for(i in 1:nrx)
cxk[i] <-
if(is.na(dec[i,j]))
formt(xk[i], decimal.mark=dot, scientific=scientific)
else
formt(round(xk[i], dec[i,j]), decimal.mark=dot,
nsmall=dec[i,j], scientific=scientific)
## 12Aug99
} else if(rtype==4) # 12Aug99
cxk <-
if(is.na(cdec[j]))
formt(xk, decimal.mark=dot, scientific=scientific)
else
formt(round(xk, cdec[j]), decimal.mark=dot, nsmall=cdec[j],
scientific=scientific)
if(na.blank)
cxk[is.na(xk)] <- ''
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 <- "."
}
} else { #ended if(num)
cj <-
if(length(col.just))
col.just[j]
else 'l'
cxk <- as.character(xk)
}
cx <- cbind(cx, cxk)
nam <- c(nam, namk)
cjust <- c(cjust, cj)
} #end for k
}#end for j
dimnames(cx) <- list(rnam, 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=dimnames(cx)[[2]],
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'),
double.slash=FALSE,
vbar=FALSE, collabel.just=rep("c",nc), na.blank=TRUE,
insert.bottom=NULL, first.hline.double=!(booktabs | ctable),
where='!tbp', size=NULL,
center=c('center','centering','none'),
landscape=FALSE,
multicol=TRUE, ## to remove multicolumn if no need SSJ 17nov03
...) ## center MJ 08sep03
{
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, ...)
## removed check.names=FALSE from above 23jan03
if (missing(rowname))
rowname <- dimnames(cx)[[1]]
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, "\\\\", "\\")
eol <-
if(ctable)
paste(sl, 'NN', sep='')
else
paste(sl,sl,sep='')
if(booktabs) { # 27may02
toprule <- paste(sl,"toprule",sep="")
midrule <- paste(sl,"midrule",sep="")
bottomrule <- paste(sl,"bottomrule",sep="")
} else if(ctable) { ## 13dec02
toprule <- paste(sl, 'FL', sep='')
midrule <- paste(sl, 'ML', sep='')
bottomrule <- paste(sl, 'LL', sep='')
} else {
toprule <-
if(first.hline.double)
paste(sl,"hline",sl,"hline",sep="")
else
paste(sl,"hline",sep="")
midrule <- bottomrule <- paste(sl,"hline",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 (!is.null(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) & !is.null(cellTexCmds)) {
my.index <- cumsum(n.cgroup)
new.index <- NULL
new.col <- dim(cx)[2] + 1
for (i in seq(along=my.index))
new.index <- c(new.index, my.index[i], new.col)
new.index <- new.index[-length(new.index)]
cellTexCmds <- cbind(cellTexCmds, "")[, new.index]
}
if (!is.null(cellTexCmds) | !is.null(rownamesTexCmd)) {
## LaTeX commands have been specified for either the rownames or
## the cells.
## Fake rownamesTexCmd if it is NULL and if rowname exists.
if (is.null(rownamesTexCmd) & !is.null(rowname))
rownamesTexCmd <- rep("", nr)
## Fake cellTexCmds if it is NULL.
if (is.null(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 <- list()
for (i in seq(along=first.col))
col.subs[[i]] <- first.col[i]:last.col[i]
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]]]
cgroupxx <- cgroup[1]
n.cgroupxx <- n.cgroup[1]
for (i in seq(along=col.subs)[-1]) {
cxx <- cbind(cxx, "", cxi[[i]]) # was ""="" 23Feb01 "=" 2Apr02
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])
}
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
nc <- ncol(cx)
}
cline <- NULL
if (length(rowname)) {
cx <- cbind(rowname, cx)
dimnames(cx)[[2]][1] <- rowlabel
col.just <- c(rowlabel.just, col.just)
if(length(extracolheads))
extracolheads <- c('', extracolheads) ## 16jun03
collabel.just <- c(rowlabel.just, collabel.just)
if (!length(cgroup))
n.cgroup <- c(1, nc)
else {
cgroup <- c(rowlabel, cgroup)
dimnames(cx)[[2]][1] <- ""
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%\n", file=file, append=file!='')
## append= 19apr03 and other places
## Was as.character(as.name(match.call())) 15Sep00
if(dcolumn) {
decimal.point <- ifelse(cdot, paste(sl,"cdot",sep=""), ".")
cat(sl,"newcolumntype{.}{D{.}{",decimal.point,"}{-1}}\n",
sep="", file=file, append=file!='') # was newcolumn 26Feb02
}
{ # 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="")
}
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) { ## 13dec02
latex.begin <- c(if(length(size))
paste('{',sl,size,sep=''),
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=''),
paste('label=',label,',',sep=''),
if(!landscape)
paste('pos=',where,',',sep=''),
if(landscape)
'rotate',
paste(']{',tabular.cols, '}',sep=''),
if(length(insert.bottom))
paste('{',sl,'tnote[]{',sedit(insert.bottom,'\\\\',' '),
'}}',
sep='')
else '{}',
## tnote does not allow \\ in its argument
paste('{', toprule, sep='')
)
latex.end <- c('}',
if(length(size))
'}')
} else if(!longtable) {
latex.begin <- c(if(landscape)
paste(sl, "begin{landscape}",sep=""),
if(table.env)
paste(sl, "begin{table}",
if(here)
"[H]"
else
paste('[',where,']',sep=''),
"\n", sep=""),
if(length(size))
paste(sl,size,'\n',sep=''),
if(caption.loc=='top' && !missing(caption))
paste(caption, "\n"), ## 3oct03
if(center == 'center') ## MJ: 08sep03
paste(sl,"begin{center}\n", sep="")## MJ: 08sep03
else {
if (center == 'centering') ## MJ: 08sep03
paste(sl,"centering\n", sep="")
}, ## MJ: 08sep03
paste(sl,"begin{tabular}{", tabular.cols, "}",
toprule, "\n", sep="")
## 11Jun95 12jan03 "}" was "}{" WHY!
)
latex.end <- c(paste(sl,"end{tabular}\n", sep = ""),
if(center == 'center') ## MJ: 08sep03
paste(sl,"end{center}\n", sep=""), ## MJ: 08sep03
if(caption.loc=='bottom' && !missing(caption))
paste(caption,'\n'), # 3oct03
if(length(insert.bottom))
insert.bottom,
if(table.env)
paste(sl, "end{table}\n", sep=""),
if(landscape)
paste(sl, "end{landscape}\n", sep="")
)
} else {
latex.begin <- c(paste(if (!draft.longtable)
paste(sl,"let",sl,"LTmulticolumn=",sl,"multicolumn", sep=""),
paste(sl,"setlongtables",sep=""),
if(landscape)
paste(sl, "begin{landscape}",sep=""),
if(length(size))
paste('{',sl,size,'\n',sep=''),
paste(sl,"begin{longtable}{", tabular.cols,
"}",sep=""),
sep="\n"),
if(caption.loc=='top' && !missing(caption))
paste(caption, sl,sl,"\n", sep=""),
paste(toprule, "\n", sep="") #11Jun95
)
latex.end <- paste(if(caption.loc=='bottom' && !missing(caption))
paste(caption, sl,sl,"\n",sep=""), ## 3oct03
paste(sl,"end{longtable}\n", sep=""),
if(length(size))
'}',
if(landscape)
paste(sl,"end{landscape}\n",sep="")
)
}
cat(latex.begin, file=file, append=file!='')
if(length(cgroup)) { # was !missing 5Oct00
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="")
##labs <- paste(sl, "bf ", cgroup, sep="")
if (!is.null(cgroupTexCmd))
labs <- paste(sl, cgroupTexCmd, " ", cgroup, sep="")
# DRW 12apr05.
if(multicol) ## SSJ 17nov03
labs <- paste(slmc, n.cgroup, "}{", cvbar, "}{", labs, "}", sep="")
cat(labs, file=file, sep="&\n", append=file!='')
if (!length(cline)) { # was is.length 2Apr02
inr <- as.numeric(length(rowname))
cline <- paste(sl,"cline{",1+inr,"-",nc,"}",sep="")
}
cat(eol, " ",cline,"\n", sep="",file=file, append=file!='')
## eol was sl, sl 13dec02
}
{ # 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 <- dimnames(cx)[[2]] ## 28apr03 and next 5 15jul03 next 2
labs <- colheads
if (!is.null(colnamesTexCmd))
labs <- paste(sl, colnamesTexCmd, " ", labs, sep="")
# DRW 12apr05.
if(length(labs)) {
if(!length(extracolheads)) {
heads <- get2rowHeads(labs)
labs <- heads[[1]]
if(any(heads[[2]] != ''))
extracolheads <- heads[[2]]
}
if(multicol) ## SSJ 17nov03
labs <- paste(slmc1, cvbar, "}{", labs, "}", sep="")
cat(labs, file=file, sep="&\n", append=file!='')
if(length(extracolheads)) {
extracolheads <- ifelse(extracolheads==''| extracolsize=='',
extracolheads,
paste('{',sl,extracolsize,' ',
extracolheads,'}',sep=''))
## SSJ 17nov03 add | extracolsize=='' to avoid putting {\ } if you
don't wont change size in second line title
if(multicol) ## SSJ 17nov03
extracolheads <- ifelse(extracolheads=='',extracolheads,
paste(slmc1,cvbar,'}{',extracolheads,'}',sep=''))
else
extracolheads <- ifelse(extracolheads=='',extracolheads,
paste(extracolheads,sep=''))
##cat(eol," ",
paste(c(if(length(rowname))'',extracolheads),collapse='&'),
##file=file, append=file!='') # 21jan03
cat(eol," ", paste(extracolheads,collapse='&'),
file=file, append=file!='') # 28apr03
}
if(ctable)
cat(midrule, '\n', sep='', file=file, append=file!='')
else
cat(eol," ",midrule, "\n",sep="",file=file, append=file!='')
## eol was sl, sl 13dec02
}
}
if(longtable) {
if(missing(caption))
cat(sl,"endhead\n",midrule,sl,"endfoot\n",sep="",
file=file,append=file!='')
else {
cat(sl,"endfirsthead\n", sep="",file=file, append=file!='')
cat(sl,"caption[]{\\em (continued)} ",sl,sl,"\n",
sep="",file=file, append=file!='')
cat(midrule, "\n", sep="",file=file, append=file!='')
cat(labs, file=file, sep="&", append=file!='')
cat(sl, sl, " ", midrule, "\n", sl, "endhead", midrule, "\n",
sep="", file=file, append=file!='')
if(length(insert.bottom)) {
cat(sl, 'multicolumn{', nc, '}{l}{', sl, "parbox[t]", sl, 'LTcapwidth{',
insert.bottom, '}}', sl, sl, '\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 (!is.null(rgroupTexCmd)) { # DRW 12apr05. This if block.
rgroup <- paste("{",sl, rgroupTexCmd, " ", rgroup,"}",sep="")
} else {
rgroup <- paste("{", rgroup,"}",sep="")
}
}
##else rgroup <- paste("{",sl,"bf ",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,"\n", sep="",file=file, append=file!='')
## eol was sl,sl 13dec02
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).
## DRW 12apr05. This if/else block.
if (!is.null(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(!ctable || i < rg.end[j])
eol,
"\n", sep="",file=file, append=file!='')
## eol was sl,sl added if( ) 13dec02
linecnt <- linecnt+1
} ## End of for loop that writes the object.
cat(bottomrule, "\n", 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'), ...)
{
type <- match.arg(type)
type <- match.arg(type)
fctxt <- format(object)
if(assignment) fctxt[1] <- paste(title , '<-', fctxt[1])
environment <- ifelse(type=='example', "alltt", "verbatim")
preamble <- paste("\\begin{",environment,"}\n",sep="")
cat(preamble, file=file, append=file!="")
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 <- Cs(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,
title=first.word(deparse(substitute(object))),...)
{
## added title= 25May01
if (!length(oldClass(object)))
oldClass(object) <- data.class(object)
UseMethod("latex")
}
optionsCmds <- function(pgm)
{
optionName <- paste(pgm,'cmd',sep='')
v <- .Options[[optionName]]
if(pgm=='xdvi' && !under.unix && !length(v))
v <- 'yap' # MikTeX 7Feb03
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(under.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,'dvi',sep='.')
structure(list(file=fi), class='dvi')
}
if(.R. && FALSE) show <- function(object) UseMethod('show')
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 {
paste(viewer, ' -paper ',
width,'x',height,'in -s 0 ',
object$file,' &',sep='')
}
}
sys(cmd)
invisible()
}
## enhanced show.latex 22dec02 - special treatment of file==''
show.latex <- function(object)
{
if(object$file=='') {
if(length(object$style)) {
latexStyles <-
if(exists('latexStyles'))
unique(c(latexStyles, object$style))
else object$style
storeTemp(latexStyles,'latexStyles')
}
return(invisible())
}
show.dvi(dvi.latex(object))
}
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'), dQuote(object$file))
else
paste(optionsCmds('dvips'),'-o', file, dQuote(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')
## if(under.unix)
## sys(paste('cat',pre,fi,post,'>',paste(tmp,'tex',sep='.')))
## else sys(paste('copy',pre,'+',fi,'+',post,paste(tmp,'tex',sep='.')))
## 17dec02
## unlink(c(pre,post))
sc <-
if(under.unix)
';'
else
'&' # 7feb03
## Create system call to hevea to convert temporary latex file to html.
cmd <-
if(missing(file)) {
paste(optionsCmds('hevea'), dQuote(tmptex))
} else {
paste(optionsCmds('hevea'), '-o', file, dQuote(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 <- format.df(object, ...)
adj <- attr(x,'col.just')
if(any(adj=='r'))
for(i in seq(along=adj)[adj=='r'])
x[,i] <- paste('<div align=right>',x[,i],'</div>',sep='')
if(length(r <- dimnames(x)[[1]]))
x <- cbind('Name'=r, x)
cat('<TABLE BORDER>\n', file=file, append=append)
cat('<tr>', paste('<td>', dimnames(x)[[2]], '</td>',sep=''), '</tr>\n',
sep='', file=file, append=file!='')
if(length(link))
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(under.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
}
______________________________________________
R-help@stat.math.ethz.ch mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html
