### Internal functions.

sQuote <- function(s) paste("'", s, "'", sep = "")

.listFilesWithExts <- function(dir, exts, path = TRUE) {
    ## Return the paths or names of the files in @code{dir} with
    ## extension in @code{exts}.
    files <- list.files(dir)
    files <- files[sub(".*\\.", "", files) %in% exts]
    if(path)
        files <- if(length(files) > 0)
            file.path(dir, files)
        else
            character(0)
    files
}

.loadPackageQuietly <- function(package, lib.loc) {
    ## Load (reload if already loaded) @code{package} from
    ## @code{lib.loc}, capturing all output and messages.  All QA
    ## functions use this for loading packages because R CMD check
    ## interprets all output as indicating a problem.
    outConn <- textConnection("out", "w")
    sink(outConn, type = "output")
    sink(outConn, type = "message")
    yy <- try({
        pos <- match(paste("package", package, sep = ":"), search())
        if(!is.na(pos))
            detach(pos = pos)
        library(package, lib.loc = lib.loc, character.only = TRUE)
    })
    if(inherits(yy, "try-error"))
        stop(yy)
    sink(type = "message")
    sink(type = "output")
    close(outConn)
}

.makeS3MethodsStopList <- function(package) {
    ## Return a character vector with the names of the functions in
    ## @code{package} which 'look' like S3 methods, but are not.
    switch(package,
           base = c("boxplot.stats",
           "close.screen", "close.socket",
           "format.char", "format.info", "format.pval",
           "plot.new", "plot.window", "plot.xy",
           "split.screen",
           "update.packages"),
           quadprog = c("solve.QP", "solve.QP.compact"),
           sm = "print.graph",
           ts = "lag.plot",
           character(0))
}

.sourceAssignments <- function(file, envir) {
    ## Read and parse expressions from @code{file}, and then
    ## successively evaluate the top-level assignments in @code{envir}.
    ## Apart from only dealing with assignments, basically does the same
    ## as @code{sys.source(file, envir, keep.source = FALSE)}.
    oop <- options(keep.source = FALSE)
    on.exit(options(oop))
    assignmentSymbol <- as.name("<-")
    exprs <- parse(n = -1, file = file)
    if(length(exprs) == 0)
        return(invisible())
    for(e in exprs) {
        if(e[[1]] == assignmentSymbol)
            yy <- eval(e, envir)
    }
    invisible()
}
    
### The real stuff.

undoc <-
function(package, dir, lib.loc = NULL)
{
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        if(!file.exists(helpIndex <- file.path(dir, "help", "AnIndex")))
            stop(paste("directory", sQuote(dir),
                       "contains no help index"))
        isBase <- package == "base"

        ## Find all documented topics from the help index.
        allDocTopics <- sort(scan(file = helpIndex, 
                                  what = list("", ""),
                                  quiet = TRUE, sep="\t")[[1]])

        ## Load package into codeEnv.
        if(!isBase)
            .loadPackageQuietly(package, lib.loc)
        codeEnv <-
            as.environment(match(paste("package", package, sep = ":"),
                                 search()))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop(paste("directory", sQuote(dir),
                       "does not contain Rd sources"))
        isBase <- basename(dir) == "base"

        ## Find all documented topics from the Rd sources.
        docsExts <- c("Rd", "rd")
        files <- .listFilesWithExts(docsDir, docsExts)
        if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
            files <- c(files, .listFilesWithExts(docsOSDir, docsExts))
        aliases <- character(0)
        for(f in files) {
            aliases <- c(aliases,
                         grep("^\\\\alias", readLines(f), value = TRUE))
        }
        allDocTopics <- gsub("\\\\alias{(.*)}.*", "\\1", aliases)
        allDocTopics <- gsub("\\\\%", "%", allDocTopics)
        allDocTopics <- gsub(" ", "", allDocTopics)
        allDocTopics <- sort(unique(allDocTopics))

        codeEnv <- new.env()        
        if(file.exists(codeDir <- file.path(dir, "R"))) {
            ## Collect code in codeFile.            
            codeFile <- tempfile("Rcode")
            on.exit(unlink(codeFile))
            codeExts <- c("R", "r", "S", "s", "q")
            files <- .listFilesWithExts(codeDir, codeExts)
            if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
                files <- c(files, .listFilesWithExts(codeOSDir, codeExts))
            file.create(codeFile)
            file.append(codeFile, files)
            ## Read code from codeFile into codeEnv            
            yy <- try(.sourceAssignments(codeFile, env = codeEnv))
            if(inherits(yy, "try-error")) {
                stop("cannot source package code")
            }
        }
    }

    codeObjs <- ls(envir = codeEnv, all.names = TRUE)

    dataObjs <- character(0)
    if(file.exists(dataDir <- file.path(dir, "data"))) {
        dataExts <- c("R", "r",
                      "RData", "rdata", "rda",
                      "TXT", "txt", "tab", "CSV", "csv")
        files <- .listFilesWithExts(dataDir, dataExts)
        files <- files[!duplicated(sub("\\.[A-Za-z]*$", "", files))]
        dataEnv <- new.env()
        if(any(i <- grep("\\.\(R\|r\)$", files))) {
            for(f in files[i]) {
                yy <- try(sys.source(f, envir = dataEnv, chdir = TRUE))
                if(inherits(yy, "try-error"))
                    stop(paste("cannot source data file", sQuote(f)))
                new <- ls(envir = dataEnv, all.names = TRUE)
                dataObjs <- c(dataObjs, new)
                rm(list = new, envir = dataEnv)
            }
            files <- files[-i]
        }
        if(any(i <- grep("\\.\(RData\|rdata\|rda\)$", files))) {
            for(f in files[i]) {
                yy <- try(load(f, envir = dataEnv))
                if(inherits(yy, "try-error"))
                    stop(paste("cannot load data file", sQuote(f)))
                new <- ls(envir = dataEnv, all.names = TRUE)
                dataObjs <- c(dataObjs, new)
                rm(list = new, envir = dataEnv)
            }
            files <- files[-i]
        }
        if(length(files) > 0)
            dataObjs <- c(dataObjs,
                          basename(sub("\\.[A-Za-z]*$", "", files)))
    }

    ## Undocumented objects?
    if((length(codeObjs) == 0) && (length(dataObjs) == 0))
        warning("Neither code nor data objects found")

    if(!isBase) {
        ## Code objects in add-on packages with names starting with a
        ## dot are considered 'internal' (not user-level) by
        ## convention.
        ## <FIXME>
        ## Not clear whether everyone believes in this convention.
        ## We used to have
        ##   allObjs[! allObjs %in% c(allDocTopics,
        ##                            ".First.lib", ".Last.lib")]
        ## i.e., only exclude '.First.lib' and '.Last.lib'.
        codeObjs <- grep("^[^.].*", codeObjs, value = TRUE)
        ## Note that this also allows us to get rid of S4 meta objects
        ## (with names starting with '.__C__' or '.__M__'; well, as long
        ## as there are none in base).
        ## </FIXME>
    }

    undocObjs <- list(code = codeObjs[! codeObjs %in% allDocTopics],
                      data = dataObjs[! dataObjs %in% allDocTopics])

    if(!is.na(match("package:methods", search()))) {
        S4ClassObjs <- getClasses(codeEnv)
        undocObjs <-
            c(undocObjs,
              list("S4 class" =
                   S4ClassObjs[! topicName("class", S4ClassObjs)
                               %in% allDocTopics]))
    }
    
    class(undocObjs) <- "undoc"
    undocObjs
}

print.undoc <-
function(x, ...)
{
    for(i in which(sapply(x, length) > 0)) {
        writeLines(paste("Undocumented", names(x)[i], "objects:"))
        print(x[[i]])
    }
    invisible(x)
}

codoc <-
function(package, dir, lib.loc = NULL,
         use.values = FALSE, use.positions = TRUE,
         ignore.generic.functions = FALSE,
         verbose = getOption("verbose"))
{
    unlinkOnExitFiles <- NULL
    on.exit(unlink(unlinkOnExitFiles))

    ## Argument handling.    
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop(paste("directory", sQuote(dir),
                       "does not contain Rd sources"))
        isBase <- basename(dir) == "base"

        ## Load package into codeEnv.
        if(!isBase)
            .loadPackageQuietly(package, lib.loc)
        codeEnv <-
            as.environment(match(paste("package", package, sep = ":"),
                                 search()))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop(paste("directory", sQuote(dir),
                       "does not contain Rd sources"))
        isBase <- basename(dir) == "base"
        
        ## Collect code in codeFile.
        codeFile <- tempfile("Rcode")
        unlinkOnExitFiles <- c(unlinkOnExitFiles, codeFile)
        codeExts <- c("R", "r", "S", "s", "q")
        files <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            files <- c(files, .listFilesWithExts(codeOSDir, codeExts))
        file.create(codeFile)
        file.append(codeFile, files)
        
        ## Read code from codeFile into codeEnv.
        codeEnv <- new.env()
        if(verbose)
            cat("Reading code from", sQuote(codeFile), "\n")        
        yy <- try(.sourceAssignments(codeFile, env = codeEnv))
        if(inherits(yy, "try-error")) {
            stop("cannot source package code")
        }

    }
        
    lsCode <- ls(envir = codeEnv, all.names = TRUE)
    
    ## Find the function objects to work on.
    funs <- lsCode[sapply(lsCode, function(f) {
        f <- get(f, envir = codeEnv)
        is.function(f) && (length(formals(f)) > 0)
    }) == TRUE]
    if(ignore.generic.functions) {
        isS3Generic <- function(f) {
            any(grep("^UseMethod",
                     deparse(body(get(f, envir = codeEnv)))[1]))
        }
        funs <- funs[sapply(funs, isS3Generic) == FALSE]
    }
    ## <FIXME>
    ## Sourcing all R code files in the package is a problem for base,
    ## where this misses the .Primitive functions.  Hence, when checking
    ## base for objects shown in \usage but missing from the code, we
    ## get the primitive functions from the version of R we are using.
    ## Maybe one day we will have R code for the primitives as well ...
    if(isBase) {
        baseObjs <- ls(envir = as.environment(NULL), all.names = TRUE)
        isPrimitive <- function(fname, envir) {
            f <- get(fname, envir = envir)
            is.function(f) && any(grep("^\\.Primitive", deparse(f)))
        }
        lsCode <-
            c(lsCode, baseObjs[sapply(baseObjs, isPrimitive, NULL)],
              c(".First.lib", ".Last.lib", ".Random.seed"))
    }
    ## </FIXME>

    docsEnv <- new.env()
    checkCoDoc <- function(f) {
        ffc <- formals(get(f, envir = codeEnv))
        ffd <- formals(get(f, envir = docsEnv))
        if(!use.positions) {
            ffc <- ffc[sort(names(ffc))]
            ffd <- ffc[sort(names(ffd))]
        }
        if(!use.values) {
            ffc <- names(ffc)
            ffd <- names(ffd)
        }
        if(all(all.equal(ffc, ffd) == TRUE))
            NULL
        else {
            list(list(name = f, code = ffc, docs = ffd))
        }
    }

    ## Collect usages into docsFile.
    docsFile <- tempfile("Rdocs")
    unlinkOnExitFiles <- c(unlinkOnExitFiles, docsFile)
    docsExts <- c("Rd", "rd")
    files <- .listFilesWithExts(docsDir, docsExts)
    if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
        files <- c(files, .listFilesWithExts(docsOSDir, docsExts))
    docsList <- tempfile("Rdocs")
    unlinkOnExitFiles <- c(unlinkOnExitFiles, docsList)
    writeLines(files, docsList)
    .Script("perl", "extract-usage.pl",
            paste(if(verbose) "--verbose", docsList, docsFile))

    ## Process the usages in the documentation objects, one at a time.
    badDocObjs <- list()
    lsDocs <- character()
    if(verbose)
        cat("Reading docs from", sQuote(docsFile), "\n")
    txt <- readLines(docsFile)
    ind <- grep("^# usages in documentation object", txt)
    ## Use a text connection for reading the blocks determined by ind.
    ## Alternatively, we could split txt into a list of the blocks.
    numOfUsageCodeLines <- diff(c(ind, length(txt) + 1)) - 1
    txtConn <- textConnection(paste(txt, collapse = "\n"))
    on.exit(close(txtConn), add = TRUE)
    for(n in numOfUsageCodeLines) {
        docObj <- gsub("^# usages in documentation object ", "",
                       readLines(txtConn, 1))
        if(isBase && docObj %in% c("Defunct", "Devices")) {
            readLines(txtConn, n); next
        }
        exprs <- try(parse(n = -1, text = readLines(txtConn, n)))
        if(inherits(exprs, "try-error"))
            stop(paste("cannot source usages in documentation object",
                       sQuote(docObj)))
        for(i in exprs) {
            yy <- try(eval(i, env = docsEnv))
            if(inherits(yy, "try-error"))
                stop(paste("cannot eval usages in documentation object",
                           sQuote(docObj)))
        }

        badUsagesInFile <- list()
        usages <- ls(envir = docsEnv, all.names = TRUE)
        for(f in usages[usages %in% funs])
            badUsagesInFile <- c(badUsagesInFile, checkCoDoc(f))
        if(length(badUsagesInFile) > 0)
            badDocObjs[[docObj]] <- badUsagesInFile

        usagesNotInCode <- usages[! usages %in% lsCode]
        if(length(usagesNotInCode) > 0) {
            writeLines(paste("Objects with usage in documentation",
                             "object", sQuote(docObj),
                             "but missing from code:"))
            print(unique(usagesNotInCode))
            writeLines("")
        }

        lsDocs <- c(lsDocs, usages)
        rm(list = usages, envir = docsEnv)
    }

    ## Objects without usage information.
    ## Could still be documented via \alias.
    undocObjs <- lsCode[!lsCode %in% lsDocs]
    if(verbose) {
        writeLines("\nObjects without usage information:")
        print(undocObjs)
        writeLines("")        
    }

    class(badDocObjs) <- "codoc"
    badDocObjs
}

print.codoc <-
function(x, ...)
{
    if(length(x) == 0)
        return(invisible(x))
    hasOnlyNames <- is.character(x[[1]][[1]][["code"]])
    formatArgs <- function(s) {
        if(hasOnlyNames) {
            paste("function(", paste(s, collapse = ", "), ")", sep = "")
        }
        else {
            s <- paste(deparse(s), collapse = "")
            s <- gsub(" = \([,\\)]\)", "\\1", s)
            gsub("^list", "function", s)
        }
    }
    for(fname in names(x)) {
        writeLines(paste("Codoc mismatches from documentation object ",
                         sQuote(fname), ":", sep = ""))
        xfname <- x[[fname]]
        for(i in seq(along = xfname))
            writeLines(c(xfname[[i]][["name"]],
                         strwrap(paste("Code:",
                                       formatArgs(xfname[[i]][["code"]])),
                                 indent = 2, exdent = 17),
                         strwrap(paste("Docs:",
                                       formatArgs(xfname[[i]][["docs"]])),
                                 indent = 2, exdent = 17)))
        writeLines("")
    }
    invisible(x)
}

