revdepcheck: Reverse Dependency Checks

## TO DO
## * store pkg version tested, timestamp
## * include suggests/depends/etc. in genReport, or allow subsetting
## * Comparison with devtools::revdep_check, tools::check_packages_in_dir
## * homogenize naming conventions!

##' Originally downloaded from http://developer.r-project.org/CRAN/Scripts/depends.R.
##' Modified to include package dependency type,
##' return results as data frame with package rownames
##' @param packages names of packages to check
##' @param which dependency types to check
##' @param cols which information to store
##' @param recursive check packages recursively?
##' @param getDepType store information about dependency type?
##' @return blah
##' @importFrom tools package_dependencies
##' @export 
reverse_dependencies_with_maintainers <-
    function(packages, which = c("Depends", "Imports", "LinkingTo"),
             cols=c("Package", "Version", "Maintainer"),
             recursive = FALSE, getDepType=TRUE)
{
    contrib.url(getOption("repos")["CRAN"],type="source") # trigger chooseCRANmirror() if required
    if (length(packages)>1 && getDepType) stop("can't do depType for >1 package")
    description <- sprintf("%s/web/packages/packages.rds",
                           getOption("repos")["CRAN"])
    con <- if(substring(description, 1L, 7L) == "file://")
        file(description, "rb")
    else
        url(description, "rb")
    on.exit(close(con))
    db <- readRDS(gzcon(con))
    rownames(db) <- NULL
    rdepends <- package_dependencies(packages, db, which,
                                     recursive = recursive,
                                     reverse = TRUE)
    rdepends <- sort(unique(unlist(rdepends)))
    pos <- match(rdepends, db[, "Package"], nomatch = 0L)
    d <- data.frame(db[pos,cols],stringsAsFactors=FALSE)
    rownames(d) <- d$Package
    if (getDepType) {
        getType <- function(r) {
            pat <- paste0("(^|[ ,]|\\n)",packages,"(\\(|[ ,]|\\n|$)")
            return(names(r)[grep(pattern=pat,r)[1]])

        }
        depType <- apply(db[pos, which],1,getType)
        d$depType <- depType
    }
    d
}

##' retrieve dependency information for a package
##' (wrapper for \code{reverse_dependencies_with_maintainers})
##' @param pkg package names
##' @param verbose print progress information?
##' @param getSuggests get "Suggests:" information?
##' @export 
getDepends <- function(pkg="lme4",verbose=FALSE, getSuggests=TRUE) {
    if (verbose) cat("retrieving dependency information\n")
    w <-  c("Depends", "Imports", "LinkingTo")
    if (getSuggests) w <- c(w,"Suggests")
    reverse_dependencies_with_maintainers(pkg,which=w)
}

##' find maximum of a pair or vector of package versions
##' @param x package 1
##' @param y package 2
pkgmax <- function(x,y) {
    if (missing(y)) {
        if (length(x)==1) return(x)
        return(Reduce(pkgmax,x))
    }
    if (package_version(x)>package_version(y)) x else y
}


