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 37, Wed Jan 11 17:49:17 2006 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  setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))
4  setMethod("textdoccol",  setMethod("TextDocCol",
5            c("character", "character", "logical", "logical"),            c("character"),
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {            function(object, inputType = "PLAIN", 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("CSV","RCV1","REUT21578"))                type <- match.arg(inputType,c("PLAIN", "CSV", "RCV1", "REUT21578", "REUT21578_XML", "NEWSGROUP", "RIS"))
9                switch(type,                switch(type,
10                         # Plain text
11                         "PLAIN" = {
12                             filelist <- dir(object, full.names = TRUE)
13                             filenameIDs <- list(FileNames = filelist, IDs = 1:length(filelist))
14                             tdl <- sapply(filelist,
15                                           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                       # Text in a special CSV format
24                       # For details on the file format see the R documentation file                       # For details on the file format see the R documentation file
25                       # The first argument is a directory with .csv files                       # The first argument is a directory with .csv files
26                       "CSV" = {                       "CSV" = {
27                           tdl <- sapply(dir(object,                           filelist <- dir(object, pattern = "\\.csv", full.names = TRUE)
28                                             pattern = ".csv",                           tdl <- sapply(filelist,
                                            full.names = TRUE),  
29                                         function(file) {                                         function(file) {
30                                             m <- as.matrix(read.csv(file, header = FALSE))                                             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 <- ""                                                 author <- ""
34                                                 timestamp <- date()                                                 datetimestamp <- date()
35                                                 description <- ""                                                 description <- ""
36                                                 id <- as.integer(m[i,1])                                                 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]])
# Line 30  Line 42 
42                                                 origin <- "CSV"                                                 origin <- "CSV"
43                                                 heading <- ""                                                 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                                             l                                             l
49                                         })                                         })
50                           tdcl <- new("textdoccol", .Data = tdl)                           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                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
56                       # The first argument is a directory with the RCV1 XML files                       # The first argument is a directory with the RCV1 XML files
57                       "RCV1" = {                       "RCV1" = {
58                           tdl <- sapply(dir(object,                           filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
59                                             pattern = ".xml",                           tdl <- sapply(filelist,
                                            full.names = TRUE),  
60                                         function(file) {                                         function(file) {
61                                             tree <- xmlTreeParse(file)                                             tree <- xmlTreeParse(file)
62                                             xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)                                             xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)
63                                         })                                         })
64                           tdcl <- new("textdoccol", .Data = tdl)                           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 = 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)                           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  # TODO: Implement lacking fields as soon I have access to the original RCV1  # 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 <- "Reuters Corpus Volume 1 XML"      origin <- "Reuters Corpus Volume 1 XML"
# Line 82  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      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
179      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
180          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
181      else      else
182          author <- ""          author <- ""
183    
184      timestamp <- xmlValue(node[["DATE"]])      datetimestamp <- xmlValue(node[["DATE"]])
185      description <- ""      description <- ""
186      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- as.integer(xmlAttrs(node)[["NEWID"]])
187    
# Line 117  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.37  
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