checkAssignFuns <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        isBase <- basename(dir) == "base"

        ## Load package into codeEnv.
        if(!isBase)
            .loadPackageQuietly(package, lib.loc)
        codeEnv <-
            as.environment(match(paste("package", package, sep = ":"),
                                 search()))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        isBase <- basename(dir) == "base"

        ## Collect code into codeFile.
        codeFile <- tempfile("Rcode")
        on.exit(unlink(codeFile))
        codeExts <- c("R", "r", "S", "s", "q")
        files <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            files <- c(files, .listFilesWithExts(codeOSDir, codeExts))
        file.create(codeFile)
        file.append(codeFile, files)

        ## Read code from codeFile into codeEnv.
        codeEnv <- new.env()
        yy <- try(.sourceAssignments(codeFile, env = codeEnv))
        if(inherits(yy, "try-error")) {
            stop("cannot source package code")
        }
    }
        
    lsCode <- ls(envir = codeEnv, all.names = TRUE)

    ## Find the assignment functions in the given package.
    assignFuns <- lsCode[grep("<-", lsCode)]
    ## Find the assignment functions with last arg not named 'value'.
    badAssignFuns <-
        assignFuns[sapply(assignFuns, function(f) {
            argNames <- names(formals(get(f, envir = codeEnv)))
            argNames[length(argNames)] != "value"
        }) == TRUE]

    class(badAssignFuns) <- "checkAssignFuns"
    badAssignFuns
}

print.checkAssignFuns <-
function(x, ...)
{
    if(length(x) > 0) print(unclass(x), ...)
    invisible(x)
}

checkDocArgs <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
    }

    if(!file.exists(docsDir <- file.path(dir, "man")))
        stop(paste("directory", sQuote(dir),
                   "does not contain Rd sources"))
    isBase <- basename(dir) == "base"

    ## Collect usages into docsFile.
    docsFile <- tempfile("Rdocs")
    on.exit(unlink(docsFile))
    docsExts <- c("Rd", "rd")
    files <- .listFilesWithExts(docsDir, docsExts)
    if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
        files <- c(files, .listFilesWithExts(docsOSDir, docsExts))
    docsList <- tempfile("Rdocs")
    on.exit(unlink(docsList), add = TRUE)
    writeLines(files, docsList)
    .Script("perl", "extract-usage.pl",
            paste("--mode=args", docsList, docsFile))

    ## Process the usages in the documentation objects, one at a time.
    badDocObjs <- list()
    argsEnv <- new.env()
    txt <- readLines(docsFile)
    ind <- grep("^# usages in documentation object", txt)
    ## Use a text connection for reading the blocks determined by ind.
    ## Alternatively, we could split txt into a list of the blocks.
    numOfUsageCodeLines <- diff(c(ind, length(txt) + 1)) - 2
    txtConn <- textConnection(paste(txt, collapse = "\n"))
    on.exit(close(txtConn), add = TRUE)
    for(n in numOfUsageCodeLines) {
        docObj <- gsub("^# usages in documentation object ", "",
                       readLines(txtConn, 1))
        if(isBase
           && docObj %in% c("Defunct", "Deprecated", "Devices")) { 
            readLines(txtConn, n + 1); next
        }
        argList <- readLines(txtConn, 1)
        if(argList == "# arglist: *internal*") {
            readLines(txtConn, n); next
        }
        exprs <- try(parse(n = -1, text = readLines(txtConn, n)))
        if(inherits(exprs, "try-error"))
            stop(paste("cannot source usages in documentation object",
                       sQuote(docObj)))
        for(i in exprs) {
            yy <- try(eval(i, env = argsEnv))
            if(inherits(yy, "try-error"))
                stop(paste("cannot eval usages in documentation object",
                           sQuote(docObj)))
        }

        lsArgs <- ls(envir = argsEnv, all.names = TRUE)

        argsInArgList <-
            unlist(strsplit(gsub("# arglist:", "", argList), " +"))
        argsInUsage <-
            unlist(lapply(lsArgs,
                          function(f)
                          names(formals(get(f, envir = argsEnv)))))

        argsInUsageMissingInArgList <-
            argsInUsage[!argsInUsage %in% argsInArgList]

        if((length(argsInUsageMissingInArgList) > 0)
           || any(duplicated(argsInArgList)))
            badDocObjs[[docObj]] <-
                list(missing = argsInUsageMissingInArgList,
                     duplicated =
                     argsInArgList[duplicated(argsInArgList)])

        ## Clean up argsEnv
        rm(list = lsArgs, envir = argsEnv)
    }

    class(badDocObjs) <- "checkDocArgs"
    badDocObjs
}

print.checkDocArgs <-
function(x, ...)
{
    for(docObj in names(x)) {
        argsInUsageMissingInArgList <- x[[docObj]][["missing"]]
        if(length(argsInUsageMissingInArgList) > 0) {
            writeLines(paste("Undocumented arguments",
                             " in documentation object ",
                             sQuote(docObj), ":", sep = ""))
            print(unique(argsInUsageMissingInArgList))
        }
        duplicatedArgsInArgList <- x[[docObj]][["duplicated"]]
        if(length(duplicatedArgsInArgList) > 0) {
            writeLines(paste("Duplicated \\argument entries",
                             " in documentation object ",
                             sQuote(docObj), ":", sep = ""))
            print(duplicatedArgsInArgList)
        }
        writeLines("")
    }
    invisible(x)
}