##' Check all reverse dependencies of package
##' @param pn package name
##' @param verbose print output?
##' @param srcdir  directory for storing source tarballs
##' @param libdir  directory for installing packages
##' @param checkdir directory for running/storing checks
##' @param skip character vector of packages to skip
##' @param check_time record check timings?
##' @param upstream_pkg upstream package being checked
##' @export
checkPkg <- function(pn,
                     verbose=FALSE,
                     srcdir="./src",
                     libdir="./library",
                     checkdir="./check",skip=FALSE,
                     check_time=TRUE,
                     upstream_pkg=NULL,
                     ignore_site=FALSE,
                     repos=c("CRAN","rforge","bioconductor"))
{

    ## expand paths to protect against setwd() for R CMD check
    srcdir <- normalizePath(srcdir)
    libdir <- normalizePath(libdir)
    if (!dir.exists(srcdir)) dir.create(srcdir,showWarnings=FALSE)
    if (!dir.exists(libdir)) dir.create(libdir,showWarnings=FALSE)

    reposURL <- c(CRAN=unname(getOption("repos")["CRAN"]),
                   rforge="http://r-forge.r-project.org",
                   bioconductor="http://www.bioconductor.org/packages/release/bioc")
    reposURL <- reposURL[repos]

    if (!exists("availList")) availList <<- list()
    for (i in names(reposURL)) {
        if (is.null(availList[[i]]) || nrow(availList[[i]])==0) {
            if (verbose) cat("getting list of available packages from ",i,"\n")
            availList[[i]] <<- available.packages(contriburl=contrib.url(reposURL[[i]],type="source"),
                                                  type="source")
        }
    }
    .libPaths(libdir)
    ## include system files but NOT site files! (mimic test environment)
    instPkgs <- installed.packages(lib.loc=c(libdir,.Library))
    if (verbose) cat("checking package",pn,"\n")
    loc <- "none"  ## where is the package coming from?
    for (i in rev(names(availList))) {  ## check in BACKWARD order (bioc, rforge, CRAN)
        if (pn %in% rownames(availList[[i]])) {
            loc <- i
            pkginfo <- availList[[i]][pn,]
            break
        }
    }
    locpkg <- list.files(srcdir,paste0("^",pn,"_[0-9]+"))
    if (length(locpkg)>0) {
        locver <- gsub(paste0(pn,"_([-0-9.]+).tar.gz"),"\\1",locpkg)
    } else locver <- NULL
    if (loc=="none" && is.null(locver)) stop("package seems to be unavailable")
    ver <- pkginfo["Version"]  ## FIXME: check that src matches latest available???
    if (!is.null(locver)) {
        if (length(locver)>1) {
            locver <- pkgmax(locver)
        }
        if (package_version(locver)>package_version(ver)) {
            ver <- locver
            loc <- "local"
            if (verbose) cat("local package is more recent than CRAN or R-forge\n")
        }
    }
    tn <- paste0(pn,"_",ver,".tar.gz")
    tdn <- file.path(srcdir,tn)
    if (loc!="local" && !file.exists(tdn))
    {
        if (verbose) cat("downloading src\n")
        basepath <- switch(loc,CRAN=contrib.url(reposURL["CRAN"],type="source"),
                           rforge=contrib.url(reposURL["rforge"],type="source"),
                           bioconductor=contrib.url(reposURL["bioconductor"],
                               type="source"),
                           loc=stop("src not available"))
        download.file(file.path(basepath,tn),
                      destfile=tdn)
    }

    ## must have set check.Renviron here in order for R CMD check to respect libdir
    newer_check <- FALSE
    curCheckdir <- file.path(checkdir,paste0(pn,".Rcheck"))
    if (file.exists(curCheckdir)) {
        checktime <- file.info(curCheckdir)["mtime"]  ## check time
        tbinfo <- file.info(file.path(srcdir,tn)) ## src time
        tbtime <- tbinfo["mtime"]
        uptime <- NA
        if (!is.null(upstream_pkg)) {
            upinfo <- file.info(file.path(libdir,upstream_pkg))
            uptime <- upinfo["mtime"]  ## upstream pkg time
        }
        newer_check <- (checktime>tbtime && (is.na(uptime) || checktime>uptime))
        zero_tb <- tbinfo$size==0
        if (!check_time || !newer_check || zero_tb) unlink(curCheckdir)
    }
    if (!skip) {
        if (check_time && newer_check) {
            if (verbose) cat("check more recent than src, skipping\n")
            ss <- readLines(file.path(curCheckdir,"00check.log"))
            t0 <- NA
            stat <- NULL
        } else {
            ## install suggested packages that aren't already installed
            ## must have set R_LIBS, R_LIBS_SITE, R_LIBS_USER
            ##    in order to match R CMD check settings
            install_tarball(tdn,exdir=srcdir,dependencies=TRUE,libdir=libdir)
            instPkgs <- installed.packages(noCache=TRUE,lib.loc=c(.Library,libdir))  ## update installed package info

            ## FIXME: not safe?
            system('echo "R_LIBS_USER=`pwd`/library" > ~/.R/check.Renviron')
            if (ignore_site) {
                system('echo "R_LIBS_SITE=`pwd`/library" >> ~/.R/check.Renviron')
            }

            if (verbose)
                cat("running R CMD check ...\n")
            setwd(checkdir)
            
            ## with_libpaths(libdir,
            ##   install(file.path(srcdir,tn),dependencies=TRUE))  ## would like to install dependencies but NOT package ...

##
## http://r.789695.n4.nabble.com/R-CMD-check-not-reading-R-LIBS-from-R-check-Renviron-td4655781.html
            checkstr <- paste0("export R_LIBS=",libdir,"; ",
                            "R CMD check ",
                             file.path(srcdir,tn))
            tt <- system.time(ss <- suppressWarnings(system(checkstr,intern=TRUE)))
            unlink("~/.R/check.Renviron")
            if (verbose) print(ss)
            stat <- attr(ss,"status")
            ss <- paste0(seq(ss),": ",ss)
            t0 <- tt["elapsed"]
            setwd("..")
        }
    } else {
        stat <- "skipped"
        t0 <- NA
        msg <- ""
        ss <- ""
    }
    list(status=stat,msg=ss,time=t0,location=loc,version=ver)
}


