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.9900
 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

R/imageutils.R

@@ -4,14 +4,45 @@ startPNG <- function(filename, width, height, res, ...) {
   # Finally, if neither quartz nor Cairo, use png().
   if (capabilities("aqua")) {
     pngfun <- grDevices::png
+  } else if ((getOption('shiny.useragg') %OR% FALSE) &&
+             nchar(system.file(package = "ragg"))) {
+    # ragg seems preferrable to Cairo, especially when it comes to custom fonts
+    # https://github.com/yixuan/showtext/issues/33#issuecomment-620848077
+    # https://ragg.r-lib.org/articles/ragg_quality.html
+    pngfun <- ragg::agg_png
   } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-      nchar(system.file(package = "Cairo"))) {
+             nchar(system.file(package = "Cairo"))) {
     pngfun <- Cairo::CairoPNG
   } else {
     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.
@@ -36,14 +67,16 @@ startPNG <- function(filename, width, height, res, ...) {
 #' way.
 #'
 #' For output, it will try to use the following devices, in this order:
-#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
+#' quartz (via [grDevices::png()]), then [ragg::agg_png()], then [Cairo::CairoPNG()],
 #' and finally [grDevices::png()]. This is in order of quality of
 #' output. Notably, plain `png` output on Linux and Windows may not
 #' antialias some point shapes, resulting in poor quality output.
 #'
-#' In some cases, `Cairo()` provides output that looks worse than
-#' `png()`. To disable Cairo output for an app, use
-#' `options(shiny.usecairo=FALSE)`.
+#' In some rare cases, `ragg::agg_png()` provides output that looks worse than
+#' `Cairo()` (and `png()`). To disable ragg output for an app, use
+#' `options(shiny.useragg=FALSE)`. Moreover, in some rare cases, `Cairo()`
+#' provides output that looks worse than `png()`. To disable Cairo output
+#' for an app, use `options(shiny.usecairo=FALSE)`.
 #'
 #' @param func A function that generates a plot.
 #' @param filename The name of the output file. Defaults to a temp file with

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 with `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 CairoPNG currently doesn't pick up on the option.
+  # 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-options.R

@@ -110,6 +110,9 @@ getShinyOption <- function(name, default = NULL) {
 #' \item{shiny.usecairo (defaults to `TRUE`)}{This is used to disable graphical rendering by the
 #'   Cairo package, if it is installed. See [plotPNG()] for more
 #'   information.}
+#'  \item{shiny.useragg (defaults to `TRUE`)}{This is used to disable graphical rendering by the
+#'   ragg package, if it is installed. See [plotPNG()] for more
+#'   information.}
 #' }
 #' @param ... Options to set, with the form `name = value`.
 #' @aliases shiny-options

R/shiny.R

@@ -1337,6 +1337,35 @@ ShinySession <- R6Class(
         }
       }
 
+      bg <- paste0("output_", name, "_bg")
+      if (bg %in% cd_names()) {
+        tmp_info$bg <- htmltools::parseCssColors(
+          self$clientData[[bg]] %OR% "",
+          mustWork = FALSE
+        )
+      }
+
+      fg <- paste0("output_", name, "_fg")
+      if (fg %in% cd_names()) {
+        tmp_info$fg <- htmltools::parseCssColors(
+          self$clientData[[fg]] %OR% "",
+          mustWork = FALSE
+        )
+      }
+
+      accent <- paste0("output_", name, "_accent")
+      if (accent %in% cd_names()) {
+        tmp_info$accent <- htmltools::parseCssColors(
+          self$clientData[[accent]] %OR% "",
+          mustWork = FALSE
+        )
+      }
+
+      font <- paste0("output_", name, "_font")
+      if (font %in% cd_names()) {
+        tmp_info$font <- self$clientData[[font]]
+      }
+
       private$outputInfo[[name]] <- tmp_info
       private$outputInfo[[name]]
     },