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
|
# Note: For S4, the value is the class defintion. The slots (data) are in the
# attributes.
pack <- function(obj, ...) {
# encode by storage mode
encoding.mode <- typeof(obj)
# null may not have attributes
if (encoding.mode == "NULL" || identical(obj, as.name('\001NULL\001'))) {
return(list(type = as.scalar("NULL")))
}
# needed because formals become attributes, etc
if (encoding.mode == "closure") {
obj <- as.list(obj)
}
# special exception
if (encoding.mode == "environment" && isNamespace(obj)) {
encoding.mode <- "namespace"
}
# Strip off 'class' from S4 attributes
attrib <- attributes(obj)
if(isS4(obj)){
attrib <- attrib[slotNames(obj)]
names(attrib) <- slotNames(obj)
}
# encode recursively
list(
type = as.scalar(encoding.mode),
attributes = givename(lapply(attrib, pack, ...)),
value = switch(encoding.mode,
environment = NULL,
externalptr = NULL,
namespace = lapply(as.list(getNamespaceInfo(obj, "spec")), as.scalar),
S4 = list(class = as.scalar(class(obj)),
package = as.scalar(attr(class(obj), "package"))),
raw = as.scalar(base64_enc(unclass(obj))),
logical = as.vector(unclass(obj), mode = "logical"),
integer = as.vector(unclass(obj), mode = "integer"),
numeric = as.vector(unclass(obj), mode = "numeric"),
double = as.vector(unclass(obj), mode = "double"),
character = as.vector(unclass(obj), mode = "character"),
complex = as.vector(unclass(obj), mode = "complex"),
list = unname(lapply(unclass(obj), pack, ...)),
pairlist = unname(lapply(as.vector(obj, mode = "list"), pack, ...)),
closure = unname(lapply(obj, pack, ...)),
builtin = as.scalar(base64_enc(serialize(unclass(obj), NULL))),
special = as.scalar(base64_enc(serialize(unclass(obj), NULL))),
language = deparse(unclass(obj)),
name = deparse(unclass(obj)),
symbol = deparse(unclass(obj)),
expression = deparse(obj[[1]]),
warning("No encoding has been defined for objects with storage mode ", encoding.mode, " and will be skipped.")
)
)
}
unpack <- function(obj) {
encoding.mode <- obj$type
# functions are special
if (encoding.mode == "NULL") {
return(NULL)
}
if(identical(encoding.mode, "S4")){
obj_class <- load_s4_class(obj$value$class, package = obj$value$package)
obj_data <- lapply(obj$attributes, unpack)
if(!length(obj_class))
obj_class <- obj$value$class
return(do.call(new, c(Class = obj_class, obj_data)))
}
newdata <- c(
list(.Data = switch(encoding.mode,
environment = new.env(parent=emptyenv()),
namespace = getNamespace(obj$value$name),
externalptr = NULL,
raw = base64_dec(obj$value),
logical = as.logical(list_to_vec(obj$value)),
integer = as.integer(list_to_vec(obj$value)),
numeric = as.numeric(list_to_vec(obj$value)),
double = as.double(list_to_vec(obj$value)),
character = as.character(list_to_vec(obj$value)),
complex = as.complex(list_to_vec(obj$value)),
list = lapply(obj$value, unpack),
pairlist = lapply(obj$value, unpack),
symbol = makesymbol(x = unlist(obj$value)),
name = makesymbol(x = unlist(obj$value)),
expression = parse(text = obj$value),
language = as.call(parse(text = unlist(obj$value)))[[1]],
special = unserialize(base64_dec(obj$value)),
builtin = unserialize(base64_dec(obj$value)),
closure = lapply(obj$value, unpack),
stop("Switch falling through for encode.mode: ", encoding.mode)
)
), lapply(obj$attributes, unpack))
# this is for serializing functions arguments: as.list(lm)$data
if (identical(newdata[[1]], substitute())) {
return(substitute())
}
# build the output object
output <- do.call("structure", newdata, quote = TRUE)
# functions are special
if (encoding.mode == "closure") {
myfn <- as.function(output)
environment(myfn) <- globalenv()
return(myfn)
}
# functions are special
if (encoding.mode == "pairlist") {
return(as.pairlist(output))
}
# try to fix native symbols
if (is(output, "NativeSymbolInfo")) {
try(output <- fixNativeSymbol(output))
}
# return
return(output)
}
load_s4_class <- function(name, package){
cls <- tryCatch({
getClassDef(name, package = package)
}, error = function(e){
stop(sprintf("Failed to load S4 class definition '%s' from '%s' (%s)", name, package, e$message), call. = FALSE)
})
}
|
