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 18, Sat Nov 5 19:00:05 2005 UTC trunk/R/textmin/R/textdoccol.R revision 65, Tue Oct 31 17:10:24 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  # TODO: Define proper S4 term-document matrix  setMethod("TextDocCol",
6  setClass("textdoccol", representation(docs = "list",            signature(object = "Source"),
7                                        tdm = "matrix"))            function(object, parser = plaintext_parser) {
8                  if (inherits(parser, "function_generator"))
9  # Accessor function                    parser <- parser(...)
10  if (!isGeneric("docs")) {  
11      if (is.function("docs"))                tdl <- list()
12          fun <- docs                counter <- 1
13      else                while (!eoi(object)) {
14          fun <- function(object) standardGeneric("docs")                    object <- stepNext(object)
15      setGeneric("docs", fun)                    elem <- getElem(object)
16  }                    # If there is no Load on Demand support
17  setMethod("docs", "textdoccol", function(object) object@docs)                    # we need to load the corpus into memory at startup
18                      if (object@LoDSupport)
19  setGeneric("textdoccol", function(docs) standardGeneric("textdoccol"))                        load <- object@Load
20  # Read in XML text documents                    else
21  # Reuters Corpus Volume 1 (RCV1)                        load <- TRUE
22  setMethod("textdoccol", "character", function(docs) {                    tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23      require(XML)                    counter <- counter + 1
24                  }
25      tree <- xmlTreeParse(docs)  
26      root <- xmlRoot(tree)                return(new("TextDocCol", .Data = tdl))
27              })
28      # TODO: At each loop node points to the current newsitem  
29      node <- root  setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30    setMethod("DirSource",
31      # TODO: Implement lacking fields.            signature(directory = "character"),
32      # For this we need the full RCV1 XML set to know where to find those things            function(directory, load = FALSE) {
33      author <- "Not yet implemented"                new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),
34      timestamp <- xmlAttrs(node)[["date"]]                    Position = 0, Load = load)
35      description <- "Not yet implemented"            })
36      id <- as.integer(xmlAttrs(node)[["itemid"]])  
37      origin <- "Not yet implemented"  setGeneric("CSVSource", function(object, isConCall = FALSE) standardGeneric("CSVSource"))
38      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)  setMethod("CSVSource",
39              signature(object = "character"),
40              function(object, isConCall = FALSE) {
41                  if (!isConCall)
42                      object <- paste('file("', object, '")', sep = "")
43                  con <- eval(parse(text = object))
44                  content <- scan(con, what = "character")
45                  close(con)
46                  new("CSVSource", LoDSupport = FALSE, URI = object,
47                      Content = content, Position = 0)
48              })
49    
50    setGeneric("ReutersSource", function(object, isConCall = FALSE) standardGeneric("ReutersSource"))
51    setMethod("ReutersSource",
52              signature(object = "character"),
53              function(object, isConCall = FALSE) {
54                  if (!isConCall)
55                     object <- paste('file("', object, '")', sep = "")
56                  con <- eval(parse(text = object))
57                  corpus <- paste(readLines(con), "\n", collapse = "")
58                  close(con)
59                  tree <- xmlTreeParse(corpus, asText = TRUE)
60                  content <- xmlRoot(tree)$children
61    
62                  new("ReutersSource", LoDSupport = FALSE, URI = object,
63                      Content = content, Position = 0)
64              })
65    
66    setGeneric("stepNext", function(object) standardGeneric("stepNext"))
67    setMethod("stepNext",
68              signature(object = "DirSource"),
69              function(object) {
70                  object@Position <- object@Position + 1
71                  object
72              })
73    setMethod("stepNext",
74              signature(object = "CSVSource"),
75              function(object) {
76                  object@Position <- object@Position + 1
77                  object
78              })
79    setMethod("stepNext",
80              signature(object = "ReutersSource"),
81              function(object) {
82                  object@Position <- object@Position + 1
83                  object
84              })
85    
86    setGeneric("getElem", function(object) standardGeneric("getElem"))
87    setMethod("getElem",
88              signature(object = "DirSource"),
89              function(object) {
90                  list(content = readLines(object@FileList[object@Position]),
91                       uri = paste('file("', object@FileList[object@Position], '")', sep = ""))
92              })
93    setMethod("getElem",
94              signature(object = "CSVSource"),
95              function(object) {
96                  list(content = object@Content[object@Position],
97                       uri = object@URI)
98              })
99    setMethod("getElem",
100              signature(object = "ReutersSource"),
101              function(object) {
102                  # Construct a character representation from the XMLNode
103                  con <- textConnection("virtual.file", "w")
104                  saveXML(object@Content[[object@Position]], con)
105                  close(con)
106    
107                  list(content = virtual.file, uri = object@URI)
108              })
109    
110    setGeneric("eoi", function(object) standardGeneric("eoi"))
111    setMethod("eoi",
112              signature(object = "DirSource"),
113              function(object) {
114                  if (length(object@FileList) <= object@Position)
115                      return(TRUE)
116                  else
117                      return(FALSE)
118              })
119    setMethod("eoi",
120              signature(object = "CSVSource"),
121              function(object) {
122                  if (length(object@Content) <= object@Position)
123                      return(TRUE)
124                  else
125                      return(FALSE)
126              })
127    setMethod("eoi",
128              signature(object = "ReutersSource"),
129              function(object) {
130                  if (length(object@Content) <= object@Position)
131                      return(TRUE)
132                  else
133                      return(FALSE)
134              })
135    
136    plaintext_parser <- function(...) {
137        function(elem, lodsupport, load, id) {
138            if (!lodsupport || (lodsupport && load)) {
139                doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,
140                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
141            }
142            else {
143                doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,
144                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
145            }
146    
147            return(doc)
148        }
149    }
150    class(plaintext_parser) <- "function_generator"
151    
152    reuters21578xml_parser <- function(...) {
153        function(elem, lodsupport, load, id) {
154            corpus <- paste(elem$content, "\n", collapse = "")
155            tree <- xmlTreeParse(corpus, asText = TRUE)
156            node <- xmlRoot(tree)
157    
158            # Mask as list to bypass S4 checks
159            class(tree) <- "list"
160    
161            # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
162            if (!is.null(node[["TEXT"]][["AUTHOR"]]))
163                author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
164            else
165                author <- ""
166    
167            datetimestamp <- xmlValue(node[["DATE"]])
168            description <- ""
169            id <- xmlAttrs(node)[["NEWID"]]
170    
171            # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
172            if (!is.null(node[["TEXT"]][["TITLE"]]))
173                heading <- xmlValue(node[["TEXT"]][["TITLE"]])
174            else
175                heading <- ""
176    
177            topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
178    
179            if (!lodsupport || (lodsupport && load)) {
180                doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,
181                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
182                           Heading = heading, LocalMetaData = list(Topics = topics))
183            } else {
184                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,
185                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
186                           Heading = heading, LocalMetaData = list(Topics = topics))
187            }
188    
189            return(doc)
190        }
191    }
192    class(reuters21578xml_parser) <- "function_generator"
193    
194    rcv1_parser <- function(...) {
195        function(elem, lodsupport, load, id) {
196            corpus <- paste(elem$content, "\n", collapse = "")
197            tree <- xmlTreeParse(corpus, asText = TRUE)
198            node <- xmlRoot(tree)
199    
200            # Mask as list to bypass S4 checks
201            class(tree) <- "list"
202    
203            datetimestamp <- xmlAttrs(node)[["date"]]
204            id <- xmlAttrs(node)[["itemid"]]
205            heading <- xmlValue(node[["title"]])
206    
207            if (!lodsupport || (lodsupport && load)) {
208                doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",
209                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
210                           Heading = heading)
211            } else {
212                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",
213                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
214                           Heading = heading)
215            }
216    
217            return(doc)
218        }
219    }
220    class(rcv1_parser) <- "function_generator"
221    
222    uci_kdd_newsgroup_parser <- function(...) {
223        function(elem, lodsupport, load, id) {
224            mail <- elem$content
225            author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
226            datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
227            origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
228            heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
229            newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
230    
231            if (!lodsupport || (lodsupport && load)) {
232                # The header is separated from the body by a blank line.
233                # Reference: \url{http://en.wikipedia.org/wiki/E-mail#Internet_e-mail_format}
234                for (index in seq(along = mail)) {
235                    if (mail[index] == "")
236                        break
237                }
238                content <- mail[(index + 1):length(mail)]
239    
240                doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,
241                           Author = author, DateTimeStamp = datetimestamp,
242                           Description = "", ID = id, Origin = origin,
243                           Heading = heading, Newsgroup = newsgroup)
244            } else {
245                doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
246                           Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
247            }
248    
249            return(doc)
250        }
251    }
252    class(uci_kdd_newsgroup_parser) <- "function_generator"
253    
254    # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
255    rcv1_to_plain <- function(node, ...) {
256        datetimestamp <- xmlAttrs(node)[["date"]]
257        id <- xmlAttrs(node)[["itemid"]]
258        origin <- "Reuters Corpus Volume 1 XML"
259        corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
260      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
261    
262      doc <- new("textdocument", author = author, timestamp = timestamp, description = description,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
263                 id = id, origin = origin, corpus = corpus, heading = heading)          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
264    }
265    
266    # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
267    reuters21578xml_to_plain <- function(node, ...) {
268        # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
269        if (!is.null(node[["TEXT"]][["AUTHOR"]]))
270            author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
271        else
272            author <- ""
273    
274        datetimestamp <- xmlValue(node[["DATE"]])
275        description <- ""
276        id <- xmlAttrs(node)[["NEWID"]]
277    
278        origin <- "Reuters-21578 XML"
279    
280        # The <BODY></BODY> tag is unfortunately NOT obligatory!
281        if (!is.null(node[["TEXT"]][["BODY"]]))
282            corpus <- xmlValue(node[["TEXT"]][["BODY"]])
283        else
284            corpus <- ""
285    
286        # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
287        if (!is.null(node[["TEXT"]][["TITLE"]]))
288            heading <- xmlValue(node[["TEXT"]][["TITLE"]])
289        else
290            heading <- ""
291    
292        topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
293    
294        new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
295            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
296    }
297    
298    setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))
299    setMethod("loadFileIntoMem",
300              signature(object = "PlainTextDocument"),
301              function(object, ...) {
302                  if (!Cached(object)) {
303                      con <- eval(parse(text = URI(object)))
304                      corpus <- readLines(con)
305                      close(con)
306                      Corpus(object) <- corpus
307                      Cached(object) <- TRUE
308                      return(object)
309                  } else {
310                      return(object)
311                  }
312              })
313    setMethod("loadFileIntoMem",
314              signature(object =  "XMLTextDocument"),
315              function(object, ...) {
316                  if (!Cached(object)) {
317                      con <- eval(parse(text = URI(object)))
318                      corpus <- paste(readLines(con), "\n", collapse = "")
319                      close(con)
320                      doc <- xmlTreeParse(corpus, asText = TRUE)
321                      class(doc) <- "list"
322                      Corpus(object) <- doc
323                      Cached(object) <- TRUE
324                      return(object)
325                  } else {
326                      return(object)
327                  }
328              })
329    setMethod("loadFileIntoMem",
330              signature(object = "NewsgroupDocument"),
331              function(object, ...) {
332                  if (!Cached(object)) {
333                      con <- eval(parse(text = URI(object)))
334                      mail <- readLines(con)
335                      close(con)
336                      Cached(object) <- TRUE
337                      for (index in seq(along = mail)) {
338                          if (mail[index] == "")
339                              break
340                      }
341                      Corpus(object) <- mail[(index + 1):length(mail)]
342                      return(object)
343                  } else {
344                      return(object)
345                  }
346              })
347    
348    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
349    setMethod("tm_transform",
350              signature(object = "TextDocCol", FUN = "function"),
351              function(object, FUN, ...) {
352                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
353                  result@GlobalMetaData <- GlobalMetaData(object)
354                  return(result)
355              })
356    
357    setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
358    setMethod("toPlainTextDocument",
359              signature(object = "PlainTextDocument"),
360              function(object, FUN, ...) {
361                  return(object)
362              })
363    setMethod("toPlainTextDocument",
364              signature(object = "XMLTextDocument", FUN = "function"),
365              function(object, FUN, ...) {
366                  if (!Cached(object))
367                      object <- loadFileIntoMem(object)
368    
369                  corpus <- Corpus(object)
370    
371                  # As XMLDocument is no native S4 class, restore valid information
372                  class(corpus) <- "XMLDocument"
373                  names(corpus) <- c("doc","dtd")
374    
375                  return(FUN(xmlRoot(corpus), ...))
376              })
377    
378    setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
379    setMethod("stemTextDocument",
380              signature(object = "PlainTextDocument"),
381              function(object, ...) {
382                  if (!Cached(object))
383                      object <- loadFileIntoMem(object)
384    
385                  require(Rstem)
386                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
387                  stemmedCorpus <- wordStem(splittedCorpus, ...)
388                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
389                  return(object)
390              })
391    
392    setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
393    setMethod("removeStopWords",
394              signature(object = "PlainTextDocument", stopwords = "character"),
395              function(object, stopwords, ...) {
396                  if (!Cached(object))
397                      object <- loadFileIntoMem(object)
398    
399                  require(Rstem)
400                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
401                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
402                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
403                  return(object)
404              })
405    
406    setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
407    setMethod("tm_filter",
408              signature(object = "TextDocCol"),
409              function(object, ..., FUN = s_filter) {
410                  object[tm_index(object, ..., FUN)]
411              })
412    
413    setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
414    setMethod("tm_index",
415              signature(object = "TextDocCol"),
416              function(object, ..., FUN = s_filter) {
417                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
418              })
419    
420    s_filter <- function(object, s, ..., GlobalMetaData) {
421        b <- TRUE
422        for (tag in names(s)) {
423            if (tag %in% names(LocalMetaData(object))) {
424                b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
425            } else if (tag %in% names(GlobalMetaData)){
426                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
427            } else {
428                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
429            }
430        }
431        return(b)
432    }
433    
434    setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
435    setMethod("fulltext_search_filter",
436              signature(object = "PlainTextDocument", pattern = "character"),
437              function(object, pattern, ...) {
438                  if (!Cached(object))
439                      object <- loadFileIntoMem(object)
440    
441                  return(any(grep(pattern, Corpus(object))))
442              })
443    
444    setGeneric("attachData", function(object, data) standardGeneric("attachData"))
445    setMethod("attachData",
446              signature(object = "TextDocCol", data = "TextDocument"),
447              function(object, data) {
448                  data <- as(list(data), "TextDocCol")
449                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
450                  return(object)
451              })
452    
453    setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))
454    setMethod("attachMetaData",
455              signature(object = "TextDocCol"),
456              function(object, name, metadata) {
457                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
458                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
459                  return(object)
460              })
461    
462    setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))
463    setMethod("setSubscriptable",
464              signature(object = "TextDocCol"),
465              function(object, name) {
466                  if (!is.character(GlobalMetaData(object)$subscriptable))
467                      object <- attachMetaData(object, "subscriptable", name)
468                  else
469                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
470                  return(object)
471              })
472    
473    setMethod("[",
474              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
475              function(x, i, j, ... , drop) {
476                  if(missing(i))
477                      return(x)
478    
479                  object <- x
480                  object@.Data <- x@.Data[i, ..., drop = FALSE]
481                  for (m in names(GlobalMetaData(object))) {
482                      if (m %in% GlobalMetaData(object)$subscriptable) {
483                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
484                      }
485                  }
486                  return(object)
487              })
488    
489    setMethod("[<-",
490              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
491              function(x, i, j, ... , value) {
492                  object <- x
493                  object@.Data[i, ...] <- value
494                  return(object)
495              })
496    
497    setMethod("[[",
498              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
499              function(x, i, j, ...) {
500                  return(x@.Data[[i, ...]])
501              })
502    
503    setMethod("[[<-",
504              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
505              function(x, i, j, ..., value) {
506                  object <- x
507                  object@.Data[[i, ...]] <- value
508                  return(object)
509              })
510    
511    setMethod("c",
512              signature(x = "TextDocCol"),
513              function(x, ..., recursive = TRUE){
514                  args <- list(...)
515                  if(length(args) == 0)
516                      return(x)
517                  return(as(c(as(x, "list"), ...), "TextDocCol"))
518        })
519    setMethod("c",
520              signature(x = "TextDocument"),
521              function(x, ..., recursive = TRUE){
522                  args <- list(...)
523                  if(length(args) == 0)
524                      return(x)
525                  return(new("TextDocCol", .Data = list(x, ...)))
526        })
527    
528    setMethod("length",
529              signature(x = "TextDocCol"),
530              function(x){
531                  return(length(as(x, "list")))
532        })
533    
534    setMethod("show",
535              signature(object = "TextDocCol"),
536              function(object){
537                  cat("A text document collection with", length(object), "text document")
538                  if (length(object) == 1)
539                      cat("\n")
540                  else
541                      cat("s\n")
542        })
543    
544    setMethod("summary",
545              signature(object = "TextDocCol"),
546              function(object){
547                  show(object)
548                  if (length(GlobalMetaData(object)) > 0) {
549                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
550                      if (length(GlobalMetaData(object)) == 1)
551                          cat(".\n")
552                      else
553                          cat("s.\n")
554                      cat("Available tags are:\n")
555                      cat(names(GlobalMetaData(object)), "\n")
556                  }
557        })
558    
559    setGeneric("inspect", function(object) standardGeneric("inspect"))
560    setMethod("inspect",
561              signature("TextDocCol"),
562              function(object) {
563                  summary(object)
564                  cat("\n")
565                  show(as(object, "list"))
566              })
567    
568      new("textdoccol", docs = list(doc), tdm = matrix())  # No metadata is checked
569    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
570    setMethod("%IN%",
571              signature(x = "TextDocument", y = "TextDocCol"),
572              function(x, y) {
573                  x %in% y
574  })  })

Legend:
Removed from v.18  
changed lines
  Added in v.65

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