← Back to branch summary

~ubuntu-branches/ubuntu/karmic/rkward/karmic

« back to all changes in this revision

Viewing changes to rkward/rbackend/rpackages/rkward/R/internal.R

  • Committer: Bazaar Package Importer
  • Author(s): Thomas Friedrichsmeier
  • Date: 2006-11-06 16:30:00 UTC
  • mfrom: (1.2.1 upstream) (3.1.1 feisty)
  • Revision ID: james.westby@ubuntu.com-20061106163000-qi8ju75eqecrfay7
* new upstream release
* depend on either php4-cli or php5-cli

Show diffs side-by-side

added added

removed removed

Lines of Context:
rkward/rbackend/rpackages/rkward/R/internal.R
1
1
".rk.get.meta" <- function (x) {
2
 
        c (row.names (attr (x, ".rk.meta")), as.vector (attr (x, ".rk.meta")[[1]]), recursive=TRUE)
3
 
}
4
 
 
5
 
".rk.set.meta" <- function (x, l, m) {
6
 
        eval (substitute (attr (x, ".rk.meta") <<- data.frame (d=m, row.names=l)))
7
 
}
8
 
 
9
 
".rk.editor.opened" <- function (x) {
10
 
        if (!exists (".rk.editing")) .rk.editing <<- c ()
11
 
        .rk.editing <<- c (.rk.editing, deparse (substitute (x)))
12
 
}
13
 
 
14
 
".rk.editor.closed" <- function (x) {
15
 
        if (exists (".rk.editing")) .rk.editing <<- .rk.editing[.rk.editing != deparse (substitute (x))]
16
 
}
17
 
 
18
 
".rk.classify" <- function (x) {
19
 
        type <- 0
20
 
        if (is.data.frame (x)) type = type + 1
21
 
        if (is.matrix (x)) type = type + 2
22
 
        if (is.array (x)) type = type + 4
23
 
        if (is.list (x)) type = type + 8
24
 
        if (type != 0) type = type + 16 else type = 32
25
 
        if (is.function (x)) type = type + 128
26
 
        if (!is.null (attr (x, ".rk.meta"))) type = type + 256
27
 
        d <- dim (x)
28
 
        if (length (d) < 1) d <- length (x);    # handling for objects that according to R do not have a dimension (such as vectors, functions, etc.)
29
 
        c (type, d)
30
 
}
31
 
 
32
 
".rk.get.type" <- function (x) {
33
 
        if (is.data.frame (x) || is.matrix (x) || is.array (x) || is.list (x)) return (1)               # container
34
 
        if (is.function (x)) return (2)         # function
35
 
        if (is.vector (x)) return (3)           # a vector/variable
36
 
        return (4)              # something else
 
2
        y <- attr (x, ".rk.meta");
 
3
        c (names (y), as.character (y))
 
4
}
 
5
 
 
6
".rk.set.meta" <- function (x, m) {
 
7
        eval (substitute (attr (x, ".rk.meta") <<- m))
 
8
}
 
9
 
 
10
".rk.set.invalid.field" <- function (x, r, d) {
 
11
        l <- attr (x, ".rk.invalid.fields");
 
12
        if (is.null (l)) l <- list ();
 
13
        l[[as.character(r)]] <- d;
 
14
        eval (substitute (attr (x, ".rk.invalid.fields") <<- l))
37
15
}
38
16
 
39
17
".rk.data.frame.insert.row" <- function (x, index=0) {
97
75
        x <- as.data.frame (installed.packages ())
98
76
        try (titles <- as.data.frame (library ()$results)$Title)
99
77
        if (length (titles) != dim (x)[1]) titles <- rep ("", dim (x)[1])
100
 
        return (c (as.vector (x$Package), as.vector (titles), as.vector (x$Version), as.vector (x$LibPath)))
 
78
        return (list (as.character (x$Package), as.character (titles), as.character (x$Version), as.character (x$LibPath)))
101
79
}
102
80
 
103
81
# Here we concatenate everything (same as above) to get search results easily
106
84
        return(c(as.vector(H$topic),as.vector(H$title),as.vector(H$Package)))
107
85
}
108
86
 
 
87
# This function works like available.packages (with no arguments), but does simple caching of the result, and of course uses a cache if available. Cache is only used, if it is less than 1 hour old, and options("repos") is unchanged.
 
88
".rk.cached.available.packages" <- function () {
 
89
        x <- NULL
 
90
        if (exists (".rk.available.packages.cache")) {
 
91
                if (.rk.available.packages.cache$timestamp > (Sys.time () - 3600)) {
 
92
                        if (all (.rk.available.packages.cache$repos$repos == options ("repos")$repos)) {
 
93
                                x <- .rk.available.packages.cache$cache
 
94
                        }
 
95
                }
 
96
        }
 
97
 
 
98
        if (is.null(x)) {
 
99
                x <- available.packages()
 
100
                .rk.available.packages.cache <<- list (cache = x, timestamp = Sys.time (), repos = options ("repos"))
 
101
        }
 
102
 
 
103
        return (x)
 
104
}
 
105
 
 
106
".rk.get.old.packages" <- function () {
 
107
        x <- old.packages (available=.rk.cached.available.packages ())
 
108
        return (list (as.character (x[,"Package"]), as.character (x[,"LibPath"]), as.character (x[,"Installed"]), as.character (x[,"ReposVer"]), rk.make.repos.string ()))
 
109
}
109
110
 
110
111
".rk.get.available.packages" <- function () {
111
 
        x <- available.packages ()
112
 
        return (c (as.vector (x[,1]), as.vector (x[,2])))
 
112
        x <- .rk.cached.available.packages ()
 
113
        return (list (as.character (x[,1]), as.character (x[,2]), rk.make.repos.string ()))
113
114
}
114
115
 
115
116
"require" <- function (package, quietly = FALSE, character.only = FALSE, ...)
125
126
}
126
127
 
127
128
# overriding q, to ask via GUI instead. Arguments are not interpreted.
128
 
