R/write.dna.R

   1 ## write.dna.R (2012-06-22)
   2
   3 ##   Write DNA Sequences in a File
   4
   5 ## Copyright 2003-2012 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 write.dna <- function(x, file, format = "interleaved", append = FALSE,
  11                       nbcol = 6, colsep = " ", colw = 10, indent = NULL,
  12                       blocksep = 1)
  13 {
  14     format <- match.arg(format, c("interleaved", "sequential", "fasta"))
  15     phylip <- if (format %in% c("interleaved", "sequential")) TRUE else FALSE
  16     if (inherits(x, "DNAbin")) x <- as.character(x)
  17     aligned <- TRUE
  18     if (is.matrix(x)) {
  19         N <- dim(x)
  20         S <- N[2]
  21         N <- N[1]
  22         xx <- vector("list", N)
  23         for (i in 1:N) xx[[i]] <- x[i, ]
  24         names(xx) <- rownames(x)
  25         x <- xx
  26         rm(xx)
  27     } else {
  28         N <- length(x)
  29         S <- unique(unlist(lapply(x, length)))
  30         if (length(S) > 1) aligned <- FALSE
  31     }
  32     if (is.null(names(x))) names(x) <- as.character(1:N)
  33     if (is.null(indent))
  34       indent <- if (phylip) 10 else  0
  35     if (is.numeric(indent))
  36         indent <- paste(rep(" ", indent), collapse = "")
  37     if (format == "interleaved") {
  38         blocksep <- paste(rep("\n", blocksep), collapse = "")
  39         if (nbcol < 0) format <- "sequential"
  40     }
  41     zz <- if (append) file(file, "a") else file(file, "w")
  42     on.exit(close(zz))
  43     if (phylip) {
  44         if (!aligned)
  45             stop("sequences must have the same length for
  46  interleaved or sequential format.")
  47         cat(N, " ", S, "\n", sep = "", file = zz)
  48         if (nbcol < 0) {
  49             nb.block <- 1
  50             nbcol <- totalcol <- ceiling(S/colw)
  51         } else {
  52             nb.block <- ceiling(S/(colw * nbcol))
  53             totalcol <- ceiling(S/colw)
  54         }
  55         ## Prepare the sequences in a matrix whose elements are
  56         ## strings with `colw' characters.
  57         SEQ <- matrix("", N, totalcol)
  58         for (i in 1:N) {
  59             X <- paste(x[[i]], collapse = "")
  60             for (j in 1:totalcol)
  61                 SEQ[i, j] <- substr(X, 1 + (j - 1)*colw, colw + (j - 1)*colw)
  62         }
  63         ## Prepare the names so that they all have the same nb of chars
  64         max.nc <- max(nchar(names(x)))
  65         ## always put a space between the sequences and the taxa names
  66         fmt <- paste("%-", max.nc + 1, "s", sep = "")
  67         names(x) <- sprintf(fmt, names(x))
  68     }
  69     switch(format, "interleaved" = {
  70         ## Write the first block with the taxon names
  71         colsel <- if (nb.block == 1) 1:totalcol else 1:nbcol
  72         for (i in 1:N) {
  73             cat(names(x)[i], file = zz)
  74             cat(SEQ[i, colsel], sep = colsep, file = zz)
  75             cat("\n", file = zz)
  76         }
  77         ## Write eventually the other blocks
  78         if (nb.block > 1) {
  79             for (k in 2:nb.block) {
  80                 cat(blocksep, file = zz)
  81                 endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
  82                 for (i in 1:N) {
  83                     cat(indent, file = zz)
  84                     cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
  85                     cat("\n", file = zz)
  86                 }
  87             }
  88         }
  89
  90     }, "sequential" = {
  91         if (nb.block == 1) {
  92             for (i in 1:N) {
  93                 cat(names(x)[i], file = zz)
  94                 cat(SEQ[i, ], sep = colsep, file = zz)
  95                 cat("\n", file = zz)
  96             }
  97         } else {
  98             for (i in 1:N) {
  99                 cat(names(x)[i], file = zz)
 100                 cat(SEQ[i, 1:nbcol], sep = colsep, file = zz)
 101                 cat("\n", file = zz)
 102                 for (k in 2:nb.block) {
 103                     endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
 104                     cat(indent, file = zz)
 105                     cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
 106                     cat("\n", file = zz)
 107                 }
 108             }
 109         }
 110     }, "fasta" = {
 111         for (i in 1:N) {
 112             cat(">", names(x)[i], file = zz, sep = "")
 113             cat("\n", file = zz)
 114             X <- paste(x[[i]], collapse = "")
 115             S <- length(x[[i]])
 116             totalcol <- ceiling(S/colw)
 117             if (nbcol < 0) nbcol <- totalcol
 118             nb.lines <- ceiling(totalcol/nbcol)
 119             SEQ <- character(totalcol)
 120             for (j in 1:totalcol)
 121                 SEQ[j] <- substr(X, 1 + (j - 1) * colw, colw + (j - 1) * colw)
 122             for (k in 1:nb.lines) {
 123                 endsel <-
 124                     if (k == nb.lines) length(SEQ) else nbcol + (k - 1)*nbcol
 125                 cat(indent, file = zz)
 126                 cat(SEQ[(1 + (k - 1)*nbcol):endsel], sep = colsep, file = zz)
 127                 cat("\n", file = zz)
 128             }
 129         }
 130     })
 131 }