R/write.dna.R

   1 ## write.dna.R (2009-05-10)
   2
   3 ##   Write DNA Sequences in a File
   4
   5 ## Copyright 2003-2009 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         ## in case all names are 10 char long or less, sequences are
  66         ## always started on the 11th column of the file
  67         if (max.nc < 11) max.nc <- 9
  68         fmt <- paste("%-", max.nc + 1, "s", sep = "")
  69         names(x) <- sprintf(fmt, names(x))
  70     }
  71     if (format == "interleaved") {
  72         ## Write the first block with the taxon names
  73         colsel <- if (nb.block == 1) 1:totalcol else 1:nbcol
  74         for (i in 1:N) {
  75             cat(names(x)[i], file = zz)
  76             cat(SEQ[i, colsel], sep = colsep, file = zz)
  77             cat("\n", file = zz)
  78         }
  79         ## Write eventually the other blocks
  80         if (nb.block > 1) {
  81             for (k in 2:nb.block) {
  82                 cat(blocksep, file = zz)
  83                 endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
  84                 for (i in 1:N) {
  85                     cat(indent, file = zz)
  86                     cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
  87                     cat("\n", file = zz)
  88                 }
  89             }
  90         }
  91
  92     }
  93     if (format == "sequential") {
  94         if (nb.block == 1) {
  95             for (i in 1:N) {
  96                 cat(names(x)[i], file = zz)
  97                 cat(SEQ[i, ], sep = colsep, file = zz)
  98                 cat("\n", file = zz)
  99             }
 100         } else {
 101             for (i in 1:N) {
 102                 cat(names(x)[i], file = zz)
 103                 cat(SEQ[i, 1:nbcol], sep = colsep, file = zz)
 104                 cat("\n", file = zz)
 105                 for (k in 2:nb.block) {
 106                     endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
 107                     cat(indent, file = zz)
 108                     cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
 109                     cat("\n", file = zz)
 110                 }
 111             }
 112         }
 113     }
 114     if (format == "fasta") {
 115         for (i in 1:N) {
 116             cat(">", names(x)[i], file = zz)
 117             cat("\n", file = zz)
 118             X <- paste(x[[i]], collapse = "")
 119             S <- length(x[[i]])
 120             totalcol <- ceiling(S/colw)
 121             if (nbcol < 0) nbcol <- totalcol
 122             nb.lines <- ceiling(totalcol/nbcol)
 123             SEQ <- character(totalcol)
 124             for (j in 1:totalcol)
 125                 SEQ[j] <- substr(X, 1 + (j - 1) * colw, colw + (j - 1) * colw)
 126             for (k in 1:nb.lines) {
 127                 endsel <-
 128                     if (k == nb.lines) length(SEQ) else nbcol + (k - 1)*nbcol
 129                 cat(indent, file = zz)
 130                 cat(SEQ[(1 + (k - 1)*nbcol):endsel], sep = colsep, file = zz)
 131                 cat("\n", file = zz)
 132             }
 133         }
 134     }
 135 }