dumbBrackets <- function(x) {
    gsub("<","&lt;",
         gsub(">","&gt",x))
}

## FIXME: needs to be utf-encoded/protected
dumbQuotes <- function(x) {
    gsub("[“”]","\"",
         gsub("[‘’]","'",x))
}

colorCode <- function(strvec,
                      colCodes=c(gray="skipped",purple="WARNING",
                      red="ERROR",blue="NOTE",green="OK",cyan=NA)) {
    colvec <- names(colCodes)
    m <- sapply(colCodes,grepl,x=strvec)
    otherVal <- names(colCodes)[is.na(colCodes)]
    tmpf <- function(x) {
        if (sum(w <- which(na.omit(x)==1))==0) otherVal else names(x[w[1]])
    }
    fcol <- apply(m,1,tmpf)
    paste0("<font style=\"color:",fcol,"\">",strvec,"</font>")
}

errstrings <- c(error_examples="examples.+ERROR",
            error_depfail="(Package.+but not available|package.+ERROR)",
            error_install="can be installed.+ERROR",
            error_vignette="(Errors.+vignettes|code from vignettes.+ERROR)")
diagfun <- c(error_examples=function(x) tail(x,3),
             error_depfail=function(x) {
                 grep(errstrings["error_depfail"],x,value=TRUE)
             },
             error_install=function(x) {
                 tail(readLines(file.path(checkdir,
                                          paste0(pkgname,".Rcheck"),
                                          "00install.out")))
             },
             error_vignette=function(x) tail(x,3))

statusfun <- function(x)
    gsub("^.*Status: [0-9]* *([A-Z]+).*","\\1",tail(x,1))

## diagnostic strings:
## * grep for top level string: ERROR, WARNING, NOTE
##  * if any found, combine strings within next level to look for specific
##    issues on next lines
##  * if any found, add to diag strings
##  * if not found, add "other"

diag_strings <- list(
    ERROR=list(
    tests="Running the tests.*failed",
    vignette="Errors in running code in vignettes",
    example="Running examples in",
    dependency="Packages* suggested but not available"),
    WARNING=list(
        doc="Undocumented S4 methods"),
    NOTE=list(
    "other_CRAN_note"=c("Packages* unavailable to check Rd xrefs",
    "no visible global",
    "no visible binding for global",
    "Malformed",
    "'library' or 'require' calls*",
    "Packages in Depends field",
    "includes the non-default packages",
    "looks like a leftover",
    "Packages which this enhances"),
        vignette="Error in re-building vignettes"))

