R/msaPrettyPrint.R

In msa: Multiple Sequence Alignment

msaPrettyPrint <- function(x, y, output=c("pdf", "tex", "dvi", "asis"),
                           subset=NULL, file=NULL, alFile=NULL,
                           askForOverwrite=TRUE, psFonts=FALSE, code=NA,
                           paperWidth=11, paperHeight=8.5, margins=c(0.1, 0.3),
                           shadingMode=c("identical", "similar", "functional"),
                           shadingModeArg=NA,
                           shadingColors=c("blues", "reds", "greens", "grays",
                                           "black"),
                           showConsensus=c("bottom", "top", "none"),
                           consensusColors=c("ColdHot", "HotCold", "BlueRed",
                                             "RedBlue", "GreenRed", "RedGreen",
                                             "Gray"),
                           consensusThreshold=50,
                           showLogo=c("top", "bottom", "none"),
                           logoColors=c("chemical", "rasmol", "hydropathy",
                                        "structure", "standard area",
                                        "accessible area"),
                           showLogoScale=c("none", "leftright",
                                           "left", "right"),
                           showNames=c("left", "right", "none"),
                           showNumbering=c("right", "left", "none"),
                           showLegend=TRUE, furtherCode=NA, verbose=FALSE)
{
    xname <- deparse(substitute(x))
    output <- match.arg(output)

    if (is.null(file))
    {
        if (length(grep("[^\\w]", xname, perl=TRUE)) > 0)
        {
            warning("Cannot use default file name '", xname, ".", output,
                    "' because it would contain invalid characters => ",
                    "resorting to 'msaPrettyPrintOutput.", output, "'!")
            xname <- "msaPrettyPrintOutput"
        }

        file <- paste(xname, output, sep=".")
    }

    if (is.null(alFile))
        alFile <- tempfile(pattern="seq", tmpdir=tempdir(), fileext=".fasta")
    else if (is.character(alFile) &&
             substr(alFile, nchar(alFile) - 5, nchar(alFile)) == ".fasta")
    {
        if (askForOverwrite && file.exists(alFile))
        {
            message("File ", alFile, " exists. Overwrite? (y/N)")

            answer <- try(tolower(scan(what=character(), nmax=1,
                                       quiet=TRUE)), silent=TRUE)

            if (nchar(answer) != 1 || substr(answer, 1, 1) != "y")
                return(invisible(NULL))
        }
    }
    else
        stop("The parameter alFile has an invalid argument!")

    if (!is(x, "MultipleAlignment"))
        stop("The parameter x has an invalid argument! \n",
             "x must be a multiple alignment object!")

    if (output != "asis")
    {
        if (!is.numeric(paperWidth) || length(paperWidth) != 1 ||
            paperWidth <= 0)
            stop("The parameter paperWidth must be ",
                 "single positive number (unit: inches)!")

        if (!is.numeric(paperHeight) || length(paperHeight) != 1 ||
            paperHeight <= 0)
            stop("The parameter paperHeight must be ",
                 "single positive number (unit: inches)!")

        if (!is.numeric(margins) || length(margins) != 2)
            stop("The parameter margins must be ",
                 "two positive numbers (unit: inches)!")
    }

    if (!identical(subset, NULL) && !identical(subset, NA))
    {
        if (is.numeric(subset))
        {
            if (max(subset) < .Machine$integer.max)
                subset <- as.integer(subset)
            else
               stop("One or more values for parameter subset ",
                    "are larger than integer!")
        }
        else if (!is.integer(subset))
            stop("The parameter subset has an invalid argument!")

        if (length(subset) < 2)
            stop("The parameter subset is expected to be \n",
                 " a vector with at least 2 entries!")

        if (!all(subset %in% 1:nrow(x)))
            stop("Some values in parameter subset are out of range!")
    }
    else if (length(rowmask(x)) > 0)
    {
        if (setdiff(IRanges(start=1, end=nrow(x)), rowmask(x))
            <= .Machine$integer.max)
            subset <- as.integer(setdiff(IRanges(start=1, end=nrow(x)),
                                         rowmask(x)))
        else
            stop("There is no typecast possible in parameter subset!")
    }
    else
        subset <- 1:nrow(x)

    shadingMode <- match.arg(shadingMode)
    shadingColors <- match.arg(shadingColors)
    showConsensus <- match.arg(showConsensus)
    consensusColors <- match.arg(consensusColors)
    showLogo <- match.arg(showLogo)
    logoColors <- match.arg(logoColors)
    showLogoScale <- match.arg(showLogoScale)
    showNames <- match.arg(showNames)
    showNumbering <- match.arg(showNumbering)

    if (!is.numeric(consensusThreshold) || length(consensusThreshold) < 1 ||
        length(consensusThreshold) > 2 ||
        any(consensusThreshold < 0) || any(consensusThreshold > 100))
        stop("The parameter consensusThreshold must be \n",
             "one or two numbers between 0 and 100 !")
    else if (length(consensusThreshold) == 2 &&
             consensusThreshold[1] >= consensusThreshold[2])
        stop("The second percentage in consensusThreshold must be \n",
             "at least as large as the first one!")

    if (shadingMode %in% c("identical", "similar"))
    {
        if (!identical(shadingModeArg, NA) &&
                (!is.numeric(shadingModeArg) ||
                 length(shadingModeArg) > 2 ||
                 length(shadingModeArg) < 1 ||
                 (length(shadingModeArg) == 2 &&
                     shadingModeArg[1] > shadingModeArg[2])||
                 shadingModeArg[1] < 0 ||
                 shadingModeArg[1] > 100 ||
                 (length(shadingModeArg) == 2 &&
                     (shadingModeArg[2] < 0 ||
                      shadingModeArg[2] > 100))))
           stop("If identical or similarity shading is used, shadingModeArg\n",
                 "must be a single numeric threshold between 0 and 100 or\n",
                 "two thresholds between 0 and 100 in increasing order!")
    }
    else if (identical(shadingMode, "functional"))
    {
        if (!identical(shadingModeArg, NA))
            shadingModeArg <- match.arg(shadingModeArg,
                                       c("charge", "hydropathy", "structure",
                                         "chemical", "rasmol", "standard area",
                                         "accessible area"))
        else
            stop("Missing shadingModeArg for functional shading mode. \n",
                 "Valid values are: \n",
                 "\"charge\", \n",
                 "\"hydropathy\", \n",
                 "\"structure\", \n",
                 "\"chemical\",\n",
                 " \"rasmol\",\n",
                 "\"standard area\",\n",
                 "\"accessible area\"!")
    }
    else if (!identical(shadingMode, NA))
        stop("The parameter shadingModeArg has an invalid argument!")

    if (showConsensus != "none" && showConsensus == showLogo)
        stop("Cannot display consensus sequence and sequence logo ",
             "on the same side!")

    if (showNames != "none" && showNames == showNumbering)
        stop("Cannot display sequence names and numbering on the same side!")

    if (!identical(code, NA) && !is.character(code))
        stop("The parameter code has an invalid argument!")

    if (!identical(furtherCode, NA) && !is.character(furtherCode))
        stop("The parameter furtherCode has an invalid argument!")

    if (missing(y))
        toShow <- IRanges(start=1, end=ncol(x))
    else if (is(y, "IRanges"))
    {
        if (all(start(y) >= 1) && all(end(y) <= ncol(x)))
            toShow <- reduce(y)
        else
            stop("The parameter y has invalid ranges: out of bounds!")
    }
    else if ((is.numeric(y) || is.integer(y)) && length(y) == 2 && y[1] >= 1 &&
             y[2] <= ncol(x) && y[1] < y[2])
        toShow <- IRanges(start=y[1], end=y[2])
    else
        stop("The parameter y has an invalid argument!")

    if (length(colmask(x)) > 0)
        toShow <- setdiff(toShow, colmask(x))

    if (sum(width(toShow)) == 0)
        stop("Sequences empty or everything masked: nothing to be shown!")

    jobname <- ""
    suffix <- ""

    if (output != "asis")
    {
        if (!is.character(file) || length(file) > 1)
            stop("The argument for parameter file must be \n",
                 "a single character string!")

        if (substr(file, nchar(file) - 2, nchar(file)) != output)
            stop("The file name suffix and output type do not match!")

        jobname <- substr(file, 1, nchar(file) - 4)

        if (length(grep("[^\\w\\-/\\\\:.]", jobname, perl=TRUE)) > 0)
        {
            warning("Cannot use file name '", file,
                    "' because it contains invalid characters => \n",
                    "resorting to 'msaPrettyPrintOutput.", output, "'!")
            jobname <- "msaPrettyPrintOutput"
            file <- paste0(jobname, output)
        }

        if (askForOverwrite && file.exists(file))
        {
            message("File ", file, " exists. Overwrite? (y/N)")

            answer <- try(tolower(scan(what=character(), nmax=1,
                                       quiet=TRUE)), silent=TRUE)

            if (nchar(answer) != 1 || substr(answer, 1, 1) != "y")
                return(invisible(NULL))
        }
    }

    writeXStringSet(as(unmasked(x), "XStringSet")[subset], filepath=alFile)

    if (verbose)
        message("Multiple alignment written to temporary file ", alFile)

    texOutput <- paste0("\\begin{texshade}{", stratifyFilenames(alFile), "}")

    if (is(x, "AAMultipleAlignment"))
        texOutput <- c(texOutput, "\\seqtype{P}")
    else
        texOutput <- c(texOutput, "\\seqtype{N}")

    if (length(toShow) == 1)
    {
        if (sum(width(toShow)) < ncol(x))
            texOutput <- c(texOutput, paste("\\setends{consensus}{",
                                            start(toShow), "..", end(toShow),
                                            "}", sep=""))
    }
    else
    {
        coList <- sapply(1:length(toShow),
                         function(i) paste(start(toShow)[i], "..",
                                           end(toShow)[i], sep=""))

        texOutput <- c(texOutput, paste("\\setdomain{consensus}{",
                                        paste(coList, collapse=","), "}",
                                        sep=""))
    }

    if (identical(code, NA))
    {
        if (identical(shadingModeArg, NA))
            texOutput <- c(texOutput,
                               paste("\\shadingmode{", shadingMode, "}",
                                     sep=""))
        else
            texOutput <- c(texOutput,
                               paste("\\shadingmode[",
                                     shadingModeArg, "]{",
                                     shadingMode, "}", sep=""))

        if (length(consensusThreshold) == 2)
            texOutput <- c(texOutput, paste("\\threshold[",
                                            consensusThreshold[2], "]{",
                                            consensusThreshold[1], "}",
                                            sep=""))
        else
            texOutput <- c(texOutput, paste("\\threshold{",
                                            consensusThreshold[1], "}",
                                            sep=""))

        if (showConsensus != "none")
        {
            texOutput <- c(texOutput,
                           paste("\\showconsensus[", consensusColors,
                                 "]{", showConsensus, "}", sep=""))
        }
        else
            texOutput <- c(texOutput, "\\hideconsensus")

        texOutput <- c(texOutput, paste("\\shadingcolors{",
                                        shadingColors, "}", sep=""))

        if (showLogo != "none")
            texOutput <- c(texOutput,
                           paste("\\showsequencelogo[", logoColors,
                                 "]{", showLogo, "}", sep=""))

        if (showLogoScale == "none")
            texOutput <- c(texOutput, "\\hidelogoscale")
        else
            texOutput <- c(texOutput,
                           paste("\\showlogoscale{", showLogoScale, "}",
                                 sep=""))

        if (showNames != "none")
        {
            seqNames <- rownames(x)[subset]
            pattern <- "[^a-zA-Z0-9,;:.?!/\\-\\(\\)\\'\" ]"
            seqNames <- gsub(pattern, " ", seqNames, perl=TRUE)

            texOutput <- c(texOutput,
                           paste("\\shownames{", showNames, "}", sep=""),
                           paste("\\nameseq{", 1:length(subset), "}{",
                                 seqNames, "}", sep=""))
        }
        else
            texOutput <- c(texOutput, "\\hidenames")

        if (showNumbering != "none")
            texOutput <- c(texOutput,
                           paste("\\shownumbering{", showNumbering, "}",
                                 sep=""))
        else
            texOutput <- c(texOutput, "\\hidenumbering")

        if (showLegend)
            texOutput <- c(texOutput, "\\showlegend")

        if (!identical(furtherCode, NA))
            texOutput <- c(texOutput, furtherCode)
    }
    else
        texOutput <- c(texOutput, code)

    texOutput <- c(texOutput, "\\end{texshade}")

    if (output == "asis")
        cat(texOutput, sep="\n")
    else
    {
        texHeader <- c("\\documentclass[10pt]{article}", "")

        if (psFonts)
            texHeader <- c(texHeader, "\\usepackage{times}")

        texHeader <- c(texHeader, "\\usepackage{texshade}")

        texHeader <- c(texHeader, "", "\\headheight=0pt", "\\headsep=0pt",
                       "\\hoffset=0pt", "\\voffset=0pt",
                       paste0("\\paperwidth=", paperWidth, "in"),
                       paste0("\\paperheight=", paperHeight, "in"),
                       "\\ifx\\pdfoutput\\undefined",
                       "\\relax",
                       "\\else",
                       "\\pdfpagewidth=\\paperwidth",
                       "\\pdfpageheight=\\paperheight",
                       "\\fi",
                       paste0("\\oddsidemargin=", margins[1] - 1, "in"),
                       paste0("\\topmargin=", margins[2] - 1, "in"),
                       paste0("\\textwidth=",
                              paperWidth - 2 * margins[1], "in"),
                       paste0("\\textheight=",
                              paperHeight - 2 * margins[2],"in"),
                       "", "\\pagestyle{empty}", "", "\\begin{document}")
        texFooter <- "\\end{document}"

        if (output == "tex")
            writeLines(c(texHeader, texOutput, texFooter), con=file)
        else
        {
            texfile <- paste(jobname, "tex", sep=".")

            if (askForOverwrite && file.exists(texfile))
            {
                message("File ", texfile, " exists. Overwrite? (y/N)")

                answer <- try(tolower(scan(what=character(), nmax=1,
                                           quiet=TRUE)), silent=TRUE)

                if (nchar(answer) != 1 || substr(answer, 1, 1) != "y")
                    return(invisible(NULL))
            }

            writeLines(c(texHeader, texOutput, texFooter), con=texfile)

            if (verbose)
                message("File ", texfile, " created")

            texi2dvi(texfile, quiet=!verbose, pdf=identical(output, "pdf"),
                     texinputs=system.file("tex", package="msa"),
                     clean=TRUE, index=FALSE)
        }

        if (verbose)
            message("Output file ", file, " created")
    }

    invisible(texOutput)
}