diff --git a/R/ggplotly.R b/R/ggplotly.R index 44aaf73ba9..6c0aad48eb 100644 --- a/R/ggplotly.R +++ b/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) } diff --git a/R/plotly.R b/R/plotly.R index 57e3b21949..fb701803c6 100644 --- a/R/plotly.R +++ b/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", diff --git a/R/plotly_example.R b/R/plotly_example.R index 9b7a86e3c2..325c0a0a18 100644 --- a/R/plotly_example.R +++ b/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")] diff --git a/R/shiny.R b/R/shiny.R index 78efba9b31..6f9e66a521 100644 --- a/R/shiny.R +++ b/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) diff --git a/R/signup.R b/R/signup.R index c2787e5a6c..82ce8b4e8b 100644 --- a/R/signup.R +++ b/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( diff --git a/R/staticimports.R b/R/staticimports.R new file mode 100644 index 0000000000..525b30fcb7 --- /dev/null +++ b/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, ...) + } +}) diff --git a/R/utils.R b/R/utils.R index c55c295252..8e294e51b4 100644 --- a/R/utils.R +++ b/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) diff --git a/tests/testthat/test-plotly-color.R b/tests/testthat/test-plotly-color.R index 8ef57d55a8..7a81297ac1 100644 --- a/tests/testthat/test-plotly-color.R +++ b/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,