checkDocStyle <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in 'dir' ...
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop(paste("directory", sQuote(dir),
                       "does not contain Rd sources"))
        isBase <- basename(dir) == "base"

        ## Load package into codeEnv.
        if(!isBase)
            .loadPackageQuietly(package, lib.loc)
        codeEnv <-
            as.environment(match(paste("package", package, sep = ":"),
                                 search()))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop(paste("directory", sQuote(dir),
                       "does not contain Rd sources"))
        isBase <- basename(dir) == "base"

        ## Collect code into codeFile.
        codeFile <- tempfile("Rcode")
        on.exit(unlink(codeFile))
        codeExts <- c("R", "r", "S", "s", "q")
        files <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            files <- c(files, .listFilesWithExts(codeOSDir, codeExts))
        file.create(codeFile)
        file.append(codeFile, files)

        ## Read code from codeFile into codeEnv.
        codeEnv <- new.env()
        yy <- try(.sourceAssignments(codeFile, env = codeEnv))
        if(inherits(yy, "try-error")) {
            stop("cannot source package code")
        }
    }

    lsCode <- ls(envir = codeEnv, all.names = TRUE)

    ## Find the function objects in the given package.
    funs <-
        lsCode[sapply(lsCode, function(f)
                      is.function(get(f, envir = codeEnv))) == TRUE]

    ## Find all generic functions in the given package and (the current)
    ## base package.
    isS3Generic <- function(fname, envir) {
        f <- get(fname, envir = envir)
        ((is.function(f)
          && any(grep("^UseMethod", deparse(body(f))[1])))
         || (fname %in% c("as.data.frame", "plot")))
    }
    allGenerics <- character()
    envList <- list(codeEnv)
    if(!isBase) envList <- c(envList, list(as.environment(NULL)))
    for(env in envList) {
        allObjs <- ls(envir = env, all.names = TRUE)
        allGenerics <-
            c(allGenerics,
              allObjs[sapply(allObjs, isS3Generic, env) == TRUE])
    }

    ## Find all methods in the given package for the generic functions
    ## determined above.  Store as a list indexed by the names of the
    ## generic functions.
    methodsStopList <- .makeS3MethodsStopList(basename(dir))
    methodsInPackage <- sapply(allGenerics, function(g) {
        name <- paste("^", g, ".", sep = "")
        methods <- grep(gsub("([.[])", "\\\\\\1", name),
                        funs, value = TRUE)
        methods <- methods[! methods %in% methodsStopList]
        methods
    })
    allMethodsInPackage <- unlist(methodsInPackage)
    
    ## Collect usages into docsFile.
    docsFile <- tempfile("Rdocs")
    on.exit(unlink(docsFile), add = TRUE)
    docsExts <- c("Rd", "rd")
    files <- .listFilesWithExts(docsDir, docsExts)
    if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
        files <- c(files, .listFilesWithExts(docsOSDir, docsExts))
    docsList <- tempfile("Rdocs")
    on.exit(unlink(docsList), add = TRUE)
    writeLines(files, docsList)
    .Script("perl", "extract-usage.pl",
            paste("--mode=style", docsList, docsFile))

    ## Process the usages in the documentation objects, one at a time.
    badDocObjs <- list()
    docsEnv <- new.env()
    txt <- readLines(docsFile)
    ind <- grep("^# usages in documentation object", txt)
    ## Use a text connection for reading the blocks determined by ind.
    ## Alternatively, we could split txt into a list of the blocks.
    numOfUsageCodeLines <- diff(c(ind, length(txt) + 1)) - 1
    txtConn <- textConnection(paste(txt, collapse = "\n"))
    on.exit(close(txtConn), add = TRUE)
    for(n in numOfUsageCodeLines) {
        docObj <- gsub("^# usages in documentation object ", "",
                       readLines(txtConn, 1))
        usageTxt <- readLines(txtConn, n)
        ## Note: Special \method{GENERIC}{CLASS} Rd markup was preserved
        ## by calling extract-usage in mode @code{style}.  We keep this
        ## in usageTxt for later, but of course need to replace it by
        ## the GENERIC.CLASS S3 function names for parsing.
        exprs <- try(parse(n = -1,
                           text = gsub(paste("\\\\method",
                                             "{([a-zA-Z0-9.]+)}",
                                             "{([a-zA-Z0-9.]+)}",
                                             sep = ""),
                                       "\\1.\\2", usageTxt)))
        if(inherits(exprs, "try-error"))
            stop(paste("cannot source usages in documentation object",
                       sQuote(docObj)))
        for(i in exprs) {
            yy <- try(eval(i, env = docsEnv))
            if(inherits(yy, "try-error"))
                stop(paste("cannot eval usages in documentation object",
                           sQuote(docObj)))
        }

        usages <- ls(envir = docsEnv, all.names = TRUE)

        methodsWithGeneric <-
            sapply(usages[usages %in% allGenerics],
                   function(g) usages[usages %in%
                                      methodsInPackage[[g]]],
                   simplify = FALSE)
        methodsWithGeneric <-
            methodsWithGeneric[lapply(methodsWithGeneric, length) > 0]

        methodsWithFullName <-
            sapply(usages[usages %in% allMethodsInPackage],
                   function(f) any(grep(paste(f, "*<-"), usageTxt)))
        methodsWithFullName <-
            methodsWithFullName[methodsWithFullName == TRUE]

        if((length(methodsWithGeneric) > 0) ||
           (length(methodsWithFullName > 0)))
            badDocObjs[[docObj]] <-
                list(withGeneric  = methodsWithGeneric,
                     withFullName = methodsWithFullName)

        rm(list = usages, envir = docsEnv)
    }

    class(badDocObjs) <- "checkDocStyle"
    badDocObjs
}

print.checkDocStyle <-
function(x, ...) {
    for(docObj in names(x)) {
        writeLines(paste("Usages in documentation object ",
                         sQuote(docObj), ":", sep = ""))
        methodsWithGeneric <- x[[docObj]][["withGeneric"]]
        if(length(methodsWithGeneric) > 0) {
            writeLines("Methods shown alongside generic:")
            for(g in names(methodsWithGeneric)) {
                methods <- paste(methodsWithGeneric[[g]],
                                 collapse = " ")
                writeLines(strwrap(paste(g, ": ", methods, sep = ""),
                                   indent = 2, exdent = 4))
            }
        }
        methodsWithFullName <- x[[docObj]][["withFullName"]]
        if(length(methodsWithFullName > 0)) {
            writeLines("Methods shown with their own name:")
            writeLines(strwrap(paste(names(methodsWithFullName)),
                               indent = 2, exdent = 4))
        }
        writeLines("")
    }
    invisible(x)
}

checkFF <-
function(package, dir, file, lib.loc = NULL,
         verbose = getOption("verbose"))
{
    useSaveImage <- FALSE

    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        packageDir <- .find.package(package, lib.loc)
        file <- file.path(packageDir, "R", "all.rda")
        if(file.exists(file))
            useSaveImage <- TRUE
        else
            file <- file.path(packageDir, "R", package)
    }
    else if(!missing(dir)) {
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        codeExts <- c("R", "r", "S", "s", "q")
        codeFiles <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            codeFiles <- c(codeFiles,
                           .listFilesWithExts(codeOSDir, codeExts))
        file <- tempfile()
        on.exit(unlink(file))
        file.create(file)
        file.append(file, codeFiles)
    }
    else if(missing(file)) {
        stop("you must specify 'package', 'dir' or 'file'")
    }
    
    if(!file.exists(file))
        stop(paste("file", sQuote(file), "does not exist"))

    ## <FIXME>
    ## Should there really be 'verbose' argument?
    ## It may be useful to extract all foreign function calls but then
    ## we would want the calls back ...
    ## What we currently do is the following: if 'verbose' is true, we
    ## show all foreign function calls in abbreviated form with the line
    ## ending in either 'OK' or 'MISSING', and we return the list of
    ## 'bad' FF calls (i.e., where the 'PACKAGE' argument is missing)
    ## *invisibly* (so that output is not duplicated).
    ## Otherwise, if not verbose, we return the list of bad FF calls.
    ## </FIXME>

    badExprs <- list()
    FFfuns <- c(".C", ".Fortran", ".Call", ".External",
                ".Call.graphics", ".External.graphics")
    findBadExprs <- function(e) {
        if(is.call(e) || is.expression(e)) {
            if(as.character(e[[1]]) %in% FFfuns) {
                parg <- if(is.null(e[["PACKAGE"]])) {
                    badExprs <<- c(badExprs, e)
                    "MISSING"
                }
                else
                    "OK"
                if(verbose) {
                    cat(e[[1]], "(", deparse(e[[2]]), ", ...): ", parg,
                        "\n", sep = "")
                }
            }
            for(i in seq(along = e)) Recall(e[[i]])
        }
    }

    exprs <- if(useSaveImage) {
        if(verbose) writeLines("loading saved image ...")
        codeEnv <- new.env()
        load(file, envir = codeEnv)
        lapply(ls(envir = codeEnv, all.names = TRUE),
               function(f) {
                   f <- get(f, envir = codeEnv)
                   if(typeof(f) == "closure") body(f) else NULL
               })
    }
    else
        parse(file = file, n = -1)
    for(i in seq(along = exprs)) findBadExprs(exprs[[i]])
    class(badExprs) <- "checkFF"
    if(verbose)
        invisible(badExprs)
    else
        badExprs
}

