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 32, Thu Dec 15 13:13:54 2005 UTC trunk/R/textmin/R/textdoccol.R revision 70, Tue Nov 7 18:18:51 2006 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # S4 class definition  # The "..." are additional arguments for the function_generator parser
4  # Text document collection  setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))
5  setClass("textdoccol",  setMethod("TextDocCol",
6           contains = c("list"))            signature(object = "Source"),
7              function(object, parser = plaintext_parser, ...) {
8  # Constructors                if (inherits(parser, "function_generator"))
9                      parser <- parser(...)
10  setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))  
11  setMethod("textdoccol",                tdl <- list()
12            c("character", "character", "logical", "logical"),                counter <- 1
13            function(object, inputType = "RCV1", stripWhiteSpace = FALSE, toLower = FALSE) {                while (!eoi(object)) {
14                      object <- step_next(object)
15                # Add a new type for each unique input source format                    elem <- get_elem(object)
16                type <- match.arg(inputType,c("RCV1","CSV","REUT21578"))                    # If there is no Load on Demand support
17                switch(type,                    # we need to load the corpus into memory at startup
18                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format                    if (object@LoDSupport)
19                       # For the moment the first argument is still a single file                        load <- object@Load
20                       # This will be changed to a directory as soon as we have the full RCV1 data set                    else
21                       "RCV1" = {                        load <- TRUE
22                           tree <- xmlTreeParse(object)                    tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23                           tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))                    counter <- counter + 1
24                       },                }
25                       # Text in a special CSV format (as e.g. exported from an Excel sheet)  
26                       # For details on the file format see data/Umfrage.csv                return(new("TextDocCol", .Data = tdl))
27                       # The first argument has to be a single file            })
28                       "CSV" = {  
29                           m <- as.matrix(read.csv(object))  setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30                           l <- vector("list", dim(m)[1])  setMethod("DirSource",
31                           for (i in 1:dim(m)[1]) {            signature(directory = "character"),
32                               author <- "Not yet implemented"            function(directory, load = FALSE) {
33                               timestamp <- date()                new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),
34                               description <- "Not yet implemented"                    Position = 0, Load = load)
                              id <- i  
                              corpus <- as.character(m[i,2:dim(m)[2]])  
                              if (stripWhiteSpace)  
                                  corpus <- gsub("[[:space:]]+", " ", corpus)  
                              if (toLower)  
                                  corpus <- tolower(corpus)  
                              origin <- "Not yet implemented"  
                              heading <- "Not yet implemented"  
   
                              l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,  
                                  description = description, id = id, origin = origin, heading = heading)  
                          }  
                          tdcl <- new("textdoccol", .Data = l)  
                      },  
                      # 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" = {  
                          tdl <- sapply(dir(object,  
                                            pattern = ".xml",  
                                            full.names = TRUE),  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)  
