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}