pkg/R/print.xtable.R

   1 ### xtable package\r
   2 ###\r
   3 ### Produce LaTeX and HTML tables from R objects.\r
   4 ###\r
   5 ### Copyright 2000-2012 David B. Dahl <dahl@stat.tamu.edu>\r
   6 ###\r
   7 ### Maintained by Charles Roosen <croosen@mango-solutions.com>\r
   8 ###\r
   9 ### This file is part of the `xtable' library for R and related languages.\r
  10 ### It is made available under the terms of the GNU General Public\r
  11 ### License, version 2, or at your option, any later version,\r
  12 ### incorporated herein by reference.\r
  13 ###\r
  14 ### This program is distributed in the hope that it will be\r
  15 ### useful, but WITHOUT ANY WARRANTY; without even the implied\r
  16 ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
  17 ### PURPOSE.  See the GNU General Public License for more\r
  18 ### details.\r
  19 ###\r
  20 ### You should have received a copy of the GNU General Public\r
  21 ### License along with this program; if not, write to the Free\r
  22 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,\r
  23 ### MA 02111-1307, USA\r
  24 print.xtable <- function(\r
  25   x,\r
  26   type="latex",\r
  27   file="",\r
  28   append=FALSE,\r
  29   floating=TRUE,\r
  30   floating.environment="table",\r
  31   table.placement="ht",\r
  32   caption.placement="bottom",\r
  33   latex.environments=c("center"),\r
  34   tabular.environment="tabular",\r
  35   size=NULL,\r
  36   hline.after=c(-1,0,nrow(x)),\r
  37   NA.string="",\r
  38   include.rownames=TRUE,\r
  39   include.colnames=TRUE,\r
  40   only.contents=FALSE,\r
  41   add.to.row=NULL,\r
  42   sanitize.text.function=NULL,\r
  43   sanitize.rownames.function=sanitize.text.function,\r
  44   sanitize.colnames.function=sanitize.text.function,\r
  45   math.style.negative=FALSE,\r
  46   html.table.attributes="border=1",\r
  47   ...) {\r
  48   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after\r
  49   # By default it print an \hline before and after the columns names independently they are printed or not and at the end of the table\r
  50   # Old code that set hline.after should include c(-1, 0, nrow(x)) in the hline.after vector\r
  51   # If you do not want any \hline inside the data, set hline.after to NULL \r
  52   # PHEADER instead the string '\\hline\n' is used in the code\r
  53   # Now hline.after counts how many time a position appear  \r
  54   # I left an automatic PHEADER in the longtable is this correct?\r
  55 \r
  56   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames, include.colnames  \r
  57   pos <- 0\r
  58   if (include.rownames) pos <- 1\r
  59   \r
  60   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after checks\r
  61   if (any(hline.after < -1) | any(hline.after > nrow(x))) stop("'hline.after' must be inside [-1, nrow(x)]")\r
  62   \r
  63   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row checks\r
  64   if (!is.null(add.to.row)) {\r
  65     if (is.list(add.to.row) && length(add.to.row)==2) {\r
  66       if (is.null(names(add.to.row))) {\r
  67         names(add.to.row) <- c('pos', 'command')\r
  68       } else if (any(sort(names(add.to.row))!=c('command', 'pos'))) {\r
  69         stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")\r
  70       }\r
  71       if (is.list(add.to.row$pos) && is.vector(add.to.row$command, mode='character')) {\r
  72         if ((npos <- length(add.to.row$pos)) != length(add.to.row$command)) {\r
  73           stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")\r
  74         }\r
  75         if (any(unlist(add.to.row$pos) < -1) | any(unlist(add.to.row$pos) > nrow(x))) {\r
  76           stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")\r
  77         }\r
  78       } else {\r
  79         stop("the first argument ('pos') of 'add.to.row' must be a list, the second argument ('command') must be a vector of mode character")\r
  80       }\r
  81     } else {\r
  82       stop("'add.to.row' argument must be a list of length 2")\r
  83     }\r
  84   } else {\r
  85      add.to.row <- list(pos=list(), command=vector(length=0, mode="character"))\r
  86      npos <- 0\r
  87   }\r
  88 \r
  89   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row\r
  90   # Add further commands at the end of rows\r
  91   if (type=="latex") {\r
  92      PHEADER <- "\\hline\n"\r
  93   } else {\r
  94      PHEADER <- ""\r
  95   }\r
  96    \r
  97   lastcol <- rep(" ", nrow(x)+2)\r
  98   if (!is.null(hline.after)) {\r
  99      add.to.row$pos[[npos+1]] <- hline.after\r
 100      add.to.row$command <- c(add.to.row$command, PHEADER)\r
 101   }\r
 102   if ( length(add.to.row$command) > 0 ) {\r
 103     for (i in 1:length(add.to.row$command)) {\r
 104       addpos <- add.to.row$pos[[i]]\r
 105       freq <- table(addpos)\r
 106       addpos <- unique(addpos)\r
 107       for (j in 1:length(addpos)) {\r
 108         lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2], paste(rep(add.to.row$command[i], freq[j]), sep="", collapse=""), sep=" ")\r
 109       }\r
 110     }\r
 111   }\r
 112   \r
 113   if (length(type)>1) stop("\"type\" must have length 1")\r
 114   type <- tolower(type)\r
 115   if (!all(!is.na(match(type,c("latex","html"))))) stop("\"type\" must be in {\"latex\", \"html\"}")\r
 116   if (!all(!is.na(match(floating.environment,c("table","table*","sidewaystable"))))) stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\"}")\r
 117   if (!all(!is.na(match(unlist(strsplit(table.placement, split="")),c("H","h","t","b","p","!"))))) {\r
 118     stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")\r
 119   }\r
 120   if (!all(!is.na(match(caption.placement,c("bottom","top"))))) stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")\r
 121 \r
 122   if (type=="latex") {\r
 123     BCOMMENT <- "% "\r
 124     ECOMMENT <- "\n"\r
 125     # See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003 regarding "texfloat"\r
 126     # See e-mail form "Fernando Henrique Ferraz P. da Rosa" <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"\r
 127     if ( tabular.environment == "longtable" & floating == TRUE ) {\r
 128       warning("Attempt to use \"longtable\" with floating=TRUE. Changing to FALSE.")\r
 129       floating <- FALSE\r
 130     }\r
 131     if ( floating == TRUE ) {\r
 132       # See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>" dated 7-09-2003 regarding "suggestion for an amendment of the source"\r
 133       # See e-mail from "Mitchell, David" <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding "Additions to R xtable package"\r
 134       # See e-mail from "Garbade, Sven" <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22 regarding the floating environment.\r
 135       BTABLE <- paste("\\begin{", floating.environment, "}",ifelse(!is.null(table.placement),\r
 136         paste("[",table.placement,"]",sep=""),""),"\n",sep="")\r
 137       if ( is.null(latex.environments) || (length(latex.environments)==0) ) {\r
 138         BENVIRONMENT <- ""\r
 139         EENVIRONMENT <- ""\r
 140       }\r
 141       else {\r
 142         BENVIRONMENT <- ""\r
 143         EENVIRONMENT <- ""\r
 144         for ( i in 1:length(latex.environments) ) {\r
 145           if ( latex.environments[i] == "" ) next\r
 146           BENVIRONMENT <- paste(BENVIRONMENT, "\\begin{",latex.environments[i],"}\n",sep="")\r
 147           EENVIRONMENT <- paste("\\end{",latex.environments[i],"}\n",EENVIRONMENT,sep="")\r
 148         }\r
 149       }\r
 150       ETABLE <- paste("\\end{", floating.environment, "}\n", sep="")\r
 151     }\r
 152     else {\r
 153       BTABLE <- ""\r
 154       ETABLE <- ""\r
 155       BENVIRONMENT <- ""\r
 156       EENVIRONMENT <- ""\r
 157     }\r
 158 \r
 159     tmp.index.start <- 1\r
 160     if ( ! include.rownames ) {\r
 161       while ( attr(x,"align",exact=TRUE)[tmp.index.start] == '|' ) tmp.index.start <- tmp.index.start + 1\r
 162       tmp.index.start <- tmp.index.start + 1\r
 163     }\r
 164     BTABULAR <- paste("\\begin{",tabular.environment,"}{",\r
 165                       paste(c(attr(x, "align",exact=TRUE)[tmp.index.start:length(attr(x,"align",exact=TRUE))], "}\n"),\r
 166                             sep="", collapse=""),\r
 167                       sep="")\r
 168     \r
 169     ## fix 10-26-09 (robert.castelo@upf.edu) the following 'if' condition is added here to support\r
 170     ## a caption on the top of a longtable\r
 171     if (tabular.environment == "longtable" && caption.placement=="top") {\r
 172         BCAPTION <- "\\caption{"\r
 173         ECAPTION <- "} \\\\ \n"\r
 174         if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) BTABULAR <- paste(BTABULAR,  BCAPTION, attr(x,"caption",exact=TRUE), ECAPTION, sep="")\r
 175     }\r
 176     # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row position -1\r
 177     BTABULAR <- paste(BTABULAR,lastcol[1], sep="")\r
 178     # the \hline at the end, if present, is set in full matrix    \r
 179     ETABULAR <- paste("\\end{",tabular.environment,"}\n",sep="")\r
 180     \r
 181     # BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004\r
 182     if (is.null(size) || !is.character(size)) {\r
 183       BSIZE <- ""\r
 184       ESIZE <- ""\r
 185     } else {\r
 186       if(length(grep("^\\\\",size))==0){\r
 187         size <- paste("\\",size,sep="")\r
 188       }\r
 189       BSIZE <- paste("{",size,"\n",sep="")\r
 190       ESIZE <- "}\n"\r
 191     }\r
 192     BLABEL <- "\\label{"\r
 193     ELABEL <- "}\n"\r
 194     BCAPTION <- "\\caption{"\r
 195     ECAPTION <- "}\n"\r
 196     BROW <- ""\r
 197     EROW <- " \\\\ \n"\r
 198     BTH <- ""\r
 199     ETH <- ""\r
 200     STH <- " & "\r
 201     BTD1 <- " & "\r
 202     BTD2 <- ""\r
 203     BTD3 <- ""\r
 204     ETD  <- ""\r
 205     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
 206     sanitize <- function(str) {\r
 207       result <- str\r
 208       result <- gsub("\\\\","SANITIZE.BACKSLASH",result)\r
 209       result <- gsub("$","\\$",result,fixed=TRUE)\r
 210       result <- gsub(">","$>$",result,fixed=TRUE)\r
 211       result <- gsub("<","$<$",result,fixed=TRUE)\r
 212       result <- gsub("|","$|$",result,fixed=TRUE)\r
 213       result <- gsub("{","\\{",result,fixed=TRUE)\r
 214       result <- gsub("}","\\}",result,fixed=TRUE)\r
 215       result <- gsub("%","\\%",result,fixed=TRUE)\r
 216       result <- gsub("&","\\&",result,fixed=TRUE)\r
 217       result <- gsub("_","\\_",result,fixed=TRUE)\r
 218       result <- gsub("#","\\#",result,fixed=TRUE)\r
 219       result <- gsub("^","\\verb|^|",result,fixed=TRUE)\r
 220       result <- gsub("~","\\~{}",result,fixed=TRUE)\r
 221       result <- gsub("SANITIZE.BACKSLASH","$\\backslash$",result,fixed=TRUE)\r
 222       return(result)\r
 223     }\r
 224     sanitize.numbers <- function(x) {\r
 225       result <- x\r
 226       if ( math.style.negative ) {\r
 227         # Jake Bowers <jwbowers@illinois.edu> in e-mail from 2008-08-20 suggested\r
 228         # disabling this feature to avoid problems with LaTeX's dcolumn package.\r
 229         # by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de> in e-mail\r
 230         # from 2008-10-03 requested the ability to use the old behavior.\r
 231         for(i in 1:length(x)) {\r
 232           result[i] <- gsub("-","$-$",result[i],fixed=TRUE)\r
 233         }\r
 234       }\r
 235       return(result)\r
 236     }\r
 237     sanitize.final <- function(result) {\r
 238       return(result)\r
 239     }\r
 240   } else {\r
 241     BCOMMENT <- "<!-- "\r
 242     ECOMMENT <- " -->\n"\r
 243     BTABLE <- paste("<TABLE ",html.table.attributes,">\n",sep="")\r
 244     ETABLE <- "</TABLE>\n"\r
 245     BENVIRONMENT <- ""\r
 246     EENVIRONMENT <- ""\r
 247     BTABULAR <- ""\r
 248     ETABULAR <- ""\r
 249     BSIZE <- ""\r
 250     ESIZE <- ""\r
 251     BLABEL <- "<A NAME="\r
 252     ELABEL <- "></A>\n"\r
 253     BCAPTION <- paste("<CAPTION ALIGN=\"",caption.placement,"\"> ",sep="")\r
 254     ECAPTION <- " </CAPTION>\n"\r
 255     BROW <- "<TR>"\r
 256     EROW <- " </TR>\n"\r
 257     BTH <- " <TH> "\r
 258     ETH <- " </TH> "\r
 259     STH <- " </TH> <TH> "\r
 260     BTD1 <- " <TD align=\""\r
 261     align.tmp <- attr(x,"align",exact=TRUE)\r
 262     align.tmp <- align.tmp[align.tmp!="|"]\r
 263     BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],nrow=nrow(x),ncol=ncol(x)+pos,byrow=TRUE)\r
 264     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
 265     BTD2[regexpr("^p",BTD2)>0] <- "left"\r
 266     BTD2[BTD2=="r"] <- "right"\r
 267     BTD2[BTD2=="l"] <- "left"\r
 268     BTD2[BTD2=="c"] <- "center"\r
 269     BTD3 <- "\"> "\r
 270     ETD  <- " </TD>"\r
 271     sanitize <- function(str) {\r
 272       result <- str\r
 273       result <- gsub("&","&amp ",result,fixed=TRUE)\r
 274       result <- gsub(">","&gt ",result,fixed=TRUE)\r
 275       result <- gsub("<","&lt ",result,fixed=TRUE)\r
 276       # Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05 recommended not escaping underscores.\r
 277       # result <- gsub("_", "\\_", result, fixed=TRUE)\r
 278       return(result)\r
 279     }\r
 280     sanitize.numbers <- function(x) {\r
 281       return(x)\r
 282     }\r
 283     sanitize.final <- function(result) {\r
 284       # Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de> in e-mail dated 2005-07-30.\r
 285       result$text <- gsub("  *"," ", result$text,fixed=TRUE)\r
 286       result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)\r
 287       return(result)\r
 288     }\r
 289   }\r
 290 \r
 291   result <- string("",file=file,append=append)\r
 292   info <- R.Version()\r
 293   # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 to set automatically the package version\r
 294   result <- result + BCOMMENT + type + " table generated in " +\r
 295             info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT\r
 296   result <- result + BCOMMENT + date() + ECOMMENT\r
 297   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents\r
 298   if (!only.contents) {\r
 299     result <- result + BTABLE\r
 300     result <- result + BENVIRONMENT\r
 301     if ( floating == TRUE ) {\r
 302       if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
 303       if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL  \r
 304     }\r
 305     result <- result + BSIZE\r
 306     result <- result + BTABULAR\r
 307   }\r
 308   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.colnames, include.rownames \r
 309   if (include.colnames) {\r
 310     result <- result + BROW + BTH\r
 311     if (include.rownames) result <- result + STH\r
 312     if (is.null(sanitize.colnames.function)) {                                     # David G. Whiting in e-mail 2007-10-09\r
 313       result <- result + paste(sanitize(names(x)),collapse=STH)\r
 314     } else {\r
 315       result <- result + paste(sanitize.colnames.function(names(x)), collapse=STH) # David G. Whiting in e-mail 2007-10-09\r
 316     }\r
 317     result <- result + ETH + EROW\r
 318   }\r
 319 \r
 320   cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)\r
 321   if (include.rownames) {\r
 322     if (is.null(sanitize.rownames.function)) {                                     # David G. Whiting in e-mail 2007-10-09\r
 323       cols[,1] <- sanitize(row.names(x))\r
 324     } else {\r
 325       cols[,1] <- sanitize.rownames.function(row.names(x))                         # David G. Whiting in e-mail 2007-10-09\r
 326     }\r
 327   }\r
 328 \r
 329 ## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com]\r
 330 ## 06 Dec 2011\r
 331 ##\r
 332 #  disp <- function(y) {\r
 333 #    if (is.factor(y)) {\r
 334 #      y <- levels(y)[y]\r
 335 #    }\r
 336 #    if (is.list(y)) {\r
 337 #      y <- unlist(y)\r
 338 #    }\r
 339 #    return(y)\r
 340 #  }\r
 341   varying.digits <- is.matrix( attr( x, "digits",exact=TRUE ) )\r
 342   # Code for letting "digits" be a matrix was provided by Arne Henningsen <ahenningsen@agric-econ.uni-kiel.de> in e-mail dated 2005-06-04.\r
 343   #if( !varying.digits ) {\r
 344     # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
 345   #  attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )\r
 346   #}\r
 347   for(i in 1:ncol(x)) {\r
 348         xcol <- x[,i]\r
 349         if(is.factor(xcol))\r
 350                 xcol <- as.character(xcol)\r
 351         if(is.list(xcol))\r
 352                 xcol <- sapply(xcol,unlist)\r
 353     ina <- is.na(xcol)\r
 354     is.numeric.column <- is.numeric(xcol)\r
 355 \r
 356         if(is.character(xcol))\r
 357                 cols[,i+pos] <- xcol\r
 358         else if(!varying.digits){\r
 359                 cols[,i+pos] <-\r
 360                         formatC( xcol,\r
 361                         format = ifelse( attr( x, "digits",exact=TRUE )[i+1] < 0, "E", \r
 362                         attr( x, "display",exact=TRUE )[i+1] ), \r
 363                         digits = abs( attr( x, "digits",exact=TRUE )[i+1] ), \r
 364                         decimal.mark=options()$OutDec)\r
 365     }else{\r
 366                 for( j in 1:nrow( cols ) ) {\r
 367                 ### modified Claudio Agostinelli <claudio@unive.it> dated 2009-09-14\r
 368                 ### add decimal.mark=options()$OutDec\r
 369                 cols[j,i+pos] <-\r
 370                         formatC( xcol[j],\r
 371                         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)\r
 372                 }\r
 373         }\r
 374         ## End Ian Fellows changes\r
 375         \r
 376     if ( any(ina) ) cols[ina,i+pos] <- NA.string\r
 377     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
 378     if ( is.numeric.column ) {\r
 379       cols[,i+pos] <- sanitize.numbers(cols[,i+pos])\r
 380     } else {\r
 381       if (is.null(sanitize.text.function)) {\r
 382         cols[,i+pos] <- sanitize(cols[,i+pos])\r
 383       } else {\r
 384         cols[,i+pos] <- sanitize.text.function(cols[,i+pos])\r
 385       }\r
 386     }\r
 387   }\r
 388 \r
 389   multiplier <- 5\r
 390   full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)\r
 391   full[,1] <- BROW\r
 392   full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1\r
 393   full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2\r
 394   full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3\r
 395   full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols\r
 396   full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD\r
 397 \r
 398   full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")\r
 399   if (type=="latex") full[,2] <- ""\r
 400   result <- result + lastcol[2] + paste(t(full),collapse="")\r
 401   if (!only.contents) {\r
 402     if (tabular.environment == "longtable") {\r
 403       result <- result + PHEADER\r
 404       ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid\r
 405       ## that bottom caption interferes with a top caption of a longtable\r
 406       if(caption.placement=="bottom"){\r
 407         if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
 408       }\r
 409       if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL\r
 410       ETABULAR <- "\\end{longtable}\n"\r
 411     }\r
 412     result <- result + ETABULAR\r
 413     result <- result + ESIZE\r
 414     if ( floating == TRUE ) {\r
 415       if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
 416       if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL  \r
 417     }\r
 418     result <- result + EENVIRONMENT\r
 419     result <- result + ETABLE\r
 420   }   \r
 421   result <- sanitize.final(result)\r
 422   print(result)\r
 423 \r
 424   return(invisible(result$text))\r
 425 }\r
 426 \r
 427 "+.string" <- function(x,y) {\r
 428   x$text <- paste(x$text,as.string(y)$text,sep="")\r
 429   return(x)\r
 430 }\r
 431 \r
 432 print.string <- function(x,...) {\r
 433   cat(x$text,file=x$file,append=x$append)\r
 434   return(invisible())\r
 435 }\r
 436 \r
 437 string <- function(text,file="",append=FALSE) {\r
 438   x <- list(text=text,file=file,append=append)\r
 439   class(x) <- "string"\r
 440   return(x)\r
 441 }\r
 442 \r
 443 as.string <- function(x,file="",append=FALSE) {\r
 444   if (is.null(attr(x,"class",exact=TRUE)))\r
 445   switch(data.class(x),\r
 446       character=return(string(x,file,append)),\r
 447       numeric=return(string(as.character(x),file,append)),\r
 448       stop("Cannot coerse argument to a string"))\r
 449   if (class(x)=="string")\r
 450     return(x)\r
 451   stop("Cannot coerse argument to a string")\r
 452 }\r
 453 \r
 454 is.string <- function(x) {\r
 455   return(class(x)=="string")\r
 456 }\r
 457 \r