R-alpha: generic write()

[Kurt Hornik]

Attached is a first shot at a generic write with my `old' write.table as
write.data.frame, suitably modified.  There is also a stupid generic
latex function, which is just there because it illustrates that the
extra arguments sep and eol are useful.

In playing with it, I noticed a few `problems'.

* The documentation for factor() says,

	If exclude is set to a zero length vector, then any NA values in
	x are used for form a new level for the factor.  This means that
	there will be no NA values in the result.

Perhaps I don't really understand this, but

R> x <- factor(c(1:3, NA), exclude=numeric(0))
R> x
[1]  1  2  3 NA
R> levels(x)
[1] "1" "2" "3"

???

* coerce.c has two error messages of the form

	error("use \"factor\", \"ordered\", \"cut\" or \"code\" to create factors\n");

but there is no function `code'.

* cat() is a bit inconsistent:

R> cat(x, sep = "&")
1&2&3&4R> cat(x, sep = "&\n")
1&
2&
3&
4
R>

Actually, a final newline is added whenever sep contains a newline.
>From src/main/builtin.c:

        nlsep = 0;
        for (i = 0; i < LENGTH(sepr); i++)
                if (strstr(CHAR(STRING(sepr)[i]), "\n")) nlsep = 1;

	...

        if ((pwidth != INT_MAX) || nlsep)
                Rprintf("\n");

I am not sure this is the right thing to do.

(In particular, it makes it rather messy to incrementally build data
files with `explicit' end-of-line strings (such as "\\") by appending
via cat().)

* I am not sure what should happen with names or dimnames when writing.

* I am also not sure what the optional argument quote should do.  Should
it quote UNCONDITIONALLY, or only the character strings?

-k

***********************************************************************
write <- function(x, file = "data", ...)  UseMethod("write")

write.default <-
function(x, file = "", append = FALSE, quote = FALSE, sep = " ", eol = "\n",
	 na = NA, ncolumns = if (is.character(x)) 1 else 5, ...) {
  if (is.matrix(x)) {
    write.data.frame(x, append = append, quote = quote, sep = sep,
		     eol = eol, na = na, col.names = FALSE, ...) 
  }
  else {
    if (is.factor(x))
      x <- levels(x)[x]
    else
      x <- as.vector(x)
    if (is.vector(x)) {
      x[is.na(x)] <- na
      if (quote)
	x <- paste("\"", x, "\"", sep = "")
      cat(x, file = file, sep = c(rep(sep, ncolumns - 1), eol),
	  append = append)
    }
    else
      stop("No suitable write method available")
  }
}

write.data.frame <-
function(x, file = "", append = FALSE, quote = FALSE, sep = " ", eol = "\n",
	 na = NA, row.names = TRUE, col.names = TRUE)
{
  if (is.data.frame(x) && is.logical(quote) && quote)
    quote <- which(unlist(lapply(x, is.character)))
  x <- as.matrix(x)
  p <- ncol(x)
  d <- dimnames(x)
  x[is.na(x)] <- na
  if (is.logical(quote))
    quote <- if (quote) 1 : p else NULL
  else if (is.numeric(quote)) {
    if (any(quote < 1 | quote > p))
      stop("invalid numbers in quote")
  }
  else
    stop("invalid quote specification")
      
  if (is.logical(row.names)) {
    if (row.names)
      x <- cbind(d[[1]], x)
  }
  else {
    row.names <- as.character(row.names)
    if (length(row.names) == nrow(x))
      x <- cbind(row.names, x)
    else
      stop("invalid row.names specification")
  }
  if (!is.null(quote) && (p < ncol(x)))
    quote <- c(0, quote) + 1

  if (is.logical(col.names))
    col.names <- if (col.names) d[[2]] else NULL
  else {
    col.names <- as.character(col.names)
    if (length(col.names) != p)
      stop("invalid col.names specification")
  }
  if (!is.null(col.names)) {
    if (append)
      warning("appending column names to file")
    if (!is.null(quote))
      col.names <- paste("\"", col.names, "\"", sep = "")
    cat(col.names, file = file, sep = rep(sep, p - 1), append = append)
    cat(eol, file = file, append = TRUE)
    append <- TRUE
  }

  for (i in quote)
    x[, i] <- paste("\"", x[, i], "\"", sep = "")

  cat(t(x), file = file, sep = c(rep(sep, ncol(x) - 1), eol),
      append = append)
}

latex <- function(x, file = "", ...)  UseMethod("latex")

latex.default <- 
function(x, file = "", ...) {
  write(x, file = file, sep = " & ", eol = " \\\\\n", ...)
}
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-