The R Project SVN R

tidy_validate <-
function(f, tidy = "tidy") {
    z <- suppressWarnings(system2(tidy,
                                  c("-language en", "-qe",
                                    ## <FIXME>
                                    ## HTML Tidy complains about empty
                                    ## spans, which may be ok.
                                    ## To suppress all such complaints:
                                    ##   "--drop-empty-elements no",
                                    ## To allow experimenting for now:
                                    Sys.getenv("_R_CHECK_RD_VALIDATE_RD2HTML_OPTS_",
                                               "--drop-empty-elements no"),
                                    ## </FIXME>
                                    f),
                                  stdout = TRUE, stderr = TRUE))
    if(!length(z)) return(NULL)
    ## Strip trailing \r from HTML Tidy output on Windows:
    z <- trimws(z, which = "right")
    ## (Alternatively, replace '$' by '[ \t\r\n]+$' in the regexp below.)
    s <- readLines(f, warn = FALSE)
    m <- regmatches(z,
                    regexec("^line ([0-9]+) column ([0-9]+) - (.+)$",
                            z))
    m <- unique(do.call(rbind, m[lengths(m) == 4L]))
    p <- m[, 2L]
    concordance <- as.Rconcordance(grep("^<!-- concordance:", s, value = TRUE))
    result <- cbind(line = p, col = m[, 3L], msg = m[, 4L], txt = s[as.numeric(p)])
    
    if (!is.null(concordance))
        result <- cbind(result, matchConcordance(p, concordance = concordance))
    
    result
}

tidy_validate_db <-
function(x, paths = NULL) {
    if(!is.null(paths))
        names(x) <- paths
    x <- Filter(length, x)
    if(!length(x)) return(NULL)
    cbind(path = rep.int(names(x), vapply(x, nrow, 0)),
          do.call(rbind, x))
}

tidy_validate_files <-
function(files, verbose = interactive()) {
    tidy_validate_db(lapply(files,
                            function(f) {
                                if(verbose)
                                    message(sprintf("Processing %s ...",
                                                    f))
                                tidy_validate(f)
                            }),
                     files)
}

tidy_validate_R_httpd_path <-
function(path) {
    y <- httpd(path, query = NULL)
    if(!is.null(f <- y$file)) {
        ## Should only do this for appropriate content types
        if(is.null(y$"content-type"))
            tidy_validate(f)
        else
            NULL
    } else if(!is.null(payload <- y$payload)) {
        f <- tempfile()
        on.exit(unlink(f))
        writeLines(payload, f)
        tidy_validate(f)
    } else NULL
}

tidy_validate_package_Rd_files <-
function(package, dir, lib.loc = NULL, auto = NA, verbose = interactive())
{
    if(!missing(dir))
        return(tidy_validate_package_Rd_files_from_dir(dir, auto, verbose))

    if(!length(package)) return(NULL)

    n <- 3L

    one <- function(p) {
        if(verbose)
            message(sprintf("* Package: %s", p))
        db <- tools::Rd_db(p, lib.loc = lib.loc)
        files <- sub("[Rr]d$", "html", basename(names(db)))
        results <-
            lapply(files,
                   function(f) {
                       if(verbose)
                           message(sprintf("Processing %s ...", f))
                       path <- sprintf("/library/%s/html/%s", p, f)
                       tryCatch(tidy_validate_R_httpd_path(path),
                                error = identity)
                   })
        ## names(results) <- sprintf("%s/%s", p, files)
        ## results <- Filter(length, results)
        ## if(!length(results)) return(NULL)
        ## cbind(file = rep.int(names(results), vapply(results, nrow, 0)),
        ##       do.call(rbind, results))
        tidy_validate_db(results, sprintf("%s/%s", p, files))
    }

    do.call(rbind, lapply(package, one))
}

tidy_validate_package_Rd_files_from_dir <- function(dir, auto = NA, verbose) {

    if(!length(dir)) return(NULL)

    out <- tempfile()
    on.exit(unlink(out))

    one <- function(d) {
        if(verbose)
            message(sprintf("* Package: %s", basename(d)))
        db <- tools::Rd_db(dir = d)
        if(!is.na(auto)) {
            ## Rd files auto-generated by roxygen2 start with
            ##   % Generated by roxygen2
            ## However, in the Rd db we don't have this info, as we go
            ## via stage 2 Rd preparation which drops COMMENT elements
            ## (we might want to make this more customizable?).  So we
            ## try to get the info from the Rd file sources.
            is <- vapply(file.path(d, "man", names(db)),
                         function(f) {
                             if(!file.exists(f))
                                 FALSE
                             else
                                 (readChar(f, 23, useBytes = TRUE) ==
                                  "% Generated by roxygen2")
                         },
                         NA)
            db <- db[if(auto) is else !is]
        }
        results <-
            lapply(db,
                   function(x) {
                       tools::Rd2HTML(x, out, concordance = TRUE)
                       tidy_validate(out)
                   })
        tidy_validate_db(results,
                         sprintf("%s::%s", basename(d), names(db)))
    }

    do.call(rbind, lapply(dir, one))
}


tidy_validate_urls <-
function(urls, verbose = interactive()) {
    destfile <- tempfile("tidy_validate")
    on.exit(unlink(destfile))
    tidy_validate_db(lapply(urls,
                            function(u) {
                                if(verbose)
                                    message(sprintf("Processing %s ...",
                                                    u))
                                utils::download.file(u, destfile,
                                                     quiet = TRUE)
                                tidy_validate(destfile)
                            }),
                     urls)
}