print.checkFF <-
function(x, ...)
{
    if(length(x) > 0) {
        writeLines("Foreign function calls without 'PACKAGE' argument:")
        for(i in seq(along = x)) {
            writeLines(paste(deparse(x[[i]][[1]]),
                             "(",
                             deparse(x[[i]][[2]]),
                             ", ...)",
                             sep = ""))
        }
    }
    invisible(x)
}

checkMethods <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        dir <- .find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        isBase <- basename(dir) == "base"

        ## Load package into codeEnv.
        if(!isBase)
            .loadPackageQuietly(package, lib.loc)
        codeEnv <-
            as.environment(match(paste("package", package, sep = ":"),
                                 search()))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on 'dir'
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        isBase <- basename(dir) == "base"

        ## Collect code into codeFile.
        codeFile <- tempfile("Rcode")
        on.exit(unlink(codeFile))
        codeExts <- c("R", "r", "S", "s", "q")
        files <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            files <- c(files, .listFilesWithExts(codeOSDir, codeExts))
        file.create(codeFile)
        file.append(codeFile, files)
        
        ## Read code from codeFile into codeEnv.
        codeEnv <- new.env()
        yy <- try(.sourceAssignments(codeFile, env = codeEnv))
        if(inherits(yy, "try-error")) {
            stop("cannot source package code")
        }
    }

    lsCode <- ls(envir = codeEnv, all.names = TRUE)

    ## Find the function objects in the given package.
    funs <-
        lsCode[sapply(lsCode, function(f)
                      is.function(get(f, envir = codeEnv))) == TRUE]

    isS3Generic <- function(fname, envir) {
        f <- get(fname, envir = envir)
        ((is.function(f)
          && any(grep("^UseMethod", deparse(body(f))[1])))
         || (fname %in% c("as.data.frame", "plot")))
    }

    methodsStopList <- .makeS3MethodsStopList(basename(dir))

    checkArgs <- function(g, m, env) {
        ## Do the arguments of method m (in codeEnv) 'extend' those of
        ## the generic g from environment env?  The method must have all
        ## arguments the generic has, with positional arguments of g in
        ## the same positions for m.
        ## Exception: '...' in the method swallows anything
        gArgs <- ogArgs <- names(formals(get(g, envir = env)))
        mArgs <- omArgs <- names(formals(get(m, envir = codeEnv)))
        ## If m is a formula method, its first argument *may* be called
        ## formula.  (Note that any argument name mismatch throws an
        ## error in current S-PLUS versions.)
        if(length(grep("\\.formula$", m)) > 0) {
            gArgs <- gArgs[-1]
            mArgs <- mArgs[-1]
        }
        dotsPos <- which(gArgs == "...")
        ipos <- if(length(dotsPos) > 0)
            seq(from = 1, length = dotsPos - 1)
        else
            seq(along = gArgs)

        dotsPos <- which(mArgs == "...")
        if(length(dotsPos) > 0)
            ipos <- ipos[seq(from = 1, length = dotsPos - 1)]
        PosMatchOK <- identical(gArgs[ipos], mArgs[ipos])
        ArgMatchOK <- all(gArgs %in% mArgs) || length(dotsPos) > 0
        if(PosMatchOK && ArgMatchOK)
            NULL
        else {
            l <- list(ogArgs, omArgs)
            names(l) <- c(g, m)
            list(l)
        }
    }

    ## Now determine the 'bad' methods in the function objects of the
    ## package.
    badMethods <- list()
    envList <- list(codeEnv)
    if(!isBase) envList <- c(envList, list(as.environment(NULL)))
    for(env in envList) {
        allObjs <- ls(envir = env, all.names = TRUE)
        ## <FIXME>
        ## This is not good enough for base where we also have generics
        ## which dispatch in C code.  We should also add group methods.
        genFuns <- allObjs[sapply(allObjs, isS3Generic, env) == TRUE]        
        ## </FIXME>

        for(g in genFuns) {
            ## Find all methods in funs for generic g.  Taken from the
            ## current code for methods().
            name <- paste("^", g, ".", sep = "")
            methods <- grep(gsub("([.[])", "\\\\\\1", name),
                            funs, value = TRUE)
            methods <- methods[! methods %in% methodsStopList]
            for(m in methods)
                badMethods <- c(badMethods, checkArgs(g, m, env))
        }
    }

    class(badMethods) <- "checkMethods"
    badMethods
}

print.checkMethods <-
function(x, ...)
{
    formatArgs <- function(s)
        paste("function(", paste(s, collapse = ", "), ")", sep = "")
    for(entry in x) {
        writeLines(c(paste(names(entry)[1], ":", sep = ""),
                     strwrap(formatArgs(entry[[1]]),
                             indent = 2, exdent = 11),
                     paste(names(entry)[2], ":", sep = ""),
                     strwrap(formatArgs(entry[[2]]),
                             indent = 2, exdent = 11),
                     ""))
    }
    invisible(x)
}

checkTnF <-
function(package, dir, file, lib.loc = NULL)
{
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        packageDir <- .find.package(package, lib.loc)
        if(file.exists(file.path(packageDir, "R", "all.rda"))) {
            warning("cannot check R code installed as image")
            return(invisible())
        }
        file <- file.path(packageDir, "R", package)
    }
    else if(!missing(dir)) {
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            dir <- file.path(dirname(dir), basename(dir))
        if(!file.exists(codeDir <- file.path(dir, "R")))
            stop(paste("directory", sQuote(dir),
                       "does not contain R code"))
        codeExts <- c("R", "r", "S", "s", "q")
        codeFiles <- .listFilesWithExts(codeDir, codeExts)
        if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
            codeFiles <- c(codeFiles,
                           .listFilesWithExts(codeOSDir, codeExts))
        file <- tempfile()
        on.exit(unlink(file))
        file.create(file)
        file.append(file, codeFiles)
    }
    else if(missing(file)) {
        stop("you must specify 'package', 'dir' or 'file'")
    }

    if(!file.exists(file))
        stop(paste("file", sQuote(file), "does not exist"))

    badExprs <- list()
    badTnF <- c("T", "F")    
    findBadExprs <- function(e, p) {
        if(is.name(e) && (as.character(e) %in% badTnF) && !is.null(p)) {
            ## Need the 'list()' to deal with T/F in function arglists
            ## which are pairlists ...
            badExprs <<- c(badExprs, list(p))
        }
        else if(is.recursive(e)) {
            for(i in seq(along = e)) Recall(e[[i]], e)
        }
    }

    exprs <- parse(file = file, n = -1)
    for(i in seq(along = exprs))
        findBadExprs(exprs[[i]], NULL)
    class(badExprs) <- "checkTnF"
    badExprs
}

print.checkTnF <-
function(x, ...)
{
    for(i in seq(along = x)) {
        writeLines(strwrap(paste("found T/F in",
                                 paste(deparse(x[[i]]), collapse = "")),
                           exdent = 4))
    }
    invisible(x)
}
Sweave <- function(file, driver=RweaveLatex(),
                   syntax=getOption("SweaveSyntax"), ...)
{
    if(is.character(driver))
        driver <- get(driver, mode="function")()
    else if(is.function(driver))
        driver <- driver()


    if(is.null(syntax))
        syntax <- SweaveGetSyntax(file)    
    if(is.character(syntax))
        syntax <- get(syntax, mode="list")
    
    drobj <- driver$setup(file=file, syntax=syntax, ...)
    on.exit(driver$finish(drobj, error=TRUE))
    
    text <- readLines(file)
    
    mode <- "doc"
    chunknr <- 0
    chunk <- NULL

    namedchunks <- list()
    for(line in text){
        if(any(grep(syntax$doc, line))){
            if(mode=="doc"){
                if(!is.null(chunk))
                    drobj <- driver$writedoc(drobj, chunk)
                mode <- "doc"
            }
            else{
                if(!is.null(chunkopts$label))
                    namedchunks[[chunkopts$label]] <- chunk
                if(!is.null(chunk))
                    drobj <- driver$runcode(drobj, chunk, chunkopts)
                mode <- "doc"
            }
            chunk <- NULL
        }
        else if(any(grep(syntax$code, line))){
            if(mode=="doc"){
                if(!is.null(chunk))
                    drobj <- driver$writedoc(drobj, chunk)
                mode <- "code"
            }
            else{
                if(!is.null(chunkopts$label))
                    namedchunks[[chunkopts$label]] <- chunk
                if(!is.null(chunk))
                    drobj <- driver$runcode(drobj, chunk, chunkopts)
                mode <- "code"
            }
            chunkopts <- sub(syntax$code, "\\1", line)
            chunkopts <- SweaveParseOptions(chunkopts,
                                            drobj$options,
                                            driver$checkopts)
            chunk <- NULL
            chunknr <- chunknr+1
            chunkopts$chunknr <- chunknr
        }
        else{
            if(mode=="code" && any(grep(syntax$coderef, line))){
                chunkref <- sub(syntax$coderef, "\\1", line)
                if(!(chunkref %in% names(namedchunks)))
                    warning(paste("Reference to unknown chunk",
                                  chunkref))
                line <- namedchunks[[chunkref]]
            }
            else if(mode=="doc" && any(grep(syntax$syntaxname, line))){
                sname <- sub(syntax$syntaxname, "\\1", line)
                syntax <- get(sname, mode = "list")
                if(class(syntax) != "SweaveSyntax")
                    stop(paste("Object '", sname,
                               "'has not class SweaveSyntax"))
                drobj$syntax <- syntax
            }
            if(is.null(chunk))
                chunk <- line
            else                    
                chunk <- c(chunk, line)
        }
    }
    if(mode=="doc") driver$writedoc(drobj, chunk)
    else drobj <- driver$runcode(drobj, chunk, chunkopts)

    on.exit()
    driver$finish(drobj)
}

###**********************************************************

SweaveSyntaxNoweb <-
    list(doc = "^@",
         code = "^<<(.*)>>=.*",
         coderef = "^<<(.*)>>.*",
         docopt = "\\\\SweaveOpts{([^}]*)}",
         docexpr = "\\\\Sexpr{([^}]*)}",
         extension = "\\.[rsRS]?nw$",
         syntaxname = "\\\\SweaveSyntax{([^}]*)}")

class(SweaveSyntaxNoweb) <- "SweaveSyntax"

SweaveSyntaxLatex <- SweaveSyntaxNoweb
SweaveSyntaxLatex$doc <-  "^[[:space:]]*\\\\end{Scode}"
SweaveSyntaxLatex$code <- "^[[:space:]]*\\\\begin{Scode}{?([^}]*)}?.*"
SweaveSyntaxLatex$coderef <- "^[[:space:]]*\\\\Scoderef{([^}]*)}.*"
SweaveSyntaxLatex$extension <- "\\.[rsRS]tex$"

SweaveGetSyntax <- function(file){

    synt <- apropos("SweaveSyntax", mode="list")
    for(sname in synt){
        s <- get(sname, mode="list")
        if(class(s) != "SweaveSyntax") next
        if(any(grep(s$extension, file))) return(s)
    }
    return(SweaveSyntaxNoweb)
}


###**********************************************************

SweaveParseOptions <- function(text, defaults=list(), check=NULL)
{
    x <- sub("^[[:space:]]*\(.*\)", "\\1", text)
    x <- sub("\(.*[^[:space:]]\)[[:space:]]*$", "\\1", x)
    x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
    x <- strsplit(x, "[[:space:]]*=[[:space:]]*")

    ## only the first option may have no name: the chunk label
    if(length(x)>0){
        if(length(x[[1]])==1){
            x[[1]] <- c("label", x[[1]])
        }
    }
    else
        return(defaults)
    
    if(any(sapply(x, length)!=2))
        stop(paste("Parse error or empty option in\n", text))

    options <- defaults
    
    for(k in 1:length(x))
        options[[ x[[k]][1] ]] <- x[[k]][2]

    if(!is.null(options[["label"]]) && !is.null(options[["engine"]]))
        options[["label"]] <- sub(paste(".", options[["engine"]], "$",
                                        sep=""),
                                  "", options[["label"]])
    
    if(!is.null(check))
        options <- check(options)
    
    options
}

SweaveHooks <- function(options, run=FALSE, envir=.GlobalEnv)
{
    if(is.null(SweaveHooks <- getOption("SweaveHooks")))
        return(NULL)

    z <- character(0)
    for(k in names(SweaveHooks)){
        if(k != "" && !is.null(options[[k]]) && options[[k]]){
            if(is.function(SweaveHooks[[k]])){
                z <- c(z, k)
                if(run)
                    eval(SweaveHooks[[k]](), envir=envir)
            }
        }
    }
    z
}

            
        
           

###**********************************************************


RweaveLatex <- function()
{
    list(setup = RweaveLatexSetup,
         runcode = RweaveLatexRuncode,
         writedoc = RweaveLatexWritedoc,
         finish = RweaveLatexFinish,
         checkopts = RweaveLatexOptions)         
}

RweaveLatexSetup <-
    function(file, syntax,
             output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE,
             eval=TRUE, split=FALSE, stylepath=TRUE, pdf=TRUE, eps=TRUE)
{
    if(is.null(output)){
        prefix.string <- basename(sub(syntax$extension, "", file))
        output <- paste(prefix.string, "tex", sep=".")
    }
    else{
        prefix.string <- basename(sub("\\.tex$", "", output))
    }
    if(!quiet) cat("Writing to file ", output, "\n",
                   "Processing code chunks ...\n", sep="")
    output <- file(output, open="w+")
    
    if(stylepath)
        styfile <- file.path(.path.package("tools"),
                             "Sweave", "Sweave")
    else
        styfile <- "Sweave"

    options <- list(prefix=TRUE, prefix.string=prefix.string,
                    engine="R", print=FALSE, eval=eval,
                    fig=FALSE, pdf=pdf, eps=eps, 
                    width=6, height=6, term=TRUE,
                    echo=echo, results="verbatim", split=split,
                    strip.white=TRUE, include=TRUE)
    
    list(output=output, styfile=styfile, havesty=FALSE,
         debug=debug, quiet=quiet, syntax = syntax,
         options=options, chunkout=list())
}

RweaveLatexRuncode <- function(object, chunk, options)
{    
    if(!(options$engine %in% c("R", "S"))){
        return(object)
    }

    if(!object$quiet){
        cat(formatC(options$chunknr, width=2), ":")
        if(options$echo) cat(" echo")
        if(options$eval){
            if(options$print) cat(" print")
            if(options$term) cat(" term")
            cat("", options$results)
            if(options$fig){
                if(options$eps) cat(" eps") 
                if(options$pdf) cat(" pdf") 
            }
        }
        if(!is.null(options$label))
            cat(" (label=", options$label, ")", sep="")
        cat("\n")
    }

    chunkprefix <- RweaveChunkPrefix(options)
    
    if(options$split){
        chunkout <- object$chunkout[[chunkprefix]]
        if(is.null(chunkout)){
            chunkout <- file(paste(chunkprefix, "tex", sep="."), "w")
            if(!is.null(options$label))
                object$chunkout[[chunkprefix]] <- chunkout
        }
    }
    else
        chunkout <- object$output

    SweaveHooks(options, run=TRUE)
    chunkexps <- parse(text=chunk)
    openSinput <- FALSE

    if(length(chunkexps)==0)
        return(object)
    
    for(nce in 1:length(chunkexps))
    {
        ce <- chunkexps[[nce]]
        dce <- deparse(ce)
        if(object$debug)
            cat("\nRnw> ", paste(dce, collapse="\n+  "),"\n")
        if(options$echo){
            if(!openSinput){
                cat("\\begin{Sinput}",
                    file=chunkout, append=TRUE)
                openSinput <- TRUE
            }
            cat("\nR> ", paste(dce, collapse="\n+  "),
                file=chunkout, append=TRUE, sep="")
        }

        tmpcon <- textConnection("output", "w")
        sink(file=tmpcon)
        err <- NULL
        if(options$eval) err <- RweaveEvalWithOpt(ce, options)
        sink()
        close(tmpcon)
        if(inherits(err, "try-error")) stop(err)
        
        if(object$debug)
            cat(paste(output, collapse="\n"))
        
        if(length(output)>0 & (options$results!="hide")){
            if(openSinput){
                cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
                openSinput <- FALSE
            }
            if(options$results=="verbatim")
                cat("\\begin{Soutput}\n",
                    file=chunkout, append=TRUE)

            output <- paste(output,collapse="\n")
            if(options$strip.white){
                output <- sub("^[[:space:]]*\n", "", output)
                output <- sub("\n[[:space:]]*$", "", output)
            }
            cat(output, file=chunkout, append=TRUE)
            remove(output)
            
            if(options$results=="verbatim"){
                cat("\n\\end{Soutput}\n", file=chunkout, append=TRUE)
            }
        }
    }

    if(openSinput){
        cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
    }
    
    if(is.null(options$label) & options$split)
        close(chunkout)

    if(options$split & options$include)
        cat("\\input{", chunkprefix, "}\n", sep="",
            file=object$output, append=TRUE)

    if(options$fig && options$eval){
        if(options$eps){
            postscript(file=paste(chunkprefix, "eps", sep="."),
                       width=options$width, height=options$height,
                       paper="special", horizontal=FALSE)
            
            err <- try({SweaveHooks(options, run=TRUE);
                        eval(chunkexps, envir=.GlobalEnv)})
            dev.off()
            if(inherits(err, "try-error")) stop(err)
        }
        if(options$pdf){
            pdf(file=paste(chunkprefix, "pdf", sep="."),
                width=options$width, height=options$height)

            err <- try({SweaveHooks(options, run=TRUE);
                        eval(chunkexps, envir=.GlobalEnv)})
            dev.off()
            if(inherits(err, "try-error")) stop(err)
        }
        if(options$include)
            cat("\\includegraphics{", chunkprefix, "}\n", sep="",
                file=object$output, append=TRUE)
    }
    return(object)
}

RweaveLatexWritedoc <- function(object, chunk)
{
    if(any(grep("\\usepackage[^\}]*Sweave.*\}", chunk)))
        object$havesty <- TRUE

    if(!object$havesty){
        chunk <- gsub("\\\\begin\\{document\\}",
                      paste("\\\\usepackage{",
                            object$styfile,
                            "}\n\\\\begin{document}", sep=""),
                      chunk)
        object$havesty <- TRUE
    }

    while(any(pos <- grep(object$syntax$docexpr, chunk)))
    {
        cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]])
        cmd <- substr(chunk[pos[1]], cmdloc,
                      cmdloc+attr(cmdloc, "match.length")-1)
        cmd <- sub(object$syntax$docexpr, "\\1", cmd)
        if(object$options$eval)
            val <- as.character(eval(parse(text=cmd), envir=.GlobalEnv))
        else
            val <- paste("\\\\verb{<<", cmd, ">>{", sep="")
        
        chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]])
    }
    while(any(pos <- grep(object$syntax$docopt, chunk)))
    {
        opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
                    "\\1", chunk[pos[1]])
        object$options <- SweaveParseOptions(opts, object$options,
                                             RweaveLatexOptions)
        chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
    }

    cat(chunk, sep="\n", file=object$output, append=TRUE)
    return(object)
}

RweaveLatexFinish <- function(object, error=FALSE)
{
    if(!object$quiet && !error)
        cat(paste("\nYou can now run LaTeX on",
                  summary(object$output)$description), "\n")
    close(object$output)
    if(length(object$chunkout)>0){
        for(con in object$chunkout) close(con)
    }
}

RweaveLatexOptions <- function(options)
{
    ## convert a character string to logical
    c2l <- function(x){
        if(is.null(x)) return(FALSE)
        else return(as.logical(toupper(as.character(x))))
    }

    NUMOPTS <- c("width", "height")
    NOLOGOPTS <- c(NUMOPTS, "results", "prefix.string",
                   "engine", "label")

    for(opt in names(options)){
        if(! (opt %in% NOLOGOPTS)){
            oldval <- options[[opt]]
            if(!is.logical(options[[opt]])){
                options[[opt]] <- c2l(options[[opt]])
            }
            if(is.na(options[[opt]]))
                stop(paste("invalid value for", opt, ":", oldval))
        }
        else if(opt %in% NUMOPTS){
            options[[opt]] <- as.numeric(options[[opt]])
        }
    }

    options$results <- match.arg(options$results,
                                 c("verbatim", "tex", "hide"))

    options
}


RweaveChunkPrefix <- function(options)
{
    if(!is.null(options$label)){
        if(options$prefix)
            chunkprefix <- paste(options$prefix.string, "-",
                                 options$label, sep="")
        else
            chunkprefix <- options$label
    }
    else            
        chunkprefix <- paste(options$prefix.string, "-",
                             formatC(options$chunknr, flag="0", width=3),
                             sep="")

    return(chunkprefix)
}

RweaveEvalWithOpt <- function (expr, options){
    if(options$eval){
        res <- try(.Internal(eval.with.vis(expr, .GlobalEnv, NULL)))
        if(inherits(res, "try-error")) return(res)
        if(options$print | (options$term & res$visible))
            print(res$value)
    }
    return(res)
}
    


###**********************************************************
            
Stangle <- function(file, driver=Rtangle(),
                    syntax=getOption("SweaveSyntax"), ...)
{
    Sweave(file=file, driver=driver, ...)
}
            
Rtangle <-  function()
{
    list(setup = RtangleSetup,
         runcode = RtangleRuncode,
         writedoc = RtangleWritedoc,
         finish = RtangleFinish,
         checkopts = RweaveLatexOptions)
}


RtangleSetup <- function(file, syntax,
                         output=NULL, annotate=TRUE, split=FALSE,
                         prefix=TRUE, quiet=FALSE)
{
    if(is.null(output)){
        prefix.string <- basename(sub(syntax$extension, "", file))
        output <- paste(prefix.string, "R", sep=".")
    }
    else{
        prefix.string <- basename(sub("\\.[rsRS]$", "", output))
    }
    
    if(!split){
        if(!quiet)
            cat("Writing to file", output, "\n")
        output <- file(output, open="w")
    }
    else{
        if(!quiet)
            cat("Writing chunks to files ...\n")
        output <- NULL
    }

    options <- list(split=split, prefix=prefix,
                    prefix.string=prefix.string,
                    engine="R")

    list(output=output, annotate=annotate, options=options,
         chunkout=list(), quiet=quiet, syntax=syntax)
}
               
    
RtangleRuncode <-  function(object, chunk, options)
{
    if(!(options$engine %in% c("R", "S"))){
        return(object)
    }

    chunkprefix <- RweaveChunkPrefix(options)
    
    if(options$split){
        outfile <- paste(chunkprefix, options$engine, sep=".")
        if(!object$quiet)
            cat(options$chunknr, ":", outfile,"\n")
        chunkout <- object$chunkout[[chunkprefix]]
        if(is.null(chunkout)){
            chunkout <- file(outfile, "w")
            if(!is.null(options$label))
                object$chunkout[[chunkprefix]] <- chunkout
        }
    }
    else
        chunkout <- object$output

    if(object$annotate){
        cat("###################################################\n",
            "### chunk number ", options$chunknr,
            ": ", options$label, "\n",
            "###################################################\n",
            file=chunkout, append=TRUE, sep="")
    }

    hooks <- SweaveHooks(options, run=FALSE)
    for(k in hooks)
        cat("getOption(\"SweaveHooks\")[[\"", k, "\"]]()\n",
            file=chunkout, append=TRUE, sep="")

    cat(chunk,"\n", file=chunkout, append=TRUE, sep="\n")

    if(is.null(options$label) & options$split)
        close(chunkout)

    return(object)
}

RtangleWritedoc <- function(object, chunk)
{
    while(any(pos <- grep(object$syntax$docopt, chunk)))
    {
        opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
                    "\\1", chunk[pos[1]])
        object$options <- SweaveParseOptions(opts, object$options)
        chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
    }
    return(object)
}


RtangleFinish <- function(object, error=FALSE)
{
    if(!is.null(object$output))
        close(object$output)

    if(length(object$chunkout)>0){
        for(con in object$chunkout) close(con)
    }
}

## run a tangle+source and a weave on all vignettes of a package

checkVignettes <- function(package, dir, lib.loc = NULL,
                           tangle=TRUE, weave=TRUE,
                           workdir=c("tmp", "src", "cur"),
                           keepfiles = FALSE)
{
    vigns <- pkgVignettes(package=package, dir=dir, lib.loc=lib.loc)
    if(is.null(vigns)) return(NULL)
    
    workdir <- match.arg(workdir)
    wd <- getwd()
    if(workdir=="tmp"){
        tmpd <- tempfile("Sweave")
        dir.create(tmpd)
        setwd(tmpd)
    }
    else{
        keepfiles <- TRUE
        if(workdir=="src") setwd(vigns$dir)
    }
    
    outConn <- textConnection("out", "w")
    sink(outConn, type = "output")
    sink(outConn, type = "message")
    
    on.exit({sink(type = "output")
             sink(type = "message")
             setwd(wd)
             if(!keepfiles) unlink(tmpd, recursive=TRUE)
         })

    result <- list(tangle=list(), weave=list(),
                   source=list())

    
    for(f in vigns$docs){
        if(tangle){
            yy <- try(Stangle(f, quiet=TRUE))
            if(inherits(yy, "try-error"))
                result$tangle[[f]] <- yy
        }
        
        if(weave){
            yy <- try(Sweave(f, quiet=TRUE))
            if(inherits(yy, "try-error"))
                result$weave[[f]] <- yy                
        }
    }

    if(tangle){
        rfiles <- .listFilesWithExts(getwd(), c("r", "s", "R", "S"))
        for(f in rfiles){
            yy <- try(source(f))
            if(inherits(yy, "try-error"))
                result$source[[f]] <- yy                                
        }
    }

    class(result) <- "checkVignettes"
    result
}
    
    
print.checkVignettes <- function(x, ...)
{

    mycat <- function(y, title){    
        if(length(y)>0){
            cat("\n", title, "\n\n", sep="")
            for(k in 1:length(y)){
                cat("File", names(y)[k], ":\n")
                cat(as.character(y[[k]]), "\n")
            }
        }
    }

    mycat(x$weave,  "*** Weave Errors ***")
    mycat(x$tangle, "*** Tangle Errors ***")
    mycat(x$source, "*** Source Errors ***")    
}    



## get an object of class pkgVignettes which contains a list of Sweave
## files and the name of the directory which contains them

pkgVignettes <- function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1)
            stop("argument 'package' must be of length 1")
        docdir <- file.path(.find.package(package, lib.loc), "doc")
        ## Using package installed in @code{dir} ...
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file.exists(dir))
            stop(paste("directory", sQuote(dir), "does not exist"))
        else
            ## maybe perform tilde expansion on @code{dir}
            docdir <- file.path(dirname(dir), basename(dir), "inst", "doc")
    }
    
    if(!file.exists(docdir)) return(NULL)

    exts <- outer(c("r", "s", "R", "S"), c("nw","tex"), paste, sep="")
    docs <- .listFilesWithExts(docdir, exts)
    
    z <- list(docs=docs, dir=docdir)
    class(z) <- "pkgVignettes"
    z
}


## run a weave and pdflatex on all vignettes of a package and try to
## remove all temporary files that were created

buildVignettes <-function(package, dir, lib.loc = NULL)
{
    vigns <- pkgVignettes(package=package, dir=dir, lib.loc=lib.loc)
    if(is.null(vigns)) return(NULL)
    
    wd <- getwd()
    setwd(vigns$dir)

    on.exit(setwd(wd))

    origfiles <- list.files()
    have.makefile <- "makefile" %in% tolower(origfiles)

    pdfs <- character(0)
    for(f in vigns$docs){
            
        f <- basename(f)
        bf <- sub("\\..[^\\.]*$", "", f)
        bft <- paste(bf, ".tex", sep="")
        pdfs <- c(pdfs, paste(bf, ".pdf", sep=""))
            
        yy <- try(Sweave(f, quiet=TRUE))
        if(inherits(yy, "try-error")) return(yy)
        if(!have.makefile){
            yy <- system(paste(file.path(R.home(), "bin", "texi2dvi"),
                               "--pdf", bft, ">",
                               paste(bf, ".stdout", sep="")))
            if(yy>0)
                return(paste("Error: running texi2dvi on", bft, "failed"))
        }
    }
    
    if(have.makefile)
    {
        yy <- system(Sys.getenv("MAKE"))
        if(yy>0) return("Error: running make failed")
    }
    else{
        f <- list.files()
        f <- f[!(f %in% c(pdfs, origfiles))]
        unlink(f)
    }
    invisible(NULL)
}
        
                      
                     

        
            
        