##' process errors
##' @param z blah
##' @param pkgname package name
##' @param debug debug output?
##' @param checkdir check directory
procError <- function(z,pkgname=NULL,debug=FALSE,checkdir="check") {
    if (is.null(loc <- z$location)) loc <- ""
    if (is.null(ver <- z$version)) ver <- ""
    L <- list(pkgname=pkgname,location=loc,version=ver)
    if (!is.null(z$status) && z$status=="skipped") {
        m <- list(result="skipped",diag="")
    } else {
        ## won't happen?
        if (is(z,"try-error")) {
            m <- list(results="internal test failure",
                      diag="")
        } else {
            m <- list(diag="", result=statusfun(z$msg))
            cfun <- function(x) {
                paste0("(",paste(x,collapse="|"),")")
            }
            for (i in names(diag_strings)) {
                if (any(grepl(i,z$msg))) {
                    str <- lapply(diag_strings[[i]],cfun)
                    gfun <- function(target) {
                        ## get all but last line with NOTE/WARNING/ERROR
                        target.lines <- head(grep(i,z$msg),-1)+1
                        sapply(target.lines, function(i) z$msg[i])
                    }
                    found <- sapply(str,function(x) any(grepl(x,gfun(i))))
                    types <- if (!any(found)) "other" else {
                        paste(names(str)[found],collapse=", ")
                    }
                    m$diag <- c(m$diag, paste0(i,": ",types))
                }
            }
        }
    }
    m$diag <- paste(m$diag[nzchar(m$diag)],collapse="; ")
    return(c(L,m))
}

## not used?
errLevels <- c(paste("error",
                     c("depfail","examples","install","vignette"),sep="_"),
               "OK")

