SCM

SCM Repository

[tm] Annotation of /pkg/R/corpus.R
ViewVC logotype

Annotation of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 67 - (view) (download)
Original Path: trunk/R/textmin/R/textdoccol.R

1 : feinerer 17 # Author: Ingo Feinerer
2 :    
3 : feinerer 65 # The "..." are additional arguments for the function_generator parser
4 : feinerer 63 setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))
5 : feinerer 49 setMethod("TextDocCol",
6 : feinerer 63 signature(object = "Source"),
7 : feinerer 67 function(object, parser = plaintext_parser, ...) {
8 : feinerer 63 if (inherits(parser, "function_generator"))
9 :     parser <- parser(...)
10 :    
11 :     tdl <- list()
12 :     counter <- 1
13 :     while (!eoi(object)) {
14 : feinerer 66 object <- step_next(object)
15 :     elem <- get_elem(object)
16 : feinerer 63 # If there is no Load on Demand support
17 :     # we need to load the corpus into memory at startup
18 :     if (object@LoDSupport)
19 :     load <- object@Load
20 :     else
21 :     load <- TRUE
22 :     tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23 :     counter <- counter + 1
24 :     }
25 :    
26 : feinerer 60 return(new("TextDocCol", .Data = tdl))
27 : feinerer 21 })
28 :    
29 : feinerer 63 setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30 :     setMethod("DirSource",
31 :     signature(directory = "character"),
32 :     function(directory, load = FALSE) {
33 :     new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),
34 :     Position = 0, Load = load)
35 :     })
36 : feinerer 60
37 : feinerer 67 setGeneric("CSVSource", function(object) standardGeneric("CSVSource"))
38 : feinerer 63 setMethod("CSVSource",
39 : feinerer 65 signature(object = "character"),
40 : feinerer 67 function(object) {
41 :     object <- substitute(file(object))
42 :     con <- eval(object)
43 : feinerer 65 content <- scan(con, what = "character")
44 :     close(con)
45 :     new("CSVSource", LoDSupport = FALSE, URI = object,
46 :     Content = content, Position = 0)
47 : feinerer 63 })
48 : feinerer 67 setMethod("CSVSource",
49 :     signature(object = "ANY"),
50 :     function(object) {
51 :     object <- substitute(object)
52 :     con <- eval(object)
53 :     content <- scan(con, what = "character")
54 :     close(con)
55 :     new("CSVSource", LoDSupport = FALSE, URI = object,
56 :     Content = content, Position = 0)
57 :     })
58 : feinerer 60
59 : feinerer 67 setGeneric("ReutersSource", function(object) standardGeneric("ReutersSource"))
60 : feinerer 65 setMethod("ReutersSource",
61 :     signature(object = "character"),
62 : feinerer 67 function(object) {
63 :     object <- substitute(file(object))
64 :     con <- eval(object)
65 : feinerer 65 corpus <- paste(readLines(con), "\n", collapse = "")
66 :     close(con)
67 :     tree <- xmlTreeParse(corpus, asText = TRUE)
68 : feinerer 63 content <- xmlRoot(tree)$children
69 : feinerer 65
70 :     new("ReutersSource", LoDSupport = FALSE, URI = object,
71 : feinerer 63 Content = content, Position = 0)
72 :     })
73 : feinerer 67 setMethod("ReutersSource",
74 :     signature(object = "ANY"),
75 :     function(object) {
76 :     object <- substitute(object)
77 :     con <- eval(object)
78 :     corpus <- paste(readLines(con), "\n", collapse = "")
79 :     close(con)
80 :     tree <- xmlTreeParse(corpus, asText = TRUE)
81 :     content <- xmlRoot(tree)$children
82 : feinerer 63
83 : feinerer 67 new("ReutersSource", LoDSupport = FALSE, URI = object,
84 :     Content = content, Position = 0)
85 :     })
86 :    
87 : feinerer 66 setGeneric("step_next", function(object) standardGeneric("step_next"))
88 :     setMethod("step_next",
89 : feinerer 63 signature(object = "DirSource"),
90 :     function(object) {
91 :     object@Position <- object@Position + 1
92 :     object
93 :     })
94 : feinerer 66 setMethod("step_next",
95 : feinerer 63 signature(object = "CSVSource"),
96 :     function(object) {
97 :     object@Position <- object@Position + 1
98 :     object
99 :     })
100 : feinerer 66 setMethod("step_next",
101 : feinerer 65 signature(object = "ReutersSource"),
102 : feinerer 63 function(object) {
103 :     object@Position <- object@Position + 1
104 :     object
105 :     })
106 :    
107 : feinerer 66 setGeneric("get_elem", function(object) standardGeneric("get_elem"))
108 :     setMethod("get_elem",
109 : feinerer 63 signature(object = "DirSource"),
110 :     function(object) {
111 : feinerer 67 filename <- object@FileList[object@Position]
112 : feinerer 63 list(content = readLines(object@FileList[object@Position]),
113 : feinerer 67 uri = substitute(file(filename)))
114 : feinerer 63 })
115 : feinerer 66 setMethod("get_elem",
116 : feinerer 63 signature(object = "CSVSource"),
117 :     function(object) {
118 :     list(content = object@Content[object@Position],
119 : feinerer 65 uri = object@URI)
120 : feinerer 63 })
121 : feinerer 66 setMethod("get_elem",
122 : feinerer 65 signature(object = "ReutersSource"),
123 : feinerer 63 function(object) {
124 : feinerer 65 # Construct a character representation from the XMLNode
125 :     con <- textConnection("virtual.file", "w")
126 :     saveXML(object@Content[[object@Position]], con)
127 :     close(con)
128 :    
129 :     list(content = virtual.file, uri = object@URI)
130 : feinerer 63 })
131 :    
132 :     setGeneric("eoi", function(object) standardGeneric("eoi"))
133 :     setMethod("eoi",
134 :     signature(object = "DirSource"),
135 :     function(object) {
136 :     if (length(object@FileList) <= object@Position)
137 :     return(TRUE)
138 :     else
139 :     return(FALSE)
140 :     })
141 :     setMethod("eoi",
142 :     signature(object = "CSVSource"),
143 :     function(object) {
144 :     if (length(object@Content) <= object@Position)
145 :     return(TRUE)
146 :     else
147 :     return(FALSE)
148 :     })
149 :     setMethod("eoi",
150 : feinerer 65 signature(object = "ReutersSource"),
151 : feinerer 63 function(object) {
152 :     if (length(object@Content) <= object@Position)
153 :     return(TRUE)
154 :     else
155 :     return(FALSE)
156 :     })
157 :    
158 :     plaintext_parser <- function(...) {
159 :     function(elem, lodsupport, load, id) {
160 :     if (!lodsupport || (lodsupport && load)) {
161 : feinerer 65 doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,
162 : feinerer 63 Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
163 :     }
164 :     else {
165 : feinerer 65 doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,
166 : feinerer 63 Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
167 :     }
168 :    
169 :     return(doc)
170 : feinerer 60 }
171 :     }
172 : feinerer 63 class(plaintext_parser) <- "function_generator"
173 : feinerer 60
174 : feinerer 66 reut21578xml_parser <- function(...) {
175 : feinerer 63 function(elem, lodsupport, load, id) {
176 : feinerer 65 corpus <- paste(elem$content, "\n", collapse = "")
177 :     tree <- xmlTreeParse(corpus, asText = TRUE)
178 : feinerer 63 node <- xmlRoot(tree)
179 : feinerer 60
180 : feinerer 65 # Mask as list to bypass S4 checks
181 :     class(tree) <- "list"
182 :    
183 : feinerer 63 # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
184 :     if (!is.null(node[["TEXT"]][["AUTHOR"]]))
185 :     author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
186 :     else
187 :     author <- ""
188 : feinerer 60
189 : feinerer 63 datetimestamp <- xmlValue(node[["DATE"]])
190 :     description <- ""
191 :     id <- xmlAttrs(node)[["NEWID"]]
192 : feinerer 40
193 : feinerer 63 # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
194 :     if (!is.null(node[["TEXT"]][["TITLE"]]))
195 :     heading <- xmlValue(node[["TEXT"]][["TITLE"]])
196 :     else
197 :     heading <- ""
198 : feinerer 41
199 : feinerer 63 topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
200 : feinerer 41
201 : feinerer 63 if (!lodsupport || (lodsupport && load)) {
202 : feinerer 65 doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,
203 : feinerer 63 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
204 :     Heading = heading, LocalMetaData = list(Topics = topics))
205 :     } else {
206 : feinerer 65 doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,
207 : feinerer 63 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
208 :     Heading = heading, LocalMetaData = list(Topics = topics))
209 :     }
210 : feinerer 40
211 : feinerer 63 return(doc)
212 : feinerer 60 }
213 :     }
214 : feinerer 66 class(reut21578xml_parser) <- "function_generator"
215 : feinerer 41
216 : feinerer 63 rcv1_parser <- function(...) {
217 :     function(elem, lodsupport, load, id) {
218 : feinerer 65 corpus <- paste(elem$content, "\n", collapse = "")
219 :     tree <- xmlTreeParse(corpus, asText = TRUE)
220 : feinerer 63 node <- xmlRoot(tree)
221 : feinerer 41
222 : feinerer 65 # Mask as list to bypass S4 checks
223 :     class(tree) <- "list"
224 :    
225 : feinerer 63 datetimestamp <- xmlAttrs(node)[["date"]]
226 :     id <- xmlAttrs(node)[["itemid"]]
227 :     heading <- xmlValue(node[["title"]])
228 : feinerer 40
229 : feinerer 63 if (!lodsupport || (lodsupport && load)) {
230 : feinerer 65 doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",
231 : feinerer 63 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
232 :     Heading = heading)
233 :     } else {
234 : feinerer 65 doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",
235 : feinerer 63 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
236 :     Heading = heading)
237 :     }
238 : feinerer 40
239 : feinerer 63 return(doc)
240 : feinerer 60 }
241 : feinerer 40 }
242 : feinerer 63 class(rcv1_parser) <- "function_generator"
243 : feinerer 40
244 : feinerer 66 newsgroup_parser <- function(...) {
245 : feinerer 63 function(elem, lodsupport, load, id) {
246 : feinerer 65 mail <- elem$content
247 : feinerer 63 author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
248 :     datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
249 :     origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
250 :     heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
251 :     newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
252 : feinerer 60
253 : feinerer 63 if (!lodsupport || (lodsupport && load)) {
254 : feinerer 65 # The header is separated from the body by a blank line.
255 :     # Reference: \url{http://en.wikipedia.org/wiki/E-mail#Internet_e-mail_format}
256 :     for (index in seq(along = mail)) {
257 :     if (mail[index] == "")
258 :     break
259 :     }
260 : feinerer 63 content <- mail[(index + 1):length(mail)]
261 : feinerer 60
262 : feinerer 65 doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,
263 : feinerer 63 Author = author, DateTimeStamp = datetimestamp,
264 : feinerer 65 Description = "", ID = id, Origin = origin,
265 : feinerer 63 Heading = heading, Newsgroup = newsgroup)
266 :     } else {
267 : feinerer 65 doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
268 :     Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
269 : feinerer 63 }
270 :    
271 :     return(doc)
272 : feinerer 60 }
273 :     }
274 : feinerer 66 class(newsgroup_parser) <- "function_generator"
275 : feinerer 60
276 : feinerer 23 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
277 : feinerer 65 rcv1_to_plain <- function(node, ...) {
278 : feinerer 42 datetimestamp <- xmlAttrs(node)[["date"]]
279 : feinerer 60 id <- xmlAttrs(node)[["itemid"]]
280 : feinerer 36 origin <- "Reuters Corpus Volume 1 XML"
281 : feinerer 18 corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
282 :     heading <- xmlValue(node[["title"]])
283 : feinerer 17
284 : feinerer 65 new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
285 : feinerer 60 Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
286 : feinerer 19 }
287 : feinerer 23
288 :     # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
289 : feinerer 66 reut21578xml_to_plain <- function(node, ...) {
290 : feinerer 36 # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
291 :     if (!is.null(node[["TEXT"]][["AUTHOR"]]))
292 :     author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
293 :     else
294 :     author <- ""
295 :    
296 : feinerer 42 datetimestamp <- xmlValue(node[["DATE"]])
297 : feinerer 36 description <- ""
298 : feinerer 60 id <- xmlAttrs(node)[["NEWID"]]
299 : feinerer 23
300 : feinerer 36 origin <- "Reuters-21578 XML"
301 : feinerer 23
302 :     # The <BODY></BODY> tag is unfortunately NOT obligatory!
303 :     if (!is.null(node[["TEXT"]][["BODY"]]))
304 :     corpus <- xmlValue(node[["TEXT"]][["BODY"]])
305 :     else
306 :     corpus <- ""
307 :    
308 :     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
309 :     if (!is.null(node[["TEXT"]][["TITLE"]]))
310 :     heading <- xmlValue(node[["TEXT"]][["TITLE"]])
311 :     else
312 :     heading <- ""
313 :    
314 : feinerer 49 topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
315 :    
316 : feinerer 65 new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
317 : feinerer 49 Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
318 : feinerer 23 }
319 : feinerer 49
320 : feinerer 66 setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))
321 :     setMethod("load_doc",
322 : feinerer 62 signature(object = "PlainTextDocument"),
323 : feinerer 65 function(object, ...) {
324 : feinerer 61 if (!Cached(object)) {
325 : feinerer 67 con <- eval(URI(object))
326 : feinerer 65 corpus <- readLines(con)
327 :     close(con)
328 : feinerer 56 Corpus(object) <- corpus
329 : feinerer 60 Cached(object) <- TRUE
330 : feinerer 56 return(object)
331 :     } else {
332 :     return(object)
333 :     }
334 :     })
335 : feinerer 66 setMethod("load_doc",
336 : feinerer 62 signature(object = "XMLTextDocument"),
337 : feinerer 65 function(object, ...) {
338 : feinerer 61 if (!Cached(object)) {
339 : feinerer 67 con <- eval(URI(object))
340 : feinerer 65 corpus <- paste(readLines(con), "\n", collapse = "")
341 :     close(con)
342 :     doc <- xmlTreeParse(corpus, asText = TRUE)
343 : feinerer 49 class(doc) <- "list"
344 : feinerer 56 Corpus(object) <- doc
345 : feinerer 60 Cached(object) <- TRUE
346 : feinerer 49 return(object)
347 :     } else {
348 :     return(object)
349 :     }
350 :     })
351 : feinerer 66 setMethod("load_doc",
352 : feinerer 62 signature(object = "NewsgroupDocument"),
353 : feinerer 65 function(object, ...) {
354 : feinerer 61 if (!Cached(object)) {
355 : feinerer 67 con <- eval(URI(object))
356 : feinerer 65 mail <- readLines(con)
357 :     close(con)
358 : feinerer 60 Cached(object) <- TRUE
359 : feinerer 65 for (index in seq(along = mail)) {
360 :     if (mail[index] == "")
361 :     break
362 :     }
363 : feinerer 56 Corpus(object) <- mail[(index + 1):length(mail)]
364 :     return(object)
365 :     } else {
366 :     return(object)
367 :     }
368 :     })
369 : feinerer 49
370 : feinerer 54 setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
371 :     setMethod("tm_transform",
372 : feinerer 62 signature(object = "TextDocCol", FUN = "function"),
373 : feinerer 49 function(object, FUN, ...) {
374 : feinerer 56 result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
375 :     result@GlobalMetaData <- GlobalMetaData(object)
376 :     return(result)
377 : feinerer 49 })
378 :    
379 : feinerer 66 setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))
380 :     setMethod("as.plaintext_doc",
381 : feinerer 62 signature(object = "PlainTextDocument"),
382 : feinerer 49 function(object, FUN, ...) {
383 :     return(object)
384 :     })
385 : feinerer 66 setMethod("as.plaintext_doc",
386 : feinerer 62 signature(object = "XMLTextDocument", FUN = "function"),
387 : feinerer 49 function(object, FUN, ...) {
388 : feinerer 61 if (!Cached(object))
389 : feinerer 66 object <- load_doc(object)
390 : feinerer 49
391 : feinerer 56 corpus <- Corpus(object)
392 : feinerer 49
393 :     # As XMLDocument is no native S4 class, restore valid information
394 :     class(corpus) <- "XMLDocument"
395 :     names(corpus) <- c("doc","dtd")
396 :    
397 : feinerer 61 return(FUN(xmlRoot(corpus), ...))
398 : feinerer 49 })
399 :    
400 : feinerer 67 setGeneric("tm_tolower", function(object, ...) standardGeneric("tm_tolower"))
401 :     setMethod("tm_tolower",
402 :     signature(object = "PlainTextDocument"),
403 :     function(object, ...) {
404 :     if (!Cached(object))
405 :     object <- load_doc(object)
406 :    
407 :     Corpus(object) <- tolower(object)
408 :     return(object)
409 :     })
410 :    
411 :     setGeneric("strip_whitespace", function(object, ...) standardGeneric("strip_whitespace"))
412 :     setMethod("strip_whitespace",
413 :     signature(object = "PlainTextDocument"),
414 :     function(object, ...) {
415 :     if (!Cached(object))
416 :     object <- load_doc(object)
417 :    
418 :     Corpus(object) <- gsub("[[:space:]]+", " ", object)
419 :     return(object)
420 :     })
421 :    
422 : feinerer 66 setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))
423 :     setMethod("stem_doc",
424 : feinerer 62 signature(object = "PlainTextDocument"),
425 : feinerer 61 function(object, ...) {
426 :     if (!Cached(object))
427 : feinerer 66 object <- load_doc(object)
428 : feinerer 56
429 : feinerer 49 require(Rstem)
430 :     splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
431 : feinerer 67 stemmedCorpus <- wordStem(splittedCorpus)
432 : feinerer 56 Corpus(object) <- paste(stemmedCorpus, collapse = " ")
433 :     return(object)
434 : feinerer 49 })
435 :    
436 : feinerer 66 setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))
437 :     setMethod("remove_words",
438 : feinerer 60 signature(object = "PlainTextDocument", stopwords = "character"),
439 : feinerer 61 function(object, stopwords, ...) {
440 :     if (!Cached(object))
441 : feinerer 66 object <- load_doc(object)
442 : feinerer 56
443 : feinerer 49 require(Rstem)
444 :     splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
445 :     noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
446 : feinerer 56 Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
447 :     return(object)
448 : feinerer 49 })
449 :    
450 : feinerer 64 setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
451 : feinerer 54 setMethod("tm_filter",
452 : feinerer 61 signature(object = "TextDocCol"),
453 : feinerer 64 function(object, ..., FUN = s_filter) {
454 : feinerer 61 object[tm_index(object, ..., FUN)]
455 :     })
456 :    
457 : feinerer 63 setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
458 : feinerer 61 setMethod("tm_index",
459 :     signature(object = "TextDocCol"),
460 : feinerer 64 function(object, ..., FUN = s_filter) {
461 : feinerer 57 sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
462 : feinerer 49 })
463 :    
464 : feinerer 63 s_filter <- function(object, s, ..., GlobalMetaData) {
465 : feinerer 61 b <- TRUE
466 :     for (tag in names(s)) {
467 :     if (tag %in% names(LocalMetaData(object))) {
468 :     b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
469 :     } else if (tag %in% names(GlobalMetaData)){
470 :     b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
471 :     } else {
472 :     b <- b && any(grep(s[[tag]], eval(call(tag, object))))
473 :     }
474 :     }
475 :     return(b)
476 :     }
477 :    
478 : feinerer 63 setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
479 :     setMethod("fulltext_search_filter",
480 : feinerer 61 signature(object = "PlainTextDocument", pattern = "character"),
481 :     function(object, pattern, ...) {
482 :     if (!Cached(object))
483 : feinerer 66 object <- load_doc(object)
484 : feinerer 61
485 :     return(any(grep(pattern, Corpus(object))))
486 :     })
487 :    
488 : feinerer 66 setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
489 :     setMethod("attach_data",
490 : feinerer 62 signature(object = "TextDocCol", data = "TextDocument"),
491 : feinerer 52 function(object, data) {
492 :     data <- as(list(data), "TextDocCol")
493 :     object@.Data <- as(c(object@.Data, data), "TextDocCol")
494 :     return(object)
495 :     })
496 :    
497 : feinerer 66 setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
498 :     setMethod("attach_metadata",
499 : feinerer 62 signature(object = "TextDocCol"),
500 : feinerer 52 function(object, name, metadata) {
501 : feinerer 56 object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
502 :     names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
503 : feinerer 52 return(object)
504 :     })
505 : feinerer 53
506 : feinerer 66 setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
507 :     setMethod("set_subscriptable",
508 : feinerer 62 signature(object = "TextDocCol"),
509 : feinerer 53 function(object, name) {
510 : feinerer 56 if (!is.character(GlobalMetaData(object)$subscriptable))
511 : feinerer 66 object <- attach_metadata(object, "subscriptable", name)
512 : feinerer 53 else
513 : feinerer 56 object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
514 : feinerer 53 return(object)
515 :     })
516 :    
517 :     setMethod("[",
518 :     signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
519 :     function(x, i, j, ... , drop) {
520 :     if(missing(i))
521 :     return(x)
522 :    
523 :     object <- x
524 :     object@.Data <- x@.Data[i, ..., drop = FALSE]
525 : feinerer 56 for (m in names(GlobalMetaData(object))) {
526 :     if (m %in% GlobalMetaData(object)$subscriptable) {
527 :     object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
528 : feinerer 53 }
529 :     }
530 :     return(object)
531 :     })
532 :    
533 : feinerer 63 setMethod("[<-",
534 :     signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
535 :     function(x, i, j, ... , value) {
536 :     object <- x
537 :     object@.Data[i, ...] <- value
538 :     return(object)
539 :     })
540 :    
541 :     setMethod("[[",
542 :     signature(x = "TextDocCol", i = "ANY", j = "ANY"),
543 :     function(x, i, j, ...) {
544 :     return(x@.Data[[i, ...]])
545 :     })
546 :    
547 :     setMethod("[[<-",
548 :     signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
549 :     function(x, i, j, ..., value) {
550 :     object <- x
551 :     object@.Data[[i, ...]] <- value
552 :     return(object)
553 :     })
554 :    
555 : feinerer 53 setMethod("c",
556 :     signature(x = "TextDocCol"),
557 :     function(x, ..., recursive = TRUE){
558 :     args <- list(...)
559 :     if(length(args) == 0)
560 :     return(x)
561 :     return(as(c(as(x, "list"), ...), "TextDocCol"))
562 :     })
563 : feinerer 65 setMethod("c",
564 :     signature(x = "TextDocument"),
565 :     function(x, ..., recursive = TRUE){
566 :     args <- list(...)
567 :     if(length(args) == 0)
568 :     return(x)
569 :     return(new("TextDocCol", .Data = list(x, ...)))
570 :     })
571 : feinerer 54
572 :     setMethod("length",
573 :     signature(x = "TextDocCol"),
574 :     function(x){
575 :     return(length(as(x, "list")))
576 :     })
577 :    
578 :     setMethod("show",
579 :     signature(object = "TextDocCol"),
580 :     function(object){
581 :     cat("A text document collection with", length(object), "text document")
582 :     if (length(object) == 1)
583 :     cat("\n")
584 :     else
585 :     cat("s\n")
586 :     })
587 :    
588 :     setMethod("summary",
589 :     signature(object = "TextDocCol"),
590 :     function(object){
591 :     show(object)
592 :     if (length(GlobalMetaData(object)) > 0) {
593 :     cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
594 :     if (length(GlobalMetaData(object)) == 1)
595 :     cat(".\n")
596 :     else
597 :     cat("s.\n")
598 :     cat("Available tags are:\n")
599 :     cat(names(GlobalMetaData(object)), "\n")
600 :     }
601 :     })
602 : feinerer 55
603 :     setGeneric("inspect", function(object) standardGeneric("inspect"))
604 :     setMethod("inspect",
605 : feinerer 65 signature("TextDocCol"),
606 : feinerer 55 function(object) {
607 :     summary(object)
608 :     cat("\n")
609 :     show(as(object, "list"))
610 :     })
611 : feinerer 65
612 :     # No metadata is checked
613 :     setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
614 :     setMethod("%IN%",
615 :     signature(x = "TextDocument", y = "TextDocCol"),
616 :     function(x, y) {
617 :     x %in% y
618 :     })

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge