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

trunk/R/trunk/R/textdoccol.R revision 40, Tue Feb 14 15:02:45 2006 UTC trunk/R/textmin/R/textdoccol.R 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, ...) standardGeneric("textdoccol"))  # The "..." are additional arguments for the function_generator parser
4  setMethod("textdoccol",  setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))
5            c("character", "character", "logical", "logical"),  setMethod("TextDocCol",
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {            signature(object = "Source"),
7                # Add a new type for each unique input source format            function(object, parser = plaintext_parser) {
8                type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "RIS"))                if (inherits(parser, "function_generator"))
9                switch(type,                    parser <- parser(...)
10                       # Text in a special CSV format  
11                       # For details on the file format see the R documentation file                tdl <- list()
12                       # The first argument is a directory with .csv files                counter <- 1
13                       "CSV" = {                while (!eoi(object)) {
14                           filelist <- dir(object, pattern = ".csv",full.names = TRUE)                    object <- step_next(object)
15                           tdl <- sapply(filelist,                    elem <- get_elem(object)
16                                         function(file) {                    # If there is no Load on Demand support
17                                             m <- as.matrix(read.csv(file, header = FALSE))                    # we need to load the corpus into memory at startup
18                                             l <- vector("list", dim(m)[1])                    if (object@LoDSupport)
19                                             for (i in 1:dim(m)[1]) {                        load <- object@Load
20                                                 author <- ""                    else
21                                                 timestamp <- date()                        load <- TRUE
22                                                 description <- ""                    tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23                                                 id <- as.integer(m[i,1])                    counter <- counter + 1
                                                corpus <- as.character(m[i,2:dim(m)[2]])  
                                                if (stripWhiteSpace)  
                                                    corpus <- gsub("[[:space:]]+", " ", corpus)  
                                                if (toLower)  
                                                    corpus <- tolower(corpus)  
                                                origin <- "CSV"  
                                                heading <- ""  
   
                                                l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,  
                                                              description = description, id = id, origin = origin, heading = heading)  
24                                             }                                             }
25                                             l  
26                  return(new("TextDocCol", .Data = tdl))
27              })
28    
29    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    
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                           if (length(filelist) > 1)  
86                               tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))  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                  list(content = virtual.file, uri = object@URI)
108              })
109    
110    setGeneric("eoi", function(object) standardGeneric("eoi"))
111    setMethod("eoi",
112              signature(object = "DirSource"),
113              function(object) {
114                  if (length(object@FileList) <= object@Position)
115                      return(TRUE)
116                           else                           else
117                               tdcl <- new("textdoccol", .Data = tdl)                    return(FALSE)
                      },  
                      # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  
                      # The first argument is a directory with the RCV1 XML files  
                      "RCV1" = {  
                          filelist <- dir(object, pattern = ".xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("textdoccol", .Data = tdl)  
                      },  
                      # Read in text documents in Reuters-21578 XML (not SGML) format  
                      # Typically the first argument will be a directory where we can  
                      # find the files reut2-000.xml ... reut2-021.xml  
                      "REUT21578" = {  
                          filelist <- dir(object, pattern = ".xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("textdoccol", .Data = tdl)  
                      },  
                      # Read in HTML documents as used by http://ris.bka.gv.at/vwgh  
                      # The file name must be named according to the following schema:  
                      # Geschäftszahl.html, e.g. 2002130005.html  
                      "RIS" = {  
                          filelist <- dir(object, pattern = ".html", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            l <- list()  
                                            l[[length(l) + 1]] <- parseHTML(file, stripWhiteSpace, toLower)  
                                            l  
118                                         })                                         })
119                           tdcl <- new("textdoccol", .Data = tdl)  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                tdcl  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  # Parse an HTML document  plaintext_parser <- function(...) {
137  parseHTML <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {      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)
148        }
149    }
150    class(plaintext_parser) <- "function_generator"
151    
152    reut21578xml_parser <- function(...) {
153        function(elem, lodsupport, load, id) {
154            corpus <- paste(elem$content, "\n", collapse = "")
155            tree <- xmlTreeParse(corpus, asText = TRUE)
156            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!
162            if (!is.null(node[["TEXT"]][["AUTHOR"]]))
163                author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
164            else
165      author <- ""      author <- ""
     timestamp <- date()  
     description <- ""  
     id <- as.integer(gsub(".html", "", basename(file)))  
166    
167      tree <- htmlTreeParse(file)          datetimestamp <- xmlValue(node[["DATE"]])
168      htmlElem <- unlist(tree$children$html$children)          description <- ""
169      textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]          id <- xmlAttrs(node)[["NEWID"]]
     names(textElem) <- NULL  
   
     corpus <- paste(textElem, collapse = " ")  
     origin <- ""  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
170    
171            # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
172            if (!is.null(node[["TEXT"]][["TITLE"]]))
173                heading <- xmlValue(node[["TEXT"]][["TITLE"]])
174            else
175      heading <- ""      heading <- ""
176    
177      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,          topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
178          description = description, id = id, origin = origin, heading = heading)  
179            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",
186                           Heading = heading, LocalMetaData = list(Topics = topics))
187            }
188    
189            return(doc)
190        }
191    }
192    class(reut21578xml_parser) <- "function_generator"
193    
194    rcv1_parser <- function(...) {
195        function(elem, lodsupport, load, id) {
196            corpus <- paste(elem$content, "\n", collapse = "")
197            tree <- xmlTreeParse(corpus, asText = TRUE)
198            node <- xmlRoot(tree)
199    
200            # Mask as list to bypass S4 checks
201            class(tree) <- "list"
202    
203            datetimestamp <- xmlAttrs(node)[["date"]]
204            id <- xmlAttrs(node)[["itemid"]]
205            heading <- xmlValue(node[["title"]])
206    
207            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",
214                           Heading = heading)
215            }
216    
217            return(doc)
218        }
219    }
220    class(rcv1_parser) <- "function_generator"
221    
222    newsgroup_parser <- function(...) {
223        function(elem, lodsupport, load, id) {
224            mail <- elem$content
225            author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
226            datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
227            origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
228            heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
229            newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
230    
231            if (!lodsupport || (lodsupport && load)) {
232                # 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                for (index in seq(along = mail)) {
235                    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)
250        }
251  }  }
252    class(newsgroup_parser) <- "function_generator"
253    
 # TODO: Implement lacking fields as soon I have access to the original RCV1  
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  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  rcv1_to_plain <- function(node, ...) {
256      author <- "Not yet implemented"      datetimestamp <- xmlAttrs(node)[["date"]]
257      timestamp <- xmlAttrs(node)[["date"]]      id <- xmlAttrs(node)[["itemid"]]
     description <- "Not yet implemented"  
     id <- as.integer(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)
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
260      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
261    
262      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
263          description = description, id = id, origin = origin, 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  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  reut21578xml_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"]])
271      else      else
272          author <- ""          author <- ""
273    
274      timestamp <- xmlValue(node[["DATE"]])      datetimestamp <- xmlValue(node[["DATE"]])
275      description <- ""      description <- ""
276      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- xmlAttrs(node)[["NEWID"]]
277    
278      origin <- "Reuters-21578 XML"      origin <- "Reuters-21578 XML"
279    
# Line 151  Line 283 
283      else      else
284          corpus <- ""          corpus <- ""
285    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
286      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
287      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
288          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
289      else      else
290          heading <- ""          heading <- ""
291    
292      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
293          description = description, id = id, origin = origin, heading = heading)  
294        new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
295            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
296    }
297    
298    setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))
299    setMethod("load_doc",
300              signature(object = "PlainTextDocument"),
301              function(object, ...) {
302                  if (!Cached(object)) {
303                      con <- eval(parse(text = URI(object)))
304                      corpus <- readLines(con)
305                      close(con)
306                      Corpus(object) <- corpus
307                      Cached(object) <- TRUE
308                      return(object)
309                  } else {
310                      return(object)
311                  }
312              })
313    setMethod("load_doc",
314              signature(object =  "XMLTextDocument"),
315              function(object, ...) {
316                  if (!Cached(object)) {
317                      con <- eval(parse(text = URI(object)))
318                      corpus <- paste(readLines(con), "\n", collapse = "")
319                      close(con)
320                      doc <- xmlTreeParse(corpus, asText = TRUE)
321                      class(doc) <- "list"
322                      Corpus(object) <- doc
323                      Cached(object) <- TRUE
324                      return(object)
325                  } else {
326                      return(object)
327                  }
328              })
329    setMethod("load_doc",
330              signature(object = "NewsgroupDocument"),
331              function(object, ...) {
332                  if (!Cached(object)) {
333                      con <- eval(parse(text = URI(object)))
334                      mail <- readLines(con)
335                      close(con)
336                      Cached(object) <- TRUE
337                      for (index in seq(along = mail)) {
338                          if (mail[index] == "")
339                              break
340                      }
341                      Corpus(object) <- mail[(index + 1):length(mail)]
342                      return(object)
343                  } else {
344                      return(object)
345                  }
346              })
347    
348    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
349    setMethod("tm_transform",
350              signature(object = "TextDocCol", FUN = "function"),
351              function(object, FUN, ...) {
352                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
353                  result@GlobalMetaData <- GlobalMetaData(object)
354                  return(result)
355              })
356    
357    setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))
358    setMethod("as.plaintext_doc",
359              signature(object = "PlainTextDocument"),
360              function(object, FUN, ...) {
361                  return(object)
362              })
363    setMethod("as.plaintext_doc",
364              signature(object = "XMLTextDocument", FUN = "function"),
365              function(object, FUN, ...) {
366                  if (!Cached(object))
367                      object <- load_doc(object)
368    
369                  corpus <- Corpus(object)
370    
371                  # As XMLDocument is no native S4 class, restore valid information
372                  class(corpus) <- "XMLDocument"
373                  names(corpus) <- c("doc","dtd")
374    
375                  return(FUN(xmlRoot(corpus), ...))
376              })
377    
378    setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))
379    setMethod("stem_doc",
380              signature(object = "PlainTextDocument"),
381              function(object, ...) {
382                  if (!Cached(object))
383                      object <- load_doc(object)
384    
385                  require(Rstem)
386                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
387                  stemmedCorpus <- wordStem(splittedCorpus, ...)
388                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
389                  return(object)
390              })
391    
392    setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))
393    setMethod("remove_words",
394              signature(object = "PlainTextDocument", stopwords = "character"),
395              function(object, stopwords, ...) {
396                  if (!Cached(object))
397                      object <- load_doc(object)
398    
399                  require(Rstem)
400                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
401                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
402                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
403                  return(object)
404              })
405    
406    setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
407    setMethod("tm_filter",
408              signature(object = "TextDocCol"),
409              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))
418              })
419    
420    s_filter <- function(object, s, ..., GlobalMetaData) {
421        b <- TRUE
422        for (tag in names(s)) {
423            if (tag %in% names(LocalMetaData(object))) {
424                b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
425            } 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    setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
435    setMethod("fulltext_search_filter",
436              signature(object = "PlainTextDocument", pattern = "character"),
437              function(object, pattern, ...) {
438                  if (!Cached(object))
439                      object <- load_doc(object)
440    
441                  return(any(grep(pattern, Corpus(object))))
442              })
443    
444    setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
445    setMethod("attach_data",
446              signature(object = "TextDocCol", data = "TextDocument"),
447              function(object, data) {
448                  data <- as(list(data), "TextDocCol")
449                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
450                  return(object)
451              })
452    
453    setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
454    setMethod("attach_metadata",
455              signature(object = "TextDocCol"),
456              function(object, name, metadata) {
457                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
458                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
459                  return(object)
460              })
461    
462    setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
463    setMethod("set_subscriptable",
464              signature(object = "TextDocCol"),
465              function(object, name) {
466                  if (!is.character(GlobalMetaData(object)$subscriptable))
467                      object <- attach_metadata(object, "subscriptable", name)
468                  else
469                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
470                  return(object)
471              })
472    
473    setMethod("[",
474              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
475              function(x, i, j, ... , drop) {
476                  if(missing(i))
477                      return(x)
478    
479                  object <- x
480                  object@.Data <- x@.Data[i, ..., drop = FALSE]
481                  for (m in names(GlobalMetaData(object))) {
482                      if (m %in% GlobalMetaData(object)$subscriptable) {
483                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
484                      }
485                  }
486                  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",
512              signature(x = "TextDocCol"),
513              function(x, ..., recursive = TRUE){
514                  args <- list(...)
515                  if(length(args) == 0)
516                      return(x)
517                  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",
529              signature(x = "TextDocCol"),
530              function(x){
531                  return(length(as(x, "list")))
532        })
533    
534    setMethod("show",
535              signature(object = "TextDocCol"),
536              function(object){
537                  cat("A text document collection with", length(object), "text document")
538                  if (length(object) == 1)
539                      cat("\n")
540                  else
541                      cat("s\n")
542        })
543    
544    setMethod("summary",
545              signature(object = "TextDocCol"),
546              function(object){
547                  show(object)
548                  if (length(GlobalMetaData(object)) > 0) {
549                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
550                      if (length(GlobalMetaData(object)) == 1)
551                          cat(".\n")
552                      else
553                          cat("s.\n")
554                      cat("Available tags are:\n")
555                      cat(names(GlobalMetaData(object)), "\n")
556  }  }
557        })
558    
559    setGeneric("inspect", function(object) standardGeneric("inspect"))
560    setMethod("inspect",
561              signature("TextDocCol"),
562              function(object) {
563                  summary(object)
564                  cat("\n")
565                  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.40  
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