Reporting of output styles (colors and fonts)

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.4.0.9002
+Version: 1.4.0.9003
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "[email protected]"),
     person("Joe", "Cheng", role = "aut", email = "[email protected]"),
@@ -70,7 +70,7 @@ Imports:
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.4.0.9001),
+    htmltools (>= 0.4.0.9003),
     R6 (>= 2.0),
     sourcetools,
     later (>= 1.0.0),
@@ -95,7 +95,9 @@ Suggests:
     shinytest,
     yaml,
     future,
-    dygraphs
+    dygraphs,
+    ragg,
+    showtext
 Remotes:
     rstudio/htmltools,
     rstudio/shinytest

NEWS.md

@@ -17,6 +17,8 @@ shiny 1.4.0.9001
 
 * Resolved [#2732](https://github.com/rstudio/shiny/issues/2732): `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/jeroen/commonmark) package. ([#2737](https://github.com/rstudio/shiny/pull/2737))
 
+* The `getCurrentOutputInfo()` function can now return the background color (`bg`), foreground color (`fg`), `accent` (i.e., hyperlink) color, and `font` information of the output's HTML container. This information is reported by `plotOutput()`, `imageOutput()`, and any other output bindings containing a class of `.shiny-report-theme`. This feature allows developers to style an output's contents based on the container's CSS styling.  ([#2740](https://github.com/rstudio/shiny/pull/2740))
+
 ### Minor new features and improvements
 
 * Fixed [#2042](https://github.com/rstudio/shiny/issues/2042), [#2628](https://github.com/rstudio/shiny/issues/2628): In a `dateInput` and `dateRangeInput`, disabled months and years are now a lighter gray, to make it easier to see that they are disabled. ([#2690](https://github.com/rstudio/shiny/pull/2690))

R/app_template.R

@@ -116,13 +116,12 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   }
 
   if ("shinytest" %in% examples) {
-    if (system.file(package = "shinytest") != "" &&
-        utils::packageVersion("shinytest") <= "1.3.1.9000")
+    if (!is_available("shinytest", "1.4.0"))
     {
       message(
         "The tests/shinytest directory needs shinytest 1.4.0 or later to work properly.\n",
       )
-      if (system.file(package = "shinytest") != "") {
+      if (is_available("shinytest")) {
         message("You currently have shinytest ",
                 utils::packageVersion("shinytest"), " installed.")
       }

R/globals.R

@@ -28,22 +28,14 @@ register_s3_method <- function(pkg, generic, class, fun = NULL) {
 }
 
 register_upgrade_message <- function(pkg, version) {
-  # Is an out-dated version of this package installed?
-  needs_upgrade <- function() {
-    if (system.file(package = pkg) == "")
-      return(FALSE)
-    if (utils::packageVersion(pkg) >= version)
-      return(FALSE)
-    TRUE
-  }
 
   msg <- sprintf(
     "This version of Shiny is designed to work with '%s' >= %s.
     Please upgrade via install.packages('%s').",
     pkg, version, pkg
   )
 
-  if (pkg %in% loadedNamespaces() && needs_upgrade()) {
+  if (pkg %in% loadedNamespaces() && !is_available(pkg, version)) {
     packageStartupMessage(msg)
   }
 
@@ -53,7 +45,7 @@ register_upgrade_message <- function(pkg, version) {
   setHook(
     packageEvent(pkg, "onLoad"),
     function(...) {
-      if (needs_upgrade()) packageStartupMessage(msg)
+      if (!is_available(pkg, version)) packageStartupMessage(msg)
     }
   )
 }

R/graph.R

@@ -1,31 +1,20 @@
-is_installed <- function(package, version) {
-  installedVersion <- tryCatch(utils::packageVersion(package), error = function(e) NA)
-  !is.na(installedVersion) && installedVersion >= version
-}
-
 # Check that the version of an suggested package satisfies the requirements
 #
 # @param package The name of the suggested package
 # @param version The version of the package
-check_suggested <- function(package, version, location) {
+check_suggested <- function(package, version = NULL) {
 
-  if (is_installed(package, version)) {
+  if (is_available(package, version)) {
     return()
   }
 
-  missing_location <- missing(location)
   msg <- paste0(
     sQuote(package),
-    if (is.na(version)) "" else paste0("(>= ", version, ")"),
-    " must be installed for this functionality.",
-    if (!missing_location)
-      paste0(
-        "\nPlease install the missing package: \n",
-        "  source(\"https://install-github.me/", location, "\")"
-      )
+    if (is.na(version %OR% NA)) "" else paste0("(>= ", version, ")"),
+    " must be installed for this functionality."
   )
 
-  if (interactive() && missing_location) {
+  if (interactive()) {
     message(msg, "\nWould you like to install it?")
     if (utils::menu(c("Yes", "No")) == 1) {
       return(utils::install.packages(package))

R/imageutils.R

@@ -1,17 +1,47 @@
 startPNG <- function(filename, width, height, res, ...) {
-  # If quartz is available, use png() (which will default to quartz).
-  # Otherwise, if the Cairo package is installed, use CairoPNG().
-  # Finally, if neither quartz nor Cairo, use png().
-  if (capabilities("aqua")) {
+  # shiny.useragg is an experimental option that isn't officially supported or
+  # documented. It's here in the off chance that someone really wants
+  # to use ragg (say, instead of showtext, for custom font rendering).
+  # In the next shiny release, this option will likely be superseded in
+  # favor of a fully customizable graphics device option
+  if ((getOption('shiny.useragg') %OR% TRUE) && is_available("ragg")) {
+    pngfun <- ragg::agg_png
+  } else if (capabilities("aqua")) {
+    # i.e., png(type = 'quartz')
     pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-      nchar(system.file(package = "Cairo"))) {
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) && is_available("Cairo")) {
     pngfun <- Cairo::CairoPNG
   } else {
+    # i.e., png(type = 'cairo')
     pngfun <- grDevices::png
   }
 
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
+
+  # Set a smarter default for the device's bg argument (based on thematic's global state).
+  # Note that, technically, this is really only needed for CairoPNG, since the other
+  # devices allow their bg arg to be overridden by par(bg=...), which thematic does prior
+  # to plot-time, but it shouldn't hurt to inform other the device directly as well
+  if (is.null(args$bg) && isNamespaceLoaded("thematic")) {
+    # TODO: use :: once thematic is on CRAN
+    args$bg <- getFromNamespace("thematic_get_option", "thematic")("bg", "white")
+    # auto vals aren't resolved until plot time, so if we see one, resolve it
+    if (isTRUE("auto" == args$bg)) {
+      args$bg <- getCurrentOutputInfo()[["bg"]]()
+    }
+  }
+
+  # Handle both bg and background device arg
+  # https://github.com/r-lib/ragg/issues/35
+  fmls <- names(formals(pngfun))
+  if (("background" %in% fmls) && (!"bg" %in% fmls)) {
+    if (is.null(args$background)) {
+      args$background <- args$bg
+    }
+    args$bg <- NULL
+  }
+
+  do.call(pngfun, args)
   # Call plot.new() so that even if no plotting operations are performed at
   # least we have a blank background. N.B. we need to set the margin to 0
   # temporarily before plot.new() because when the plot size is small (e.g.

R/render-plot.R

@@ -200,6 +200,17 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
   domain <- createGraphicsDevicePromiseDomain(device)
   grDevices::dev.control(displaylist = "enable")
 
+  # In some cases (at least when `png(type='cairo')), showtext's font
+  # rendering needs to know about the device's resolution to work properly.
+  # I don't see any immediate harm in setting the dpi option for any device,
+  # but it's worth noting that the option doesn't currently work with CairoPNG.
+  # https://github.com/yixuan/showtext/issues/33
+  showtextOpts <- if (isNamespaceLoaded("showtext")) {
+    showtext::showtext_opts(dpi = res)
+  } else {
+    NULL
+  }
+
   hybrid_chain(
     hybrid_chain(
       promises::with_promise_domain(domain, {
@@ -246,6 +257,9 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
       }),
       finally = function() {
         grDevices::dev.off(device)
+        if (length(showtextOpts)) {
+          showtext::showtext_opts(showtextOpts)
+        }
       }
     ),
     function(result) {

R/shiny.R

@@ -1319,6 +1319,13 @@ ShinySession <- R6Class(
 
       # If we don't already have width for this output info, see if it's
       # present, and if so, add it.
+
+      # Note that all the following clientData values (which are reactiveValues)
+      # are wrapped in reactive() so that users can take a dependency on particular
+      # output info (i.e., just depend on width/height, or just depend on bg, fg, etc).
+      # To put it another way, if getCurrentOutputInfo() simply returned a list of values
+      # from self$clientData, than anything that calls getCurrentOutputInfo() would take
+      # a reactive dependency on all of these values.
       if (! ("width" %in% names(tmp_info)) ) {
         width_name  <- paste0("output_", name, "_width")
         if (width_name %in% cd_names()) {
@@ -1337,6 +1344,42 @@ ShinySession <- R6Class(
         }
       }
 
+      # parseCssColors() currently errors out if you hand it any NAs
+      # This'll make sure we're always working with a string (and if
+      # that string isn't a valid CSS color, will return NA)
+      # https://github.com/rstudio/htmltools/issues/161
+      parse_css_colors <- function(x) {
+        htmltools::parseCssColors(x %OR% "", mustWork = FALSE)
+      }
+
+      bg <- paste0("output_", name, "_bg")
+      if (bg %in% cd_names()) {
+        tmp_info$bg <- reactive({
+          parse_css_colors(self$clientData[[bg]])
+        })
+      }
+
+      fg <- paste0("output_", name, "_fg")
+      if (fg %in% cd_names()) {
+        tmp_info$fg <- reactive({
+          parse_css_colors(self$clientData[[fg]])
+        })
+      }
+
+      accent <- paste0("output_", name, "_accent")
+      if (accent %in% cd_names()) {
+        tmp_info$accent <- reactive({
+          parse_css_colors(self$clientData[[accent]])
+        })
+      }
+
+      font <- paste0("output_", name, "_font")
+      if (font %in% cd_names()) {
+        tmp_info$font <- reactive({
+          self$clientData[[font]]
+        })
+      }
+
       private$outputInfo[[name]] <- tmp_info
       private$outputInfo[[name]]
     },

R/utils.R

@@ -1873,3 +1873,13 @@ findEnclosingApp <- function(path = ".") {
     path <- dirname(path)
   }
 }
+
+# Check if a package is installed, and if version is specified,
+# that we have at least that version
+is_available <- function(package, version = NULL) {
+  installed <- nzchar(system.file(package = package))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(utils::packageVersion(package) >= version)
+}