R/write.nexus.data.R

   1 "write.nexus.data" <- function (x, file, format = "dna", datablock = TRUE,
   2                                 interleaved = TRUE, charsperline = NULL,
   3                                 gap = NULL, missing = NULL)
   4 {
   5     # Nexus data parser.
   6     #
   7     # Version: 09/13/2006 09:06:33 AM CEST
   8     #
   9     # By:      Johan Nylander, nylander @ scs.fsu.edu
  10     #
  11     # TODO:    Standard data, mixed data, nice indent
  12     #------------------------------------------------------------------
  13
  14     indent          <- "  "  # Two blanks
  15     maxtax          <- 5     # Max nr of taxon names to be printed on a line
  16     defcharsperline <- 80    # Default nr of characters per line if interleaved
  17     defgap          <- "-"   # Default gap character
  18     defmissing      <- "?"   # Default missing data character
  19
  20     ntax <- length(x)
  21     nchars <- length(x[[1]])
  22     zz <- file(file, "w")
  23
  24     if (is.null(names(x))) {
  25         names(x) <- as.character(1:ntax)
  26     }
  27
  28     "fcat" <- function (..., file = zz)
  29     {
  30         cat(..., file = file, sep = "", append = TRUE)
  31     }
  32
  33     "find.max.length" <- function (x)
  34     {
  35         max <- 0
  36         for (i in 1:length(x)) {
  37            val <- length((strsplit(x[i], split = NULL))[[1]])
  38            if (val > max) {
  39                max <- val
  40            }
  41         }
  42         max
  43     }
  44
  45     "print.matrix" <- function(x, dindent = "    ")
  46     {
  47         Names <- names(x)
  48         printlength <- find.max.length(Names) + 2
  49         if (interleaved == FALSE) {
  50             for (i in 1:length(x)) {
  51                 sequence <- paste(x[[i]], collapse = "")
  52                 taxon <- Names[i]
  53                 thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
  54                 fcat(indent, indent, thestring, "\n")
  55             }
  56         }
  57         else {
  58             ntimes <- ceiling(nchars/charsperline)
  59             start <- 1
  60             end <- charsperline
  61             for (j in 1:ntimes) {
  62                 for (i in 1:length(x)) {
  63                     sequence <- paste(x[[i]][start:end], collapse = "")
  64                     taxon <- Names[i]
  65                     thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
  66                     fcat(indent, indent, thestring, "\n")
  67                 }
  68                 if (j < ntimes) {
  69                     fcat("\n")
  70                 }
  71                 start <- start + charsperline
  72                 end <- end + charsperline
  73                 if (end > nchars) {
  74                     end <- nchars
  75                 }
  76             }
  77         }
  78     }
  79
  80     fcat("#NEXUS\n[Data written by write.nexus.data.R,", " ", date(),"]\n")
  81
  82     NCHAR <- paste("NCHAR=", nchars, sep = "")
  83     NTAX <- paste("NTAX=", ntax, sep = "")
  84
  85     if (format == "dna") {
  86         DATATYPE <- "DATATYPE=DNA"
  87     }
  88     if (format == "protein") {
  89         DATATYPE <- "DATATYPE=PROTEIN"
  90     }
  91
  92     if (is.null(charsperline)) {
  93         if (nchars < defcharsperline) {
  94             charsperline <- nchars
  95             interleaved <- FALSE
  96         }
  97         else {
  98             if (nchars > defcharsperline) {
  99                 charsperline <- defcharsperline
 100             }
 101         }
 102     }
 103
 104     if (is.null(missing)) {
 105         MISSING <- paste("MISSING=", defmissing, sep = "")
 106     }
 107     else {
 108         MISSING <- paste("MISSING=", missing, sep = "")
 109     }
 110
 111     if (is.null(gap)) {
 112         GAP <- paste("GAP=", defgap, sep = "")
 113     }
 114     else {
 115         GAP <- paste("GAP=", gap, sep = "")
 116     }
 117
 118     if (interleaved == TRUE) {
 119         INTERLEAVE <- "INTERLEAVE=YES"
 120     }
 121     if (interleaved == FALSE) {
 122         INTERLEAVE <- "INTERLEAVE=NO"
 123     }
 124
 125     if (datablock == TRUE) {
 126         fcat("BEGIN DATA;\n")
 127         fcat(indent,"DIMENSIONS", " ", NTAX, " ", NCHAR, ";\n")
 128         if (format %in% c("dna", "protein")) {
 129             fcat(indent, "FORMAT", " ", DATATYPE, " ", MISSING, " ", GAP, " ", INTERLEAVE, ";\n") # from François Michonneau (2009-10-02)
 130         }
 131         fcat(indent,"MATRIX\n")
 132         print.matrix(x)
 133         fcat(indent, ";\n")
 134         fcat("END;\n\n")
 135     }
 136     else {
 137         fcat("BEGIN TAXA;\n")
 138         fcat(indent, "DIMENSIONS", " ", NTAX, ";\n")
 139         fcat(indent, "TAXLABELS\n")
 140         fcat(indent, indent)
 141         j <- 0
 142         for (i in 1:ntax) {
 143             fcat(names(x[i]), " ")
 144             j <- j + 1
 145             if (i == ntax) {
 146                 fcat("\n", indent, ";\n")
 147             }
 148             else {
 149                 if (j == maxtax) {
 150                     fcat("\n", indent, indent)
 151                     j <- 0
 152                 }
 153             }
 154         }
 155         fcat("END;\n\n")
 156         fcat("BEGIN CHARACTERS;\n")
 157         fcat(indent, "DIMENSIONS", " ", NCHAR, ";\n")
 158         if (format %in% c("dna", "protein")) {
 159             fcat(indent, "FORMAT", " ", MISSING, " ", GAP, " ", DATATYPE, " ", INTERLEAVE, ";\n")
 160         }
 161         fcat(indent,"MATRIX\n")
 162         print.matrix(x)
 163         fcat(indent, ";")
 164         fcat("\nEND;\n\n")
 165     }
 166     close(zz)
 167 }
 168