Avoid unnecessary run-time checks of shiny version and use staticimports to import stuff

Author: cpsievert

R/htmlwidgets.R

@@ -476,13 +476,9 @@ createWidget <- function(name,
 shinyWidgetOutput <- function(outputId, name, width, height, package = name,
                               inline = FALSE, reportSize = FALSE, reportTheme = FALSE) {
 
-  checkShinyVersion()
-
   # Theme reporting requires this shiny feature
   # https://github.com/rstudio/shiny/pull/2740/files
-  if (reportTheme &&
-      nzchar(system.file(package = "shiny")) &&
-      packageVersion("shiny") < "1.4.0.9003") {
+  if (reportTheme && is_installed("shiny", "1.4.0.9003")) {
     message("`reportTheme = TRUE` requires shiny v.1.4.0.9003 or higher. Consider upgrading shiny.")
   }
 
@@ -512,7 +508,6 @@ shinyWidgetOutput <- function(outputId, name, width, height, package = name,
 #' @rdname htmlwidgets-shiny
 #' @export
 shinyRenderWidget <- function(expr, outputFunction, env, quoted, cacheHint = "auto")  {
-  checkShinyVersion()
   # generate a function for the expression
   shiny::installExprFunction(expr, "func", env, quoted)
 
@@ -588,17 +583,6 @@ shinyRenderWidget <- function(expr, outputFunction, env, quoted, cacheHint = "au
 # For the magic behind shiny::installExprFunction()
 utils::globalVariables("func")
 
-checkShinyVersion <- function(error = TRUE) {
-  x <- utils::packageDescription('htmlwidgets', fields = 'Enhances')
-  r <- '^.*?shiny \\(>= ([0-9.]+)\\).*$'
-  if (is.na(x) || length(grep(r, x)) == 0 || system.file(package = 'shiny') == '')
-    return()
-  v <- gsub(r, '\\1', x)
-  f <- if (error) stop else packageStartupMessage
-  if (utils::packageVersion('shiny') < v)
-    f("Please upgrade the 'shiny' package to (at least) version ", v)
-}
-
 # Helper function to create payload
 createPayload <- function(instance){
   if (!is.null(instance$preRenderHook)){

R/knitr-methods.R

@@ -1,44 +1,8 @@
-# Reusable function for registering a set of methods with S3 manually. The
-# methods argument is a list of character vectors, each of which has the form
-# c(package, genname, class).
-registerMethods <- function(methods) {
-  lapply(methods, function(method) {
-    pkg <- method[[1]]
-    generic <- method[[2]]
-    class <- method[[3]]
-    func <- get(paste(generic, class, sep="."))
-    if (pkg %in% loadedNamespaces()) {
-      registerS3method(generic, class, func, envir = asNamespace(pkg))
-    }
-    setHook(
-      packageEvent(pkg, "onLoad"),
-      function(...) {
-        registerS3method(generic, class, func, envir = asNamespace(pkg))
-      }
-    )
-  })
-}
-
 .onLoad <- function(...) {
-  # htmlwidgets provides methods for knitr::knit_print, but knitr isn't a Depends or
-  # Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to
-  # declare it as an export, not an S3method. That means that R will only know to
-  # use our methods if htmlwidgets is actually attached, i.e., you have to use
-  # library(htmlwidgets) in a knitr document or else you'll get escaped HTML in your
-  # document. This code snippet manually registers our method(s) with S3 once both
-  # htmlwidgets and knitr are loaded.
-  registerMethods(list(
-    # c(package, genname, class)
-    c("knitr", "knit_print", "htmlwidget")
-  ))
-}
-
-.onAttach <- function(...) {
-  # warn if the version of shiny is lower than what was specified in DESCRIPTION
-  checkShinyVersion(error = FALSE)
+  register_s3_method("knitr", "knit_print", "htmlwidget")
+  register_upgrade_message("shiny", "1.1", error = TRUE)
 }
 
 knit_print.htmlwidget <- function(x, ..., options = NULL) {
   knitr::knit_print(toHTML(x, standalone = FALSE, knitrOptions = options), options = options,  ...)
 }
-

R/staticimports.R

@@ -0,0 +1,77 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:staticimports
+# ======================================================================
+
+`%||%` <- function(a, b) {
+  if (is.null(a)) b else a
+}
+
+get_package_version <- function(pkg) {
+  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(package = pkg))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+register_s3_method <- function(pkg, generic, class, fun = NULL) {
+  stopifnot(is.character(pkg), length(pkg) == 1)
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  if (is.null(fun)) {
+    fun <- get(paste0(generic, ".", class), envir = parent.frame())
+  } else {
+    stopifnot(is.function(fun))
+  }
+
+  if (pkg %in% loadedNamespaces()) {
+    registerS3method(generic, class, fun, envir = asNamespace(pkg))
+  }
+
+  # Always register hook in case pkg is loaded at some
+  # point the future (or, potentially, but less commonly,
+  # unloaded & reloaded)
+  setHook(
+    packageEvent(pkg, "onLoad"),
+    function(...) {
+      registerS3method(generic, class, fun, envir = asNamespace(pkg))
+    }
+  )
+}
+
+register_upgrade_message <- function(pkg, version, error = FALSE) {
+
+  msg <- sprintf(
+    "This version of '%s' is designed to work with '%s' >= %s.
+    Please upgrade via install.packages('%s').",
+    environmentName(environment(register_upgrade_message)),
+    pkg, version, pkg
+  )
+
+  cond <- if (error) stop else packageStartupMessage
+
+  if (pkg %in% loadedNamespaces() && !is_installed(pkg, version)) {
+    cond(msg)
+  }
+
+  # Always register hook in case pkg is loaded at some
+  # point the future (or, potentially, but less commonly,
+  # unloaded & reloaded)
+  setHook(
+    packageEvent(pkg, "onLoad"),
+    function(...) {
+      if (!is_installed(pkg, version)) cond(msg)
+    }
+  )
+}

R/utils.R

@@ -1,3 +1,9 @@
+# @staticimports pkg:staticimports
+#  is_installed get_package_version
+#  register_s3_method register_upgrade_message
+#  %||%
+
+
 # Copied from shiny 0.14.2
 toJSON2 <- function(
   x, ...,  dataframe = "columns", null = "null", na = "null", auto_unbox = TRUE,
@@ -14,17 +20,6 @@ toJSON2 <- function(
   )
 }
 
-if (requireNamespace('shiny') && packageVersion('shiny') >= '0.12.0') local({
-  tryCatch({
-    toJSON <- getFromNamespace('toJSON', 'shiny')
-    args2 <- formals(toJSON2)
-    args1 <- formals(toJSON)
-    if (!identical(args1, args2)) {
-      warning('Check shiny:::toJSON and make sure htmlwidgets:::toJSON is in sync')
-    }
-  })
-})
-
 toJSON <- function(x) {
   if (!is.list(x) || !('x' %in% names(x))) return(toJSON2(x))
   func <- attr(x$x, 'TOJSON_FUNC', exact = TRUE)
@@ -49,10 +44,9 @@ getDependency <- function(name, package = name){
   #  in this cases dependencies should be provided through the
   #  dependencies argument of createWidget
   widgetDep <- list()
-  if (file.exists(system.file(config, package = package))) {
-    config = yaml::yaml.load_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) {
       l$package = package
       do.call(htmlDependency, l)
@@ -65,7 +59,7 @@ getDependency <- function(name, package = name){
   bindingDep <- if (file.exists(system.file(jsfile, package = package))) {
     htmlDependency(
       name = paste0(name, "-binding"),
-      version = packageVersion(package),
+      version = get_package_version(package),
       src = "htmlwidgets",
       package = package,
       script = basename(jsfile),
@@ -76,7 +70,7 @@ getDependency <- function(name, package = name){
   c(
     list(htmlDependency(
       name = "htmlwidgets",
-      version = packageVersion("htmlwidgets"),
+      version = get_package_version("htmlwidgets"),
       src = "www",
       package = "htmlwidgets",
       script = "htmlwidgets.js"
@@ -86,9 +80,6 @@ getDependency <- function(name, package = name){
   )
 }
 
-`%||%` <- function(x, y){
-  if (is.null(x)) y else x
-}
 
 prop <- function(x, path) {
   tryCatch({