SCM

SCM Repository

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

Diff of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 60, Sun Oct 22 17:57:47 2006 UTC revision 66, Tue Oct 31 22:03:33 2006 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  setGeneric("TextDocCol", function(object, parser = plaintext.parser, lod = FALSE) standardGeneric("TextDocCol"))  # The "..." are additional arguments for the function_generator parser
4    setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))
5  setMethod("TextDocCol",  setMethod("TextDocCol",
6            signature(object = "character"),            signature(object = "Source"),
7            function(object, parser = plaintext.parser, lod = FALSE) {            function(object, parser = plaintext_parser) {
8                filelist <- dir(object, full.names = TRUE)                if (inherits(parser, "function_generator"))
9                tdl <- lapply(filelist, parser, lod)                    parser <- parser(...)
10    
11                  tdl <- list()
12                  counter <- 1
13                  while (!eoi(object)) {
14                      object <- step_next(object)
15                      elem <- get_elem(object)
16                      # 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                return(new("TextDocCol", .Data = tdl))                return(new("TextDocCol", .Data = tdl))
27            })            })
28    
29  plaintext.parser <- function(file, lod) {  setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30      id <- file  setMethod("DirSource",
31      origin <- dirname(file)            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    
37    setGeneric("CSVSource", function(object, isConCall = FALSE) standardGeneric("CSVSource"))
38    setMethod("CSVSource",
39              signature(object = "character"),
40              function(object, isConCall = FALSE) {
41                  if (!isConCall)
42                      object <- paste('file("', object, '")', sep = "")
43                  con <- eval(parse(text = object))
44                  content <- scan(con, what = "character")
45                  close(con)
46                  new("CSVSource", LoDSupport = FALSE, URI = object,
47                      Content = content, Position = 0)
48              })
49    
50    setGeneric("ReutersSource", function(object, isConCall = FALSE) standardGeneric("ReutersSource"))
51    setMethod("ReutersSource",
52              signature(object = "character"),
53              function(object, isConCall = FALSE) {
54                  if (!isConCall)
55                     object <- paste('file("', object, '")', sep = "")
56                  con <- eval(parse(text = object))
57                  corpus <- paste(readLines(con), "\n", collapse = "")
58                  close(con)
59                  tree <- xmlTreeParse(corpus, asText = TRUE)
60                  content <- xmlRoot(tree)$children
61    
62                  new("ReutersSource", LoDSupport = FALSE, URI = object,
63                      Content = content, Position = 0)
64              })
65    
66    setGeneric("step_next", function(object) standardGeneric("step_next"))
67    setMethod("step_next",
68              signature(object = "DirSource"),
69              function(object) {
70                  object@Position <- object@Position + 1
71                  object
72              })
73    setMethod("step_next",
74              signature(object = "CSVSource"),
75              function(object) {
76                  object@Position <- object@Position + 1
77                  object
78              })
79    setMethod("step_next",
80              signature(object = "ReutersSource"),
81              function(object) {
82                  object@Position <- object@Position + 1
83                  object
84              })
85    
86    setGeneric("get_elem", function(object) standardGeneric("get_elem"))
87    setMethod("get_elem",
88              signature(object = "DirSource"),
89              function(object) {
90                  list(content = readLines(object@FileList[object@Position]),
91                       uri = paste('file("', object@FileList[object@Position], '")', sep = ""))
92              })
93    setMethod("get_elem",
94              signature(object = "CSVSource"),
95              function(object) {
96                  list(content = object@Content[object@Position],
97                       uri = object@URI)
98              })
99    setMethod("get_elem",
100              signature(object = "ReutersSource"),
101              function(object) {
102                  # Construct a character representation from the XMLNode
103                  con <- textConnection("virtual.file", "w")
104                  saveXML(object@Content[[object@Position]], con)
105                  close(con)
106    
107      doc <- new("PlainTextDocument", FileName = file, Cached = FALSE, Author = "Unknown",                list(content = virtual.file, uri = object@URI)
108                 DateTimeStamp = date(), Description = "", ID = id, Origin = origin, Heading = "")            })
109    
110      if (lod) {  setGeneric("eoi", function(object) standardGeneric("eoi"))
111          doc <- loadFileIntoMem(doc)  setMethod("eoi",
112              signature(object = "DirSource"),
113              function(object) {
114                  if (length(object@FileList) <= object@Position)
115                      return(TRUE)
116                  else
117                      return(FALSE)
118              })
119    setMethod("eoi",
120              signature(object = "CSVSource"),
121              function(object) {
122                  if (length(object@Content) <= object@Position)
123                      return(TRUE)
124                  else
125                      return(FALSE)
126              })
127    setMethod("eoi",
128              signature(object = "ReutersSource"),
129              function(object) {
130                  if (length(object@Content) <= object@Position)
131                      return(TRUE)
132                  else
133                      return(FALSE)
134              })
135    
136    plaintext_parser <- function(...) {
137        function(elem, lodsupport, load, id) {
138            if (!lodsupport || (lodsupport && load)) {
139                doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,
140                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
141            }
142            else {
143                doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,
144                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
145      }      }
146    
147      return(doc)      return(doc)
148  }  }
149    }
150    class(plaintext_parser) <- "function_generator"
151    
152  reuter21578xml.parser <- function(file, lod) {  reut21578xml_parser <- function(...) {
153      tree <- xmlTreeParse(file)      function(elem, lodsupport, load, id) {
154            corpus <- paste(elem$content, "\n", collapse = "")
155            tree <- xmlTreeParse(corpus, asText = TRUE)
156      node <- xmlRoot(tree)      node <- xmlRoot(tree)
157    
158            # Mask as list to bypass S4 checks
159            class(tree) <- "list"
160    
161      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
162      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
163          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
# Line 45  Line 176 
176    
177      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
178    
179      doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = author,          if (!lodsupport || (lodsupport && load)) {
180                doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,
181                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
182                           Heading = heading, LocalMetaData = list(Topics = topics))
183            } else {
184                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,
185                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
186                 Heading = heading, LocalMetaData = list(Topics = topics))                 Heading = heading, LocalMetaData = list(Topics = topics))
   
     if (lod) {  
         doc <- loadFileIntoMem(doc)  
187      }      }
188    
189      return(doc)      return(doc)
190  }  }
191    }
192    class(reut21578xml_parser) <- "function_generator"
193    
194  rcv1.parser <- function(file, lod) {  rcv1_parser <- function(...) {
195      tree <- xmlTreeParse(file)      function(elem, lodsupport, load, id) {
196            corpus <- paste(elem$content, "\n", collapse = "")
197            tree <- xmlTreeParse(corpus, asText = TRUE)
198      node <- xmlRoot(tree)      node <- xmlRoot(tree)
199    
200            # Mask as list to bypass S4 checks
201            class(tree) <- "list"
202    
203      datetimestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
204      id <- xmlAttrs(node)[["itemid"]]      id <- xmlAttrs(node)[["itemid"]]
205      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
206    
207      doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = "",          if (!lodsupport || (lodsupport && load)) {
208                doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",
209                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
210                           Heading = heading)
211            } else {
212                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",
213                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
214                 Heading = heading)                 Heading = heading)
   
     if (lod) {  
         doc <- loadFileIntoMem(doc)  
215      }      }
216    
217      return(doc)      return(doc)
218  }  }
219    }
220    class(rcv1_parser) <- "function_generator"
221    
222  uci.kdd.newsgroup.parser <-  function(file, lod) {  newsgroup_parser <- function(...) {
223      mail <- readLines(file)      function(elem, lodsupport, load, id) {
224            mail <- elem$content
225      author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))      author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
226      datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))      datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
227      origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))      origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
228      heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))      heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
229      newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))      newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
230    
231      new("NewsgroupDocument", FileName = file, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,          if (!lodsupport || (lodsupport && load)) {
232          Description = "", ID = file, Origin = origin, Heading = heading, Newsgroup = newsgroup)              # The header is separated from the body by a blank line.
233                # Reference: \url{http://en.wikipedia.org/wiki/E-mail#Internet_e-mail_format}
234      if (lod) {              for (index in seq(along = mail)) {
235          doc <- loadFileIntoMem(doc)                  if (mail[index] == "")
236                        break
237                }
238                content <- mail[(index + 1):length(mail)]
239    
240                doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,
241                           Author = author, DateTimeStamp = datetimestamp,
242                           Description = "", ID = id, Origin = origin,
243                           Heading = heading, Newsgroup = newsgroup)
244            } else {
245                doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
246                           Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
247      }      }
248    
249      return(doc)      return(doc)
250  }  }
251    }
252    class(newsgroup_parser) <- "function_generator"
253    
254  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
255  # TODO: Check if it works with example  rcv1_to_plain <- function(node, ...) {
 rcv1.to.plain <- function(node) {  
256      datetimestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
257      id <- xmlAttrs(node)[["itemid"]]      id <- xmlAttrs(node)[["itemid"]]
258      origin <- "Reuters Corpus Volume 1 XML"      origin <- "Reuters Corpus Volume 1 XML"
259      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
260      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
261    
262      new("PlainTextDocument", .Data = corpus, Author = "", DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
263          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
264  }  }
265    
266  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
267  # TODO: Ensure it works  reut21578xml_to_plain <- function(node, ...) {
 reuters21578xml.to.plain <- function(node) {  
268      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
269      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
270          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
# Line 135  Line 291 
291    
292      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
293    
294      new("PlainTextDocument", .Data = corpus, Cached = TRUE, Author = author, DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
295          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
296  }  }
297    
298  setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))  setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))
299  setMethod("loadFileIntoMem",  setMethod("load_doc",
300            c("PlainTextDocument"),            signature(object = "PlainTextDocument"),
301            function(object, ...) {            function(object, ...) {
302                if (Cached(object) == FALSE) {                if (!Cached(object)) {
303                    corpus <- readLines(FileName(object))                    con <- eval(parse(text = URI(object)))
304                      corpus <- readLines(con)
305                      close(con)
306                    Corpus(object) <- corpus                    Corpus(object) <- corpus
307                    Cached(object) <- TRUE                    Cached(object) <- TRUE
308                    return(object)                    return(object)
# Line 152  Line 310 
310                    return(object)                    return(object)
311                }                }
312            })            })
313  setMethod("loadFileIntoMem",  setMethod("load_doc",
314            c("XMLTextDocument"),            signature(object =  "XMLTextDocument"),
315            function(object, ...) {            function(object, ...) {
316                if (Cached(object) == FALSE) {                if (!Cached(object)) {
317                    file <- FileName(object)                    con <- eval(parse(text = URI(object)))
318                    doc <- xmlTreeParse(file)                    corpus <- paste(readLines(con), "\n", collapse = "")
319                      close(con)
320                      doc <- xmlTreeParse(corpus, asText = TRUE)
321                    class(doc) <- "list"                    class(doc) <- "list"
322                    Corpus(object) <- doc                    Corpus(object) <- doc
323                    Cached(object) <- TRUE                    Cached(object) <- TRUE
# Line 166  Line 326 
326                    return(object)                    return(object)
327                }                }
328            })            })
329  setMethod("loadFileIntoMem",  setMethod("load_doc",
330            c("NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
331            function(object, ...) {            function(object, ...) {
332                if (Cached(object) == FALSE) {                if (!Cached(object)) {
333                    mail <- readLines(FileName(object))                    con <- eval(parse(text = URI(object)))
334                      mail <- readLines(con)
335                      close(con)
336                    Cached(object) <- TRUE                    Cached(object) <- TRUE
337                    index <- grep("^Lines:", mail)                    for (index in seq(along = mail)) {
338                          if (mail[index] == "")
339                              break
340                      }
341                    Corpus(object) <- mail[(index + 1):length(mail)]                    Corpus(object) <- mail[(index + 1):length(mail)]
342                    return(object)                    return(object)
343                } else {                } else {
# Line 182  Line 347 
347    
348  setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))  setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
349  setMethod("tm_transform",  setMethod("tm_transform",
350            c("TextDocCol"),            signature(object = "TextDocCol", FUN = "function"),
351            function(object, FUN, ...) {            function(object, FUN, ...) {
352                result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")                result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
353                result@GlobalMetaData <- GlobalMetaData(object)                result@GlobalMetaData <- GlobalMetaData(object)
354                return(result)                return(result)
355            })            })
356    
357  setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))  setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))
358  setMethod("toPlainTextDocument",  setMethod("as.plaintext_doc",
359            c("PlainTextDocument"),            signature(object = "PlainTextDocument"),
360            function(object, FUN, ...) {            function(object, FUN, ...) {
361                return(object)                return(object)
362            })            })
363  setMethod("toPlainTextDocument",  setMethod("as.plaintext_doc",
364            c("XMLTextDocument"),            signature(object = "XMLTextDocument", FUN = "function"),
365            function(object, FUN, ...) {            function(object, FUN, ...) {
366                if (Cached(object) == FALSE)                if (!Cached(object))
367                    object <- loadFileIntoMem(object)                    object <- load_doc(object)
368    
369                corpus <- Corpus(object)                corpus <- Corpus(object)
370    
# Line 207  Line 372 
372                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
373                names(corpus) <- c("doc","dtd")                names(corpus) <- c("doc","dtd")
374    
375                return(FUN(xmlRoot(corpus), ...)))                return(FUN(xmlRoot(corpus), ...))
376            })            })
377    
378  setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))  setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))
379  setMethod("stemTextDocument",  setMethod("stem_doc",
380            c("PlainTextDocument"),            signature(object = "PlainTextDocument"),
381            function(object) {            function(object, ...) {
382                if (Cached(object) == FALSE)                if (!Cached(object))
383                    object <- loadFileIntoMem(object)                    object <- load_doc(object)
384    
385                require(Rstem)                require(Rstem)
386                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
# Line 224  Line 389 
389                return(object)                return(object)
390            })            })
391    
392  setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))  setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))
393  setMethod("removeStopWords",  setMethod("remove_words",
394            signature(object = "PlainTextDocument", stopwords = "character"),            signature(object = "PlainTextDocument", stopwords = "character"),
395            function(object, stopwords) {            function(object, stopwords, ...) {
396                if (Cached(object) == FALSE)                if (!Cached(object))
397                    object <- loadFileIntoMem(object)                    object <- load_doc(object)
398    
399                require(Rstem)                require(Rstem)
400                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
# Line 238  Line 403 
403                return(object)                return(object)
404            })            })
405    
406  setGeneric("tm_filter", function(object, FUN, ...) standardGeneric("tm_filter"))  setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
407  setMethod("tm_filter",  setMethod("tm_filter",
408            c("TextDocCol"),            signature(object = "TextDocCol"),
409            function(object, FUN, ...) {            function(object, ..., FUN = s_filter) {
410                  object[tm_index(object, ..., FUN)]
411              })
412    
413    setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
414    setMethod("tm_index",
415              signature(object = "TextDocCol"),
416              function(object, ..., FUN = s_filter) {
417                sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))                sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
418            })            })
419    
420  setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))  s_filter <- function(object, s, ..., GlobalMetaData) {
421  setMethod("filterREUT21578Topics",      b <- TRUE
422            c("PlainTextDocument", "character"),      for (tag in names(s)) {
423            function(object, topics) {          if (tag %in% names(LocalMetaData(object))) {
424                if (Cached(object) == FALSE)              b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
425                    object <- loadFileIntoMem(object)          } else if (tag %in% names(GlobalMetaData)){
426                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
427            } else {
428                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
429            }
430        }
431        return(b)
432    }
433    
434                if (any(LocalMetaData(object)$Topics %in% topics))  setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
435                    return(TRUE)  setMethod("fulltext_search_filter",
436                else            signature(object = "PlainTextDocument", pattern = "character"),
437                    return(FALSE)            function(object, pattern, ...) {
438            })                if (!Cached(object))
439                      object <- load_doc(object)
440    
441  setGeneric("filterIDs", function(object, IDs, ...) standardGeneric("filterIDs"))                return(any(grep(pattern, Corpus(object))))
 setMethod("filterIDs",  
           c("TextDocument", "numeric"),  
           function(object, IDs) {  
               if (ID(object) %in% IDs)  
                   return(TRUE)  
               else  
                   return(FALSE)  
442            })            })
443    
444  setGeneric("attachData", function(object, data) standardGeneric("attachData"))  setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
445  setMethod("attachData",  setMethod("attach_data",
446            c("TextDocCol","TextDocument"),            signature(object = "TextDocCol", data = "TextDocument"),
447            function(object, data) {            function(object, data) {
448                data <- as(list(data), "TextDocCol")                data <- as(list(data), "TextDocCol")
449                object@.Data <- as(c(object@.Data, data), "TextDocCol")                object@.Data <- as(c(object@.Data, data), "TextDocCol")
450                return(object)                return(object)
451            })            })
452    
453  setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))  setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
454  setMethod("attachMetaData",  setMethod("attach_metadata",
455            c("TextDocCol"),            signature(object = "TextDocCol"),
456            function(object, name, metadata) {            function(object, name, metadata) {
457                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
458                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
459                return(object)                return(object)
460            })            })
461    
462  setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))  setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
463  setMethod("setSubscriptable",  setMethod("set_subscriptable",
464            c("TextDocCol"),            signature(object = "TextDocCol"),
465            function(object, name) {            function(object, name) {
466                if (!is.character(GlobalMetaData(object)$subscriptable))                if (!is.character(GlobalMetaData(object)$subscriptable))
467                    object <- attachMetaData(object, "subscriptable", name)                    object <- attach_metadata(object, "subscriptable", name)
468                else                else
469                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
470                return(object)                return(object)
# Line 313  Line 486 
486                return(object)                return(object)
487            })            })
488    
489    setMethod("[<-",
490              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
491              function(x, i, j, ... , value) {
492                  object <- x
493                  object@.Data[i, ...] <- value
494                  return(object)
495              })
496    
497    setMethod("[[",
498              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
499              function(x, i, j, ...) {
500                  return(x@.Data[[i, ...]])
501              })
502    
503    setMethod("[[<-",
504              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
505              function(x, i, j, ..., value) {
506                  object <- x
507                  object@.Data[[i, ...]] <- value
508                  return(object)
509              })
510    
511  setMethod("c",  setMethod("c",
512            signature(x = "TextDocCol"),            signature(x = "TextDocCol"),
513            function(x, ..., recursive = TRUE){            function(x, ..., recursive = TRUE){
# Line 321  Line 516 
516                    return(x)                    return(x)
517                return(as(c(as(x, "list"), ...), "TextDocCol"))                return(as(c(as(x, "list"), ...), "TextDocCol"))
518      })      })
519    setMethod("c",
520              signature(x = "TextDocument"),
521              function(x, ..., recursive = TRUE){
522                  args <- list(...)
523                  if(length(args) == 0)
524                      return(x)
525                  return(new("TextDocCol", .Data = list(x, ...)))
526        })
527    
528  setMethod("length",  setMethod("length",
529            signature(x = "TextDocCol"),            signature(x = "TextDocCol"),
# Line 355  Line 558 
558    
559  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
560  setMethod("inspect",  setMethod("inspect",
561            c("TextDocCol"),            signature("TextDocCol"),
562            function(object) {            function(object) {
563                summary(object)                summary(object)
564                cat("\n")                cat("\n")
565                show(as(object, "list"))                show(as(object, "list"))
566            })            })
567    
568    # No metadata is checked
569    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
570    setMethod("%IN%",
571              signature(x = "TextDocument", y = "TextDocCol"),
572              function(x, y) {
573                  x %in% y
574              })

Legend:
Removed from v.60  
changed lines
  Added in v.66

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge