1# Utils for R package projects
2#
3# Author: Renaud Gaujoux
4# Created: May 1, 2013
5###############################################################################
6
7is_pattern <- function(x){
8  grepl('[*^?)$([]', x)
9}
10# match with exact or regular expression lookup
11match_mix <- function(x, table, nomatch = NA_integer_, ignore.case = FALSE){
12
13  # find regular expression patterns
14  is_reg <- is_pattern(table)
15  case <- function(x) if( ignore.case ) tolower(x) else x
16  hit <- match(case(x), case(table[!is_reg]), nomatch = nomatch)
17
18  if( any(is_reg) ){
19    reg_match <- unlist_(sapply(table[is_reg], grep, x, ignore.case = ignore.case, simplify = FALSE))
20    reg_match <- reg_match[!duplicated(reg_match)]
21    hit[reg_match] <- pmin(hit[reg_match], match(names(reg_match), table), na.rm = TRUE)
22
23  }
24
25  hit[!is.na(hit)]
26}
27
28#' Test for Package Root Directory
29#'
30#' Tells if a directory is a package directory, i.e. that it contains
31#' a \code{DESCRIPTION} file.
32#'
33#' @param x path to the directory to test
34#' @param error logical that indicates if an error should be raised
35#' if the directory is not a package directory.
36#'
37is_package_path <- function(x, error = FALSE) {
38	if (is.null(x)) return(FALSE)
39	x <- normalizePath(x, mustWork = FALSE)
40	x <- gsub("\\\\$", "", x)
41	desc_path <- file.path(x, "DESCRIPTION")
42	if( !error ){
43		file.exists(x) && file.exists(desc_path)
44	}else{
45		if ( !file.exists(x) ) stop("Can't find directory ", x, call. = FALSE)
46		if ( !file.info(x)$isdir ) stop(x, " is not a directory", call. = FALSE)
47		if (!file.exists(desc_path)) stop("No DESCRIPTION file found in ", x, call. = FALSE)
48		TRUE
49	}
50}
51
52
53#' Find Path to Development Package Root Directory
54#'
55#' Development packages are looked-up according to rules
56#' defined in a file \code{.Rpackages} in the user's home directory.
57#'
58#' @section Specification of package path:
59#' Package paths are specified in a list with:
60#'   * unnamed elements: character strings give path to directories to lookup for sub-directories that match
61#' exactly the package's name;
62#'   * named element containing character strings: these are paths that are looked up only for packages that
63#' match the element name. If the element name contains any of the characters `*?()$^\\][`, then it is matched using
64#' regular expression.
65#'
66#' @param x name of the development package to lookup.
67#' @param error logical that indicates if an error is thrown when the project root directory
68#' could not be found.
69#' @export
70find_devpackage <- function(x, error = TRUE)
71{
72
73
74	if (is_package_path(x)) {
75		return(x)
76	}
77
78	config_path <- "~/.Rpackages"
79	if (!file.exists(config_path)) {
80		return(NULL)
81	}
82	config_path <- path.expand(config_path)
83	lookup <- source(config_path)$value
84
85  default_lookup <- lookup$default
86  lookup <- lookup[!names(lookup) %in% 'default']
87
88  # check for a match
89  i <- c(match_mix(x, names(lookup), ignore.case = TRUE), which(names(lookup) %in% ''))
90  if( length(i) ){
91      reg_spec <- is_pattern(names(lookup))
92      for(k in i){
93        val <- lookup[[k]]
94        n <- names(lookup)[k]
95        if( grepl('*', val, fixed = TRUE) ){ # check path like a/b/*/c
96          p <- gsub('*', x, val, fixed = TRUE)
97          if( is_package_path(p) ){
98            message("Loading path resolved by ", n, ':', val)
99            return(p)
100
101          }
102
103        } else if( !reg_spec[k] && is_package_path(val) ){ # exact match
104          message("Loading path resolved by ", n, ':', val)
105          return(val)
106
107        }else if( reg_spec[k] ){
108          paths <- list.dirs(val, full.names = TRUE, recursive = FALSE)
109          x2 <- sub(n, "", x)
110          x2[!nzchar(x2)] <- x[!nzchar(x2)]
111          hit <- match(x2, basename(paths))
112          p <- paths[hit[1L]]
113          if( length(hit) && is_package_path(p) ){
114            message("Loading path resolved by ", n, ':', val)
115            return(p)
116
117          }
118
119        }
120      }
121
122  }
123
124  if( !is.null(default_lookup) ) {
125		default_loc <- default_lookup(x)
126		if ( is_package_path(default_loc, error = error) ) {
127      message("Loading path resolved by default lookup")
128			return(default_loc)
129		}
130	}
131
132  if( error ) message("Could not find package directory for project ", x)
133	NULL
134}
135
136#' Load Development Package
137#'
138#' @param pkg name of the package/project to load.
139#' @param reset logical that indicates if the package should be reloaded (passed to \code{\link[devtools]{load_all}}.
140#' @param ... other arguments passed to \code{\link[devtools]{load_all}}.
141#' @param utests logical that indicates if an environment containing the unit test functions should be created.
142#' If \code{TRUE} this environment is accessible at \code{pkgname::UnitTests$test.filename.r$function.name}.
143#' @param verbose logical that indicates if log messages should be printed.
144#' @param addlib logical that indicates if the \code{lib/} sub-directory, if it exists, should be prepended
145#' to the library path.
146#' This enables to control the version of the loaded dependencies.
147#' @param character.only logical that indicates if argument \var{pkg} should be evaluated or taken litteral.
148#' @param try.library logicatl that indicates if projects that could not be found should be looked up in
149#' the installed packages.
150#'
151#' @export
152load_project <- function(pkg, reset = FALSE, ..., utests = TRUE, verbose=FALSE, addlib=TRUE, character.only = FALSE, try.library = FALSE) {
153
154	if( !character.only ){
155		pkg <- deparse(substitute(pkg))
156		pkg <- sub("^\"(.*)\"$", "\\1", pkg)
157	}
158
159  # lookup dev package root directory
160	devpkg_path <- find_devpackage(pkg, error = !try.library)
161  # load from installed pacakges if not found and requested
162  if( is.null(devpkg_path) ){
163    if( !try.library ) return(invisible())
164    message(sprintf("Trying to load installed package %s ... ", pkg), appendLF = FALSE)
165    library(pkg, character.only = TRUE, quietly = TRUE)
166    message('OK')
167    return(invisible())
168
169  }
170
171	pkg <- devpkg_path
172
173  if( !requireNamespace('devtools') ){
174    stop("Could not load package: required package 'devtools' is not installed.")
175  }
176
177	# add ../lib to the path if necessary
178	if( addlib && is.character(tp <- pkg) ){
179		tp <- as.package(tp)
180		pdir <- normalizePath(file.path(dirname(tp$path), "lib"), mustWork=FALSE)
181		if( file_test('-d', pdir) && !is.element(pdir, .libPaths()) ){
182			message("Adding to .libPaths: '", pdir, "'")
183			olibs <- .libPaths()
184			.libPaths(c(pdir, .libPaths()))
185			on.exit( .libPaths(olibs), add=TRUE )
186		}
187	}
188	devpkg <- as.package(pkg)
189
190	# load package
191	op <- options(verbose=verbose)
192	on.exit(options(op), add=TRUE)
193	devtools::load_all(pkg, reset = reset, ...)
194	#
195
196	# source unit test files if required
197	udir <- file.path(devpkg$path, 'inst', c('tests', 'unitTests'))
198	if( utests && length(w <- which(file.exists(udir))) ){
199		message("# Sourcing unit test directory ... ", appendLF = FALSE)
200		f <- list.files(udir[w[1L]], pattern = "\\.[Rr]$", full.names=TRUE)
201		if( length(f) ){
202#			if( !requireNamespace('RUnit') ) stop("Missing required dependency 'RUnit' to load unit tests")
203			# create unit test environment
204      ns_env <- getDevtoolsFunction('ns_env')
205			utest_env <- new.env(parent = ns_env(devpkg))
206			assign('UnitTests', utest_env, ns_env(devpkg))
207			# source test files in separate sub-environments
208			sapply(f, function(f){
209						e <- new.env(parent = utest_env)
210						assign(basename(f), e, utest_env)
211						sys.source(f, envir = e)
212					})
213		}
214		message('OK [', length(f), ']')
215		# reload to export the unit test environment
216		devtools::load_all(pkg, reset = FALSE, ...)
217	}
218	#
219
220	invisible(devpkg)
221}
222
223#' @describeIn load_project shortcut for `load_project(..., try.library = TRUE)`, to load project
224#' code from installed library if not found as a development project.
225#' All its arguments are passed to `load_project`.
226#' @export
227library_project <- function(...) load_project(..., try.library = TRUE)
228
229getDevtoolsFunction <- function(name){
230
231  if( qrequire('devtools') && !is.null(fun <- ns_get(name, 'devtools')) ) return(fun)
232  if( qrequire('pkgload') && !is.null(fun <- ns_get(name, 'pkgload')) ) return(fun)
233  if( qrequire('pkgbuild') && !is.null(fun <- ns_get(name, envir = 'pkgbuild')) ) return(fun)
234
235}
236
237is_Mac <- function(check.gui=FALSE){
238	is.mac <- (length(grep("darwin", R.version$platform)) > 0)
239	# return TRUE is running on Mac (adn optionally through GUI)
240	is.mac && (!check.gui || .Platform$GUI == 'AQUA')
241}
242
243R_OS <- function(){
244	if( is_Mac() ) 'MacOS'
245	else .Platform$OS.type
246}
247
248packageMakefile <- function(package=NULL, template=NULL, temp = FALSE, print = TRUE){
249
250	capture.output(suppressMessages({
251		library(pkgmaker)
252        if( !requireNamespace('devtools', quietly = TRUE) )
253                stop("Package 'devtools' is required to generate a package Makefile")
254
255	}))
256#	defMakeVar <- pkgmaker::defMakeVar
257#	subMakeVar <- pkgmaker::subMakeVar
258
259	project_path <- getwd()
260	project_name <- basename(project_path)
261	subproject_path_part <- ''
262	if( is.null(package) || isString(package) ){
263		if( isString(package) && !nzchar(package) ) package <- NULL
264		lookup_dir <- c('pkg', '.')
265		if( !is.null(package) ){
266			lookup_dir <- c(package, lookup_dir, file.path('pkg', package))
267			subproject_path_part <- file.path(package, '')
268		}
269		pdir <- file.path(lookup_dir, 'DESCRIPTION')
270		if( !length(sd <- which(is.file(pdir))) ){
271			stop("Could not detect package source directory")
272		}
273		package <- pdir[sd[1L]]
274	}
275	package <- normalizePath(package)
276	p <- pkg <- as.package(dirname(package));
277	pdir <- package_dir <- p[['path']];
278
279	## create makefile from template
280	# load template makefile
281	if( is.null(template) ){
282		template <- packagePath('package.mk', package='pkgmaker')
283	}
284	l <- paste(readLines(template), collapse="\n")
285
286	# user
287	cuser <- Sys.info()["user"]
288	l <- defMakeVar('AUTHOR_USER', cuser, l)
289	l <- defMakeVar('R_PACKAGE', pkg$package, l)
290	# R_PACKAGE_PATH
291	l <- defMakeVar('R_PACKAGE_PATH', package_dir, l)
292	# R_PACKAGE_PROJECT
293	l <- defMakeVar('R_PACKAGE_PROJECT', project_name, l)
294	# R_PACKAGE_PROJECT_PATH
295	l <- defMakeVar('R_PACKAGE_PROJECT_PATH', project_path, l)
296	l <- defMakeVar('R_PACKAGE_SUBPROJECT_PATH_PART', subproject_path_part, l)
297	# R_BIN
298	l <- subMakeVar('R_BIN', R.home('bin'), l)
299    # REPO_DIRS
300    repo_dirs <- gsub("^\\./", "", sapply(c('source', 'win.binary', 'mac.binary'), contrib.url, repos = '.'))
301    l <- defMakeVar('REPO_DIRS', paste0(repo_dirs, collapse = ' '), l)
302    # BUILD_DIR
303    l <- defMakeVar('BUILD_DIR', file.path(repo_dirs['source'], ''), l)
304	# R_PACKAGE_TAR_GZ
305	pkg_targz <- file.path(repo_dirs['source'], package_buildname(p, 'source'))
306	l <- defMakeVar('R_PACKAGE_TAR_GZ', pkg_targz, l)
307    # R_PACKAGE_ZIP
308	pkg_zip <- file.path(repo_dirs['win.binary'], package_buildname(p, 'win.binary'))
309	l <- defMakeVar('R_PACKAGE_ZIP', pkg_zip, l)
310    # R_PACKAGE_TGZ
311	pkg_mac <- file.path(repo_dirs['mac.binary'], package_buildname(p, 'mac.binary'))
312	l <- defMakeVar('R_PACKAGE_TGZ', pkg_mac, l)
313	# R_PACKAGE_TYPE
314	l <- defMakeVar('R_PACKAGE_OS', R_OS(), l)
315	#
316
317    # auto-conf variables
318    init_var <- list(version = pkg$version)
319    if( is.dir(file.path(package_dir, 'vignettes')) )
320        init_var <- c(init_var, has_vignettes=TRUE)
321    # dump variables
322    if( length(init_var) ){
323        init_var <- setNames(init_var, paste0('R_PACKAGE_', toupper(names(init_var))))
324        init_var_str <- str_out(init_var, Inf, use.names = TRUE, sep = "\n")
325        l <- subMakeVar('INIT_CHECKS', init_var_str, l)
326    }
327
328	# R_CMD_CHECK
329	rlibs <- ''
330    if( is.dir(devlib <- file.path(dirname(pdir), 'lib')) ){
331		rlibs <- paste0("R_LIBS=", devlib, ' ')
332	}
333    l <- subMakeVar('R_LIBS', rlibs, l)
334	#
335
336	# create makefile
337	mk <- if( temp ) tempfile('package_', tmpdir='.', fileext='.mk') else 'package.mk'
338	cat(l, file=mk)
339	if ( print ){
340		cat(mk)
341	}
342	invisible(l)
343}