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 37, Wed Jan 11 17:49:17 2006 UTC trunk/R/textmin/R/textdoccol.R revision 69, Fri Nov 3 10:50:39 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"))                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                           tdl <- sapply(dir(object,                    object <- step_next(object)
15                                             pattern = ".csv",                    elem <- get_elem(object)
16                                             full.names = TRUE),                    # If there is no Load on Demand support
17                                         function(file) {                    # we need to load the corpus into memory at startup
18                                             m <- as.matrix(read.csv(file, header = FALSE))                    if (object@LoDSupport)
19                                             l <- vector("list", dim(m)[1])                        load <- object@Load
20                                             for (i in 1:dim(m)[1]) {                    else
21                                                 author <- ""                        load <- TRUE
22                                                 timestamp <- date()                    tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23                                                 description <- ""                    counter <- counter + 1
                                                id <- as.integer(m[i,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) 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    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    setGeneric("ReutersSource", function(object) standardGeneric("ReutersSource"))
60    setMethod("ReutersSource",
61              signature(object = "character"),
62              function(object) {
63                  object <- substitute(file(object))
64                  con <- eval(object)
65                  corpus <- paste(readLines(con), "\n", collapse = "")
66                  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                           tdcl <- new("textdoccol", .Data = tdl)  setMethod("step_next",
101                       },            signature(object = "ReutersSource"),
102                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format            function(object) {
103                       # The first argument is a directory with the RCV1 XML files                object@Position <- object@Position + 1
104                       "RCV1" = {                object
                          tdl <- sapply(dir(object,  
                                            pattern = ".xml",  
                                            full.names = TRUE),  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)  
                                        })  
                          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" = {  
                          tdl <- sapply(dir(object,  
                                            pattern = ".xml",  
                                            full.names = TRUE),  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)  
105                                         })                                         })
106                           tdcl <- new("textdoccol", .Data = tdl)  
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                tdcl  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  # TODO: Implement lacking fields as soon I have access to the original RCV1  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            datetimestamp <- xmlValue(node[["DATE"]])
190            description <- ""
191            id <- xmlAttrs(node)[["NEWID"]]
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"]])
228    
229            if (!lodsupport || (lodsupport && load)) {
230                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  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
277  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  rcv1_to_plain <- function(node, ...) {
278      author <- "Not yet implemented"      datetimestamp <- xmlAttrs(node)[["date"]]
279      timestamp <- xmlAttrs(node)[["date"]]      id <- xmlAttrs(node)[["itemid"]]
     description <- "Not yet implemented"  
     id <- as.integer(xmlAttrs(node)[["itemid"]])  
280      origin <- "Reuters Corpus Volume 1 XML"      origin <- "Reuters Corpus Volume 1 XML"
281      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)  
   
282      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
283    
284      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
285          description = description, id = id, origin = origin, heading = heading)          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      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
291      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
292          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
293      else      else
294          author <- ""          author <- ""
295    
296      timestamp <- xmlValue(node[["DATE"]])      datetimestamp <- xmlValue(node[["DATE"]])
297      description <- ""      description <- ""
298      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- xmlAttrs(node)[["NEWID"]]
299    
300      origin <- "Reuters-21578 XML"      origin <- "Reuters-21578 XML"
301    
# Line 106  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("A text document collection with", length(object), "text document")
599                  if (length(object) == 1)
600                      cat("\n")
601                  else
602                      cat("s\n")
603        })
604    
605    setMethod("summary",
606              signature(object = "TextDocCol"),
607              function(object){
608                  show(object)
609                  if (length(GlobalMetaData(object)) > 0) {
610                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
611                      if (length(GlobalMetaData(object)) == 1)
612                          cat(".\n")
613                      else
614                          cat("s.\n")
615                      cat("Available tags are:\n")
616                      cat(names(GlobalMetaData(object)), "\n")
617                  }
618        })
619    
620    setGeneric("inspect", function(object) standardGeneric("inspect"))
621    setMethod("inspect",
622              signature("TextDocCol"),
623              function(object) {
624                  summary(object)
625                  cat("\n")
626                  show(as(object, "list"))
627              })
628    
629    # No metadata is checked
630    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
631    setMethod("%IN%",
632              signature(x = "TextDocument", y = "TextDocCol"),
633              function(x, y) {
634                  x %in% y
635              })

Legend:
Removed from v.37  
changed lines
  Added in v.69

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