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