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 67, Wed Nov 1 17:29:59 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"]])
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
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"]])      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      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        datetimestamp <- xmlValue(node[["DATE"]])
297        description <- ""
298        id <- xmlAttrs(node)[["NEWID"]]
299    
300      origin <- "Not yet implemented"      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                  object[tm_index(object, ..., FUN)]
455              })
456    
457    setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
458    setMethod("tm_index",
459              signature(object = "TextDocCol"),
460              function(object, ..., FUN = s_filter) {
461                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
462              })
463    
464    s_filter <- function(object, s, ..., GlobalMetaData) {
465        b <- TRUE
466        for (tag in names(s)) {
467            if (tag %in% names(LocalMetaData(object))) {
468                b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
469            } else if (tag %in% names(GlobalMetaData)){
470                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
471            } else {
472                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
473            }
474        }
475        return(b)
476    }
477    
478    setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
479    setMethod("fulltext_search_filter",
480              signature(object = "PlainTextDocument", pattern = "character"),
481              function(object, pattern, ...) {
482                  if (!Cached(object))
483                      object <- load_doc(object)
484    
485                  return(any(grep(pattern, Corpus(object))))
486              })
487    
488    setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
489    setMethod("attach_data",
490              signature(object = "TextDocCol", data = "TextDocument"),
491              function(object, data) {
492                  data <- as(list(data), "TextDocCol")
493                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
494                  return(object)
495              })
496    
497    setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
498    setMethod("attach_metadata",
499              signature(object = "TextDocCol"),
500              function(object, name, metadata) {
501                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
502                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
503                  return(object)
504              })
505    
506    setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
507    setMethod("set_subscriptable",
508              signature(object = "TextDocCol"),
509              function(object, name) {
510                  if (!is.character(GlobalMetaData(object)$subscriptable))
511                      object <- attach_metadata(object, "subscriptable", name)
512                  else
513                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
514                  return(object)
515              })
516    
517    setMethod("[",
518              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
519              function(x, i, j, ... , drop) {
520                  if(missing(i))
521                      return(x)
522    
523                  object <- x
524                  object@.Data <- x@.Data[i, ..., drop = FALSE]
525                  for (m in names(GlobalMetaData(object))) {
526                      if (m %in% GlobalMetaData(object)$subscriptable) {
527                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
528                      }
529                  }
530                  return(object)
531              })
532    
533    setMethod("[<-",
534              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
535              function(x, i, j, ... , value) {
536                  object <- x
537                  object@.Data[i, ...] <- value
538                  return(object)
539              })
540    
541    setMethod("[[",
542              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
543              function(x, i, j, ...) {
544                  return(x@.Data[[i, ...]])
545              })
546    
547    setMethod("[[<-",
548              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
549              function(x, i, j, ..., value) {
550                  object <- x
551                  object@.Data[[i, ...]] <- value
552                  return(object)
553              })
554    
555    setMethod("c",
556              signature(x = "TextDocCol"),
557              function(x, ..., recursive = TRUE){
558                  args <- list(...)
559                  if(length(args) == 0)
560                      return(x)
561                  return(as(c(as(x, "list"), ...), "TextDocCol"))
562        })
563    setMethod("c",
564              signature(x = "TextDocument"),
565              function(x, ..., recursive = TRUE){
566                  args <- list(...)
567                  if(length(args) == 0)
568                      return(x)
569                  return(new("TextDocCol", .Data = list(x, ...)))
570        })
571    
572    setMethod("length",
573              signature(x = "TextDocCol"),
574              function(x){
575                  return(length(as(x, "list")))
576        })
577    
578    setMethod("show",
579              signature(object = "TextDocCol"),
580              function(object){
581                  cat("A text document collection with", length(object), "text document")
582                  if (length(object) == 1)
583                      cat("\n")
584                  else
585                      cat("s\n")
586        })
587    
588    setMethod("summary",
589              signature(object = "TextDocCol"),
590              function(object){
591                  show(object)
592                  if (length(GlobalMetaData(object)) > 0) {
593                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
594                      if (length(GlobalMetaData(object)) == 1)
595                          cat(".\n")
596                      else
597                          cat("s.\n")
598                      cat("Available tags are:\n")
599                      cat(names(GlobalMetaData(object)), "\n")
600                  }
601        })
602    
603    setGeneric("inspect", function(object) standardGeneric("inspect"))
604    setMethod("inspect",
605              signature("TextDocCol"),
606              function(object) {
607                  summary(object)
608                  cat("\n")
609                  show(as(object, "list"))
610              })
611    
612    # No metadata is checked
613    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
614    setMethod("%IN%",
615              signature(x = "TextDocument", y = "TextDocCol"),
616              function(x, y) {
617                  x %in% y
618              })

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

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