# Utils for R package projects
#
# Author: Renaud Gaujoux
# Created: May 1, 2013
###############################################################################
is_pattern <- function(x){
grepl('[*^?)$([]', x)
}
# match with exact or regular expression lookup
match_mix <- function(x, table, nomatch = NA_integer_, ignore.case = FALSE){
# find regular expression patterns
is_reg <- is_pattern(table)
case <- function(x) if( ignore.case ) tolower(x) else x
hit <- match(case(x), case(table[!is_reg]), nomatch = nomatch)
if( any(is_reg) ){
reg_match <- unlist_(sapply(table[is_reg], grep, x, ignore.case = ignore.case, simplify = FALSE))
reg_match <- reg_match[!duplicated(reg_match)]
hit[reg_match] <- pmin(hit[reg_match], match(names(reg_match), table), na.rm = TRUE)
}
hit[!is.na(hit)]
}
#' Test for Package Root Directory
#'
#' Tells if a directory is a package directory, i.e. that it contains
#' a \code{DESCRIPTION} file.
#'
#' @param x path to the directory to test
#' @param error logical that indicates if an error should be raised
#' if the directory is not a package directory.
#'
#' @keywords internal
is_package_path <- function(x, error = FALSE) {
if (is.null(x)) return(FALSE)
x <- normalizePath(x, mustWork = FALSE)
x <- gsub("\\\\$", "", x)
desc_path <- file.path(x, "DESCRIPTION")
if( !error ){
file.exists(x) && file.exists(desc_path)
}else{
if ( !file.exists(x) ) stop("Can't find directory ", x, call. = FALSE)
if ( !file.info(x)$isdir ) stop(x, " is not a directory", call. = FALSE)
if (!file.exists(desc_path)) stop("No DESCRIPTION file found in ", x, call. = FALSE)
TRUE
}
}
#' Find Path to Development Package Root Directory
#'
#' Development packages are looked-up according to rules
#' defined in a file \code{.Rpackages} in the user's home directory.
#'
#' @section Specification of package path:
#' Package paths are specified in a list with:
#' * unnamed elements: character strings give path to directories to lookup for sub-directories that match
#' exactly the package's name;
#' * named element containing character strings: these are paths that are looked up only for packages that
#' match the element name. If the element name contains any of the characters `*?()$^\\][`, then it is matched using
#' regular expression.
#'
#' @param x name of the development package to lookup.
#' @param error logical that indicates if an error is thrown when the project root directory
#' could not be found.
#'
#' @return A character string containing the path to the package.
#' @export
find_devpackage <- function(x, error = TRUE)
{
if (is_package_path(x)) {
return(x)
}
config_path <- "~/.Rpackages"
if (!file.exists(config_path)) {
return(NULL)
}
config_path <- path.expand(config_path)
lookup <- source(config_path)$value
default_lookup <- lookup$default
lookup <- lookup[!names(lookup) %in% 'default']
# check for a match
i <- c(match_mix(x, names(lookup), ignore.case = TRUE), which(names(lookup) %in% ''))
if( length(i) ){
reg_spec <- is_pattern(names(lookup))
for(k in i){
val <- lookup[[k]]
n <- names(lookup)[k]
if( grepl('*', val, fixed = TRUE) ){ # check path like a/b/*/c
p <- gsub('*', x, val, fixed = TRUE)
if( is_package_path(p) ){
message("Loading path resolved by ", n, ':', val)
return(p)
}
} else if( !reg_spec[k] && is_package_path(val) ){ # exact match
message("Loading path resolved by ", n, ':', val)
return(val)
}else if( reg_spec[k] ){
paths <- list.dirs(val, full.names = TRUE, recursive = FALSE)
x2 <- sub(n, "", x)
x2[!nzchar(x2)] <- x[!nzchar(x2)]
hit <- match(x2, basename(paths))
p <- paths[hit[1L]]
if( length(hit) && is_package_path(p) ){
message("Loading path resolved by ", n, ':', val)
return(p)
}
}
}
}
if( !is.null(default_lookup) ) {
default_loc <- default_lookup(x)
if ( is_package_path(default_loc, error = error) ) {
message("Loading path resolved by default lookup")
return(default_loc)
}
}
if( error ) message("Could not find package directory for project ", x)
NULL
}
#' Load Development Package
#'
#' @param pkg name of the package/project to load.
#' @param reset logical that indicates if the package should be reloaded (passed to \code{\link[devtools]{load_all}}.
#' @param ... other arguments passed to \code{\link[devtools]{load_all}}.
#' @param utests logical that indicates if an environment containing the unit test functions should be created.
#' If \code{TRUE} this environment is accessible at \code{pkgname::UnitTests$test.filename.r$function.name}.
#' @param verbose logical that indicates if log messages should be printed.
#' @param addlib logical that indicates if the \code{lib/} sub-directory, if it exists, should be prepended
#' to the library path.
#' This enables to control the version of the loaded dependencies.
#' @param character.only logical that indicates if argument \var{pkg} should be evaluated or taken litteral.
#' @param try.library logicatl that indicates if projects that could not be found should be looked up in
#' the installed packages.
#'
#' @return Invisibly the `package` object of the loaded package.
#'
#' @export
load_project <- function(pkg, reset = FALSE, ..., utests = TRUE, verbose=FALSE, addlib=TRUE, character.only = FALSE, try.library = FALSE) {
if( !character.only ){
pkg <- deparse(substitute(pkg))
pkg <- sub("^\"(.*)\"$", "\\1", pkg)
}
# lookup dev package root directory
devpkg_path <- find_devpackage(pkg, error = !try.library)
# load from installed pacakges if not found and requested
if( is.null(devpkg_path) ){
if( !try.library ) return(invisible())
message(sprintf("Trying to load installed package %s ... ", pkg), appendLF = FALSE)
library(pkg, character.only = TRUE, quietly = TRUE)
message('OK')
return(invisible())
}
pkg <- devpkg_path
if( !requireNamespace('devtools') ){
stop("Could not load package: required package 'devtools' is not installed.")
}
# add ../lib to the path if necessary
if( addlib && is.character(tp <- pkg) ){
tp <- as.package(tp)
pdir <- normalizePath(file.path(dirname(tp$path), "lib"), mustWork=FALSE)
if( file_test('-d', pdir) && !is.element(pdir, .libPaths()) ){
message("Adding to .libPaths: '", pdir, "'")
olibs <- .libPaths()
.libPaths(c(pdir, .libPaths()))
on.exit( .libPaths(olibs), add=TRUE )
}
}
devpkg <- as.package(pkg)
# load package
op <- options(verbose=verbose)
on.exit(options(op), add=TRUE)
devtools::load_all(pkg, reset = reset, ...)
#
# source unit test files if required
udir <- file.path(devpkg$path, 'inst', c('tests', 'unitTests'))
if( utests && length(w <- which(file.exists(udir))) ){
message("# Sourcing unit test directory ... ", appendLF = FALSE)
f <- list.files(udir[w[1L]], pattern = "\\.[Rr]$", full.names=TRUE)
if( length(f) ){
# if( !requireNamespace('RUnit') ) stop("Missing required dependency 'RUnit' to load unit tests")
# create unit test environment
ns_env <- getDevtoolsFunction('ns_env')
utest_env <- new.env(parent = ns_env(devpkg))
assign('UnitTests', utest_env, ns_env(devpkg))
# source test files in separate sub-environments
sapply(f, function(f){
e <- new.env(parent = utest_env)
assign(basename(f), e, utest_env)
sys.source(f, envir = e)
})
}
message('OK [', length(f), ']')
# reload to export the unit test environment
devtools::load_all(pkg, reset = FALSE, ...)
}
#
invisible(devpkg)
}
#' @describeIn load_project shortcut for `load_project(..., try.library = TRUE)`, to load project
#' code from installed library if not found as a development project.
#' All its arguments are passed to `load_project`.
#' @export
library_project <- function(...) load_project(..., try.library = TRUE)
getDevtoolsFunction <- function(name){
if( qrequire('devtools') && !is.null(fun <- ns_get(name, 'devtools')) ) return(fun)
if( qrequire('pkgload') && !is.null(fun <- ns_get(name, 'pkgload')) ) return(fun)
if( qrequire('pkgbuild') && !is.null(fun <- ns_get(name, envir = 'pkgbuild')) ) return(fun)
}
is_Mac <- function(check.gui=FALSE){
is.mac <- (length(grep("darwin", R.version$platform)) > 0)
# return TRUE is running on Mac (adn optionally through GUI)
is.mac && (!check.gui || .Platform$GUI == 'AQUA')
}
R_OS <- function(){
if( is_Mac() ) 'MacOS'
else .Platform$OS.type
}
packageMakefile <- function(package=NULL, template=NULL, temp = FALSE, print = TRUE){
capture.output(suppressMessages({
library(pkgmaker)
if( !requireNamespace('devtools', quietly = TRUE) )
stop("Package 'devtools' is required to generate a package Makefile")
}))
# defMakeVar <- pkgmaker::defMakeVar
# subMakeVar <- pkgmaker::subMakeVar
project_path <- getwd()
project_name <- basename(project_path)
subproject_path_part <- ''
if( is.null(package) || isString(package) ){
if( isString(package) && !nzchar(package) ) package <- NULL
lookup_dir <- c('pkg', '.')
if( !is.null(package) ){
lookup_dir <- c(package, lookup_dir, file.path('pkg', package))
subproject_path_part <- file.path(package, '')
}
pdir <- file.path(lookup_dir, 'DESCRIPTION')
if( !length(sd <- which(is.file(pdir))) ){
stop("Could not detect package source directory")
}
package <- pdir[sd[1L]]
}
package <- normalizePath(package)
p <- pkg <- as.package(dirname(package));
pdir <- package_dir <- p[['path']];
## create makefile from template
# load template makefile
if( is.null(template) ){
template <- packagePath('package.mk', package='pkgmaker')
}
l <- paste(readLines(template), collapse="\n")
# user
cuser <- Sys.info()["user"]
l <- defMakeVar('AUTHOR_USER', cuser, l)
l <- defMakeVar('R_PACKAGE', pkg$package, l)
# R_PACKAGE_PATH
l <- defMakeVar('R_PACKAGE_PATH', package_dir, l)
# R_PACKAGE_PROJECT
l <- defMakeVar('R_PACKAGE_PROJECT', project_name, l)
# R_PACKAGE_PROJECT_PATH
l <- defMakeVar('R_PACKAGE_PROJECT_PATH', project_path, l)
l <- defMakeVar('R_PACKAGE_SUBPROJECT_PATH_PART', subproject_path_part, l)
# R_BIN
l <- subMakeVar('R_BIN', R.home('bin'), l)
# REPO_DIRS
repo_dirs <- gsub("^\\./", "", sapply(c('source', 'win.binary', 'mac.binary'), contrib.url, repos = '.'))
l <- defMakeVar('REPO_DIRS', paste0(repo_dirs, collapse = ' '), l)
# BUILD_DIR
l <- defMakeVar('BUILD_DIR', file.path(repo_dirs['source'], ''), l)
# R_PACKAGE_TAR_GZ
pkg_targz <- file.path(repo_dirs['source'], package_buildname(p, 'source'))
l <- defMakeVar('R_PACKAGE_TAR_GZ', pkg_targz, l)
# R_PACKAGE_ZIP
pkg_zip <- file.path(repo_dirs['win.binary'], package_buildname(p, 'win.binary'))
l <- defMakeVar('R_PACKAGE_ZIP', pkg_zip, l)
# R_PACKAGE_TGZ
pkg_mac <- file.path(repo_dirs['mac.binary'], package_buildname(p, 'mac.binary'))
l <- defMakeVar('R_PACKAGE_TGZ', pkg_mac, l)
# R_PACKAGE_TYPE
l <- defMakeVar('R_PACKAGE_OS', R_OS(), l)
#
# auto-conf variables
init_var <- list(version = pkg$version)
if( is.dir(file.path(package_dir, 'vignettes')) )
init_var <- c(init_var, has_vignettes=TRUE)
# dump variables
if( length(init_var) ){
init_var <- setNames(init_var, paste0('R_PACKAGE_', toupper(names(init_var))))
init_var_str <- str_out(init_var, Inf, use.names = TRUE, sep = "\n")
l <- subMakeVar('INIT_CHECKS', init_var_str, l)
}
# R_CMD_CHECK
rlibs <- ''
if( is.dir(devlib <- file.path(dirname(pdir), 'lib')) ){
rlibs <- paste0("R_LIBS=", devlib, ' ')
}
l <- subMakeVar('R_LIBS', rlibs, l)
#
# create makefile
mk <- if( temp ) tempfile('package_', tmpdir='.', fileext='.mk') else 'package.mk'
cat(l, file=mk)
if ( print ){
cat(mk)
}
invisible(l)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.