]> git.donarmstrong.com Git - xtable.git/blobdiff - pkg/R/print.xtable.R
Fixed bug #2795
[xtable.git] / pkg / R / print.xtable.R
index c0cce93ef7f9a2a37050769bf1b71e3a141a4fc2..35d4c4611bcce6ae00f3d7bd2edf885ac3fbf54c 100644 (file)
@@ -2,7 +2,7 @@
 ###\r
 ### Produce LaTeX and HTML tables from R objects.\r
 ###\r
-### Copyright 2000-2012 David B. Dahl <dahl@stat.tamu.edu>\r
+### Copyright 2000-2013 David B. Dahl <dahl@stat.tamu.edu>\r
 ###\r
 ### Maintained by Charles Roosen <croosen@mango-solutions.com>\r
 ###\r
@@ -29,6 +29,7 @@ print.xtable <- function(x,
   floating.environment = getOption("xtable.floating.environment", "table"),\r
   table.placement = getOption("xtable.table.placement", "ht"),\r
   caption.placement = getOption("xtable.caption.placement", "bottom"),\r
+  caption.width = getOption("xtable.caption.width", NULL),\r
   latex.environments = getOption("xtable.latex.environments", c("center")),\r
   tabular.environment = getOption("xtable.tabular.environment", "tabular"),\r
   size = getOption("xtable.size", NULL),\r
@@ -52,7 +53,8 @@ print.xtable <- function(x,
   booktabs = getOption("xtable.booktabs", FALSE),\r
   scalebox = getOption("xtable.scalebox", NULL),\r
   width = getOption("xtable.width", NULL),\r
-  timestamp = date(),\r
+  comment = getOption("xtable.comment", TRUE),\r
+  timestamp = getOption("xtable.timestamp", date()),\r
   ...)\r
 {\r
     ## If caption is length 2, treat the second value as the "short caption"\r
@@ -121,11 +123,11 @@ print.xtable <- function(x,
         ## Original code before changes in version 1.6-1\r
         ## PHEADER <- "\\hline\n"\r
 \r
-       ## booktabs code from Matthieu Stigler <matthieu.stigler@gmail.com>,\r
+           ## booktabs code from Matthieu Stigler <matthieu.stigler@gmail.com>,\r
         ## 1 Feb 2012\r
         if(!booktabs){\r
             PHEADER <- "\\hline\n"\r
-       } else {\r
+           } else {\r
             PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "")\r
             if(0%in%hline.after) {\r
                 PHEADER <- c(PHEADER, "\\midrule\n")\r
@@ -142,13 +144,13 @@ print.xtable <- function(x,
     if (!is.null(hline.after)) {\r
         ## booktabs change - Matthieu Stigler: fill the hline arguments\r
         ## separately, 1 Feb 2012\r
-       ##\r
+           ##\r
         ## Code before booktabs change was:\r
-       ##    add.to.row$pos[[npos+1]] <- hline.after\r
+           ##    add.to.row$pos[[npos+1]] <- hline.after\r
 \r
         if (!booktabs){\r
             add.to.row$pos[[npos+1]] <- hline.after\r
-       } else {\r
+           } else {\r
             for(i in 1:length(hline.after)) {\r
                 add.to.row$pos[[npos+i]] <- hline.after[i]\r
             }\r
@@ -165,7 +167,7 @@ print.xtable <- function(x,
                 lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2],\r
                                               paste(rep(add.to.row$command[i],\r
                                                         freq[j]),\r
-                                                    sep = "", collapse = ""),\r
+                                                sep = "", collapse = ""),\r
                                               sep = " ")\r
             }\r
         }\r
@@ -176,11 +178,13 @@ print.xtable <- function(x,
     if (!all(!is.na(match(type, c("latex","html"))))) {\r
         stop("\"type\" must be in {\"latex\", \"html\"}")\r
     }\r
-    if (!all(!is.na(match(floating.environment,\r
-                          c("table","table*","sidewaystable",\r
-                            "margintable"))))) {\r
-        stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}")\r
-    }\r
+    ## Disabling the check on known floating environments as many users \r
+    ## want to use additional environments.    \r
+    #    if (!all(!is.na(match(floating.environment,\r
+    #                          c("table","table*","sidewaystable",\r
+    #                            "margintable"))))) {\r
+    #        stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}")\r
+    #    }\r
     if (("margintable" %in% floating.environment)\r
         & (!is.null(table.placement))) {\r
         warning("margintable does not allow for table placement; setting table.placement to NULL")\r
@@ -256,17 +260,17 @@ print.xtable <- function(x,
                 tmp.index.start <- tmp.index.start + 1\r
             tmp.index.start <- tmp.index.start + 1\r
         }\r
-       ## Added "width" argument for use with "tabular*" or\r
+        ## Added "width" argument for use with "tabular*" or\r
         ## "tabularx" environments - CR, 7/2/12\r
-       if (is.null(width)){\r
+        if (is.null(width)){\r
             WIDTH <-""\r
-       } else if (is.element(tabular.environment,\r
+        } else if (is.element(tabular.environment,\r
                               c("tabular", "longtable"))){\r
             warning("Ignoring 'width' argument.  The 'tabular' and 'longtable' environments do not support a width specification.  Use another environment such as 'tabular*' or 'tabularx' to specify the width.")\r
             WIDTH <- ""\r
-       } else {\r
+        } else {\r
             WIDTH <- paste("{", width, "}", sep = "")\r
-       }\r
+        }\r
 \r
         BTABULAR <-\r
             paste("\\begin{", tabular.environment, "}",\r
@@ -300,12 +304,12 @@ print.xtable <- function(x,
         ## the \hline at the end, if present, is set in full matrix\r
         ETABULAR <- paste("\\end{", tabular.environment, "}\n", sep = "")\r
 \r
-       ## Add scalebox - CR, 7/2/12\r
-       if (!is.null(scalebox)){\r
+        ## Add scalebox - CR, 7/2/12\r
+        if (!is.null(scalebox)){\r
             BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR,\r
                               sep = "")\r
             ETABULAR <- paste(ETABULAR, "}\n", sep = "")\r
-       }\r
+        }\r
 \r
         ## BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail\r
         ## dated Wednesday, December 01, 2004\r
@@ -320,13 +324,21 @@ print.xtable <- function(x,
             ESIZE <- "}\n"\r
         }\r
         BLABEL <- "\\label{"\r
-        ELABEL <- "}\n"\r
-        if (is.null(short.caption)){\r
-        BCAPTION <- "\\caption{"\r
-    } else {\r
-        BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "")\r
-    }\r
-        ECAPTION <- "}\n"\r
+        ELABEL <- "}\n"                \r
+        ## Added caption width (jeff.laake@nooa.gov)\r
+           if(!is.null(caption.width)){\r
+               BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="")\r
+               ECAPTION <- "}"\r
+           } else {\r
+               BCAPTION <- NULL\r
+               ECAPTION <- NULL\r
+           }             \r
+           if (is.null(short.caption)){\r
+                  BCAPTION <- paste(BCAPTION,"\\caption{",sep="")\r
+           } else {\r
+                  BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="")\r
+           }   \r
+        ECAPTION <- paste(ECAPTION,"} \n",sep="")                              \r
         BROW <- ""\r
         EROW <- " \\\\ \n"\r
         BTH <- ""\r
@@ -411,9 +423,15 @@ print.xtable <- function(x,
         ETD  <- " </TD>"\r
         sanitize <- function(str) {\r
             result <- str\r
-            result <- gsub("&", "&amp ", result, fixed = TRUE)\r
-            result <- gsub(">", "&gt ", result, fixed = TRUE)\r
-            result <- gsub("<", "&lt ", result, fixed = TRUE)\r
+            ## Changed as suggested in bug report #2795\r
+            ## That is replacement of "&" is "&amp;"\r
+            ## instead of previous "&amp" etc\r
+            ## result <- gsub("&", "&amp ", result, fixed = TRUE)\r
+            ## result <- gsub(">", "&gt ", result, fixed = TRUE)\r
+            ## result <- gsub("<", "&lt ", result, fixed = TRUE)\r
+            result <- gsub("&", "&amp;", result, fixed = TRUE)\r
+            result <- gsub(">", "&gt;", result, fixed = TRUE)\r
+            result <- gsub("<", "&lt;", result, fixed = TRUE)\r
             ## Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05\r
             ## recommended not escaping underscores.\r
             ## result <- gsub("_", "\\_", result, fixed=TRUE)\r
@@ -436,12 +454,14 @@ print.xtable <- function(x,
     info <- R.Version()\r
     ## modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
     ## to set automatically the package version\r
-    result <- result + BCOMMENT + type + " table generated in " +\r
+       if (comment){\r
+        result <- result + BCOMMENT + type + " table generated in " +\r
               info$language + " " + info$major + "." + info$minor +\r
               " by xtable " +  packageDescription('xtable')$Version +\r
               " package" + ECOMMENT\r
-    if (!is.null(timestamp)){            \r
-        result <- result + BCOMMENT + timestamp + ECOMMENT\r
+        if (!is.null(timestamp)){                \r
+            result <- result + BCOMMENT + timestamp + ECOMMENT\r
+        }\r
     }          \r
     ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents\r
     if (!only.contents) {\r