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 68, Thu Nov 2 14:06:42 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                           tdcl <- new("textdoccol", .Data = tdl)  
29                       },  setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  setMethod("DirSource",
31                       # The first argument is a directory with the RCV1 XML files            signature(directory = "character"),
32                       "RCV1" = {            function(directory, load = FALSE) {
33                           tdl <- sapply(dir(object,                new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),
34                                             pattern = ".xml",                    Position = 0, Load = load)
                                            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)  
35                                         })                                         })
36                           tdcl <- new("textdoccol", .Data = tdl)  
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                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    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    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            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    
 # TODO: Implement lacking fields as soon I have access to the original RCV1  
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("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
508    setMethod("set_subscriptable",
509              signature(object = "TextDocCol"),
510              function(object, name) {
511                  if (!is.character(GlobalMetaData(object)$subscriptable))
512                      object <- attach_metadata(object, "subscriptable", name)
513                  else
514                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
515                  return(object)
516              })
517    
518    setMethod("[",
519              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
520              function(x, i, j, ... , drop) {
521                  if(missing(i))
522                      return(x)
523    
524                  object <- x
525                  object@.Data <- x@.Data[i, ..., drop = FALSE]
526                  for (m in names(GlobalMetaData(object))) {
527                      if (m %in% GlobalMetaData(object)$subscriptable) {
528                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
529                      }
530                  }
531                  return(object)
532              })
533    
534    setMethod("[<-",
535              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
536              function(x, i, j, ... , value) {
537                  object <- x
538                  object@.Data[i, ...] <- value
539                  return(object)
540              })
541    
542    setMethod("[[",
543              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
544              function(x, i, j, ...) {
545                  return(x@.Data[[i, ...]])
546              })
547    
548    setMethod("[[<-",
549              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
550              function(x, i, j, ..., value) {
551                  object <- x
552                  object@.Data[[i, ...]] <- value
553                  return(object)
554              })
555    
556    setMethod("c",
557              signature(x = "TextDocCol"),
558              function(x, ..., recursive = TRUE){
559                  args <- list(...)
560                  if(length(args) == 0)
561                      return(x)
562                  return(as(c(as(x, "list"), ...), "TextDocCol"))
563        })
564    setMethod("c",
565              signature(x = "TextDocument"),
566              function(x, ..., recursive = TRUE){
567                  args <- list(...)
568                  if(length(args) == 0)
569                      return(x)
570                  return(new("TextDocCol", .Data = list(x, ...)))
571        })
572    
573    setMethod("length",
574              signature(x = "TextDocCol"),
575              function(x){
576                  return(length(as(x, "list")))
577        })
578    
579    setMethod("show",
580              signature(object = "TextDocCol"),
581              function(object){
582                  cat("A text document collection with", length(object), "text document")
583                  if (length(object) == 1)
584                      cat("\n")
585                  else
586                      cat("s\n")
587        })
588    
589    setMethod("summary",
590              signature(object = "TextDocCol"),
591              function(object){
592                  show(object)
593                  if (length(GlobalMetaData(object)) > 0) {
594                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
595                      if (length(GlobalMetaData(object)) == 1)
596                          cat(".\n")
597                      else
598                          cat("s.\n")
599                      cat("Available tags are:\n")
600                      cat(names(GlobalMetaData(object)), "\n")
601  }  }
602        })
603    
604    setGeneric("inspect", function(object) standardGeneric("inspect"))
605    setMethod("inspect",
606              signature("TextDocCol"),
607              function(object) {
608                  summary(object)
609                  cat("\n")
610                  show(as(object, "list"))
611              })
612    
613    # No metadata is checked
614    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
615    setMethod("%IN%",
616              signature(x = "TextDocument", y = "TextDocCol"),
617              function(x, y) {
618                  x %in% y
619              })

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

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