pkg/R/table.attributes.R

   1 ### xtable package
   2 ###
   3 ### Produce LaTeX and HTML tables from R objects.
   4 ###
   5 ### Copyright 2000-2013 David B. Dahl <dahl@stat.byu.edu>
   6 ###
   7 ### This file is part of the `xtable' library for R and related languages.
   8 ### It is made available under the terms of the GNU General Public
   9 ### License, version 2, or at your option, any later version,
  10 ### incorporated herein by reference.
  11 ###
  12 ### This program is distributed in the hope that it will be
  13 ### useful, but WITHOUT ANY WARRANTY; without even the implied
  14 ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15 ### PURPOSE.  See the GNU General Public License for more
  16 ### details.
  17 ###
  18 ### You should have received a copy of the GNU General Public
  19 ### License along with this program; if not, write to the Free
  20 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21 ### MA 02111-1307, USA
  22
  23 "caption<-" <- function(x, value) UseMethod("caption<-")
  24 "caption<-.xtable" <- function(x, value) {
  25   if (length(value) > 2)
  26     stop("\"caption\" must have length 1 or 2")
  27   attr(x, "caption") <- value
  28   return(x)
  29 }
  30
  31 caption <- function(x, ...) UseMethod("caption")
  32 caption.xtable <- function(x, ...) {
  33   return(attr(x, "caption", exact = TRUE))
  34 }
  35
  36 "label<-" <- function(x, value) UseMethod("label<-")
  37 "label<-.xtable" <- function(x, value) {
  38   if (length(value) > 1)
  39     stop("\"label\" must have length 1")
  40   attr(x, "label") <- value
  41   return(x)
  42 }
  43
  44 label <- function(x, ...) UseMethod("label")
  45 label.xtable <- function(x, ...) {
  46   return(attr(x, "label", exact = TRUE))
  47 }
  48
  49 "align<-" <- function(x, value) UseMethod("align<-")
  50
  51 ### Based on contribution from Jonathan Swinton <jonathan@swintons.net>
  52 ### in e-mail dated Wednesday, January 17, 2007
  53 .alignStringToVector <- function(aString) {
  54   ## poor mans parsing - separating string of form "l{2in}llr|p{1in}c|{1in}"
  55   ## into "l{2in}" "l"  "l"  "r" "|" "p{1in}" "c" "|{1in}"
  56   aString.Align <- character(0);
  57   aString.Width <- character(0);
  58   wString <- aString
  59   while( nchar(wString) > 0) {
  60     aString.Align <- c(aString.Align, substr(wString, 1, 1))
  61     ## is it followed by a brace?
  62     thisWidth <- ""
  63     if ( nchar(wString) > 1 & substr(wString, 2, 2) == "{") {
  64       beforeNextBrace <- regexpr("[^\\]\\}", wString)
  65       if (beforeNextBrace <0 ) {
  66         stop("No closing } in align string")
  67       }
  68       thisWidth <- substr(wString, 2, beforeNextBrace + 1)
  69       wString <- substr(wString, beforeNextBrace + 2, nchar(wString))
  70     } else {
  71       wString <- substr(wString, 2, nchar(wString))
  72     }
  73     aString.Width <- c(aString.Width, thisWidth)
  74   }
  75
  76   alignAllowed <- c("l","r","p","c","|","X")
  77
  78   if (any( !(aString.Align %in% alignAllowed))) {
  79     warning("Nonstandard alignments in align string")
  80   }
  81   res <- paste(aString.Align, aString.Width, sep = "")
  82   res
  83 }
  84 ###.alignStringToVector ("l{2in}llr|p{1in}c|{1in}")
  85 ###.alignStringToVector ("l{2in}llr|p{1in}c|")
  86 ### latex syntax error, but gives wrong alignment
  87 ###.alignStringToVector ("{2in}llr|p{1in}c|")
  88 ###.alignStringToVector("llllp{3cm}")
  89
  90 "align<-.xtable" <- function(x, value) {
  91 ### Based on contribution from Benno <puetz@mpipsykl.mpg.de>
  92 ### in e-mail dated Wednesday, December 01, 2004
  93 ### Based on contribution from Jonathan Swinton <jonathan@swintons.net>
  94 ### in e-mail dated Wednesday, January 17, 2007
  95   ## cat("%", value, "\n")
  96   if ( (!is.null(value)) && ( is.character(value) ) &&
  97        ( length(value) == 1 ) && ( nchar(value) > 1 ) ) {
  98         value <- .alignStringToVector(value)
  99   }
 100   ## That should have checked we had only lrcp|
 101   ## but what if the "if statement" is false?
 102   ## For simplicity, deleting check present in version 1.4-2 and earlier.
 103   c.value <- if (any(!is.na(match(value, "|")))) {
 104                value[-which(value == '|')]
 105              } else {
 106                value
 107              }
 108   if (length(c.value) != ncol(x) + 1)
 109     stop(paste("\"align\" must have length equal to",
 110                ncol(x) + 1, "( ncol(x) + 1 )"))
 111   attr(x, "align") <- value
 112   return(x)
 113 }
 114
 115 align <- function(x, ...) UseMethod("align")
 116 align.xtable <- function(x, ...) {
 117   return(attr(x, "align", exact = TRUE))
 118 }
 119
 120 "digits<-" <- function(x, value) UseMethod("digits<-")
 121 "digits<-.xtable" <- function(x, value) {
 122   if( is.matrix( value ) ) {
 123     if( ncol( value ) != ncol(x) + 1 || nrow( value ) != nrow(x) ) {
 124       stop( "if argument 'digits' is a matrix, it must have columns equal",
 125            " to ", ncol(x) + 1, " ( ncol(x) + 1 ) and rows equal to ", nrow(x),
 126            " ( nrow( x )" )
 127     }
 128   } else {
 129     if( length(value) == 1 ) { value <- rep(value, ncol(x) + 1) }
 130     if( length( value ) > 1 & length( value ) != ncol(x) + 1 ) {
 131       stop( "if argument 'digits' is a vector of length more than one, it must have length equal",
 132            " to ", ncol(x) + 1, " ( ncol(x) + 1 )" )
 133     }
 134   }
 135   if (!is.numeric(value))
 136     stop("\"digits\" must be numeric")
 137   attr(x, "digits") <- value
 138   return(x)
 139 }
 140
 141 digits <- function(x, ...) UseMethod("digits")
 142 digits.xtable <- function(x, ...) {
 143   return(attr(x, "digits", exact = TRUE))
 144 }
 145
 146 "display<-" <- function(x, value) UseMethod("display<-")
 147 "display<-.xtable" <- function(x, value) {
 148   if (length(value) != ncol(x) + 1)
 149     stop(paste("\"display\" must have length equal to",
 150                ncol(x) + 1, "( ncol(x) + 1 )"))
 151   if (!all(!is.na(match(value, c("d","f","e","E","g","G","fg","s")))))
 152     stop("\"display\" must be in {\"d\",\"f\",\"e\",\"E\",\"g\",\"G\", \"fg\", \"s\"}")
 153   attr(x, "display") <- value
 154   return(x)
 155 }
 156
 157 display <- function(x, ...) UseMethod("display")
 158 display.xtable <- function(x, ...) {
 159   return(attr(x, "display", exact = TRUE))
 160 }
 161