Use faster versions of system.file()/packageVersion()/is_installed() (#2072)

Author: cpsievert

R/ggplotly.R

@@ -181,7 +181,7 @@ gg2list <- function(p, width = NULL, height = NULL,
     grDevices::png
   } else if (capabilities("jpeg")) {
     grDevices::jpeg 
-  } else if (system.file(package = "Cairo") != "") {
+  } else if (is_installed("Cairo")) {
     function(filename, ...) Cairo::Cairo(file = filename, ...)
   } else {
     stop(
@@ -243,7 +243,7 @@ gg2list <- function(p, width = NULL, height = NULL,
     # currently, LayerSf is the only core-ggplot2 Layer that makes use
     # of it https://github.com/tidyverse/ggplot2/pull/2875#issuecomment-438708426
     data <- layer_data
-    if (packageVersion("ggplot2") > "3.1.0") {
+    if (get_package_version("ggplot2") > "3.1.0") {
       data <- by_layer(function(l, d) if (is.function(l$setup_layer)) l$setup_layer(d, plot) else d)
     }
 

R/plotly.R

@@ -274,7 +274,7 @@ plot_geo <- function(data = data.frame(), ..., offline = FALSE) {
   p <- plot_ly(data, ...)
 
   if (isTRUE(offline)) {
-    if (system.file(package = "plotlyGeoAssets") == "") {
+    if (!is_installed("plotlyGeoAssets")) {
       stop(
         "The plotlyGeoAssets package is required to make 'offline' maps. ",
         "Please install and try again.",
@@ -491,7 +491,7 @@ plotlyMainBundlePath <- function() {
   dep <- plotlyMainBundle()
   path <- file.path(dep$src$file, dep$script)
   if (!is.null(dep$package)) {
-    path <- system.file(path, package = dep$package)
+    path <- system_file(path, package = dep$package)
   }
   path
 }
@@ -513,7 +513,7 @@ locale_dependency <- function(locale) {
   }
 
   locale_dir <- dependency_dir("plotlyjs", "locales")
-  locales_all <- sub("\\.js$", "", list.files(system.file(locale_dir, package = "plotly")))
+  locales_all <- sub("\\.js$", "", list.files(system_file(locale_dir, package = "plotly")))
   if (!tolower(locale) %in% locales_all) {
     stop(
       "Invalid locale: '", locale, "'.\n\n",

R/plotly_example.R

@@ -24,7 +24,7 @@ plotly_example <- function(type = c("demo", "shiny", "rmd"), name, edit = TRUE,
   }
 
   # check to make sure the example exists
-  exampleDir <- system.file("examples", type, package = "plotly")
+  exampleDir <- system_file("examples", type, package = "plotly")
   nms <- basename(list.dirs(exampleDir, recursive = FALSE))
   if (missing(name) || !isTRUE(name %in% nms)) {
     message(
@@ -36,7 +36,7 @@ plotly_example <- function(type = c("demo", "shiny", "rmd"), name, edit = TRUE,
     return(invisible())
   }
 
-  finalDir <- system.file("examples", type, name, package = "plotly")
+  finalDir <- system_file("examples", type, name, package = "plotly")
   if (edit) {
     files <- list.files(finalDir, full.names = TRUE)
     scripts <- files[tools::file_ext(files) %in% c("R", "Rmd")]

R/shiny.R

@@ -34,7 +34,7 @@ plotlyOutput <- function(outputId, width = "100%", height = "400px",
     package = "plotly",
     reportSize = TRUE
   )
-  if (is_available("shiny", "1.4.0.9003") && is_available("htmlwidgets", "1.5.2.9000")) {
+  if (is_installed("shiny", "1.4.0.9003") && is_installed("htmlwidgets", "1.5.2.9000")) {
     args$reportTheme <- reportTheme
   }
   do.call(htmlwidgets::shinyWidgetOutput, args)

R/signup.R

@@ -42,7 +42,7 @@ signup <- function(username, email, save = TRUE) {
     un = username,
     email = email,
     platform = "R",
-    version = as.character(packageVersion("plotly"))
+    version = as.character(get_package_version("plotly"))
   )
   base_url <- file.path(get_domain(), "apimkacct")
   resp <- httr::RETRY(

R/staticimports.R

@@ -0,0 +1,107 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:staticimports
+# ======================================================================
+
+# Borrowed from pkgload:::dev_meta, with some modifications.
+# Returns TRUE if `pkg` was loaded with `devtools::load_all()`.
+devtools_loaded <- function(pkg) {
+  ns <- .getNamespace(pkg)
+  if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) {
+    return(FALSE)
+  }
+  TRUE
+}
+
+get_package_version <- function(pkg) {
+  # `utils::packageVersion()` can be slow, so first try the fast path of
+  # checking if the package is already loaded.
+  ns <- .getNamespace(pkg)
+  if (is.null(ns)) {
+    utils::packageVersion(pkg)
+  } else {
+    as.package_version(ns$.__NAMESPACE__.$spec[["version"]])
+  }
+}
+
+is_installed <- function(pkg, version = NULL) {
+  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+# Borrowed from pkgload::shim_system.file, with some modifications. This behaves
+# like `system.file()`, except that (1) for packages loaded with
+# `devtools::load_all()`, it will return the path to files in the package's
+# inst/ directory, and (2) for other packages, the 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 = "/")
+}
+
+# A wrapper for `system.file()`, which caches the results, because
+# `system.file()` can be slow. Note that because of caching, if
+# `system_file_cached()` is called on a package that isn't installed, then the
+# package is installed, and then `system_file_cached()` is called again, it will
+# still return "".
+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/utils.R

@@ -1,3 +1,6 @@
+# @staticimports pkg:staticimports
+#  is_installed get_package_version system_file
+
 is.plotly <- function(x) {
   inherits(x, "plotly")
 }
@@ -1089,7 +1092,7 @@ get_kwargs <- function() {
 
 # "common" POST header fields
 api_headers <- function() {
-  v <- as.character(packageVersion("plotly"))
+  v <- as.character(get_package_version("plotly"))
   httr::add_headers(
     plotly_version = v,
     `Plotly-Client-Platform` = paste("R", v),
@@ -1130,22 +1133,13 @@ cat_profile <- function(key, value, path = "~") {
 
 # check that suggested packages are installed
 try_library <- function(pkg, fun = NULL) {
-  if (system.file(package = pkg) != "") {
+  if (is_installed(pkg)) {
     return(invisible())
   }
   stop("Package `", pkg, "` required",  if (!is.null(fun)) paste0(" for `", fun, "`"), ".\n", 
        "Please install and try again.", call. = FALSE)
 }
 
-# a la shiny:::is_available
-is_available <- function(package, version = NULL) {
-  installed <- nzchar(system.file(package = package))
-  if (is.null(version)) {
-    return(installed)
-  }
-  installed && isTRUE(utils::packageVersion(package) >= version)
-}
-
 # similar logic to rstudioapi::isAvailable()
 is_rstudio <- function() {
   identical(.Platform$GUI, "RStudio")
@@ -1168,7 +1162,7 @@ longest_element <- function(x) {
 
 # A dplyr::group_by wrapper for the add argument
 group_by_add <- function(..., add = TRUE) {
-  if (packageVersion('dplyr') >= '1.0') {
+  if (get_package_version('dplyr') >= '1.0') {
     dplyr::group_by(...,  .add = add)
   } else {
     dplyr::group_by(...,  add = add)

tests/testthat/test-plotly-color.R

@@ -32,7 +32,7 @@ test_that("Custom RColorBrewer pallette works for factor variable", {
   l <- expect_traces(p, 3, "scatterplot-color-factor-custom")
   markers <- lapply(l$data, "[[", "marker")
   colz <- unlist(lapply(markers, "[[", "color"))
-  idx <- if (packageVersion("scales") > '1.0.0') c(1, 2, 3) else c(1, 5, 9)
+  idx <- if (get_package_version("scales") > '1.0.0') c(1, 2, 3) else c(1, 5, 9)
   expect_identical(sort(colsToCompare[idx]), sort(colz))
   # providing vector of RGB codes should also work
   p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species,