-
Notifications
You must be signed in to change notification settings - Fork 315
/
makebasedb.R
122 lines (103 loc) · 4.57 KB
/
makebasedb.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
local({
makeLazyLoadDB <- function(from, filebase, compress = TRUE, ascii = FALSE,
variables) {
envlist <- function(e) {
names <- ls(e, all=TRUE)
list <- .Call("R_getVarsFromFrame", names, e, FALSE, PACKAGE="base")
names(list) <- names
list
}
envtable <- function() {
idx <- 0
envs <- NULL
enames <- character(0)
find <- function(v, keys, vals)
for (i in seq(along=keys))
if (identical(v, keys[[i]]))
return(vals[i])
getname <- function(e) find(e, envs, enames)
getenv <- function(n) find(n, enames, envs)
insert <- function(e) {
idx <<- idx + 1
name <- paste("env", idx, sep="::")
envs <<- c(e, envs)
enames <<- c(name, enames)
name
}
list(insert = insert, getenv = getenv, getname = getname)
}
lazyLoadDBinsertValue <- function(value, file, ascii, compress, hook)
.Call("R_lazyLoadDBinsertValue", value, file, ascii, compress, hook,
PACKAGE = "base")
lazyLoadDBinsertListElement <- function(x, i, file, ascii, compress, hook)
.Call("R_lazyLoadDBinsertValue", x[[i]], file, ascii, compress, hook,
PACKAGE = "base")
lazyLoadDBinsertVariable <- function(n, e, file, ascii, compress, hook) {
x <- .Call("R_getVarsFromFrame", n, e, FALSE, PACKAGE="base")
.Call("R_lazyLoadDBinsertValue", x[[1]], file, ascii, compress, hook,
PACKAGE = "base")
}
mapfile <- paste(filebase, "rdx", sep = ".")
datafile <- paste(filebase, "rdb", sep = ".")
close(file(datafile, "w")) # truncate to zero
table <- envtable()
varenv <- new.env(hash = TRUE)
envenv <- new.env(hash = TRUE)
envhook <- function(e) {
if (is.environment(e)) {
name <- table$getname(e)
if (is.null(name)) {
name <- table$insert(e)
data <- list(bindings = envlist(e),
enclos = parent.env(e))
key <- lazyLoadDBinsertValue(data, datafile, ascii,
compress, envhook)
assign(name, key, env = envenv)
}
name
}
}
if (is.environment(from)) {
if (! missing(variables))
vars <- variables
else vars <- ls(from, all = TRUE)
}
else if (is.list(from)) {
vars <- names(from)
if (length(vars) != length(from) || any(nchar(vars) == 0))
stop("source list must have names for all elements")
}
else stop("source must be an environment or a list");
for (i in seq(along = vars)) {
if (is.environment(from))
key <- lazyLoadDBinsertVariable(vars[i], from, datafile,
ascii, compress, envhook)
else key <- lazyLoadDBinsertListElement(from, i, datafile, ascii,
compress, envhook)
assign(vars[i], key, env = varenv)
}
vals <- lapply(vars, get, env = varenv, inherits = FALSE)
names(vals) <- vars
rvars <- ls(envenv, all = TRUE)
rvals <- lapply(rvars, get, env = envenv, inherits = FALSE)
names(rvals) <- rvars
val <- list(variables = vals, references = rvals,
compressed = compress)
.saveRDS(val, mapfile)
}
omit <- c(".Last.value", ".AutoloadEnv")
if (length(search()[search()!="Autoloads"]) != 2)
stop("start R with NO packages loaded to create the data base")
baseFileBase <- file.path(.Library,"base","R","base")
if (file.info(baseFileBase)["size"] < 20000) # crude heuristic
stop("may already be using lazy loading on base");
basevars <- ls(baseenv(), all=TRUE)
basevars <- basevars[! basevars %in% omit]
# **** need prims too since some prims have several names (is.name, is.symbol)
# basevars <- ls(baseenv(), all=TRUE)
# notPrim <- sapply(basevars, function(n)
# ! typeof(get(n, baseenv())) %in% c("builtin","special"))
# makeLazyLoadDB(baseenv(), baseFileBase, variables = basevars[notPrim])
makeLazyLoadDB(baseenv(), baseFileBase, variables = basevars)
# q(save = "no", runLast = FALSE)
})