1# Package related functions 2# 3# Author: Renaud Gaujoux 4# Creation: 29 Jun 2012 5############################################################################### 6 7#' @include package.R 8NULL 9 10path.protect <- function(...){ 11 f <- file.path(...) 12 if( .Platform$OS.type == 'windows' ){ 13 f <- gsub("\\\\", "/", f) 14 } 15 paste('"', f, '"', sep='') 16} 17 18#' Quick Installation of a Source Package 19#' 20#' Builds and install a minimal version of a package from its 21#' source directory. 22#' 23#' @param path path to the package source directory 24#' @param destdir installation directory. 25#' If \code{NULL}, the package is installed in the default installation library. 26#' If \code{NA}, the package is installed in a temporary directory, whose path is returned 27#' as a value. 28#' @param vignettes logical that indicates if the vignettes should be 29#' rebuilt and installed. 30#' @param force logical that indicates if the package should be installed even if a previous 31#' installation exists in the installation library. 32#' @param ... extra arguments passed to \code{\link{R.CMD}} 33#' @param lib.loc library specification. 34#' If \code{TRUE} then the installation directory \code{destdir} is added to the default 35#' library paths. 36#' This can be usefull if dependencies are installed in this directory. 37#' If \code{NULL}, then the default library path is left unchanged. 38#' 39#' @return The path of the library where the package was installed. 40#' 41#' @export 42#' 43quickinstall <- function(path, destdir=NULL, vignettes=FALSE, force=TRUE, ..., lib.loc=if(!is.null(destdir)) TRUE){ 44 45 npath <- normalizePath(path) 46 pkg <- as.package(path) 47 48 # define installation library 49 nlib <- if( !is.null(destdir) ) destdir 50 else if( is_NA(destdir) ) tempfile("pkglib_") 51 52 # normalize path 53 if( !is.null(nlib) ){ 54 # create direcory if needed 55 if( !is.dir(nlib) ) dir.create(nlib, recursive=TRUE) 56 nlib <- normalizePath(nlib) 57 58 if( !is.dir(nlib) ){ 59 stop("Could not install package '", pkg$package, "': installation directory '", nlib, "' does not exist.") 60 } 61 62 # add destination directory to default libraries 63 if( isTRUE(lib.loc) ) lib.loc <- unique(c(nlib, .libPaths())) 64 } 65 66 # setup result string 67 res <- invisible(if( !is.null(destdir) ) nlib else .libPaths()[1L]) 68 69 # early exit if the package already exists in the library (and not forcing install) 70 message("# Check for previous package installation ... ", appendLF=FALSE) 71 if( !is.null(destdir) && is.dir(file.path(nlib, pkg$package)) ){ 72 if( !force ){ 73 message("YES (skip)") 74 return(res) 75 } 76 message("YES (replace)") 77 }else message("NO") 78 79 # add lib path 80 ol <- set_libPaths(lib.loc) 81 on.exit(set_libPaths(ol), add=TRUE) 82 message("Using R Libraries: ", str_out(.libPaths(), Inf)) 83 84 owd <- setwd(tempdir()) 85 on.exit( setwd(owd), add=TRUE) 86 87 # build 88 message("# Building package `", pkg$package, "` in '", getwd(), "'") 89 opts <- '--no-manual --no-resave-data ' 90 if( !vignettes ){ 91 vflag <- if( testRversion('>= 3.0') ) '--no-build-vignettes ' else '--no-vignettes ' 92 opts <- str_c(opts, vflag) 93 } 94 R.CMD('build', opts, path.protect(npath), ...) 95 spkg <- paste(pkg$package, '_', pkg$version, '.tar.gz', sep='') 96 if( !file.exists(spkg) ) stop('Error in building package `', pkg$package,'`') 97 # install 98 message("# Installing package `", pkg$package, "`" 99 , if( !is.null(destdir) ){ 100 tmp <- if( is_NA(destdir) ) 'temporary ' 101 str_c("in ", tmp, "'", nlib, "'") 102 }) 103 opts_inst <- ' --no-multiarch --no-demo --with-keep.source ' 104 if( !vignettes ) opts_inst <- str_c(opts_inst, '--no-docs ') 105 R.CMD('INSTALL', if( !is.null(destdir) ) paste('-l', path.protect(nlib)), opts_inst, path.protect(spkg), ...) 106 107 # return installation library 108 invisible(res) 109} 110 111#' Loading Packages 112#' 113#' \code{require.quiet} silently requires a package, and \code{qrequire} is an alias to \code{require.quiet}. 114#' 115#' @param ... extra arguments passed to \code{\link{library}} or \code{\link{require}}. 116#' 117#' @rdname packages 118#' @family require 119#' @export 120require.quiet <- .silenceF(require) 121#' @rdname packages 122#' @export 123qrequire <- require.quiet 124 125#' @describeIn packages silently loads a package. 126#' 127#' @export 128qlibrary <- .silenceF(library) 129 130#' @describeIn packages tries loading a package with base \code{\link{require}} 131#' and stops with a -- custom -- error message if it fails to do so. 132#' 133#' @param msg error message to use, to which is appended the string 134#' \code{' requires package <pkg>'} to build the error message. 135#' @param package name of the package to load. 136#' @inheritParams base::require 137#' 138#' @export 139#' @examples 140#' 141#' mrequire('Running this example', 'stringr') 142#' try( mrequire('Doing impossible things', 'notapackage') ) 143#' 144mrequire <- function(msg, package, lib.loc = NULL, quietly = FALSE){ 145 146 if( !require(package = package, character.only = TRUE, lib.loc = lib.loc, quietly = quietly) ){ 147 if( !is.null(msg) ) stop(msg, " requires package ", str_out(package)) 148 else stop("Could not find required package ", str_out(package)) 149 } 150} 151 152#' @param pkg package name to load. 153#' @rdname pkgmaker-deprecated 154#' @export 155requirePackage <- function(pkg, ...){ 156 .Deprecated('mrequire') 157# mrequire(msg = c(...), package = pkg) 158} 159 160#' Setting Mirrors and Repositories 161#' 162#' \code{setBiocMirror} sets all Bioconductor repositories (software, data, 163#' annotation, etc.). 164#' so that they are directly available to \code{\link{install.packages}}. 165#' It differs from \code{\link{chooseBioCmirror}} in that it effectively enables 166#' the repositories. 167#' 168#' @param url or Bioconductor mirror url 169#' @param version version number 170#' @param unique logical that indicate if duplicated urls or names should be 171#' removed. 172#' 173#' @rdname mirrors 174#' @export 175setBiocMirror <- function(url='http://www.bioconductor.org', version=NULL, unique=TRUE){ 176 177 #get all bioconductor repos 178 biocRepos <- getBiocRepos(url, version) 179 180 repos <- c(biocRepos, getOption('repos')) 181 if( unique ){ 182 nam <- names(repos) 183 repos <- repos[!duplicated(repos) & (!duplicated(nam) | nam=='')] 184 } 185 options(repos=repos) 186} 187 188#' @describeIn mirrors is a shortcut for \code{getOption('BioC_mirror')}, which 189#' returns the current Bioconductor mirror as used by \code{biocLite}. 190#' 191#' @export 192getBiocMirror <- function(){ 193 getOption('BioC_mirror') 194} 195#' @describeIn mirrors returns urls to all Bioconductor repositories on a 196#' given mirror. 197#' 198#' @export 199getBiocRepos <- function(url='http://www.bioconductor.org', version=NULL){ 200 201 if( is.null(url) ){ 202 url <- getBiocMirror() 203 if( is.null(url) ) 204 stop("No Bioconductor mirror was setup. Use `setBiocMirror`.") 205 } 206 207 ## BioConductor CRAN-style repositories. 208 ## The software repo (bioc) _must_ be the first element. 209 biocParts <- c( 210 bioc='bioc' 211 , biocData='data/annotation' 212 , biocExp='data/experiment' 213 , biocExtra='extra' 214 ) 215 216 # define version suffix for bioconductor repo 217 if( is.null(version) ){ 218 assoc <- list(`2`=c(7L, 2L)) 219 Rv <- as.integer(sub("([0-9]+).*", "\\1", R.version$minor)) 220 offset <- assoc[[R.version$major]] 221 version <- paste(R.version$major, offset[2L] + Rv - offset[1L], sep='.') 222 } 223 224 #add version suffix for bioconductor repo 225 setNames(paste(url, 'packages', version, biocParts, sep='/'), names(biocParts)) 226} 227 228#' @describeIn mirrors sets the preferred CRAN mirror. 229#' 230#' @export 231setCRANMirror <- function(url=CRAN, unique=TRUE){ 232 233 repos <- c(CRAN=url, getOption('repos')) 234 if( unique ){ 235 nam <- names(repos) 236 repos <- repos[!duplicated(repos) & (!duplicated(nam) | nam=='')] 237 } 238 options(repos=repos) 239} 240 241#' Main CRAN Mirror URL 242#' 243#' \code{CRAN} simply contains the url of CRAN main mirror 244#' (\url{https://cran.r-project.org}), and aims at simplifying its use, e.g., in 245#' calls to \code{\link{install.packages}}. 246#' 247#' @export 248#' 249#' @examples 250#' \dontrun{ 251#' install.packages('pkgmaker', repos=CRAN) 252#' } 253CRAN <- 'https://cran.r-project.org' 254 255 256#' Adding Package Libraries 257#' 258#' Prepend/append paths to the library path list, using \code{\link{.libPaths}}. 259#' 260#' This function is meant to be more convenient than \code{.libPaths}, which requires 261#' more writing if one wants to: 262#' \itemize{ 263#' \item sequentially add libraries; 264#' \item append and not prepend new path(s); 265#' \item keep the standard user library in the search path. 266#' } 267#' 268#' @param ... paths to add to .libPath 269#' @param append logical that indicates that the paths should be appended 270#' rather than prepended. 271#' 272#' @export 273#' 274#' @examples 275#' ol <- .libPaths() 276#' # called sequentially, .libPaths only add the last library 277#' show( .libPaths('.') ) 278#' show( .libPaths(tempdir()) ) 279#' # restore 280#' .libPaths(ol) 281#' 282#' # .libPaths does not keep the standard user library 283#' show( .libPaths() ) 284#' show( .libPaths('.') ) 285#' # restore 286#' .libPaths(ol) 287#' 288#' # with add_lib 289#' show( add_lib('.') ) 290#' show( add_lib(tempdir()) ) 291#' show( add_lib('..', append=TRUE) ) 292#' 293#' # restore 294#' .libPaths(ol) 295#' 296add_lib <- function(..., append=FALSE){ 297 298 p <- 299 if( append ) c(.libPaths(), ...) 300 else c(..., .libPaths()) 301 .libPaths(p) 302} 303 304 305#' Package Check Utils 306#' 307#' \code{isCRANcheck} \strong{tries} to identify if one is running CRAN-like checks. 308#' 309#' Currently \code{isCRANcheck} returns \code{TRUE} if the check is run with 310#' either environment variable \code{_R_CHECK_TIMINGS_} (as set by flag \code{'--timings'}) 311#' or \code{_R_CHECK_CRAN_INCOMINGS_} (as set by flag \code{'--as-cran'}). 312#' 313#' \strong{Warning:} the checks performed on CRAN check machines are on purpose not always 314#' run with such flags, so that users cannot effectively "trick" the checks. 315#' As a result, there is no guarantee this function effectively identifies such checks. 316#' If really needed for honest reasons, CRAN recommends users rely on custom dedicated environment 317#' variables to enable specific tests or examples. 318#' 319#' @param ... each argument specifies a set of tests to do using an AND operator. 320#' The final result tests if any of the test set is true. 321#' Possible values are: 322#' \describe{ 323#' \item{\code{'timing'}}{Check if the environment variable \code{_R_CHECK_TIMINGS_} is set, 324#' as with the flag \code{'--timing'} was set.} 325#' \item{\code{'cran'}}{Check if the environment variable \code{_R_CHECK_CRAN_INCOMING_} is set, 326#' as with the flag \code{'--as-cran'} was set.} 327#' } 328#' 329#' @references Adapted from the function \code{CRAN} 330#' in the \pkg{fda} package. 331#' 332#' @export 333isCRANcheck <- function(...){ 334 335 tests <- list(...) 336 if( !length(tests) ){ #default tests 337 tests <- list('timing', 'cran') 338 } 339 test_sets <- c(timing="_R_CHECK_TIMINGS_", cran='_R_CHECK_CRAN_INCOMING_') 340 tests <- sapply(tests, function(x){ 341 # convert named tests 342 if( length(i <- which(x %in% names(test_sets))) ){ 343 y <- test_sets[x[i]] 344 x <- x[-i] 345 x <- c(x, y) 346 } 347 # get environment variables 348 evar <- unlist(sapply(x, Sys.getenv)) 349 all(nchar(as.character(evar)) > 0) 350 }) 351 352 any(tests) 353} 354#' @describeIn isCRANcheck tells if one is running CRAN check with flag \code{'--timing'}. 355#' 356#' @export 357isCRAN_timing <- function() isCRANcheck('timing') 358 359#' @describeIn isCRANcheck tries harder to test if running under \code{R CMD check}. 360#' It will definitely identifies check runs for: 361#' \itemize{ 362#' \item unit tests that use the unified unit test framework defined by \pkg{pkgmaker} (see \code{\link{utest}}); 363#' \item examples that are run with option \code{R_CHECK_RUNNING_EXAMPLES_ = TRUE}, 364#' which is automatically set for man pages generated with a fork of \pkg{roxygen2} (see \emph{References}). 365#' } 366#' 367#' Currently, \code{isCHECK} checks both CRAN expected flags, the value of environment variable 368#' \code{_R_CHECK_RUNNING_UTESTS_}, and the value of option \code{R_CHECK_RUNNING_EXAMPLES_}. 369#' It will return \code{TRUE} if any of these environment variables is set to 370#' anything not equivalent to \code{FALSE}, or if the option is \code{TRUE}. 371#' For example, the function \code{\link{utest}} sets it to the name of the package 372#' being checked (\code{_R_CHECK_RUNNING_UTESTS_=<pkgname>}), 373#' but unit tests run as part of unit tests vignettes are run with 374#' \code{_R_CHECK_RUNNING_UTESTS_=FALSE}, so that all tests are run and reported when 375#' generating them. 376#' 377#' @references \url{https://github.com/renozao/roxygen} 378#' @export 379#' 380#' @examples 381#' 382#' isCHECK() 383#' 384isCHECK <- function(){ 385 isCRANcheck() || # known CRAN check flags 386 !isFALSE(utestCheckMode()) || # unit test-specific flag 387 isTRUE(getOption('R_CHECK_RUNNING_EXAMPLES_')) # roxygen generated example flag 388} 389 390#' System Environment Variables 391#' 392#' @param name variable name as a character string. 393#' @param raw logical that indicates if one should return the raw value or 394#' the convertion of any false value to \code{FALSE}. 395#' 396#' @return the value of the environment variable as a character string or 397#' \code{NA} is the variable is not defined \strong{at all}. 398#' 399#' @export 400#' @examples 401#' 402#' # undefined returns FALSE 403#' Sys.getenv_value('TOTO') 404#' # raw undefined returns NA 405#' Sys.getenv_value('TOTO', raw = TRUE) 406#' 407#' Sys.setenv(TOTO='bla') 408#' Sys.getenv_value('TOTO') 409#' 410#' # anything false-like returns FALSE 411#' Sys.setenv(TOTO='false'); Sys.getenv_value('TOTO') 412#' Sys.setenv(TOTO='0'); Sys.getenv_value('TOTO') 413#' 414#' # cleanup 415#' Sys.unsetenv('TOTO') 416#' 417Sys.getenv_value <- function(name, raw = FALSE){ 418 val <- Sys.getenv(name, unset = NA, names = FALSE) 419 if( raw ) return(val) 420 # convert false values to FALSE if required 421 if( is.na(val) || !nchar(val) || identical(tolower(val), 'false') || val == '0' ){ 422 val <- FALSE 423 } 424 val 425} 426 427checkMode_function <- function(varname){ 428 429 .varname <- varname 430 function(value, raw = FALSE){ 431 if( missing(value) ) Sys.getenv_value(.varname, raw = raw) 432 else{ 433 old <- Sys.getenv_value(.varname, raw = TRUE) 434 if( is_NA(value) ) Sys.unsetenv(.varname) # unset 435 else do.call(Sys.setenv, setNames(list(value), .varname)) # set value 436 # return old value 437 old 438 } 439 } 440} 441 442 443utestCheckMode <- checkMode_function('_R_CHECK_RUNNING_UTESTS_') 444 445is_packagedir <- function(path, type = c('both', 'install', 'dev')){ 446 447 type <- match.arg(type) 448 switch(type, 449 both = is.file(file.path(path, 'DESCRIPTION')), 450 install = is.dir(file.path(path, 'Meta')), 451 dev = is.file(file.path(path, 'DESCRIPTION')) && !is.dir(file.path(path, 'Meta')) 452 ) 453} 454 455package_buildname <- function(path, type = c('source', 'win.binary', 'mac.binary')){ 456 p <- as.package(path) 457 type <- match.arg(type) 458 459 ext <- switch(type, 460 source = 'tar.gz', 461 win.binary = 'zip', 462 mac.binary = 'tgz') 463 sprintf("%s_%s.%s", p$package, p$version, ext) 464} 465 466 467#' Build a Windows Binary Package 468#' 469#' @param path path to a source or already installed package 470#' @param outdir output directory 471#' @param verbose logical or numeric that indicates the verbosity level 472#' 473#' @return Invisibly returns the full path to the generated zip file. 474#' @export 475#' @examples 476#' \dontrun{ 477#' 478#' # from source directory 479#' winbuild('path/to/package/source/dir/') 480#' # from tar ball 481#' winbuild('PKG_1.0.tar.gz') 482#' 483#' } 484winbuild <- function(path, outdir = '.', verbose = TRUE){ 485 486 # create output directory if necessary 487 if( !file.exists(outdir) ) dir.create(outdir, recursive = TRUE) 488 outdir <- normalizePath(outdir, mustWork = TRUE) 489 490 # install package if necessary 491 if( grepl("\\.tar\\.gz$", path) ){ 492 pkgpath <- tempfile() 493 on.exit( unlink(pkgpath, recursive = TRUE), add = TRUE) 494 dir.create(pkgpath) 495 if( verbose ) message("* Installing tar ball ", basename(path), " in temporary library ", pkgpath, " ... ") 496 p <- as.package(path, extract = TRUE) 497 R.CMD('INSTALL', '-l ', pkgpath, ' ', path) 498 if( verbose ) message('OK') 499 path <- file.path(pkgpath, p$package) 500 } 501 502 # make sure it is a pure R package 503 if( file.exists(file.path(path, 'src')) ){ 504 stop("Cannot build windows binary for non-pure R packages (detected src/ sub-directory)") 505 } 506 p <- as.package(path) 507 508 # install package in temporary directory if necessary 509 pkgpath <- p$path 510 if( !is_packagedir(path, 'install') ){ 511 pkgpath <- tempfile() 512 on.exit( unlink(pkgpath, recursive = TRUE), add = TRUE) 513 dir.create(pkgpath) 514 if( verbose ) message("* Building ", p$package, " and installing in temporary library ", pkgpath, " ... ", appendLF = verbose > 1) 515 olib <- .libPaths() 516 on.exit( .libPaths(olib), add = TRUE) 517 add_lib(pkgpath) 518 devtools::install(path, quiet = verbose <= 1, reload = FALSE) 519 if( verbose ) message('OK') 520 pkgpath <- file.path(pkgpath, p$package) 521 522 } 523 if( verbose ) message('* Using package installation directory ', pkgpath) 524 525 # build package filename 526 outfile <- file.path(outdir, package_buildname(pkgpath, 'win.binary')) 527 528 ## borrowed from package roxyPackage 529 owd <- getwd() 530 on.exit( setwd(owd), add = TRUE) 531 setwd(dirname(pkgpath)) 532 pkgname <- p$package 533 if( verbose ) message('* Removing platform information ... ', appendLF = FALSE) 534 pkgInfo <- readRDS(pkgInfo_file <- file.path(pkgpath, 'Meta/package.rds')) 535 pkgInfo$Built$Platform <- '' 536 saveRDS(pkgInfo, pkgInfo_file) 537 if( verbose ) message('OK') 538 if( verbose ) message('* Checking libs/ ... ', appendLF = FALSE) 539 if( has_libs <- file.exists(libs_dir <- file.path(pkgpath, 'libs')) ) unlink(libs_dir, recursive = TRUE) 540 if( verbose ) message(has_libs) 541 # make a list of backup files to exclude 542 win.exclude.files <- list.files(pkgname, pattern=".*~$", recursive=TRUE, full.names = TRUE) 543 if(length(win.exclude.files) > 0){ 544 win.exclude.files <- paste0("-x \"", paste(win.exclude.files, collapse="\" \""), "\"") 545 } 546 if( verbose ) message('* Creating windows binary package ', basename(outfile), ' ... ', appendLF = TRUE) 547 if( file.exists(outfile) ) unlink(outfile) 548 zip(outfile, pkgname, extras = win.exclude.files) 549 if( verbose ) message('OK') 550 551 # return path to generated zip file 552 invisible(outfile) 553} 554