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 60, Sun Oct 22 17:57:47 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    reuter21578xml.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        # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
41        if (!is.null(node[["TEXT"]][["TITLE"]]))
42            heading <- xmlValue(node[["TEXT"]][["TITLE"]])
43        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      if (stripWhiteSpace)      return(doc)
57          corpus <- gsub("[[:space:]]+", " ", corpus)  }
58      if (toLower)  
59          corpus <- tolower(corpus)  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"]])
66    
67        doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = "",
68                   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    # TODO: Check if it works with example
98    rcv1.to.plain <- function(node) {
99        datetimestamp <- xmlAttrs(node)[["date"]]
100        id <- xmlAttrs(node)[["itemid"]]
101        origin <- "Reuters Corpus Volume 1 XML"
102        corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
103      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
104    
105      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      new("PlainTextDocument", .Data = corpus, Author = "", DateTimeStamp = datetimestamp,
106          description = description, id = id, origin = origin, heading = heading)          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
107  }  }
108    
109  # 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
110  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  # TODO: Ensure it works
111      author <- "Not yet implemented"  reuters21578xml.to.plain <- function(node) {
112      timestamp <- xmlValue(node[["DATE"]])      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
113      description <- "Not yet implemented"      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
114      id <- as.integer(xmlAttrs(node)[["NEWID"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
115        else
116            author <- ""
117    
118        datetimestamp <- xmlValue(node[["DATE"]])
119        description <- ""
120        id <- xmlAttrs(node)[["NEWID"]]
121    
122      origin <- "Not yet implemented"      origin <- "Reuters-21578 XML"
123    
124      # The <BODY></BODY> tag is unfortunately NOT obligatory!      # The <BODY></BODY> tag is unfortunately NOT obligatory!
125      if (!is.null(node[["TEXT"]][["BODY"]]))      if (!is.null(node[["TEXT"]][["BODY"]]))
# Line 98  Line 127 
127      else      else
128          corpus <- ""          corpus <- ""
129    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
130      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
131      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
132          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
133      else      else
134          heading <- ""          heading <- ""
135    
136      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
137          description = description, id = id, origin = origin, heading = heading)  
138        new("PlainTextDocument", .Data = corpus, Cached = TRUE, Author = author, DateTimeStamp = datetimestamp,
139            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
140    }
141    
142    setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))
143    setMethod("loadFileIntoMem",
144              c("PlainTextDocument"),
145              function(object, ...) {
146                  if (Cached(object) == FALSE) {
147                      corpus <- readLines(FileName(object))
148                      Corpus(object) <- corpus
149                      Cached(object) <- TRUE
150                      return(object)
151                  } else {
152                      return(object)
153  }  }
154              })
155    setMethod("loadFileIntoMem",
156              c("XMLTextDocument"),
157              function(object, ...) {
158                  if (Cached(object) == FALSE) {
159                      file <- FileName(object)
160                      doc <- xmlTreeParse(file)
161                      class(doc) <- "list"
162                      Corpus(object) <- doc
163                      Cached(object) <- TRUE
164                      return(object)
165                  } else {
166                      return(object)
167                  }
168              })
169    setMethod("loadFileIntoMem",
170              c("NewsgroupDocument"),
171              function(object, ...) {
172                  if (Cached(object) == FALSE) {
173                      mail <- readLines(FileName(object))
174                      Cached(object) <- TRUE
175                      index <- grep("^Lines:", mail)
176                      Corpus(object) <- mail[(index + 1):length(mail)]
177                      return(object)
178                  } else {
179                      return(object)
180                  }
181              })
182    
183    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
184    setMethod("tm_transform",
185              c("TextDocCol"),
186              function(object, FUN, ...) {
187                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
188                  result@GlobalMetaData <- GlobalMetaData(object)
189                  return(result)
190              })
191    
192    setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
193    setMethod("toPlainTextDocument",
194              c("PlainTextDocument"),
195              function(object, FUN, ...) {
196                  return(object)
197              })
198    setMethod("toPlainTextDocument",
199              c("XMLTextDocument"),
200              function(object, FUN, ...) {
201                  if (Cached(object) == FALSE)
202                      object <- loadFileIntoMem(object)
203    
204                  corpus <- Corpus(object)
205    
206                  # As XMLDocument is no native S4 class, restore valid information
207                  class(corpus) <- "XMLDocument"
208                  names(corpus) <- c("doc","dtd")
209    
210                  return(FUN(xmlRoot(corpus), ...)))
211              })
212    
213    setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
214    setMethod("stemTextDocument",
215              c("PlainTextDocument"),
216              function(object) {
217                  if (Cached(object) == FALSE)
218                      object <- loadFileIntoMem(object)
219    
220                  require(Rstem)
221                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
222                  stemmedCorpus <- wordStem(splittedCorpus, ...)
223                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
224                  return(object)
225              })
226    
227    setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
228    setMethod("removeStopWords",
229              signature(object = "PlainTextDocument", stopwords = "character"),
230              function(object, stopwords) {
231                  if (Cached(object) == FALSE)
232                      object <- loadFileIntoMem(object)
233    
234                  require(Rstem)
235                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
236                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
237                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
238                  return(object)
239              })
240    
241    setGeneric("tm_filter", function(object, FUN, ...) standardGeneric("tm_filter"))
242    setMethod("tm_filter",
243              c("TextDocCol"),
244              function(object, FUN, ...) {
245                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
246              })
247    
248    setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))
249    setMethod("filterREUT21578Topics",
250              c("PlainTextDocument", "character"),
251              function(object, topics) {
252                  if (Cached(object) == FALSE)
253                      object <- loadFileIntoMem(object)
254    
255                  if (any(LocalMetaData(object)$Topics %in% topics))
256                      return(TRUE)
257                  else
258                      return(FALSE)
259              })
260    
261    setGeneric("filterIDs", function(object, IDs, ...) standardGeneric("filterIDs"))
262    setMethod("filterIDs",
263              c("TextDocument", "numeric"),
264              function(object, IDs) {
265                  if (ID(object) %in% IDs)
266                      return(TRUE)
267                  else
268                      return(FALSE)
269              })
270    
271    setGeneric("attachData", function(object, data) standardGeneric("attachData"))
272    setMethod("attachData",
273              c("TextDocCol","TextDocument"),
274              function(object, data) {
275                  data <- as(list(data), "TextDocCol")
276                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
277                  return(object)
278              })
279    
280    setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))
281    setMethod("attachMetaData",
282              c("TextDocCol"),
283              function(object, name, metadata) {
284                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
285                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
286                  return(object)
287              })
288    
289    setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))
290    setMethod("setSubscriptable",
291              c("TextDocCol"),
292              function(object, name) {
293                  if (!is.character(GlobalMetaData(object)$subscriptable))
294                      object <- attachMetaData(object, "subscriptable", name)
295                  else
296                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
297                  return(object)
298              })
299    
300    setMethod("[",
301              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
302              function(x, i, j, ... , drop) {
303                  if(missing(i))
304                      return(x)
305    
306                  object <- x
307                  object@.Data <- x@.Data[i, ..., drop = FALSE]
308                  for (m in names(GlobalMetaData(object))) {
309                      if (m %in% GlobalMetaData(object)$subscriptable) {
310                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
311                      }
312                  }
313                  return(object)
314              })
315    
316    setMethod("c",
317              signature(x = "TextDocCol"),
318              function(x, ..., recursive = TRUE){
319                  args <- list(...)
320                  if(length(args) == 0)
321                      return(x)
322                  return(as(c(as(x, "list"), ...), "TextDocCol"))
323        })
324    
325    setMethod("length",
326              signature(x = "TextDocCol"),
327              function(x){
328                  return(length(as(x, "list")))
329        })
330    
331    setMethod("show",
332              signature(object = "TextDocCol"),
333              function(object){
334                  cat("A text document collection with", length(object), "text document")
335                  if (length(object) == 1)
336                      cat("\n")
337                  else
338                      cat("s\n")
339        })
340    
341    setMethod("summary",
342              signature(object = "TextDocCol"),
343              function(object){
344                  show(object)
345                  if (length(GlobalMetaData(object)) > 0) {
346                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
347                      if (length(GlobalMetaData(object)) == 1)
348                          cat(".\n")
349                      else
350                          cat("s.\n")
351                      cat("Available tags are:\n")
352                      cat(names(GlobalMetaData(object)), "\n")
353                  }
354        })
355    
356    setGeneric("inspect", function(object) standardGeneric("inspect"))
357    setMethod("inspect",
358              c("TextDocCol"),
359              function(object) {
360                  summary(object)
361                  cat("\n")
362                  show(as(object, "list"))
363              })

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

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