1## Internal functions manipulating graphics should be stored here.
2## These functions are _not_ supposed to be called by the end user.
3
4#' DEPRECATED: \code{rk.screen.device} is obsolete. It simply calls \code{dev.new()} in this version of RKWard.
5#'
6#' Depending on your use case, you should use \code{dev.new()}, \code{RK()} or \code{rk.embed.device()}, instead.
7#'
8#' @seealso \link{dev.new}, \link{RK}, \link{rk.embed.device}
9#'
10#' @export
11"rk.screen.device" <- function (...) {
12	warning ("rk.screen.device() is obsolete.\nUse one of dev.new(), RK(), or rk.embed.device(), instead.")
13	dev.new (...)
14}
15
16# Fetch the current size of the given RK() device from the frontend, and redraw
17"RK.resize" <- function (devnum) {
18	# Note: RK.resize() often fails, if something is currently being plotted. That's usually benign, and should not produce warning messages.
19	try (.Call ("rk.graphics.device.resize", as.integer (devnum)-1, PACKAGE="(embedding)"), silent=TRUE)
20}
21
22#' @include internal.R
23assign(".rk.preview.devices", list (), envir=.rk.variables)
24
25#' @export
26".rk.startPreviewDevice" <- function (x) {
27	# NOTE: I considered rewriting this to use .rk.create.preview.data(), but it did not seem right
28	# 1. Creation and removal of storage is mostly trivial
29	# 2. Plot previews need some extra logic for handling deivce closes (see .rk.discard.preview.device.num()), and implementing
30	#    this is easier, if plot preview data is kept in an entirely separate storage
31	a <- .rk.variables$.rk.preview.devices[[x]]
32	if (is.null (a)) {
33		devnum <- dev.cur ()
34		rk.without.plot.history (dev.new ())
35		if (devnum != dev.cur ()) {
36			.rk.variables$.rk.preview.devices[[x]] <- list (devnum=dev.cur(), par=par (no.readonly=TRUE))
37		} else {
38			return (0L)	# no device could be opened
39		}
40	} else {
41		dev.set (a$devnum)
42		par (a$par)
43	}
44	as.integer (dev.cur ())
45}
46
47#' @export
48".rk.killPreviewDevice" <- function (x) {
49	a <- .rk.variables$.rk.preview.devices[[x]]
50	if (!is.null (a)) {
51		if (a$devnum %in% dev.list ()) {
52			dev.off (a$devnum)
53		}
54		.rk.variables$.rk.preview.devices[[x]] <- NULL
55	}
56}
57
58".rk.discard.preview.device.num" <- function (devnum) {
59	for (dev in names (.rk.variables$.rk.preview.devices)) {
60		if (.rk.variables$.rk.preview.devices[[dev]]$devnum == devnum) {
61			.rk.variables$.rk.preview.devices[[dev]] <- NULL
62			return (invisible (TRUE))
63		}
64	}
65	invisible (FALSE)
66}
67
68".rk.list.preview.device.numbers" <- function () {
69	unlist (sapply (.rk.variables$.rk.preview.devices, function (x) x$devnum))
70}
71
72.rk.variables$.rk.printer.devices <- list ()
73
74# see .rk.fix.assignmetns () in internal.R
75#' @export
76".rk.fix.assignments.graphics" <- function ()
77{
78	rk.replace.function ("plot.new", as.environment ("package:graphics"),
79		function () {
80			rk.record.plot$.plot.new.hook ()
81			eval (body (.rk.backups$plot.new))
82		})
83
84	rk.replace.function ("dev.off", as.environment ("package:grDevices"),
85		function (which = dev.cur ()) {
86			if (getOption ("rk.enable.graphics.history"))
87				rk.record.plot$onDelDevice (devId = which)
88
89			# see http://thread.gmane.org/gmane.comp.statistics.rkward.devel/802
90			rkward:::.rk.do.call ("killDevice", as.character (which))
91
92			ret <- eval (body (.rk.backups$dev.off))
93
94			printfile <- .rk.variables$.rk.printer.devices[[as.character (which)]]
95			if (!is.null (printfile)) {
96				rkward:::.rk.do.plain.call ("printPreview", printfile, FALSE)
97				.rk.variables$.rk.printer.devices[[as.character (which)]] <- NULL
98			}
99
100			rkward:::.rk.discard.preview.device.num(which)
101
102			return (ret)
103		})
104
105	rk.replace.function ("dev.set", as.environment ("package:grDevices"),
106		function () {
107			ret <- eval (body (.rk.backups$dev.set))
108
109			if (getOption ("rk.enable.graphics.history") && rk.record.plot$.is.device.managed (which))
110				rk.record.plot$.set.trellis.last.object (which)
111
112			ret
113		})
114
115	## set a hook defining "print.function" for lattice:
116	setHook (packageEvent ("lattice", "onLoad"),
117		function (...)
118			lattice::lattice.options (print.function = function (x, ...)
119			{
120				if (dev.cur() == 1) dev.new ()
121				## TODO: use "trellis" instead of "lattice" to accomodate ggplot2 plots?
122				plot_hist_enabled <- getOption ("rk.enable.graphics.history")
123				if (plot_hist_enabled) {
124					rk.record.plot$record (nextplot.pkg = "lattice")
125				}
126				rk.without.plot.history (plot (x, ...))
127				if (plot_hist_enabled) {
128					rk.record.plot$.save.tlo.in.hP ()
129				}
130				invisible ()
131			})
132	)
133
134	if (compareVersion (as.character (getRversion ()), "2.14.0") < 0) {
135		setHook (packageEvent ("grid", "attach"),
136			function (...)
137				rk.replace.function ("grid.newpage", as.environment ("package:grid"),
138					function () {
139						## TODO: add specific support for ggplots?
140						rk.record.plot$.plot.new.hook ()
141						ret <- eval (body (.rk.backups$grid.newpage))
142					})
143		)
144	} else {
145		setHook ("before.grid.newpage",
146			function (...)
147			{
148				rk.record.plot$.plot.new.hook ()
149			},
150			action = "append"
151		)
152	}
153
154	## persp does not call plot.new (), so set a hook. Fortunately, the hook is placed after drawing the plot.
155	setHook ("persp",
156		function (...)
157		{
158			rk.record.plot$.plot.new.hook ()
159		},
160		action = "append"
161	)
162}
163
164