##' Generate report
##' @importFrom plyr rename
##' @importFrom R2HTML HTMLInitFile HTML.title HTML HTMLli HTMLEndFile
##' @param depmatrix  results of \code{reverse_dependencies_with_maintainer()}
##' @param testresults list of packages with elements status, msg, time, location, version
##' @param contact contact e-mail
##' @param pkg package name
##' @param outfn file name for output
##' @param verbose blah
##' @param extra.info blah
##' @param sort.cols blah
##' @export
genReport <- function(depmatrix,
                      testresults,
                      contact="lme4-authors <at> r-forge.wu-wien.ac.at",
                      pkg="lme4",
                      outfn=paste0(pkg,"_compat_report"),
                      verbose=FALSE,
                      extra.info=NULL,
                      sort.cols=c("result","pkgname")) {
    require(pkg,character.only=TRUE)  ## for package version  (FIXME: should be stored with test results!)
    ## FIXME: should store/pull date from test results too
    ##if (!require("R2HTML")) {
    ## auto-install because we may be missing it in the test environment ...
    ## install.packages("R2HTML"); library("R2HTML")
    ## }

    isOK <- !sapply(testresults,inherits,what="try-error")
    tOK <- testresults[isOK]

    if (FALSE) {
        ## testing
        for (i in seq_along(tOK)) {
            print(procError(tOK[[i]],names(tOK)[[i]]))
            scan()
        }
    }
    rpt <- mapply(procError,tOK,names(tOK),SIMPLIFY=FALSE)
    rpt <- lapply(rpt,
                  function(x) {
                     x$diag <- paste(dumbQuotes(x$diag),collapse="<br>")
                      data.frame(x,stringsAsFactors=FALSE)
                  })
    rpt <- do.call(rbind,rpt)
    ## add info from notes, rr
    rpt <- merge(rpt,as.data.frame(depmatrix),by.x="pkgname",by.y="Package")
    ## table of results by package status
    sumtab <- with(rpt,table(result,depType))
    rpt <- rpt[,c("pkgname",
                  "depType","location","version",
                  "Maintainer","result","diag")] ## drop e-mail, reorder
    rpt$result <- factor(rpt$result,
                         levels=c("ERROR","WARNING","NOTE","OK","skipped"))
    rpt <- rename(rpt,c(Maintainer="maintainer"))
    if (!is.null(extra.info))
        rpt <- merge(rpt,extra.info,by="pkgname",all.x=TRUE)
    ## mess with ordering by result *before* altering result!
    rpt <- rpt[do.call(order,rpt[sort.cols]),]
    ## HTML table formatting
    rpt$maintainer <- dumbBrackets(rpt$maintainer)
    rpt$result <- colorCode(as.character(rpt$result))
    rpt$depType <- colorCode(rpt$depType,
       colCodes=c(blue="Depends",green="Suggests",purple="Imports",red=NA))
    ############# now write file
    title <- paste0(pkg,": downstream package report")
    HTMLInitFile(filename=outfn,outdir=".",
                 Title=title)
    HTML("<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">")  ## for special chars in names etc.
    HTML.title(title,HR=1)
    HTML(paste(pkg,"version:",dumbQuotes(sessionInfo()[["otherPkgs"]][[pkg]][["Version"]])))
    HTML(paste("Test date: ",date()))
    HTML.title("Notes",HR=2)
    HTML("<ul>")
    HTMLli(paste("contact:",dumbBrackets(contact)))
    HTMLli("error_depfail indicates a dependency problem")
    ## HTMLli("'error_install' results due to missing dependencies are probably spurious (packages that are installed elsewhere on my machine but not seen during testing")
    HTML("</ul>")
    HTML("<hr>")
    HTML(sumtab)
    HTML("<hr>")
    HTML(rpt,innerBorder=1,sortableDF=TRUE)
    HTMLEndFile()
    outfn
}

##' Do package tests
##' @importFrom parallel mclapply
##' @importFrom devtools install with_libpaths
##' @param pkg package
##' @param do_parallel use parallel?
##' @param testdir blah
##' @param srcdir blah
##' @param libdir blah
##' @param checkdir blah
##' @param pkg_src blah
##' @param skippkgs blah
##' @param verbose blah
##' @param xvfb use X virtual framebuffer for graphics in non-interactive session?
##' @param pkgdep dependencies of focal package (FIXME: shouldn't hardcode, should try to get these from the package itself)
##' @export
doPkgDeptests <- function(pkg="lme4",
                          do_parallel=TRUE,
                          testdir=getwd(),
                          srcdir=file.path(testdir,"src"),
                          libdir=file.path(testdir,"library"),
                          checkdir=file.path(testdir,"check"),
                          pkg_src=NULL,
                          skippkgs=character(0),
                          verbose=TRUE,
                          xvfb=TRUE,
                          pkgdep=NULL,
                          repos=c("CRAN","rforge","bioconductor")) {
    ## from tools::check_package_in_dir
    ## Xvfb usage and options.
    ## We do not use Xvfb on Windows.
    ## Otherwise, if argument 'xvfb' is
    ## * a logical, Xvfb is used only if identical to TRUE;
    ## * something else, then as.character(xvfb) gives the Xvfb options.
    xvfb_options <- "-screen 0 1280x1024x24"
    if(.Platform$OS.type == "windows")
        xvfb <- FALSE
    else if(is.logical(xvfb)) {
        if(!identical(xvfb, TRUE))
            xvfb <- FALSE
    } else {
        xvfb_options <- as.character(xvfb)
        xvfb <- TRUE
    }

    if(xvfb) {
        if (length(which_xvfb <- system("which Xvfb",intern=TRUE))==0)
            stop("Xvfb not installed")
        ## FIXME: will have to copy these from tools if this goes to CRAN
        pid <- tools:::start_virtual_X11_fb(xvfb_options)
        on.exit(tools:::close_virtual_X11_db(pid), add = TRUE)
    }

    if (!dir.exists(libdir)) dir.create(libdir,showWarnings=FALSE)
    if (!dir.exists(checkdir)) dir.create(checkdir,showWarnings=FALSE)
    if (!dir.exists(srcdir)) dir.create(srcdir,showWarnings=FALSE)

    ## install focal package
    ##   expects recent source src in working directory

    instPkgs <- installed.packages(lib.loc=libdir,noCache=TRUE)
    
    pkg_src <- list.files(pattern=paste0(pkg,".*.tar.gz"))
    if (length(pkg_src)==0) {
        warning("can't find package src: not re-installing focal package")
    } else {
        tb0times <- file.info(pkg_src)$mtime
        pkg_src <- pkg_src[which.max(tb0times)]
        tb0time <- max(tb0times)
        pkg_inst <- file.exists(file.path(libdir,pkg))
        pkgtime <- if (!pkg_inst) -Inf else {
            file.info(file.path(libdir,pkg))$mtime
        }
        if (tb0time<pkgtime) {
            warning("focal package not re-installed")
        } else {
            if (is.null(pkgdep)) {
                a1 <- available.packages()
                pkgdep <- package_dependencies(pkg,a1)[[1]]
            }
            install_tarball(pkg_src,dependencies=TRUE,exdir=srcdir,libdir=libdir)
        }
    }
    ## * must export R_LIBS_SITE=./library before running R CMD BATCH
    ##   and  make sure that .R/check.Renviron is set
    ##   (this is done by setTestEnv, called from 'runCheck')

    ##  FIXME: consistent implementation of checkdir

    ## FIXME: set up an appropriate makefile structure for this ? (a little tricky if it also depends on
    ##   checking CRAN/R-forge versions?
    ##  might to be able to use update.packages() ...

    suppressWarnings(rm("availList"))
    ## suppressWarnings(rm(list=c("availCRAN","availRforge"))) ## clean up

    ## want to install additional dependencies etc. out of the way
    ## to keep original installed base clean, but this may not be feasible
    ## it would be nice to use tools:::testInstalledPackages(), but I may simply
    ##  have to do R CMD check

    rr <- getDepends(pkg,verbose)
    pkgnames <- rr[,"Package"]

    names(pkgnames) <- pkgnames ## so results are named
    pkgnames <- pkgnames[!pkgnames %in% skippkgs]

    if (verbose) {
        cat("packages to test:\n")
        print(unname(pkgnames),quote=FALSE)
    }


    if (do_parallel) {
        Apply <- mclapply
    } else Apply <- lapply
    ## FIXME (maybe): mclapply doesn't work on Windows??

    testresults <- Apply(pkgnames,function(x) {
        ## if (verbose) cat("checking package",x,"\n")  ## redundant
        try(checkPkg(x,verbose=TRUE,checkdir=checkdir,upstream_pkg=pkg,repos=repos))
    })
    skipresults <- Apply(skippkgs,function(x) try(checkPkg(x,skip=TRUE,verbose=TRUE)))
    testresults <- c(testresults,skipresults)
    return(testresults)
}

##' do all package tests
##' FIXME:: rename???
##' @param pkg package name
##' @param repos CRAN repository
##' @param notesfile notes file, if any
##' @importFrom tools package_dependencies
##' @export
doAll <- function(pkg,
                  notesfile="lme4_notes.csv",
		  repos=c("CRAN","rforge","bioconductor")) {
    ## need this because R can't handle '@CRAN@' magic default
    ## in non-interactive mode ...
    options(repos=c(CRAN="http://cran.r-project.org/",  ## HACK
            rforge="http://r-forge.r-project.org",
            bioc="http://www.bioconductor.org/packages/release/bioc"))
    rr <- getDepends(pkg)  ## download dependency structure from CRAN
    pkgnotes <- NULL
    if (!is.null(notesfile))  
        pkgnotes <- read.csv(notesfile)
    testresults <- doPkgDeptests(pkg,verbose=TRUE,do_parallel=FALSE,
                    repos=repos)
    save("testresults",file=paste0(pkg,"_tests_out.RData"))
    genReport(rr,testresults,extra.info=pkgnotes,pkg=pkg)
}

##' wrapper for install (which can handle package names or paths,
##'  but not tarballs)
##' @param tb full path to tarball
##' @param exdir directory into which to extract
##' @param libpath library for installation
##' @importFrom devtools install with_libpaths
##' @export
install_tarball <- function(tb,exdir=".",libdir=NULL,...) {
    untar(tb,exdir=exdir)
    tb0 <- basename(tb)
    pkg <- gsub("_.*$","",tb0)
    if (is.null(libdir)) {
        install(file.path(exdir,pkg),...)
    } else {
        with_libpaths(libdir,install(file.path(exdir,pkg),...))
    }
}