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 62, Tue Oct 24 10:08:58 2006 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # S4 class definition  setGeneric("TextDocCol", function(object, parser = plaintext.parser, lod = FALSE) standardGeneric("TextDocCol"))
4  # Text document collection  setMethod("TextDocCol",
5  setClass("textdoccol",            signature(object = "character"),
6           contains = c("list"))            function(object, parser = plaintext.parser, lod = FALSE) {
7                  filelist <- dir(object, full.names = TRUE)
8  # Constructors                tdl <- lapply(filelist, parser, lod)
9                  return(new("TextDocCol", .Data = tdl))
 setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))  
 setMethod("textdoccol",  
           c("character", "character", "logical", "logical"),  
           function(object, inputType = "RCV1", stripWhiteSpace = FALSE, toLower = FALSE) {  
   
               # Add a new type for each unique input source format  
               type <- match.arg(inputType,c("RCV1","CSV","REUT21578"))  
               switch(type,  
                      # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  
                      # For the moment the first argument is still a single file  
                      # This will be changed to a directory as soon as we have the full RCV1 data set  
                      "RCV1" = {  
                          tree <- xmlTreeParse(object)  
                          tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))  
                      },  
                      # Text in a special CSV format (as e.g. exported from an Excel sheet)  
                      # For details on the file format see data/Umfrage.csv  
                      # The first argument has to be a single file  
                      "CSV" = {  
                          m <- as.matrix(read.csv(object))  
                          l <- vector("list", dim(m)[1])  
                          for (i in 1:dim(m)[1]) {  
                              author <- "Not yet implemented"  
                              timestamp <- date()  
                              description <- "Not yet implemented"  
                              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)  
10                                         })                                         })
11    
12                           tdcl <- new("textdoccol", .Data = tdl)  plaintext.parser <- function(file, lod) {
13                       })      id <- file
14                tdcl      origin <- dirname(file)
           })  
