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
|
##
## Sweave device
##
##
rgl.Sweave <- function(name, width, height, options, ...) {
if (length(hook <- getHook("on.rgl.close"))) {
# test is for compatibility with R < 3.0.0
if (is.list(hook)) hook <- hook[[1]]
dev <- environment(hook)$dev
set3d(dev)
} else {
wr <- c(0, 0, width*options$resolution, height*options$resolution)
open3d(windowRect=wr)
if (is.null(delay <- options$delay)) delay <- 0.1
Sys.sleep(as.numeric(delay))
wrnew <- par3d("windowRect")
if (wr[3] - wr[1] != wrnew[3] - wrnew[1] ||
wr[4] - wr[2] != wrnew[4] - wrnew[2])
stop("rgl window creation error; try reducing resolution, width or height")
dev <- cur3d()
}
snapshotDone <- FALSE
# stayOpen is used below in rgl.Sweave.off
stayOpen <- isTRUE(options$stayopen)
type <- options$outputtype
if (is.null(type)) type <- "png"
setHook("on.rgl.close", action="replace", function(remove=TRUE) {
prev.dev <- cur3d()
on.exit(set3d(prev.dev))
if (!snapshotDone) {
set3d(dev)
switch(type,
png = snapshot3d(filename=paste(name, "png", sep=".")),
pdf = rgl.postscript(filename=paste(name, "pdf", sep="."), fmt="pdf"),
eps = rgl.postscript(filename=paste(name, "eps", sep="."), fmt="eps"),
stop(gettextf("Unrecognized rgl outputtype: '%s'", type), domain = NA)
)
snapshotDone <<- TRUE
}
if (remove)
setHook("on.rgl.close", action="replace", NULL)
})
}
rgl.Sweave.off <- function() {
if (length(hook <- getHook("on.rgl.close"))) {
if (is.list(hook)) hook <- hook[[1]] # test is for R pre-3.0.0 compatibility
stayOpen <- environment(hook)$stayOpen
if (stayOpen) hook(FALSE)
else close3d()
}
}
##
## Sweave snapshot
##
##
Sweave.snapshot <- function() {
if (length(hook <- getHook("on.rgl.close"))) {
if (is.list(hook)) hook <- hook[[1]] # test is for R pre-3.0.0 compatibility
hook(remove = FALSE)
}
}
|
