Use new system_file()

Author: cpsievert

R/scaffold.R

@@ -32,7 +32,7 @@ scaffoldWidget <- function(name, bowerPkg = NULL, edit = interactive()){
 
 addWidgetConstructor <- function(name, package, edit){
   tpl <- paste(readLines(
-    system.file('templates/widget_r.txt', package = 'htmlwidgets')
+    system_file('templates/widget_r.txt', package = 'htmlwidgets')
   ), collapse = "\n")
 
   capName = function(name){
@@ -80,7 +80,7 @@ addWidgetYAML <- function(name, bowerPkg, edit){
 
 addWidgetJS <- function(name, edit){
   tpl <- paste(readLines(
-    system.file('templates/widget_js.txt', package = 'htmlwidgets')
+    system_file('templates/widget_js.txt', package = 'htmlwidgets')
   ), collapse = "\n")
 
   if (!file.exists(file_ <- sprintf('inst/htmlwidgets/%s.js', name))){

R/shim.R

@@ -7,6 +7,16 @@
   if (is.null(a)) b else a
 }
 
+# Borrowed from pkgload:::dev_meta, with some modifications.
+devtools_loaded <- function(pkg) {
+  ns <- .getNamespace(pkg)
+  if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) {
+    return(FALSE)
+  }
+  TRUE
+}
+
+# Since I/O can be expensive, only utils::packageVersion() if the package isn't already loaded
 get_package_version <- function(pkg) {
   ns <- .getNamespace(pkg)
   if (is.null(ns)) {
@@ -17,7 +27,7 @@ get_package_version <- function(pkg) {
 }
 
 is_installed <- function(pkg, version = NULL) {
-  installed <- isNamespaceLoaded(pkg) || nzchar(system.file(package = pkg))
+  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))
   if (is.null(version)) {
     return(installed)
   }
@@ -75,3 +85,70 @@ register_upgrade_message <- function(pkg, version, error = FALSE) {
     }
   )
 }
+
+# Borrowed from pkgload::shim_system.file, with some modifications.
+# Most notably, if the package isn't loaded via devtools, the package directory
+# lookup is cached. Also, to keep the implementation simple, it doesn't support
+# specification of lib.loc or mustWork
+system_file <- function(..., package = "base") {
+  if (!devtools_loaded(package))  {
+    return(system_file_cached(..., package = package))
+  }
+
+  if (!is.null(names(list(...)))) {
+    stop("All arguments other than `package` must be unnamed.")
+  }
+
+  # If package was loaded with devtools (the package loaded with load_all),
+  # also search for files under inst/, and don't cache the results (it seems
+  # more likely that the package path will change during the development
+  # process)
+  pkg_path <- find.package(package)
+
+  # First look in inst/
+  files_inst <- file.path(pkg_path, "inst", ...)
+  present_inst <- file.exists(files_inst)
+
+  # For any files that weren't present in inst/, look in the base path
+  files_top <- file.path(pkg_path, ...)
+  present_top <- file.exists(files_top)
+
+  # Merge them together. Here are the different possible conditions, and the
+  # desired result. NULL means to drop that element from the result.
+  #
+  # files_inst:   /inst/A  /inst/B  /inst/C  /inst/D
+  # present_inst:    T        T        F        F
+  # files_top:      /A       /B       /C       /D
+  # present_top:     T        F        T        F
+  # result:       /inst/A  /inst/B    /C       NULL
+  #
+  files <- files_top
+  files[present_inst] <- files_inst[present_inst]
+  # Drop cases where not present in either location
+  files <- files[present_inst | present_top]
+  if (length(files) == 0) {
+    return("")
+  }
+  # Make sure backslashes are replaced with slashes on Windows
+  normalizePath(files, winslash = "/")
+}
+
+system_file_cached <- local({
+  pkg_dir_cache <- character()
+
+  function(..., package = "base") {
+    if (!is.null(names(list(...)))) {
+      stop("All arguments other than `package` must be unnamed.")
+    }
+
+    not_cached <- is.na(match(package, names(pkg_dir_cache)))
+    if (not_cached) {
+      pkg_dir <- system.file(package = package)
+      pkg_dir_cache[[package]] <<- pkg_dir
+    } else {
+      pkg_dir <- pkg_dir_cache[[package]]
+    }
+
+    file.path(pkg_dir, ...)
+  }
+})

R/staticimports.R

@@ -1,5 +1,5 @@
 # @staticimports pkg:staticimports
-#  is_installed get_package_version
+#  is_installed get_package_version system_file
 #  register_s3_method register_upgrade_message
 #  %||%
 
@@ -44,7 +44,7 @@ getDependency <- function(name, package = name){
   #  in this cases dependencies should be provided through the
   #  dependencies argument of createWidget
   widgetDep <- list()
-  yaml_file <- system.file(config, package = package)
+  yaml_file <- system_file(config, package = package)
   if (file.exists(yaml_file)) {
     config = yaml::yaml.load_file(yaml_file)
     widgetDep <- lapply(config$dependencies, function(l) {
@@ -56,7 +56,7 @@ getDependency <- function(name, package = name){
   # if js binding does not exist then assume provided through
   #  some other mechanism such as a specified `htmlDependency` or `script` tag.
   #  Note, this is a very special case.
-  bindingDep <- if (file.exists(system.file(jsfile, package = package))) {
+  bindingDep <- if (file.exists(system_file(jsfile, package = package))) {
     htmlDependency(
       name = paste0(name, "-binding"),
       version = get_package_version(package),