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 57, Sun Sep 24 14:27:54 2006 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # S4 class definition  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))
4  # Text document collection  setMethod("TextDocCol",
5  setClass("textdoccol",            c("character"),
6           contains = c("list"))            function(object, inputType = "PLAIN", stripWhiteSpace = FALSE, toLower = FALSE) {
   
 # Constructors  
   
 setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))  
 setMethod("textdoccol",  
           c("character", "character", "logical", "logical"),  
           function(object, inputType = "RCV1", stripWhiteSpace = FALSE, toLower = FALSE) {  
   
7                # Add a new type for each unique input source format                # Add a new type for each unique input source format
8                type <- match.arg(inputType,c("RCV1","CSV","REUT21578"))                type <- match.arg(inputType,c("PLAIN", "CSV", "RCV1", "REUT21578", "REUT21578_XML", "NEWSGROUP", "RIS"))
9                switch(type,                switch(type,
10                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format                       # Plain text
11                       # For the moment the first argument is still a single file                       "PLAIN" = {
12                       # This will be changed to a directory as soon as we have the full RCV1 data set                           filelist <- dir(object, full.names = TRUE)
13                       "RCV1" = {                           filenameIDs <- list(FileNames = filelist, IDs = 1:length(filelist))
14                           tree <- xmlTreeParse(object)                           tdl <- sapply(filelist,
15                           tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))                                         function(file, FileNameIDs = filenameIDs) {
16                                               id <- FileNameIDs$IDs[grep(file, FileNameIDs$FileNames)]
17                                               origin <- dirname(file)
18                                               new("PlainTextDocument", FileName = file, Cached = 0, Author = "Unknown", DateTimeStamp = date(),
19                                                   Description = "", ID = id, Origin = origin, Heading = "")
20                                           })
21                             tdcl <- new("TextDocCol", .Data = tdl)
22                       },                       },
23                       # Text in a special CSV format (as e.g. exported from an Excel sheet)                       # Text in a special CSV format
24                       # For details on the file format see data/Umfrage.csv                       # For details on the file format see the R documentation file
25                       # The first argument has to be a single file                       # The first argument is a directory with .csv files
26                       "CSV" = {                       "CSV" = {
27                           m <- as.matrix(read.csv(object))                           filelist <- dir(object, pattern = "\\.csv", full.names = TRUE)
28                             tdl <- sapply(filelist,
29                                           function(file) {
30                                               m <- as.matrix(read.csv(file, header = FALSE))
31                           l <- vector("list", dim(m)[1])                           l <- vector("list", dim(m)[1])
32                           for (i in 1:dim(m)[1]) {                           for (i in 1:dim(m)[1]) {
33                               author <- "Not yet implemented"                                                 author <- ""
34                               timestamp <- date()                                                 datetimestamp <- date()
35                               description <- "Not yet implemented"                                                 description <- ""
36                               id <- i                                                 id <- as.integer(m[i,1])
37                               corpus <- as.character(m[i,2:dim(m)[2]])                               corpus <- as.character(m[i,2:dim(m)[2]])
38                               if (stripWhiteSpace)                               if (stripWhiteSpace)
39                                   corpus <- gsub("[[:space:]]+", " ", corpus)                                   corpus <- gsub("[[:space:]]+", " ", corpus)
40                               if (toLower)                               if (toLower)
41                                   corpus <- tolower(corpus)                                   corpus <- tolower(corpus)
42                               origin <- "Not yet implemented"                                                 origin <- "CSV"
43                               heading <- "Not yet implemented"                                                 heading <- ""
44    
45                               l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,                                                 l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
46                                   description = description, id = id, origin = origin, heading = heading)                                                               Description = description, ID = id, Origin = origin, Heading = heading)
47                           }                           }
48                           tdcl <- new("textdoccol", .Data = l)                                             l
49                                           })
50                             if (length(filelist) > 1)
51                                 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
52                             else
53                                 tdcl <- new("TextDocCol", .Data = tdl)
54                         },
55                         # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
56                         # The first argument is a directory with the RCV1 XML files
57                         "RCV1" = {
58                             filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
59                             tdl <- sapply(filelist,
60                                           function(file) {
61                                               tree <- xmlTreeParse(file)
62                                               xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)
63                                           })
64                             if (length(filelist) > 1)
65                                 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
66                             else
67                                 tdcl <- new("TextDocCol", .Data = tdl)
68                       },                       },
69                       # Read in text documents in Reuters-21578 XML (not SGML) format                       # Read in text documents in Reuters-21578 XML (not SGML) format
70                       # Typically the first argument will be a directory where we can                       # Typically the first argument will be a directory where we can
71                       # find the files reut2-000.xml ... reut2-021.xml                       # find the files reut2-000.xml ... reut2-021.xml
72                       "REUT21578" = {                       "REUT21578" = {
73                           tdl <- sapply(dir(object,                           filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
74                                             pattern = ".xml",                           tdl <- sapply(filelist,
                                            full.names = TRUE),  
75                                         function(file) {                                         function(file) {
76                                             tree <- xmlTreeParse(file)                                             tree <- xmlTreeParse(file)
77                                             xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)                                             xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)
78                                         })                                         })
79                             if (length(filelist) > 1)
80                           tdcl <- new("textdoccol", .Data = tdl)                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
81                             else
82                                 tdcl <- new("TextDocCol", .Data = tdl)
83                         },
84                         "REUT21578_XML" = {
85                             filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
86                             tdl <- sapply(filelist,
87                                           function(file) {
88                                               parseReutersXML(file)
89                                           })
90                             tdcl <- new("TextDocCol", .Data = tdl)
91                         },
92                         "NEWSGROUP" = {
93                             filelist <- dir(object, full.names = TRUE)
94                             tdl <- sapply(filelist,
95                                           function(file) {
96                                               parseMail(file)
97                                           })
98                             new("TextDocCol", .Data = tdl)
99                         },
100                         # Read in HTML documents as used by http://ris.bka.gv.at/vwgh
101                         "RIS" = {
102                             filelist <- dir(object, pattern = "\\..html", full.names = TRUE)
103                             tdl <- sapply(filelist,
104                                           function(file) {
105                                               # Ignore warnings from misformed HTML documents
106                                               suppressWarnings(RISDoc <- parseRISPlain(file, stripWhiteSpace, toLower))
107                                               if (!is.null(RISDoc)) {
108                                                   l <- list()
109                                                   l[[length(l) + 1]] <- RISDoc
110                                                   l
111                                               }
112                                           })
113                             tdcl <- new("TextDocCol", .Data = tdl)
114                       })                       })
115                tdcl                tdcl
116            })            })
117    
118    # Parse an Austrian RIS HTML document
119    parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {
120        author <- ""
121        datetimestamp <- date()
122        description <- ""
123    
124        tree <- htmlTreeParse(file)
125        htmlElem <- unlist(tree$children$html$children)
126    
127        if (is.null(htmlElem))
128            stop(paste("Empty document", file, "cannot be processed."))
129    
130        textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]
131        names(textElem) <- NULL
132    
133        corpus <- paste(textElem, collapse = " ")
134    
135        year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)
136        senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)
137        number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)
138    
139        id <- as.integer(paste(year, senat, number, sep = ""))
140    
141        if (is.na(id))
142            stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))
143        origin <- ""
144    
145        if (stripWhiteSpace)
146            corpus <- gsub("[[:space:]]+", " ", corpus)
147        if (toLower)
148            corpus <- tolower(corpus)
149    
150        heading <- ""
151    
152        new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
153            Description = description, ID = id, Origin = origin, Heading = heading)
154    }
155    
156  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
157  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
158      author <- "Not yet implemented"      author <- "Not yet implemented"
159      timestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
160      description <- "Not yet implemented"      description <- "Not yet implemented"
161      id <- as.integer(xmlAttrs(node)[["itemid"]])      id <- as.integer(xmlAttrs(node)[["itemid"]])
162      origin <- "Not yet implemented"      origin <- "Reuters Corpus Volume 1 XML"
163      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
164    
165      if (stripWhiteSpace)      if (stripWhiteSpace)
# Line 79  Line 169 
169    
170      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
171    
172      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
173          description = description, id = id, origin = origin, heading = heading)          Description = description, ID = id, Origin = origin, Heading = heading)
174  }  }
175    
176  # 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
177  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
178      author <- "Not yet implemented"      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
179      timestamp <- xmlValue(node[["DATE"]])      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
180      description <- "Not yet implemented"          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
181        else
182            author <- ""
183    
184        datetimestamp <- xmlValue(node[["DATE"]])
185        description <- ""
186      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- as.integer(xmlAttrs(node)[["NEWID"]])
187    
188      origin <- "Not yet implemented"      origin <- "Reuters-21578 XML"
189    
190      # The <BODY></BODY> tag is unfortunately NOT obligatory!      # The <BODY></BODY> tag is unfortunately NOT obligatory!
191      if (!is.null(node[["TEXT"]][["BODY"]]))      if (!is.null(node[["TEXT"]][["BODY"]]))
# Line 109  Line 204 
204      else      else
205          heading <- ""          heading <- ""
206    
207      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
208          description = description, id = id, origin = origin, heading = heading)  
209        new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,
210            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
211    }
212    
213    # Set up metadata for a well-formed Reuters-21578 XML file
214    parseReutersXML<- function(file) {
215        new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),
216            Description = "Reuters21578 file containing several news articles", ID = as.integer(0),
217            Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")
218  }  }
219    
220    parseMail <- function(file) {
221        mail <- readLines(file)
222        author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
223        datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
224        id <- as.integer(file)
225        origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
226        heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
227        newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
228    
229        new("NewsgroupDocument", FileName = file, Cached = 0, Author = author, DateTimeStamp = datetimestamp,
230            Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
231    }
232    
233    setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))
234    setMethod("loadFileIntoMem",
235              c("PlainTextDocument"),
236              function(object, ...) {
237                  if (Cached(object) == 0) {
238                      corpus <- readLines(FileName(object))
239                      Corpus(object) <- corpus
240                      Cached(object) <- 1
241                      return(object)
242                  } else {
243                      return(object)
244                  }
245              })
246    setMethod("loadFileIntoMem",
247              c("XMLTextDocument"),
248              function(object, ...) {
249                  if (Cached(object) == 0) {
250                      file <- FileName(object)
251                      doc <- xmlTreeParse(file)
252                      class(doc) <- "list"
253                      Corpus(object) <- doc
254                      Cached(object) <- 1
255                      return(object)
256                  } else {
257                      return(object)
258                  }
259              })
260    setMethod("loadFileIntoMem",
261              c("NewsgroupDocument"),
262              function(object, ...) {
263                  if (Cached(object) == 0) {
264                      mail <- readLines(FileName(object))
265                      Cached(object) <- 1
266                      index <- grep("^Lines:", mail)
267                      Corpus(object) <- mail[(index + 1):length(mail)]
268                      return(object)
269                  } else {
270                      return(object)
271                  }
272              })
273    
274    setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
275    setMethod("tm_transform",
276              c("TextDocCol"),
277              function(object, FUN, ...) {
278                  result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
279                  result@GlobalMetaData <- GlobalMetaData(object)
280                  return(result)
281              })
282    
283    setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
284    setMethod("toPlainTextDocument",
285              c("PlainTextDocument"),
286              function(object, FUN, ...) {
287                  return(object)
288              })
289    setMethod("toPlainTextDocument",
290              c("XMLTextDocument"),
291              function(object, FUN, ...) {
292                  if (Cached(object) == 0)
293                      object <- loadFileIntoMem(object)
294    
295                  corpus <- Corpus(object)
296    
297                  # As XMLDocument is no native S4 class, restore valid information
298                  class(corpus) <- "XMLDocument"
299                  names(corpus) <- c("doc","dtd")
300    
301                  return(xmlApply(xmlRoot(corpus), FUN, ...))
302              })
303    
304    setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
305    setMethod("stemTextDocument",
306              c("PlainTextDocument"),
307              function(object) {
308                  if (Cached(object) == 0)
309                      object <- loadFileIntoMem(object)
310    
311                  require(Rstem)
312                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
313                  stemmedCorpus <- wordStem(splittedCorpus)
314                  Corpus(object) <- paste(stemmedCorpus, collapse = " ")
315                  return(object)
316              })
317    
318    setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
319    setMethod("removeStopWords",
320              c("PlainTextDocument", "character"),
321              function(object, stopwords) {
322                  if (Cached(object) == 0)
323                      object <- loadFileIntoMem(object)
324    
325                  require(Rstem)
326                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
327                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
328                  Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
329                  return(object)
330              })
331    
332    setGeneric("tm_filter", function(object, FUN, ...) standardGeneric("tm_filter"))
333    setMethod("tm_filter",
334              c("TextDocCol"),
335              function(object, FUN, ...) {
336                  sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
337              })
338    
339    setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))
340    setMethod("filterREUT21578Topics",
341              c("PlainTextDocument", "character"),
342              function(object, topics) {
343                  if (Cached(object) == 0)
344                      object <- loadFileIntoMem(object)
345    
346                  if (any(LocalMetaData(object)$Topics %in% topics))
347                      return(TRUE)
348                  else
349                      return(FALSE)
350              })
351    
352    setGeneric("filterIDs", function(object, IDs, ...) standardGeneric("filterIDs"))
353    setMethod("filterIDs",
354              c("TextDocument", "numeric"),
355              function(object, IDs) {
356                  if (ID(object) %in% IDs)
357                      return(TRUE)
358                  else
359                      return(FALSE)
360              })
361    
362    setGeneric("attachData", function(object, data) standardGeneric("attachData"))
363    setMethod("attachData",
364              c("TextDocCol","TextDocument"),
365              function(object, data) {
366                  data <- as(list(data), "TextDocCol")
367                  object@.Data <- as(c(object@.Data, data), "TextDocCol")
368                  return(object)
369              })
370    
371    setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))
372    setMethod("attachMetaData",
373              c("TextDocCol"),
374              function(object, name, metadata) {
375                  object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
376                  names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
377                  return(object)
378              })
379    
380    setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))
381    setMethod("setSubscriptable",
382              c("TextDocCol"),
383              function(object, name) {
384                  if (!is.character(GlobalMetaData(object)$subscriptable))
385                      object <- attachMetaData(object, "subscriptable", name)
386                  else
387                      object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
388                  return(object)
389              })
390    
391    setMethod("[",
392              signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
393              function(x, i, j, ... , drop) {
394                  if(missing(i))
395                      return(x)
396    
397                  object <- x
398                  object@.Data <- x@.Data[i, ..., drop = FALSE]
399                  for (m in names(GlobalMetaData(object))) {
400                      if (m %in% GlobalMetaData(object)$subscriptable) {
401                          object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
402                      }
403                  }
404                  return(object)
405              })
406    
407    setMethod("c",
408              signature(x = "TextDocCol"),
409              function(x, ..., recursive = TRUE){
410                  args <- list(...)
411                  if(length(args) == 0)
412                      return(x)
413                  return(as(c(as(x, "list"), ...), "TextDocCol"))
414        })
415    
416    setMethod("length",
417              signature(x = "TextDocCol"),
418              function(x){
419                  return(length(as(x, "list")))
420        })
421    
422    setMethod("show",
423              signature(object = "TextDocCol"),
424              function(object){
425                  cat("A text document collection with", length(object), "text document")
426                  if (length(object) == 1)
427                      cat("\n")
428                  else
429                      cat("s\n")
430        })
431    
432    setMethod("summary",
433              signature(object = "TextDocCol"),
434              function(object){
435                  show(object)
436                  if (length(GlobalMetaData(object)) > 0) {
437                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
438                      if (length(GlobalMetaData(object)) == 1)
439                          cat(".\n")
440                      else
441                          cat("s.\n")
442                      cat("Available tags are:\n")
443                      cat(names(GlobalMetaData(object)), "\n")
444                  }
445        })
446    
447    setGeneric("inspect", function(object) standardGeneric("inspect"))
448    setMethod("inspect",
449              c("TextDocCol"),
450              function(object) {
451                  summary(object)
452                  cat("\n")
453                  show(as(object, "list"))
454              })

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

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