"q" <- function (save = "default", status = 0, runLast = TRUE) {
 
129
"q" <- function (save = "default", status = 0, runLast = TRUE, ...) {
129
130
        .rk.do.call ("quit")
130
131
}
131
132
 
132
 
"quit" <- function (save = "default", status = 0, runLast = TRUE) {
133
 
        q (save, status, runLast)
 
133
"quit" <- function (save = "default", status = 0, runLast = TRUE, ...) {
 
134
        q (save, status, runLast, ...)
134
135
}
135
136
 
136
137
#".rk.init.handlers" <- function () {
153
154
#       .rk.do.call ("endOpenX11", as.character (dev.cur ()));
154
155
#}
155
156
 
156
 
 
157
 
# changed to allow assignment of values not in levels without losing information.
158
 
"[<-.factor" <- function (x, i, value) {
159
 
        ok <- TRUE
160
 
        lx <- levels(x)
161
 
        cx <- oldClass(x)
162
 
        if (is.factor(value))
163
 
                value <- levels(value)[value]
164
 
        m <- match(value, lx)
165
 
        if (any(is.na(m) & !is.na(value))) {
166
 
                m <- value
167
 
                ok <- FALSE
168
 
                mode (x) <- "character"
169
 
                warning("invalid factor level. Dropping factor-class. Restore using rk.restore.factor ().")
170
 
        }
171
 
## here, let m revert to original value to allow temporary storage in different type (probably character)
172
 
## change storage back to 'normal' factor using "match (unclass (x), levels (x))"
173
 
        class(x) <- NULL
174
 
        if (missing(i))
175
 
                x[] <- m
176
 
        else x[i] <- m
177
 
        attr(x, "levels") <- lx
178
 
        if (ok) {
179
 
                class (x) <- cx
180
 
        } else {
181
 
                tx <- cx[cx != "factor"]
182
 
                if (length (tx) < 1) {
183
 
                        class (x) <- mode (x)
184
 
                } else {
185
 
                        class (x) <- tx
186
 
                }
187
 
        }
188
 
        x
189
 
}
190
 
 
191
 
"rk.restore.factor" <- function (x) {
192
 
        t <- match (x, levels (x))
193
 
        if (length (class (x)) > 1) {
194
 
                classes <- c ("factor", class (x))
195
 
        } else {
196
 
                classes <- "factor"
197
 
        }
198
 
        attribs <- attributes (x)
199
 
        eval (substitute (x <<- t))
200
 
        eval (substitute (attributes (x) <<- attribs))
201
 
        eval (substitute (class (x) <<- classes))
 
157
# these functions can be used to track assignments to R objects. The main interfaces are .rk.watch.symbol (k) and .rk.unwatch.symbol (k). This works by copying the symbol to a backup environment, removing it, and replacing it by an active binding to the backup location
 
158
".rk.watched.symbols" <- new.env ()
 
159
 
 
160
".rk.make.watch.f" <- function (k) {
 
161
        function (value) {
 
162
                if (!missing (value)) {
 
163
                        assign (k, value, envir=.rk.watched.symbols)
 
164
                        .rk.do.call ("ws", k);
 
165
                        invisible (value)
 
166
                } else {
 
167
                        get (k, envir=.rk.watched.symbols)
 
168
                }
 
169
        }
 
170
}
 
171
 
 
172
".rk.watch.symbol" <- function (k) {
 
173
        f <- .rk.make.watch.f (k)
 
174
        assign (k, get (k, envir=globalenv ()), envir=.rk.watched.symbols)
 
175
        rm (list=k, envir=globalenv ())
 
176
 
 
177
        makeActiveBinding (k, f, globalenv ())
 
178
 
 
179
        invisible (TRUE)
 
180
}
 
181
 
 
182
# not needed by rkward
 
183
".rk.unwatch.symbol" <- function (k) {
 
184
        rm (list=k, envir=globalenv ())
 
185
 
 
186
        k <<- .rk.watched.symbols$k
 
187
 
 
188
        rm (k, envir=.rk.watched.symbols);
 
189
 
 
190
        invisible (TRUE)
 
191
}
 
192
 
 
193
".rk.watch.globalenv" <- function () {
 
194
        newlist <- ls (globalenv (), all.names=TRUE)
 
195
        oldlist <- ls (.rk.watched.symbols, all.names=TRUE)
 
196
        for (old in oldlist) {          # unwatch no longer present items
 
197
                if (!(old %in% newlist)) {
 
198
                        rm (list=old, envir=.rk.watched.symbols);
 
199
                }
 
200
        }
 
201
 
 
202
        for (new in newlist) {          # watch new items
 
203
                if (!(new %in% oldlist)) {
 
204
                        .rk.watch.symbol (new)
 
205
                }
 
206
        }
 
207
}
 
208
 
 
209
".rk.get.vector.data" <- function (x) {
 
210
        ret <- list ();
 
211
        ret$data <- as.vector (unclass (x));
 
212
        ret$levels <- levels (x)
 
213
        if (is.null (ret$levels)) ret$levels <- ""
 
214
        i <- attr (x, ".rk.invalid.fields")
 
215
        ret$invalids <- as.character (c (names (i), i));
 
216
        if (length (ret$invalids) == 0) ret$invalids <- ""
 
217
        ret
 
218
}
 
219
 
 
220
".rk.get.structure" <- function (x, name, envlevel=0, namespacename=NULL, misplaced=FALSE) {
 
221
        fun <- FALSE
 
222
        cont <- FALSE
 
223
        type <- 0
 
224
 
 
225
# Do not change the order! Make sure all fields exist, even if empty
 
226
 
 
227
# 1: name should always be first
 
228
        name <- as.character (name)
 
229
 
 
230
# 2: classification
 
231
        if (is.data.frame (x)) type <- type + 1
 
232
        if (is.matrix (x)) type <- type + 2
 
233
        if (is.array (x)) type <- type + 4
 
234
        if (is.list (x)) type <- type + 8
 
235
        if (type != 0) {
 
236
                type <- type + 16
 
237
                cont <- TRUE
 
238
        } else {
 
239
                if (is.function (x)) {
 
240
                        fun <- TRUE
 
241
                        type <- 128
 
242
                } else if (is.environment (x)) {
 
243
                        type <- 256
 
244
                        cont <- TRUE
 
245
                } else {
 
246
                        type <- 32
 
247
                        if (is.factor (x)) type <- type + 32768                 # 2 << 14
 
248
                        else if (is.numeric (x)) type <- type + 16384           # 1 << 14
 
249
                        else if (is.character (x)) type <- type + 49152         # 3 << 14
 
250
                        else if (is.logical (x)) type <- type + 65536           # 4 << 14
 
251
                }
 
252
        }
 
253
        if (!is.null (attr (x, ".rk.meta"))) type = type + 4096
 
254
        if (misplaced) type <- type + 8192
 
255
        type <- as.integer (type)
 
256
 
 
257
# 3: classes
 
258
        classes <- class (x)
 
259
        if (is.null (classes)) classes = ""
 
260
 
 
261
# 4: meta info
 
262
        meta <- .rk.get.meta (x)
 
263
        if (is.null (meta)) meta <- ""
 
264
 
 
265
# 5: dimensionality
 
266
        dims <- dim(x)
 
267
        if (is.null (dims)) dims <- length (x)  # handling for objects that - according to R - do not have a dimension (such as vectors, functions, etc.)
 
268
        if (is.null (dims)) dims <- 0   # according to help ("length"), we need to play safe
 
269
        dims <- as.integer (dims)
 
270
 
 
271
# 6: Special info valid for some objects ony. This should always be last in the returned structure, as the number of fields may vary
 
272
        if (cont) {             # a container
 
273
                if (is.environment (x)) {
 
274
                        sub <- .rk.get.environment.children (x, envlevel+1, namespacename)
 
275
                } else {
 
276
                        sub <- list ()
 
277
                        nms <- names (x)
 
278
                        if (!is.null (nms)) {
 
279
                                i <- 0
 
280
                                for (child in x) {
 
281
                                        i <- i+1
 
282
                                        sub[[nms[i]]] <- .rk.get.structure (child, nms[i], envlevel)
 
283
                                }
 
284
                        }
 
285
                }
 
286
                return (invisible (list (name, type, classes, meta, dims, sub)))
 
287
        } else if (fun) {       # a function
 
288
                argnames <- as.character (names (formals (x)))
 
289
                argvalues <- as.character (lapply (formals (x), function (v) {
 
290
                                                if (is.character (v)) return (encodeString (v, quote="\""))
 
291
                                                else return (v)
 
292
                                        } ))
 
293
                return (invisible (list (name, type, classes, meta, dims, argnames, argvalues)))
 
294
        }
 
295
        return (invisible (list (name, type, classes, meta, dims)))
 
296
}
 
297
 
 
298
".rk.get.environment.children" <- function (x, envlevel=0, namespacename=NULL) {
 
299
        ret <- list ()
 
300
 
 
301
        if (envlevel < 2) {             # prevent infinite recursion
 
302
                lst <- ls (x, all.names=TRUE)
 
303
                if (is.null (namespacename)) {
 
304
                        for (childname in lst) {
 
305
                                ret[[childname]] <- .rk.get.structure (get (childname, envir=x), childname, envlevel)
 
306
                        }
 
307
                } else {
 
308
                        # before R 2.4.0, operator "::" would only work on true namespaces, not on package names (operator "::" work, if there is a namespace, and that namespace has the symbol in it)
 
309
                        # TODO remove once we depend on R >= 2.4.0
 
310
                        if (compareVersion (paste (R.version$major, R.version$minor, sep="."), "2.4.0") < 0) {
 
311
                                ns <- tryCatch (asNamespace (namespacename), error = function(e) NULL)
 
312
                                for (childname in lst) {
 
313
                                        misplaced <- FALSE
 
314
                                        if (is.null (ns) || (!exists (childname, envir=ns, inherits=FALSE))) misplaced <- TRUE
 
315
                                        ret[[childname]] <- .rk.get.structure (get (childname, envir=x), childname, envlevel, misplaced=misplaced)
 
316
                                }
 
317
                        } else {
 
318
                        # for R 2.4.0 or greater: operator "::" works if package has no namespace at all, or has a namespace with the symbol in it
 
319
                                ns <- tryCatch (asNamespace (namespacename), error = function(e) NULL)
 
320
                                for (childname in lst) {
 
321
                                        misplaced <- FALSE
 
322
                                        if ((!is.null (ns)) && (!exists (childname, envir=ns, inherits=FALSE))) misplaced <- TRUE
 
323
                                        ret[[childname]] <- .rk.get.structure (get (childname, envir=x), childname, envlevel, misplaced=misplaced)
 
324
                                }
 
325
                        }
 
326
                }
 
327
        }
 
328
 
 
329
        ret
202
330
}