.packageName <- "ComPairWise"
`aln.files` <-
function (name1, name2, n) 
{
    name.vector <- vector(mode = "character", length = n)
    name.vector[1] <- name1
    name.vector[2] <- name2
    for (i in 1:n) {
        if (name.vector[i] == "") 
            name.vector[i] <- readline(paste("Filename for alignment ", 
                i, "? ", sep = ""))
        if (name.vector[i] == "") 
            stop("Exiting--you didn't enter a filename!", call. = FALSE)
    }
    return(name.vector)
}
`aln.to.matrix` <-
function (alignment, taxa = FALSE) 
{
    dna.only <- alignment$seq
    dna.mat <- t(sapply(strsplit(dna.only, split = ""), as.matrix))
    if (taxa) 
        rownames(dna.mat) <- alignment$nam
    return(dna.mat)
}
`check.format` <-
function (filename) 
{
    options(warn = -1)
    on.exit(options(warn = 0))
    if (exists(filename)) {
        if (class(get(filename)) == "alignment") 
            aln.format <- "object"
    }
    else {
        is.nexus <- length(grep("#nexus|begin", scan(file = filename, 
            what = "c", nlines = 1, quiet = T), ignore.case = T)) > 
            0
        if (is.nexus) 
            is.phylip <- FALSE
        if (!is.nexus) 
            is.phylip <- (!is.na(as.numeric(scan(file = filename, 
                nlines = 1, quiet = T, what = "c"))) && length(scan(file = filename, 
                nlines = 1, quiet = T)) == 2)
        if (!is.nexus && !is.phylip) {
            aln.format <- "neither"
            stop(paste(filename, "isn't a NEXUS or a PHYLIP file!  Exiting."), 
                call. = FALSE)
        }
        if (is.nexus) 
            aln.format <- "nexus"
        if (is.phylip) 
            aln.format <- "phylip"
    }
    return(aln.format)
}
`comp.all` <-
function (align, n, ref.index) 
{
    comp.cols <- function(column) {
        if (any(!is.na(column))) {
            ref.row <- which(column > 0)[1]
            if (!is.na(ref.row)) {
                comp.vec <- c()
                for (i in 1:n) {
                  col <- which(align[ref.row, , i] == column[ref.row])
                  comp.vec <- c(comp.vec, identical(column, align[, 
                    col, i]))
                }
                comp <- all(comp.vec)
            }
            else {
                comp <- NA
            }
        }
        else {
            comp <- NA
        }
    }
    ref.align <- align[, , ref.index]
    col.ident <- apply(align[, , ref.index], 2, comp.cols)
}
`comp.mat` <-
function (align1, align2, cols1, cols2, ref, i, j, name1, name2) 
{
    all.na <- function(column) all(is.na(column))
    if (ref == "longest") {
        if (cols2 > cols1) {
            ref.align <- align2
            other.align <- align1
        }
        else {
            ref.align <- align1
            other.align <- align2
        }
    }
    else {
        if (ref == name1 || ref == i) {
            ref.align <- align1
            other.align <- align2
        }
        if (ref == name2 || ref == j) {
            ref.align <- align2
            other.align <- align1
        }
    }
    ref.align <- ref.align[, which(apply(ref.align, 2, all.na) == 
        FALSE)]
    other.align <- other.align[, which(apply(other.align, 2, 
        all.na) == FALSE)]
    comp.col <- function(column) {
        row <- which(column > 0)[1]
        if (!is.na(row)) {
            col <- which(other.align[row, ] == column[row])
            comp <- identical(column, other.align[, col])
        }
        else {
            comp <- NA
        }
    }
    col.ident <- apply(ref.align, 2, comp.col)
}
`cpw` <-
function (name1 = "", name2 = "", ref = "", n = 2, out = "screen", 
    outfile = "", graph = "screen", gr.file = "", pairwise = TRUE, 
    onegraph = TRUE, nexus.out = TRUE, keep = FALSE, gap = "-", 
    miss = "?", ...) 
{
    cpw.out <- c()
    if (graph == "" || graph == "none" || graph == FALSE) {
        graph <- FALSE
    }
    else {
        gr.type <- graph
        graph <- TRUE
    }
    if ((out == "screen" || out == "") && outfile != "") 
        out <- "file"
    if (out == "file") {
        if (outfile == "") 
            outfile <- "compairwise.out"
        sink(outfile)
    }
    name <- aln.files(name1, name2, n)
    if (ref == "") {
        ref <- readline("If you want to define a reference alignment, which one? (or leave blank to use longest alignment as ref) ")
    }
    if ((ref %in% name || ref %in% (1:n)) == FALSE) 
        ref <- "longest"
    for (i in 1:n) {
        writeLines(paste("Alignment ", i, ": ", name[i], sep = ""))
    }
    writeLines(paste("Referencing to ", ref, "\n", sep = ""))
    formats <- sapply(name, check.format)
    bases <- c("A", "G", "C", "T", "a", "c", "g", "t", "U", "u")
    ambig.bases <- c("Y", "R", "K", "M", "W", "S", "B", "H", 
        "D", "V", "N", "y", "r", "k", "m", "w", "s", "b", "h", 
        "d", "v", "n")
    all.bases <- c(bases, ambig.bases)
    non.bases <- c(gap, miss)
    align.count <- c()
    for (i in 1:n) {
        if (formats[i] == "nexus") 
            aln <- read.nexus(name[i])
        if (formats[i] == "phylip") 
            aln <- read.phylip(name[i])
        if (formats[i] == "object") 
            aln <- get(name[i])
        dna.mat <- aln.to.matrix(aln, taxa = FALSE)
        if (all(dna.mat %in% c(all.bases, non.bases) == FALSE)) 
            writeLines(paste("\n", "Warning! Non-DNA, non-gap character(s) found in ", 
                name[i], " ...", sep = ""))
        align.new <- vectorize.alignment(dna.mat, all.bases, 
            non.bases)
        align.count[i] <- ncol(align.new)
        if (i == 1) {
            longest <- 1
            align <- array(c(align.new, rep(NA, times = (ncol(align.new) * 
                nrow(align.new) * (n - 1)))), c(nrow(align.new), 
                ncol(align.new), n))
        }
        else {
            if (ncol(align.new) > ncol(align[, , 1])) {
                longest <- i
                align.temp <- array(NA, c(nrow(align.new), ncol(align.new), 
                  n))
                for (j in 1:(i - 1)) {
                  align.temp[, , j] <- c(align[, , j], rep(NA, 
                    times = (ncol(align.temp[, , 1]) - ncol(align[, 
                      , 1])) * nrow(align.temp[, , 1])))
                }
                align <- align.temp
            }
            align[, , i] <- c(align.new, rep(NA, times = (ncol(align[, 
                , 1]) - ncol(align.new)) * nrow(align.new)))
        }
    }
    if (pairwise == TRUE) {
        if (ref == "longest") {
            i.set <- 1:(n - 1)
        }
        else {
            if (ref %in% 1:n) {
                i.set <- as.numeric(ref)
                j.set <- (1:n)
                j.set <- j.set[which(j.set != ref)]
            }
            else {
                if (ref %in% name) {
                  i.set <- which(name == ref)
                  j.set <- (1:n)
                  j.set <- j.set[which(j.set != ref)]
                }
            }
        }
        for (i in i.set) {
            if (ref == "longest") {
                j.set <- (i + 1):n
            }
            else {
                j.set <- (1:n)[which((1:n) != i.set)]
            }
            for (j in j.set) {
                col.ident <- comp.mat(align1 = align[, , i], 
                  align2 = align[, , j], cols1 = align.count[i], 
                  cols2 = align.count[j], ref, i = i, j = j, 
                  name1 = name[i], name2 = name[j])
                ident.set <- which(col.ident == TRUE)
                diff.set <- which(col.ident == FALSE)
                num.ident <- as.numeric(col.ident)
                end.points <- endpoints(ident.set, diff.set)
                totals <- data.frame(cols1 <- align.count[i], 
                  cols2 <- align.count[j], cols = length(col.ident), 
                  idents = length(which(col.ident)), nonidents = length(which(!col.ident)), 
                  all_gap_missing = length(which(is.na(col.ident))))
                colnames(totals) <- c("cols_align1", "cols_align2", 
                  "cols_compared", "n_ident", "n_diff", "n_gap_miss")
                id.s <- long.string(col.ident)
                writeLines(paste("\nComparing ", name[i], " and ", 
                  name[j], ".", sep = ""))
                writeLines(paste("\n", "As a string (+ matches, - doesn't, o is all gap/missing):", 
                  "\n", id.s, "\n", sep = ""))
                writeLines(paste("Columns in alignment 1:", "\n", 
                  totals$cols_align1, sep = ""))
                writeLines(paste("Columns in alignment 2:", "\n", 
                  totals$cols_align2, sep = ""))
                writeLines(paste("Columns considered:", "\n", 
                  totals$cols_compared, sep = ""))
                writeLines(paste("Identical columns:", "\n", 
                  totals$n_ident, sep = ""))
                writeLines(paste("Different columns:", "\n", 
                  totals$n_diff, sep = ""))
                writeLines(paste("All gap/missing columns in ref alignment:", 
                  "\n", totals$n_gap_miss, sep = ""))
                if (graph) {
                  if (gr.file == "") {
                    if (outfile == "") 
                      gr.file <- "compairwise"
                    else gr.file <- outfile
                  }
                  if (onegraph == FALSE) {
                    if (i == i.set[1] && j == j.set[1]) 
                      gr.file.in <- gr.file
                    gr.file <- paste(gr.file.in, as.character(i), 
                      as.character(j), sep = "")
                  }
                  if (onegraph == FALSE || (onegraph == TRUE && 
                    i == i.set[1] && j == j.set[1])) {
                    if (gr.type == "ps" || gr.type == "postscript" || 
                      gr.type == "PS") 
                      postscript(file = paste(gr.file, ".ps", 
                        sep = ""), width = 10, height = 4)
                    if (gr.type == "eps" || gr.type == "EPS") 
                      postscript(file = paste(gr.file, ".eps", 
                        sep = ""), onefile = FALSE, width = 10, 
                        height = 4)
                    if (gr.type == "jpeg" || gr.type == "jpg" || 
                      gr.type == "JPG" || gr.type == "JPEG") 
                      jpeg(filename = paste(gr.file, ".jpg", 
                        sep = ""), width = 960, height = 480)
                    if (gr.type == "pdf" || gr.type == "PDF") 
                      pdf(file = paste(gr.file, ".pdf", sep = ""), 
                        width = 10, height = 4)
                    if (gr.type == "png" || gr.type == "PNG") 
                      png(filename = paste(gr.file, ".png", sep = ""), 
                        width = 960, height = 480)
                    if (gr.type == "bmp" || gr.type == "BMP") 
                      bmp(filename = paste(gr.file, ".bmp", sep = ""), 
                        width = 960, height = 480)
                    plot(c(1, dim(align)[2]), c(0, 1.1), axes = F, 
                      xaxt = "n", yaxt = "n", bty = "L", type = "n", 
                      xlab = "position in reference alignment", 
                      ylab = "", font.lab = 4, cex.lab = 0.75)
                  }
                  if (onegraph && n > 2) 
                    linecol <- matrix(rainbow(n^2), n, n)[i, 
                      j]
                  else linecol <- "blue"
                  lines(num.ident, lwd = 1.5, col = linecol)
                  axis(side = 1, las = 1, lwd = 1, at = c(1, 
                    end.points, length(num.ident)), font = 1, 
                    cex.axis = 0.75)
                  axis(side = 2, lty = 0, at = c(0, 1), lwd = 0, 
                    labels = c("diff", "same"), font = 3, las = 1, 
                    pos = 1, cex.axis = 0.75)
                  if (!onegraph) 
                    title(main = paste("alignment", as.character(i), 
                      "vs alignment", as.character(j), sep = " "), 
                      cex.main = 1, font.main = 4)
                  if (gr.type != "screen" && !onegraph) 
                    dev.off()
                }
                if (nexus.out) {
                  nexus.sets.block <- nexus.sets(ident.set, diff.set)
                  writeLines(paste("NEXUS sets block:", "\n", 
                    nexus.sets.block, sep = ""))
                }
                cpw.out <- rbind(cpw.out, list(totals = totals, 
                  diff = diff.set, ident = ident.set, lab = id.s, 
                  id.num = num.ident, id.log = col.ident))
            }
        }
        if (graph) 
            if (gr.type != "screen" && onegraph) 
                dev.off()
    }
    if (pairwise == FALSE) {
        if (ref == "longest") 
            ref.index <- longest
        if (ref %in% 1:n) 
            ref.index <- as.numeric(ref)
        if (ref %in% name) 
            ref.index <- which(name == ref)
        col.ident <- comp.all(align, n, ref.index)
        ident.set <- which(col.ident == TRUE)
        diff.set <- which(col.ident == FALSE)
        num.ident <- as.numeric(col.ident)
        end.points <- endpoints(ident.set, diff.set)
        for (i in 1:n) writeLines(paste("Columns in alignment ", 
            as.character(i), ": ", as.character(align.count[i]), 
            sep = ""))
        totals <- data.frame(cols = length(col.ident), idents = length(which(col.ident)), 
            nonidents = length(which(!col.ident)), all_gap_missing = length(which(is.na(col.ident))))
        colnames(totals) <- c("cols_compared", "n_ident", "n_diff", 
            "n_gap_miss")
        id.s <- long.string(col.ident)
        writeLines(paste("\n", "As a string (+ matches, - doesn't):", 
            "\n", id.s, "\n", sep = ""))
        writeLines(paste("Columns considered:", "\n", totals$cols_compared, 
            sep = ""))
        writeLines(paste("Identical columns:", "\n", totals$n_ident, 
            sep = ""))
        writeLines(paste("Different columns:", "\n", totals$n_diff, 
            sep = ""))
        writeLines(paste("All gap/missing columns in ref alignment:", 
            "\n", totals$n_gap_miss, sep = ""))
        if (graph) {
            if (gr.file == "") {
                if (outfile == "") 
                  gr.file <- "compairwise"
                else gr.file <- outfile
            }
            if (gr.type == "ps" || gr.type == "postscript" | 
                gr.type == "PS") 
                postscript(file = paste(gr.file, ".ps", sep = ""), 
                  width = 10, height = 4)
            if (gr.type == "eps" || gr.type == "EPS") 
                postscript(file = paste(gr.file, ".eps", sep = ""), 
                  onefile = FALSE, width = 9, height = 4)
            if (gr.type == "jpeg" || gr.type == "jpg" || gr.type == 
                "JPG" || gr.type == "JPEG") 
                jpeg(filename = paste(gr.file, ".jpg", sep = ""), 
                  width = 960, height = 480)
            if (gr.type == "pdf" || gr.type == "PDF") 
                pdf(file = paste(gr.file, ".pdf", sep = ""), 
                  width = 10, height = 4)
            if (gr.type == "png" || gr.type == "PNG") 
                png(filename = paste(gr.file, ".png", sep = ""), 
                  width = 960, height = 480)
            if (gr.type == "bmp" || gr.type == "BMP") 
                bmp(filename = paste(gr.file, ".bmp", sep = ""), 
                  width = 960, height = 480)
            plot(c(1, dim(align)[2]), c(0, 1.1), axes = F, xaxt = "n", 
                yaxt = "n", bty = "L", type = "n", xlab = "position in reference alignment", 
                ylab = "", font.lab = 4, cex.lab = 0.75)
            lines(num.ident, lwd = 1.5, col = "blue")
            axis(side = 1, las = 1, lwd = 1, at = c(1, end.points, 
                length(num.ident)), font = 1, cex.axis = 0.75)
            axis(side = 2, lty = 0, at = c(0, 1), lwd = 0, labels = c("diff", 
                "same"), font = 3, las = 1, pos = 1, cex.axis = 0.75)
            if (gr.type != "screen") 
                dev.off()
        }
        if (nexus.out) {
            nexus.sets.block <- nexus.sets(ident.set, diff.set)
            writeLines(paste("NEXUS sets block:", "\n", nexus.sets.block, 
                sep = ""))
        }
        cpw.out <- rbind(cpw.out, list(totals = totals, diff = diff.set, 
            ident = ident.set, lab = id.s, id.num = num.ident, 
            id.log = col.ident))
    }
    if (keep) {
        totals <<- totals
        filenames <<- name
        diff.set <<- diff.set
        id.s <<- id.s
        ident.set <<- ident.set
        num.ident <<- num.ident
        col.ident <<- col.ident
        align <<- align
    }
    if (out == "file") 
        sink()
    invisible(cpw.out)
}
`deinterleave` <-
function (alignment) 
{
    taxa <- unique(alignment$nam)
    deint <- function(taxon, alignment) paste(alignment$seq[alignment$nam == 
        taxon], sep = "", collapse = "")
    x <- unlist(lapply(taxa, deint, alignment))
    newaln <- list(nb = length(taxa), nam = taxa, seq = x, com = NA)
    class(newaln) <- "alignment"
    return(newaln)
}
`dots.to.bases` <-
function (alignment, matchchar = ".") 
{
    dotsout <- function(aln.column) {
        aln.column[aln.column == matchchar] <- aln.column[1]
        return(aln.column)
    }
    aln.new <- aln.to.matrix(alignment, F)
    aln.new <- apply(aln.new, 2, dotsout)
    aln.new <- matrix.to.aln(aln.new)
    alignment$seq <- aln.new$seq
    return(alignment)
}
`endpoints` <-
function (ident.set, diff.set) 
{
    end.points <- c()
    len.all <- length(ident.set) + length(diff.set)
    end.points <- which((1:(len.all - 1) %in% ident.set & 2:(len.all) %in% 
        diff.set) | (1:(len.all - 1) %in% diff.set & 2:(len.all) %in% 
        ident.set))
}
`long.string` <-
function (col.ident) 
{
    ident.string <- col.ident
    ident.string[which(col.ident)] <- "+"
    ident.string[which(!col.ident)] <- "-"
    ident.string[which(is.na(col.ident))] <- "o"
    id.s <- paste(ident.string, sep = "", collapse = "")
    return(id.s)
}
`matrix.to.aln` <-
function (matrix) 
{
    x <- unname(apply(matrix, 1, paste, collapse = ""))
    aln <- list(nb = nrow(matrix), nam = rownames(matrix), seq = x, 
        com = NA)
    class(aln) <- "alignment"
    return(aln)
}
`nexus.sets` <-
function (ident.set, diff.set) 
{
    if (!is.na(ident.set[1])) 
        nexus.ident.set.line <- paste("charset ident_align=", 
            paste(ident.set, sep = "", collapse = " "), ";", 
            sep = "")
    else nexus.ident.set.line <- ""
    if (!is.na(diff.set[1])) 
        nexus.diff.set.line <- paste("charset diff_align=", paste(diff.set, 
            sep = "", collapse = " "), ";", sep = "")
    else nexus.diff.set.line <- ""
    nexus.sets.block <- paste("begin sets;", "\n", nexus.ident.set.line, 
        "\n", nexus.diff.set.line, "\n", "end;", "\n", sep = "")
    return(nexus.sets.block)
}
`read.nexus` <-
function (filename) 
{
    nex.in <- scan(file = filename, sep = "\n", what = "c", strip.white = T, 
        multi.line = F, quiet = T)
    while (length(grep("\\[[^]\\[]*]", nex.in)) > 0) nex.in <- gsub("\\[[^]\\[]*]", 
        "", nex.in)
    comm.start <- grep("\\[", nex.in)
    comm.end <- grep("]", nex.in)
    if (length(comm.start) > 0 && length(comm.end) > 0) {
        for (i in 1:(length(comm.start))) {
            if (comm.end[i] == comm.start[i] + 1) {
                nex.in[comm.start[i]] <- gsub("\\[.*$", "", nex.in[comm.start[i]])
                nex.in[comm.end[i]] <- gsub("^.*]", "", nex.in[comm.end[i]])
            }
            else {
                for (j in (comm.start[i] + 1):(comm.end[i] - 
                  1)) {
                  nex.in[j] <- ""
                }
                nex.in[comm.start[i]] <- gsub("\\[.*$", "", nex.in[comm.start[i]])
                nex.in[comm.end[i]] <- gsub("^.*]", "", nex.in[comm.end[i]])
            }
        }
    }
    nex.in <- gsub("'", "", nex.in)
    nex.in <- nex.in[grep("^.+$", nex.in)]
    tax1 <- (grep("matrix", nex.in, ignore.case = T)) + 1
    semicolons <- grep(";", nex.in, ignore.case = T)
    taxlast <- semicolons[semicolons > tax1][1] - 1
    nex.header <- nex.in[1:(grep("matrix", nex.in, ignore.case = T))[1]]
    format.start <- grep("format", nex.header, ignore.case = T)
    nex.format <- unlist(strsplit(gsub("=|;", " ", nex.header[format.start:semicolons[semicolons >= 
        format.start][1]]), split = " "))
    if ("interleave" %in% nex.format) {
        if (grep("interleave", nex.format) == length(nex.format)) {
            interleave <- TRUE
        }
        else {
            if (nex.format[grep("interleave", nex.format) + 1] == 
                "no") 
                interleave <- FALSE
            else interleave <- TRUE
        }
    }
    else interleave <- FALSE
    dna.only <- sub("^[^[:blank:]]+[[:blank:]]+", "", nex.in[tax1:taxlast])
    dna.only <- gsub("[[:blank:]]+", "", dna.only)
    extr.first <- function(vector) vector[1]
    taxon.labels <- sapply(strsplit(grep("^[^[:blank:]]+[[:blank:]]+", 
        nex.in[tax1:taxlast], value = TRUE), split = "[[:blank:]]"), 
        extr.first)
    nex.align <- list(nb = length(dna.only), nam = taxon.labels, 
        seq = dna.only, com = NA)
    class(nex.align) <- "alignment"
    if ("matchchar" %in% nex.format) 
        nex.align <- dots.to.bases(nex.align, matchchar = nex.format[grep("matchchar", 
            nex.format, ignore.case = T)[1] + 1])
    if (interleave) 
        nex.align <- deinterleave(nex.align)
    return(nex.align)
}
`read.phylip` <-
function (filename) 
{
    phy.in <- scan(file = filename, skip = 1, sep = "\n", what = "c", 
        strip.white = T, multi.line = T, quiet = T)
    if (length(grep("[[:blank:]]", phy.in)) > 0) {
        dna.only <- sub("^[^[:blank:]]+[[:blank:]]+", "", phy.in)
        extr.first <- function(vector) vector[1]
        taxon.labels <- sapply(strsplit(grep("^[^[:blank:]]+[[:blank:]]+", 
            phy.in, value = TRUE), split = "[[:blank:]]"), extr.first)
    }
    else {
        dna.only <- substr(phy.in, 11, nchar(phy.in))
        taxon.labels <- substr(phy.in, 1, 10)
    }
    dna.only <- gsub("[[:blank:]]+", "", dna.only)
    phy.align <- list(nb = length(dna.only), nam = taxon.labels, 
        seq = dna.only, com = NA)
    class(phy.align) <- "alignment"
    return(phy.align)
}
`vectorize.alignment` <-
function (dna.mat, all.bases, non.bases) 
{
    vect.row <- function(row) {
        baseno <- 1
        dna.vect.row <- matrix(nrow = 1, ncol = length(row))
        for (j in 1:length(row)) {
            if (row[j] %in% all.bases) {
                dna.vect.row[j] <- baseno
                baseno <- baseno + 1
            }
            else {
                if (row[j] %in% non.bases) 
                  dna.vect.row[j] <- 0
                else {
                  dna.vect.row[j] <- -1
                  writeLines(paste("\t\t\t", as.character(row[j]), 
                    "in ref column", as.character(j)))
                }
            }
            dna.vect.row <- dna.vect.row
        }
    }
    dna.vect <- t(apply(dna.mat, 1, vect.row))
}
