### xtable package
###
### Produce LaTeX and HTML tables from R objects.
###
### Copyright 2000-2007 David B. Dahl
###
### This file is part of the `xtable' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE. See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA
"caption<-" <- function(x,value) UseMethod("caption<-")
"caption<-.xtable" <- function(x,value) {
if (length(value)>2)
stop("\"caption\" must have length 1 or 2")
attr(x,"caption") <- value
return(x)
}
caption <- function(x,...) UseMethod("caption")
caption.xtable <- function(x,...) {
return(attr(x,"caption",exact=TRUE))
}
"label<-" <- function(x,value) UseMethod("label<-")
"label<-.xtable" <- function(x,value) {
if (length(value)>1)
stop("\"label\" must have length 1")
attr(x,"label") <- value
return(x)
}
label <- function(x,...) UseMethod("label")
label.xtable <- function(x,...) {
return(attr(x,"label",exact=TRUE))
}
"align<-" <- function(x,value) UseMethod("align<-")
# Based on contribution from Jonathan Swinton in e-mail dated Wednesday, January 17, 2007
.alignStringToVector <- function(aString) {
# poor mans parsing - separating string of form "l{2in}llr|p{1in}c|{1in}"
# into "l{2in}" "l" "l" "r" "|" "p{1in}" "c" "|{1in}"
aString.Align <- character(0);
aString.Width <- character(0);
wString <- aString
while( nchar(wString)>0) {
aString.Align <- c(aString.Align,substr(wString,1,1))
# is it followed by a brace?
thisWidth <- ""
if ( nchar(wString)>1 & substr(wString,2,2)=="{") {
beforeNextBrace <- regexpr("[^\\]\\}",wString)
if (beforeNextBrace <0 ) {
stop("No closing } in align string")
}
thisWidth <- substr(wString,2,beforeNextBrace+1)
wString <- substr(wString,beforeNextBrace+2,nchar(wString))
} else {
wString <- substr(wString,2,nchar(wString))
}
aString.Width <- c(aString.Width,thisWidth)
}
alignAllowed <- c("l","r","p","c","|")
if (any( !(aString.Align %in% alignAllowed))) {
warning("Nonstandard alignments in align string")
}
res <- paste(aString.Align,aString.Width,sep="")
res
}
#.alignStringToVector ("l{2in}llr|p{1in}c|{1in}")
#.alignStringToVector ("l{2in}llr|p{1in}c|")
#.alignStringToVector ("{2in}llr|p{1in}c|") # latex syntax error, but gives wrong alignment
#.alignStringToVector("llllp{3cm}")
"align<-.xtable" <- function(x,value) {
# Based on contribution from Benno in e-mail dated Wednesday, December 01, 2004
# Based on contribution from Jonathan Swinton in e-mail dated Wednesday, January 17, 2007
# cat("%",value,"\n")
if ( (!is.null(value)) && ( is.character(value) ) && ( length(value) == 1 ) && ( nchar(value) > 1 ) ) {
value <- .alignStringToVector(value)
} # That should have checked we had only lrcp|
# but what if the "if statement" is false?
# For simplicity, deleting check present in version 1.4-2 and earlier.
c.value <- if (any(!is.na(match(value,"|")))) {
value[-which(value=='|')]
} else {
value
}
if (length(c.value)!=ncol(x)+1)
stop(paste("\"align\" must have length equal to",ncol(x)+1,"( ncol(x) + 1 )"))
attr(x,"align") <- value
return(x)
}
align <- function(x,...) UseMethod("align")
align.xtable <- function(x,...) {
return(attr(x,"align",exact=TRUE))
}
"digits<-" <- function(x,value) UseMethod("digits<-")
"digits<-.xtable" <- function(x,value) {
if( is.matrix( value ) ) {
if( ncol( value ) != ncol(x)+1 || nrow( value ) != nrow(x) ) {
stop( "if argument 'digits' is a matrix, it must have columns equal",
" to ", ncol(x)+1, " ( ncol(x) + 1 ) and rows equal to ", nrow(x),
" ( nrow( x )" )
}
} else {
if( length(value)==1 ) { value <- rep(value, ncol(x)+1) }
if( length( value ) >1 & length( value ) != ncol(x)+1 ) {
stop( "if argument 'digits' is a vector of length more than one, it must have length equal",
" to ", ncol(x)+1, " ( ncol(x) + 1 )" )
}
}
if (!is.numeric(value))
stop("\"digits\" must be numeric")
attr(x,"digits") <- value
return(x)
}
digits <- function(x,...) UseMethod("digits")
digits.xtable <- function(x,...) {
return(attr(x,"digits",exact=TRUE))
}
"display<-" <- function(x,value) UseMethod("display<-")
"display<-.xtable" <- function(x,value) {
if (length(value)!=ncol(x)+1)
stop(paste("\"display\" must have length equal to",ncol(x)+1,"( ncol(x) + 1 )"))
if (!all(!is.na(match(value,c("d","f","e","E","g","G","fg","s")))))
stop("\"display\" must be in {\"d\",\"f\",\"e\",\"E\",\"g\",\"G\", \"fg\", \"s\"}")
attr(x,"display") <- value
return(x)
}
display <- function(x,...) UseMethod("display")
display.xtable <- function(x,...) {
return(attr(x,"display",exact=TRUE))
}