/
recordedplot-methods.R
189 lines (154 loc) · 5.95 KB
/
recordedplot-methods.R
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
#' Get the architecture of an object or coerce it into another
#'
#' @param x The object to be coerced.
#' @param ... (optional) Additional arguments passed to the underlying method.
#'
#' @return
#' \code{architecture()} returns a named list with
#' character element \code{ostype} and \code{arch},
#' integer element \code{ptrsize}, and character element \code{endian}.
#' These elements take a missing values if they could not be inferred.
#'
#' @aliases as.architecture
#' @export
architecture <- function(x, ...) {
UseMethod("architecture")
}
#' @param ostype A character string, e.g. \code{"unix"} and \code{"windows"}.
#' @param arch A character string, e.g. \code{"i386"}, \code{"i686"} and \code{"x86_64"}.
#' @param ptrsize The target pointer size - either \code{4L} or \code{8L}.
#' @param endian The target endianess - either \code{"little"} or \code{"big"}.
#'
#' @return
#' \code{as.architecture()} returns a coerced version of \code{x}.
#' If no coercion was needed, then \code{x} itself is returned.
#'
#' @rdname architecture
#' @export
as.architecture <- function(x, ostype=.Platform$OS.type, arch=R.version$arch, ptrsize=.Machine$sizeof.pointer, endian=.Platform$endian, ...) {
UseMethod("as.architecture")
}
#' @export
setMethodS3("architecture", "RecordedPlot", function(x, ...) {
system <- attr(x, "system")
if (is.null(system)) return(NextMethod())
ostype <- system$ostype
if (is.null(ostype)) ostype <- NA_character_
arch <- system$arch
if (is.null(arch)) arch <- NA_character_
ptrsize <- system$ptrsize
if (is.null(ptrsize)) {
## Default pointer size is 8 bytes (64-bit)
gpar_raw <- gpar(x)
n <- length(gpar_raw)
known_sizes <- c("32 bit"=35956L, "64 bit"=35992L)
if (n == known_sizes["32 bit"]) {
ptrsize <- 4L
} else if (n == known_sizes["64 bit"]) {
ptrsize <- 8L
} else {
ptrsize <- NA_integer_
}
}
endian <- system$endian
if (is.null(ptrsize)) endian <- NA_character_
list(ostype=ostype, arch=arch, ptrsize=ptrsize, endian=endian)
}) ## architecture() for RecordedPlot
#' @export
setMethodS3("architecture", "recordedplot", function(x, ...) {
## OS type is unknown by default
ostype <- NA_character_
## Architecture label is unknown by default
arch <- NA_character_
## Guess pointer size for size of 'gpar' element
## NOTE: This is not always a correct guess, but
## it's better than nothing. /HB 2016-09-18
gpar_raw <- gpar(x)
n <- length(gpar_raw)
known_sizes <- c("32 bit"=35956L, "64 bit"=35992L)
if (n == known_sizes["32 bit"]) {
ptrsize <- 4L
} else if (n == known_sizes["64 bit"]) {
ptrsize <- 8L
} else {
ptrsize <- NA_integer_
}
## Endian is unknown by default
endian <- NA_character_
list(ostype=ostype, arch=arch, ptrsize=ptrsize, endian=endian)
}) ## architecture() for recordedplot
#' @export
setMethodS3("as.architecture", "recordedplot", function(x, ostype=.Platform$OS.type, arch=R.version$arch, ptrsize=.Machine$sizeof.pointer, endian=.Platform$endian, ...) {
stop_if_not(is.character(arch), length(arch) == 1)
stop_if_not(ptrsize %in% c(4L, 8L))
stop_if_not(is.character(endian), length(endian) == 1, (is.na(endian) || endian %in% c("little", "big")))
## Default pointer size is 8 bytes (64-bit)
arch <- architecture(x)
## Nothing to do?
if (!is.na(arch) && !is.na(arch$arch) && arch == arch$arch) return(x)
## SPECIAL: Source and target architectures are known
## to be compatible even though their ptrsizes differ
if (all(c(arch, arch$arch) %in% c("i386", "x86_64"))) {
# i386 (e.g. 32-bit Windows) <-> x86_64 (64-bit Linux)
return(x)
}
## Endianess?
if (is.na(endian) || is.na(arch$endian) || endian != arch$endian) {
stop(sprintf("NON-IMPLEMENTED FEATURE: Don't know how to coerce from %s to %s endianess", sQuote(arch$endian), sQuote(endian)))
}
## Pointer size, i.e. 32-bit or 64-bit address space?
known_sizes <- c("32 bit"=35956L, "64 bit"=35992L)
if (is.na(arch$ptrsize)) {
stop(sprintf("Failed to infer architecture. The size of the %s structure is not among the known ones (%s): %d bytes", sQuote("gpar"), paste(sprintf("%s: %s bytes", names(known_sizes), known_sizes), collapse=", "), length(gpar(x))))
}
## Nothing to do?
if (ptrsize == arch$ptrsize && endian == arch$endian) return(x)
## Coerce 'gpar' structure
pad64pos <- c(cex=29, crt=53, lwd=325, ps=389, srt=405,
heights=597, plt=35485, mar=35549, mex=35621)
gpar <- gpar(x)
pkgName <- attr(gpar, "pkgName")
if (arch$ptrsize == 8L && ptrsize == 4L) {
## 64-bit -> 32-bit
drop <- rep(pad64pos, each=4L) + 0:3
gpar <- gpar[-drop]
} else if (arch$ptrsize == 4L && ptrsize == 8L) {
## 32-bit -> 64-bit
for (pos in pad64pos) gpar <- append(gpar, raw(4L), after=pos-1L)
}
attr(gpar, "pkgName") <- pkgName
## Keep the result only if padded to a known length
if (length(gpar) %in% known_sizes) gpar(x) <- gpar
x
}) ## as.architecture() for recordedplot
## Internal gpar() and gpar<-() functions for recordedplot
gpar <- function(x) {
stop_if_not(inherits(x, "recordedplot"))
idx <- which(sapply(x, FUN=function(x) identical(attr(x, "pkgName"), "graphics")))
stop_if_not(length(idx) > 0)
raw <- x[[idx]]
stop_if_not(is.raw(raw))
raw
} ## gpar()
`gpar<-` <- function(x, value) {
stop_if_not(is.raw(value))
stop_if_not(inherits(x, "recordedplot"))
idx <- which(sapply(x, FUN=function(x) identical(attr(x, "pkgName"), "graphics")))
stop_if_not(length(idx) > 0)
x[[idx]] <- value
invisible(x)
} ## gpar<-()
#' @export
setMethodS3("as.architecture", "RecordedPlot", function(x, ...) {
y <- NextMethod()
system <- attr(x, "system")
if (is.null(system)) return(y)
## Update 'system' attribute
attr(y, "system") <- NULL
arch <- architecture(y)
if (is.na(arch$ostype)) arch$ostype <- system$ostype
if (is.na(arch$ptrsize)) arch$ptrsize <- system$ptrsize
if (is.na(arch$endian)) arch$endian <- system$endian
attr(y, "system") <- arch
y
})