"write.nexus.data" <- function (x, file, format = "dna", datablock = TRUE,
interleaved = TRUE, charsperline = NULL,
gap = NULL, missing = NULL)
{
# Nexus data parser.
#
# Version: 09/13/2006 09:06:33 AM CEST
#
# By: Johan Nylander, nylander @ scs.fsu.edu
#
# TODO: Standard data, mixed data, nice indent
#------------------------------------------------------------------
indent <- " " # Two blanks
maxtax <- 5 # Max nr of taxon names to be printed on a line
defcharsperline <- 80 # Default nr of characters per line if interleaved
defgap <- "-" # Default gap character
defmissing <- "?" # Default missing data character
ntax <- length(x)
nchars <- length(x[[1]])
zz <- file(file, "w")
if (is.null(names(x))) {
names(x) <- as.character(1:ntax)
}
"fcat" <- function (..., file = zz)
{
cat(..., file = file, sep = "", append = TRUE)
}
"find.max.length" <- function (x)
{
max <- 0
for (i in 1:length(x)) {
val <- length((strsplit(x[i], split = NULL))[[1]])
if (val > max) {
max <- val
}
}
max
}
"print.matrix" <- function(x, dindent = " ")
{
Names <- names(x)
printlength <- find.max.length(Names) + 2
if (interleaved == FALSE) {
for (i in 1:length(x)) {
sequence <- paste(x[[i]], collapse = "")
taxon <- Names[i]
thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
fcat(indent, indent, thestring, "\n")
}
}
else {
ntimes <- ceiling(nchars/charsperline)
start <- 1
end <- charsperline
for (j in 1:ntimes) {
for (i in 1:length(x)) {
sequence <- paste(x[[i]][start:end], collapse = "")
taxon <- Names[i]
thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
fcat(indent, indent, thestring, "\n")
}
if (j < ntimes) {
fcat("\n")
}
start <- start + charsperline
end <- end + charsperline
if (end > nchars) {
end <- nchars
}
}
}
}
fcat("#NEXUS\n[Data written by write.nexus.data.R,", " ", date(),"]\n")
NCHAR <- paste("NCHAR=", nchars, sep = "")
NTAX <- paste("NTAX=", ntax, sep = "")
if (format == "dna") {
DATATYPE <- "DATATYPE=DNA"
}
if (format == "protein") {
DATATYPE <- "DATATYPE=PROTEIN"
}
if (is.null(charsperline)) {
if (nchars < defcharsperline) {
charsperline <- nchars
interleaved <- FALSE
}
else {
if (nchars > defcharsperline) {
charsperline <- defcharsperline
}
}
}
if (is.null(missing)) {
MISSING <- paste("MISSING=", defmissing, sep = "")
}
else {
MISSING <- paste("MISSING=", missing, sep = "")
}
if (is.null(gap)) {
GAP <- paste("GAP=", defgap, sep = "")
}
else {
GAP <- paste("GAP=", gap, sep = "")
}
if (interleaved == TRUE) {
INTERLEAVE <- "INTERLEAVE=YES"
}
if (interleaved == FALSE) {
INTERLEAVE <- "INTERLEAVE=NO"
}
if (datablock == TRUE) {
fcat("BEGIN DATA;\n")
fcat(indent,"DIMENSIONS", " ", NTAX, " ", NCHAR, ";\n")
if (format %in% c("dna", "protein")) {
fcat(indent, "FORMAT", " ", DATATYPE, " ", MISSING, " ", GAP, " ", INTERLEAVE, ";\n") # from François Michonneau (2009-10-02)
}
fcat(indent,"MATRIX\n")
print.matrix(x)
fcat(indent, ";\n")
fcat("END;\n\n")
}
else {
fcat("BEGIN TAXA;\n")
fcat(indent, "DIMENSIONS", " ", NTAX, ";\n")
fcat(indent, "TAXLABELS\n")
fcat(indent, indent)
j <- 0
for (i in 1:ntax) {
fcat(names(x[i]), " ")
j <- j + 1
if (i == ntax) {
fcat("\n", indent, ";\n")
}
else {
if (j == maxtax) {
fcat("\n", indent, indent)
j <- 0
}
}
}
fcat("END;\n\n")
fcat("BEGIN CHARACTERS;\n")
fcat(indent, "DIMENSIONS", " ", NCHAR, ";\n")
if (format %in% c("dna", "protein")) {
fcat(indent, "FORMAT", " ", MISSING, " ", GAP, " ", DATATYPE, " ", INTERLEAVE, ";\n")
}
fcat(indent,"MATRIX\n")
print.matrix(x)
fcat(indent, ";")
fcat("\nEND;\n\n")
}
close(zz)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.