1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
startPNG <- function(filename, width, height, res, ...) {
# 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% FALSE) && 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) && is_available("Cairo")) {
pngfun <- Cairo::CairoPNG
} else {
# i.e., png(type = 'cairo')
pngfun <- grDevices::png
}
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 <- utils::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.
# 200x50), we will get an error "figure margin too large", which is triggered
# by plot.new() with the default (large) margin. However, this does not
# guarantee user's code in func() will not trigger the error -- they may have
# to set par(mar = smaller_value) before they draw base graphics.
op <- graphics::par(mar = rep(0, 4))
tryCatch(
graphics::plot.new(),
finally = graphics::par(op)
)
grDevices::dev.cur()
}
#' Run a plotting function and save the output as a PNG
#'
#' This function returns the name of the PNG file that it generates. In
#' essence, it calls `png()`, then `func()`, then `dev.off()`.
#' So `func` must be a function that will generate a plot when used this
#' way.
#'
#' For output, it will try to use the following devices, in this order:
#' quartz (via [grDevices::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)`.
#'
#' @param func A function that generates a plot.
#' @param filename The name of the output file. Defaults to a temp file with
#' extension `.png`.
#' @param width Width in pixels.
#' @param height Height in pixels.
#' @param res Resolution in pixels per inch. This value is passed to
#' [grDevices::png()]. Note that this affects the resolution of PNG rendering in
#' R; it won't change the actual ppi of the browser.
#' @param ... Arguments to be passed through to [grDevices::png()].
#' These can be used to set the width, height, background color, etc.
#' @export
plotPNG <- function(func, filename=tempfile(fileext='.png'),
width=400, height=400, res=72, ...) {
dv <- startPNG(filename, width, height, res, ...)
on.exit(grDevices::dev.off(dv), add = TRUE)
func()
filename
}
#' @importFrom grDevices dev.set dev.cur
createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
force(which)
promises::new_promise_domain(
wrapOnFulfilled = function(onFulfilled) {
force(onFulfilled)
function(...) {
old <- dev.cur()
dev.set(which)
on.exit(dev.set(old))
onFulfilled(...)
}
},
wrapOnRejected = function(onRejected) {
force(onRejected)
function(...) {
old <- dev.cur()
dev.set(which)
on.exit(dev.set(old))
onRejected(...)
}
},
wrapSync = function(expr) {
old <- dev.cur()
dev.set(which)
on.exit(dev.set(old))
force(expr)
}
)
}
|