15    
16  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file      doc <- new("PlainTextDocument", FileName = file, Cached = FALSE, Author = "Unknown",
17  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {                 DateTimeStamp = date(), Description = "", ID = id, Origin = origin, Heading = "")
18      author <- "Not yet implemented"  
19      timestamp <- xmlAttrs(node)[["date"]]      if (lod) {
20      description <- "Not yet implemented"          doc <- loadFileIntoMem(doc)
21      id <- as.integer(xmlAttrs(node)[["itemid"]])      }
22      origin <- "Not yet implemented"  
23      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      return(doc)
24    }
25    
26    reuters21578xml.parser <- function(file, lod) {
27        tree <- xmlTreeParse(file)
28        node <- xmlRoot(tree)
29    
30        # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
31        if (!is.null(node[["TEXT"]][["AUTHOR"]]))
32            author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
33        else
34            author <- ""
35    
36        datetimestamp <- xmlValue(node[["DATE"]])
37        description <- ""
38        id <- xmlAttrs(node)[["NEWID"]]
39    
40      if (stripWhiteSpace)      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
41          corpus <- gsub("[[:space:]]+", " ", corpus)      if (!is.null(node[["TEXT"]][["TITLE"]]))
42      if (toLower)          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
43          corpus <- tolower(corpus)      else
44            heading <- ""
45    
46        topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
47    
48        doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = author,
49                   DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
50                   Heading = heading, LocalMetaData = list(Topics = topics))
51    
52        if (lod) {
53            doc <- loadFileIntoMem(doc)
54        }
55    
56        return(doc)
57    }
58    
59    rcv1.parser <- function(file, lod) {
60        tree <- xmlTreeParse(file)
61        node <- xmlRoot(tree)
62    
63        datetimestamp <- xmlAttrs(node)[["date"]]
64        id <- xmlAttrs(node)[["itemid"]]
65      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
66    
67      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = "",
68          description = description, id = id, origin = origin, heading = heading)                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
69                   Heading = heading)
70    
71        if (lod) {
72            doc <- loadFileIntoMem(doc)
73        }
74    
75        return(doc)
76    }
77    
78    uci.kdd.newsgroup.parser <-  function(file, lod) {
79        mail <- readLines(file)
80        author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
81        datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
82        origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
83        heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
84        newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
85    
86        new("NewsgroupDocument", FileName = file, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
87            Description = "", ID = file, Origin = origin, Heading = heading, Newsgroup = newsgroup)
88    
89        if (lod) {
90            doc <- loadFileIntoMem(doc)
91        }
92    
93        return(doc)
94    }
95    
96    # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
97    rcv1.to.plain <- function(node) {
98        datetimestamp <- xmlAttrs(node)[["date"]]
99        id <- xmlAttrs(node)[["itemid"]]
100        origin <- "Reuters Corpus Volume 1 XML"
101        corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
102        heading <- xmlValue(node[["title"]])
103    
104        new("PlainTextDocument", .Data = corpus, Author = "", DateTimeStamp = datetimestamp,
105            Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
106  }  }
107    
108  # 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
109  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  reuters21578xml.to.plain <- function(node) {
110      author <- "Not yet implemented"      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
111      timestamp <- xmlValue(node[["DATE"]])      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
112      description <- "Not yet implemented"          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
113      id <- as.integer(xmlAttrs(node)[["NEWID"]])      else
114            author <- ""
115    
116        datetimestamp <- xmlValue(node[["DATE"]])
117        description <- ""
118        id <- xmlAttrs(node)[["NEWID"]]
119    
120      origin <- "Not yet implemented"      origin <- "Reuters-21578 XML"
121    
122      # The <BODY></BODY> tag is unfortunately NOT obligatory!      # The <BODY></BODY> tag is unfortunately NOT obligatory!
123      if (!is.null(node[["TEXT"]][["BODY"]]))      if (!is.null(node[["TEXT"]][["BODY"]]))
# Line 98  Line 125 
125      else      else
126          corpus <- ""          corpus <- ""
127    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
128      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
129      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
130          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
131      else      else
132          heading <- ""          heading <- ""
133    
134      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
135          description = description, id = id, origin = origin, heading = heading)  
136        new("PlainTextDocument", .Data = corpus, Cached = TRUE, Author = author, DateTimeStamp = datetimestamp,
137            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
138  }  }
139    
140    setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))
141    setMethod("loadFileIntoMem",
142              signature(object = "PlainTextDocument"),
143              function(object) {
144                  if (!Cached(object)) {
145                      corpus <- readLines(FileName(object))
146                      Corpus(object) <- corpus
147                      Cached(object) <- TRUE
148                      return(object)
149                  } else {
150                      return(object)
151                  }
152              })
153    setMethod("loadFileIntoMem",
154              signature(object =  "XMLTextDocument"),
155              function(object) {
156                  if (!Cached(object)) {
157                      file <- FileName(object)
158                      doc <- xmlTreeParse(file)
159                      class(doc) <- "list"
160                      Corpus(object) <- doc
161                      Cached(object) <- TRUE
162                      return(object)
163                  } else {
164                      return(object)
165                  }
166              })
167    setMethod("loadFileIntoMem",
168              signature(object = "NewsgroupDocument"),
169              function(object) {
170                  if (!Cached(object)) {
171                      mail <- readLines(FileName(object))
172                      Cached(object) <- TRUE
173                      index <- grep("^Lines:", mail)
174                      Corpus(object) <- mail[(index + 1):length(mail)]
175                      return(object)
176                  } else {
177                      return(object)
178                  }
179              })
180    
181    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
182    setMethod("tm_transform",
183              signature(object = "TextDocCol", FUN = "function"),
184              function(object, FUN, ...) {
185                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
186                  result@GlobalMetaData <- GlobalMetaData(object)
187                  return(result)
188              })
189    
190    setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
191    setMethod("toPlainTextDocument",
192              signature(object = "PlainTextDocument"),
193              function(object, FUN, ...) {
194                  return(object)
195              })
196    setMethod("toPlainTextDocument",
197              signature(object = "XMLTextDocument", FUN = "function"),
198              function(object, FUN, ...) {
199                  if (!Cached(object))
200                      object <- loadFileIntoMem(object)
201    
202                  corpus <- Corpus(object)
203    
204                  # As XMLDocument is no native S4 class, restore valid information
205                  class(corpus) <- "XMLDocument"
206                  names(corpus) <- c("doc","dtd")
207    
208                  return(FUN(xmlRoot(corpus), ...))
209              })
210    
211    setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
212    setMethod("stemTextDocument",
213              signature(object = "PlainTextDocument"),
214              function(object, ...) {
215                  if (!Cached(object))
216                      object <- loadFileIntoMem(object)
217    
218                  require(Rstem)
219                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
220                  stemmedCorpus <- wordStem(splittedCorpus, ...)
221                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
222                  return(object)
223              })
224    
225    setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
226    setMethod("removeStopWords",
227              signature(object = "PlainTextDocument", stopwords = "character"),
228              function(object, stopwords, ...) {
229                  if (!Cached(object))
230                      object <- loadFileIntoMem(object)
231    
232                  require(Rstem)
233                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
234                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
235                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
236                  return(object)
237              })
238    
239    setGeneric("tm_filter", function(object, ..., FUN = s.filter) standardGeneric("tm_filter"))
240    setMethod("tm_filter",
241              signature(object = "TextDocCol"),
242              function(object, ..., FUN = s.filter) {
243                  object[tm_index(object, ..., FUN)]
244              })
245    
246    setGeneric("tm_index", function(object, ..., FUN = s.filter) standardGeneric("tm_index"))
247    setMethod("tm_index",
248              signature(object = "TextDocCol"),
249              function(object, ..., FUN = s.filter) {
250                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
251              })
252    
253    s.filter <- function(object, s, ..., GlobalMetaData) {
254        b <- TRUE
255        for (tag in names(s)) {
256            if (tag %in% names(LocalMetaData(object))) {
257                b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
258            } else if (tag %in% names(GlobalMetaData)){
259                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
260            } else {
261                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
262            }
263        }
264        return(b)
265    }
266    
267    setGeneric("fulltext.search.filter", function(object, pattern, ...) standardGeneric("fulltext.search.filter"))
268    setMethod("fulltext.search.filter",
269              signature(object = "PlainTextDocument", pattern = "character"),
270              function(object, pattern, ...) {
271                  if (!Cached(object))
272                      object <- loadFileIntoMem(object)
273    
274                  return(any(grep(pattern, Corpus(object))))
275              })
276    
277    setGeneric("reuters21578.topic.filter", function(object, topics, ...) standardGeneric("reuters21578.topic.filter"))
278    setMethod("reuters21578.topic.filter",
279              signature(object = "PlainTextDocument", topics = "character"),
280              function(object, topics, ...) {
281                  if (!Cached(object))
282                      object <- loadFileIntoMem(object)
283    
284                  if (any(LocalMetaData(object)$Topics %in% topics))
285                      return(TRUE)
286                  else
287                      return(FALSE)
288              })
289    
290    setGeneric("id.filter", function(object, IDs, ...) standardGeneric("id.filter"))
291    setMethod("id.filter",
292              signature(object = "TextDocument", IDs = "numeric"),
293              function(object, IDs, ...) {
294                  if (ID(object) %in% IDs)
295                      return(TRUE)
296                  else
297                      return(FALSE)
298              })
299    
300    setGeneric("attachData", function(object, data) standardGeneric("attachData"))
301    setMethod("attachData",
302              signature(object = "TextDocCol", data = "TextDocument"),
303              function(object, data) {
304                  data <- as(list(data), "TextDocCol")
305                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
306                  return(object)
307              })
308    
309    setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))
310    setMethod("attachMetaData",
311              signature(object = "TextDocCol"),
312              function(object, name, metadata) {
313                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
314                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
315                  return(object)
316              })
317    
318    setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))
319    setMethod("setSubscriptable",
320              signature(object = "TextDocCol"),
321              function(object, name) {
322                  if (!is.character(GlobalMetaData(object)$subscriptable))
323                      object <- attachMetaData(object, "subscriptable", name)
324                  else
325                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
326                  return(object)
327              })
328    
329    setMethod("[",
330              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
331              function(x, i, j, ... , drop) {
332                  if(missing(i))
333                      return(x)
334    
335                  object <- x
336                  object@.Data <- x@.Data[i, ..., drop = FALSE]
337                  for (m in names(GlobalMetaData(object))) {
338                      if (m %in% GlobalMetaData(object)$subscriptable) {
339                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
340                      }
341                  }
342                  return(object)
343              })
344    
345    setMethod("c",
346              signature(x = "TextDocCol"),
347              function(x, ..., recursive = TRUE){
348                  args <- list(...)
349                  if(length(args) == 0)
350                      return(x)
351                  return(as(c(as(x, "list"), ...), "TextDocCol"))
352        })
353    
354    setMethod("length",
355              signature(x = "TextDocCol"),
356              function(x){
357                  return(length(as(x, "list")))
358        })
359    
360    setMethod("show",
361              signature(object = "TextDocCol"),
362              function(object){
363                  cat("A text document collection with", length(object), "text document")
364                  if (length(object) == 1)
365                      cat("\n")
366                  else
367                      cat("s\n")
368        })
369    
370    setMethod("summary",
371              signature(object = "TextDocCol"),
372              function(object){
373                  show(object)
374                  if (length(GlobalMetaData(object)) > 0) {
375                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
376                      if (length(GlobalMetaData(object)) == 1)
377                          cat(".\n")
378                      else
379                          cat("s.\n")
380                      cat("Available tags are:\n")
381                      cat(names(GlobalMetaData(object)), "\n")
382                  }
383        })
384    
385    setGeneric("inspect", function(object) standardGeneric("inspect"))
386    setMethod("inspect",
387              c("TextDocCol"),
388              function(object) {
389                  summary(object)
390                  cat("\n")
391                  show(as(object, "list"))
392              })

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

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