35                                         })                                         })
36    
37                           tdcl <- new("textdoccol", .Data = tdl)  setGeneric("CSVSource", function(object) standardGeneric("CSVSource"))
38    setMethod("CSVSource",
39              signature(object = "character"),
40              function(object) {
41                  object <- substitute(file(object))
42                  con <- eval(object)
43                  content <- scan(con, what = "character")
44                  close(con)
45                  new("CSVSource", LoDSupport = FALSE, URI = object,
46                      Content = content, Position = 0)
47                       })                       })
48                tdcl  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    
59  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  setGeneric("ReutersSource", function(object) standardGeneric("ReutersSource"))
60  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  setMethod("ReutersSource",
61      author <- "Not yet implemented"            signature(object = "character"),
62      timestamp <- xmlAttrs(node)[["date"]]            function(object) {
63      description <- "Not yet implemented"                object <- substitute(file(object))
64      id <- as.integer(xmlAttrs(node)[["itemid"]])                con <- eval(object)
65      origin <- "Not yet implemented"                corpus <- paste(readLines(con), "\n", collapse = "")
66      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)                close(con)
67                  tree <- xmlTreeParse(corpus, asText = TRUE)
68                  content <- xmlRoot(tree)$children
69    
70                  new("ReutersSource", LoDSupport = FALSE, URI = object,
71                      Content = content, Position = 0)
72              })
73    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    
83                  new("ReutersSource", LoDSupport = FALSE, URI = object,
84                      Content = content, Position = 0)
85              })
86    
87    setGeneric("step_next", function(object) standardGeneric("step_next"))
88    setMethod("step_next",
89              signature(object = "DirSource"),
90              function(object) {
91                  object@Position <- object@Position + 1
92                  object
93              })
94    setMethod("step_next",
95              signature(object = "CSVSource"),
96              function(object) {
97                  object@Position <- object@Position + 1
98                  object
99              })
100    setMethod("step_next",
101              signature(object = "ReutersSource"),
102              function(object) {
103                  object@Position <- object@Position + 1
104                  object
105              })
106    
107    setGeneric("get_elem", function(object) standardGeneric("get_elem"))
108    setMethod("get_elem",
109              signature(object = "DirSource"),
110              function(object) {
111                  filename <- object@FileList[object@Position]
112                  list(content = readLines(object@FileList[object@Position]),
113                       uri = substitute(file(filename)))
114              })
115    setMethod("get_elem",
116              signature(object = "CSVSource"),
117              function(object) {
118                  list(content = object@Content[object@Position],
119                       uri = object@URI)
120              })
121    setMethod("get_elem",
122              signature(object = "ReutersSource"),
123              function(object) {
124                  # 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              })
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              signature(object = "ReutersSource"),
151              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                doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,
162                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
163            }
164            else {
165                doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,
166                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
167            }
168    
169            return(doc)
170        }
171    }
172    class(plaintext_parser) <- "function_generator"
173    
174    reut21578xml_parser <- function(...) {
175        function(elem, lodsupport, load, id) {
176            corpus <- paste(elem$content, "\n", collapse = "")
177            tree <- xmlTreeParse(corpus, asText = TRUE)
178            node <- xmlRoot(tree)
179    
180            # Mask as list to bypass S4 checks
181            class(tree) <- "list"
182    
183            # 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    
189      if (stripWhiteSpace)          datetimestamp <- xmlValue(node[["DATE"]])
190          corpus <- gsub("[[:space:]]+", " ", corpus)          description <- ""
191      if (toLower)          id <- xmlAttrs(node)[["NEWID"]]
         corpus <- tolower(corpus)  
192    
193            # 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    
199            topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
200    
201            if (!lodsupport || (lodsupport && load)) {
202                doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,
203                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
204                           Heading = heading, LocalMetaData = list(Topics = topics))
205            } else {
206                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,
207                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
208                           Heading = heading, LocalMetaData = list(Topics = topics))
209            }
210    
211            return(doc)
212        }
213    }
214    class(reut21578xml_parser) <- "function_generator"
215    
216    rcv1_parser <- function(...) {
217        function(elem, lodsupport, load, id) {
218            corpus <- paste(elem$content, "\n", collapse = "")
219            tree <- xmlTreeParse(corpus, asText = TRUE)
220            node <- xmlRoot(tree)
221    
222            # Mask as list to bypass S4 checks
223            class(tree) <- "list"
224    
225            datetimestamp <- xmlAttrs(node)[["date"]]
226            id <- xmlAttrs(node)[["itemid"]]
227      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
228    
229      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,          if (!lodsupport || (lodsupport && load)) {
230          description = description, id = id, origin = origin, heading = heading)              doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",
231                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
232                           Heading = heading)
233            } else {
234                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",
235                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
236                           Heading = heading)
237            }
238    
239            return(doc)
240        }
241    }
242    class(rcv1_parser) <- "function_generator"
243    
244    newsgroup_parser <- function(...) {
245        function(elem, lodsupport, load, id) {
246            mail <- elem$content
247            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    
253            if (!lodsupport || (lodsupport && load)) {
254                # 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                content <- mail[(index + 1):length(mail)]
261    
262                doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,
263                           Author = author, DateTimeStamp = datetimestamp,
264                           Description = "", ID = id, Origin = origin,
265                           Heading = heading, Newsgroup = newsgroup)
266            } else {
267                doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
268                           Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
269            }
270    
271            return(doc)
272        }
273    }
274    class(newsgroup_parser) <- "function_generator"
275    
276    # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
277    rcv1_to_plain <- function(node, ...) {
278        datetimestamp <- xmlAttrs(node)[["date"]]
279        id <- xmlAttrs(node)[["itemid"]]
280        origin <- "Reuters Corpus Volume 1 XML"
281        corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
282        heading <- xmlValue(node[["title"]])
283    
284        new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
285            Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
286  }  }
287    
288  # 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
289  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  reut21578xml_to_plain <- function(node, ...) {
290      author <- "Not yet implemented"      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
291      timestamp <- xmlValue(node[["DATE"]])      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
292      description <- "Not yet implemented"          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
293      id <- as.integer(xmlAttrs(node)[["NEWID"]])      else
294            author <- ""
295    
296      origin <- "Not yet implemented"      datetimestamp <- xmlValue(node[["DATE"]])
297        description <- ""
298        id <- xmlAttrs(node)[["NEWID"]]
299    
300        origin <- "Reuters-21578 XML"
301    
302      # The <BODY></BODY> tag is unfortunately NOT obligatory!      # The <BODY></BODY> tag is unfortunately NOT obligatory!
303      if (!is.null(node[["TEXT"]][["BODY"]]))      if (!is.null(node[["TEXT"]][["BODY"]]))
# Line 98  Line 305 
305      else      else
306          corpus <- ""          corpus <- ""
307    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
308      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
309      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
310          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
311      else      else
312          heading <- ""          heading <- ""
313    
314      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
315          description = description, id = id, origin = origin, heading = heading)  
316        new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
317            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
318  }  }
319    
320    setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))
321    setMethod("load_doc",
322              signature(object = "PlainTextDocument"),
323              function(object, ...) {
324                  if (!Cached(object)) {
325                      con <- eval(URI(object))
326                      corpus <- readLines(con)
327                      close(con)
328                      Corpus(object) <- corpus
329                      Cached(object) <- TRUE
330                      return(object)
331                  } else {
332                      return(object)
333                  }
334              })
335    setMethod("load_doc",
336              signature(object =  "XMLTextDocument"),
337              function(object, ...) {
338                  if (!Cached(object)) {
339                      con <- eval(URI(object))
340                      corpus <- paste(readLines(con), "\n", collapse = "")
341                      close(con)
342                      doc <- xmlTreeParse(corpus, asText = TRUE)
343                      class(doc) <- "list"
344                      Corpus(object) <- doc
345                      Cached(object) <- TRUE
346                      return(object)
347                  } else {
348                      return(object)
349                  }
350              })
351    setMethod("load_doc",
352              signature(object = "NewsgroupDocument"),
353              function(object, ...) {
354                  if (!Cached(object)) {
355                      con <- eval(URI(object))
356                      mail <- readLines(con)
357                      close(con)
358                      Cached(object) <- TRUE
359                      for (index in seq(along = mail)) {
360                          if (mail[index] == "")
361                              break
362                      }
363                      Corpus(object) <- mail[(index + 1):length(mail)]
364                      return(object)
365                  } else {
366                      return(object)
367                  }
368              })
369    
370    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
371    setMethod("tm_transform",
372              signature(object = "TextDocCol", FUN = "function"),
373              function(object, FUN, ...) {
374                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
375                  result@GlobalMetaData <- GlobalMetaData(object)
376                  return(result)
377              })
378    
379    setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))
380    setMethod("as.plaintext_doc",
381              signature(object = "PlainTextDocument"),
382              function(object, FUN, ...) {
383                  return(object)
384              })
385    setMethod("as.plaintext_doc",
386              signature(object = "XMLTextDocument", FUN = "function"),
387              function(object, FUN, ...) {
388                  if (!Cached(object))
389                      object <- load_doc(object)
390    
391                  corpus <- Corpus(object)
392    
393                  # As XMLDocument is no native S4 class, restore valid information
394                  class(corpus) <- "XMLDocument"
395                  names(corpus) <- c("doc","dtd")
396    
397                  return(FUN(xmlRoot(corpus), ...))
398              })
399    
400    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    setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))
423    setMethod("stem_doc",
424              signature(object = "PlainTextDocument"),
425              function(object, ...) {
426                  if (!Cached(object))
427                      object <- load_doc(object)
428    
429                  require(Rstem)
430                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
431                  stemmedCorpus <- wordStem(splittedCorpus)
432                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
433                  return(object)
434              })
435    
436    setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))
437    setMethod("remove_words",
438              signature(object = "PlainTextDocument", stopwords = "character"),
439              function(object, stopwords, ...) {
440                  if (!Cached(object))
441                      object <- load_doc(object)
442    
443                  require(Rstem)
444                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
445                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
446                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
447                  return(object)
448              })
449    
450    setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
451    setMethod("tm_filter",
452              signature(object = "TextDocCol"),
453              function(object, ..., FUN = s_filter) {
454                  indices <- sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
455                  object[indices]
456              })
457    
458    setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
459    setMethod("tm_index",
460              signature(object = "TextDocCol"),
461              function(object, ..., FUN = s_filter) {
462                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
463              })
464    
465    s_filter <- function(object, s, ..., GlobalMetaData) {
466        b <- TRUE
467        for (tag in names(s)) {
468            if (tag %in% names(LocalMetaData(object))) {
469                b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
470            } else if (tag %in% names(GlobalMetaData)){
471                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
472            } else {
473                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
474            }
475        }
476        return(b)
477    }
478    
479    setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
480    setMethod("fulltext_search_filter",
481              signature(object = "PlainTextDocument", pattern = "character"),
482              function(object, pattern, ...) {
483                  if (!Cached(object))
484                      object <- load_doc(object)
485    
486                  return(any(grep(pattern, Corpus(object))))
487              })
488    
489    setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
490    setMethod("attach_data",
491              signature(object = "TextDocCol", data = "TextDocument"),
492              function(object, data) {
493                  data <- as(list(data), "TextDocCol")
494                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
495                  return(object)
496              })
497    
498    setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
499    setMethod("attach_metadata",
500              signature(object = "TextDocCol"),
501              function(object, name, metadata) {
502                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
503                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
504                  return(object)
505              })
506    
507    setGeneric("remove_metadata", function(object, name) standardGeneric("remove_metadata"))
508    setMethod("remove_metadata",
509              signature(object = "TextDocCol"),
510              function(object, name) {
511                  object@GlobalMetaData <- GlobalMetaData(object)[names(GlobalMetaData(object)) != name]
512                  return(object)
513              })
514    
515    setGeneric("modify_metadata", function(object, name, metadata) standardGeneric("modify_metadata"))
516    setMethod("modify_metadata",
517              signature(object = "TextDocCol"),
518              function(object, name, metadata) {
519                  object@GlobalMetaData[[name]] <- metadata
520                  return(object)
521              })
522    
523    setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
524    setMethod("set_subscriptable",
525              signature(object = "TextDocCol"),
526              function(object, name) {
527                  if (!is.character(GlobalMetaData(object)$subscriptable))
528                      object <- attach_metadata(object, "subscriptable", name)
529                  else
530                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
531                  return(object)
532              })
533    
534    setMethod("[",
535              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
536              function(x, i, j, ... , drop) {
537                  if(missing(i))
538                      return(x)
539    
540                  object <- x
541                  object@.Data <- x@.Data[i, ..., drop = FALSE]
542                  for (m in names(GlobalMetaData(object))) {
543                      if (m %in% GlobalMetaData(object)$subscriptable) {
544                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
545                      }
546                  }
547                  return(object)
548              })
549    
550    setMethod("[<-",
551              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
552              function(x, i, j, ... , value) {
553                  object <- x
554                  object@.Data[i, ...] <- value
555                  return(object)
556              })
557    
558    setMethod("[[",
559              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
560              function(x, i, j, ...) {
561                  return(x@.Data[[i, ...]])
562              })
563    
564    setMethod("[[<-",
565              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
566              function(x, i, j, ..., value) {
567                  object <- x
568                  object@.Data[[i, ...]] <- value
569                  return(object)
570              })
571    
572    setMethod("c",
573              signature(x = "TextDocCol"),
574              function(x, ..., recursive = TRUE){
575                  args <- list(...)
576                  if(length(args) == 0)
577                      return(x)
578                  return(as(c(as(x, "list"), ...), "TextDocCol"))
579        })
580    setMethod("c",
581              signature(x = "TextDocument"),
582              function(x, ..., recursive = TRUE){
583                  args <- list(...)
584                  if(length(args) == 0)
585                      return(x)
586                  return(new("TextDocCol", .Data = list(x, ...)))
587        })
588    
589    setMethod("length",
590              signature(x = "TextDocCol"),
591              function(x){
592                  return(length(as(x, "list")))
593        })
594    
595    setMethod("show",
596              signature(object = "TextDocCol"),
597              function(object){
598                  cat(sprintf(ngettext(length(object),
599                                       "A text document collection with %d text document\n",
600                                       "A text document collection with %d text documents\n"),
601                              length(object)))
602        })
603    
604    setMethod("summary",
605              signature(object = "TextDocCol"),
606              function(object){
607                  show(object)
608                  if (length(GlobalMetaData(object)) > 0) {
609                      cat(sprintf(ngettext(length(GlobalMetaData(object)),
610                                                  "\nThe global metadata consists of %d tag-value pair\n",
611                                                  "\nThe global metadata consists of %d tag-value pairs\n"),
612                                           length(GlobalMetaData(object))))
613                      cat("Available tags are:\n")
614                      cat(names(GlobalMetaData(object)), "\n")
615                  }
616        })
617    
618    setGeneric("inspect", function(object) standardGeneric("inspect"))
619    setMethod("inspect",
620              signature("TextDocCol"),
621              function(object) {
622                  summary(object)
623                  cat("\n")
624                  show(as(object, "list"))
625              })
626    
627    # No metadata is checked
628    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
629    setMethod("%IN%",
630              signature(x = "TextDocument", y = "TextDocCol"),
631              function(x, y) {
632                  x %in% y
633              })

Legend:
Removed from v.32  
changed lines
  Added in v.70

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