in e-mail
# from 2008-10-03 requested the ability to use the old behavior.
for(i in 1:length(x)) {
result[i] <- gsub("-","$-$",result[i],fixed=TRUE)
}
}
return(result)
}
sanitize.final <- function(result) {
return(result)
}
} else {
BCOMMENT <- "\n"
BTABLE <- paste("\n"
BENVIRONMENT <- ""
EENVIRONMENT <- ""
BTABULAR <- ""
ETABULAR <- ""
BSIZE <- ""
ESIZE <- ""
BLABEL <- "\n"
BCAPTION <- paste(" ",sep="")
ECAPTION <- " \n"
BROW <- ""
EROW <- "
\n"
BTH <- " "
ETH <- " | "
STH <- " "
BTD1 <- " | in e-mail dated Wednesday, January 17, 2007
BTD2[regexpr("^p",BTD2)>0] <- "left"
BTD2[BTD2=="r"] <- "right"
BTD2[BTD2=="l"] <- "left"
BTD2[BTD2=="c"] <- "center"
BTD3 <- "\"> "
ETD <- " | "
sanitize <- function(str) {
result <- str
result <- gsub("&","& ",result,fixed=TRUE)
result <- gsub(">","> ",result,fixed=TRUE)
result <- gsub("<","< ",result,fixed=TRUE)
# Kurt Hornik on 2006/10/05 recommended not escaping underscores.
# result <- gsub("_", "\\_", result, fixed=TRUE)
return(result)
}
sanitize.numbers <- function(x) {
return(x)
}
sanitize.final <- function(result) {
# Suggested by Uwe Ligges in e-mail dated 2005-07-30.
result$text <- gsub(" *"," ", result$text,fixed=TRUE)
result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)
return(result)
}
}
result <- string("",file=file,append=append)
info <- R.Version()
# modified Claudio Agostinelli dated 2006-07-28 to set automatically the package version
result <- result + BCOMMENT + type + " table generated in " +
info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT
result <- result + BCOMMENT + date() + ECOMMENT
# Claudio Agostinelli dated 2006-07-28 only.contents
if (!only.contents) {
result <- result + BTABLE
result <- result + BENVIRONMENT
if ( floating == TRUE ) {
if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
}
result <- result + BSIZE
result <- result + BTABULAR
}
# Claudio Agostinelli dated 2006-07-28 include.colnames, include.rownames
if (include.colnames) {
result <- result + BROW + BTH
if (include.rownames) result <- result + STH
if (is.null(sanitize.colnames.function)) { # David G. Whiting in e-mail 2007-10-09
result <- result + paste(sanitize(names(x)),collapse=STH)
} else {
result <- result + paste(sanitize.colnames.function(names(x)), collapse=STH) # David G. Whiting in e-mail 2007-10-09
}
result <- result + ETH + EROW
}
cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)
if (include.rownames) {
if (is.null(sanitize.rownames.function)) { # David G. Whiting in e-mail 2007-10-09
cols[,1] <- sanitize(row.names(x))
} else {
cols[,1] <- sanitize.rownames.function(row.names(x)) # David G. Whiting in e-mail 2007-10-09
}
}
disp <- function(y) {
if (is.factor(y)) {
y <- levels(y)[y]
}
if (is.list(y)) {
y <- unlist(y)
}
return(y)
}
# Code for letting "digits" be a matrix was provided by Arne Henningsen in e-mail dated 2005-06-04.
if( !is.matrix( attr( x, "digits",exact=TRUE ) ) ) {
# modified Claudio Agostinelli dated 2006-07-28
attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )
}
for(i in 1:ncol(x)) {
ina <- is.na(x[,i])
is.numeric.column <- is.numeric(x[,i])
for( j in 1:nrow( cols ) ) {
### modified Claudio Agostinelli dated 2009-09-14
### add decimal.mark=options()$OutDec
cols[j,i+pos] <-
formatC( disp( x[j,i] ),
format = ifelse( attr( x, "digits",exact=TRUE )[j,i+1] < 0, "E", attr( x, "display",exact=TRUE )[i+1] ), digits = abs( attr( x, "digits",exact=TRUE )[j,i+1] ), decimal.mark=options()$OutDec)
}
if ( any(ina) ) cols[ina,i+pos] <- NA.string
# Based on contribution from Jonathan Swinton in e-mail dated Wednesday, January 17, 2007
if ( is.numeric.column ) {
cols[,i+pos] <- sanitize.numbers(cols[,i+pos])
} else {
if (is.null(sanitize.text.function)) {
cols[,i+pos] <- sanitize(cols[,i+pos])
} else {
cols[,i+pos] <- sanitize.text.function(cols[,i+pos])
}
}
}
multiplier <- 5
full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)
full[,1] <- BROW
full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1
full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2
full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3
full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols
full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD
full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")
if (type=="latex") full[,2] <- ""
result <- result + lastcol[2] + paste(t(full),collapse="")
if (!only.contents) {
if (tabular.environment == "longtable") {
result <- result + PHEADER
## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid
## that bottom caption interferes with a top caption of a longtable
if(caption.placement=="bottom"){
if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
}
if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
ETABULAR <- "\\end{longtable}\n"
}
result <- result + ETABULAR
result <- result + ESIZE
if ( floating == TRUE ) {
if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
}
result <- result + EENVIRONMENT
result <- result + ETABLE
}
result <- sanitize.final(result)
print(result)
return(invisible(result$text))
}
"+.string" <- function(x,y) {
x$text <- paste(x$text,as.string(y)$text,sep="")
return(x)
}
print.string <- function(x,...) {
cat(x$text,file=x$file,append=x$append)
return(invisible())
}
string <- function(text,file="",append=FALSE) {
x <- list(text=text,file=file,append=append)
class(x) <- "string"
return(x)
}
as.string <- function(x,file="",append=FALSE) {
if (is.null(attr(x,"class",exact=TRUE)))
switch(data.class(x),
character=return(string(x,file,append)),
numeric=return(string(as.character(x),file,append)),
stop("Cannot coerse argument to a string"))
if (class(x)=="string")
return(x)
stop("Cannot coerse argument to a string")
}
is.string <- function(x) {
return(class(x)=="string")
}