SCM

SCM Repository

[tm] Diff of /pkg/R/corpus.R
ViewVC logotype

Diff of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/R/trunk/R/textdoccol.R revision 18, Sat Nov 5 19:00:05 2005 UTC trunk/R/textmin/R/textdoccol.R revision 51, Mon Aug 7 12:14:09 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  # TODO: Define proper S4 term-document matrix            c("character"),
6  setClass("textdoccol", representation(docs = "list",            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {
7                                        tdm = "matrix"))                # Add a new type for each unique input source format
8                  type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "REUT21578_XML", "RIS"))
9  # Accessor function                switch(type,
10  if (!isGeneric("docs")) {                       # Text in a special CSV format
11      if (is.function("docs"))                       # For details on the file format see the R documentation file
12          fun <- docs                       # The first argument is a directory with .csv files
13      else                       "CSV" = {
14          fun <- function(object) standardGeneric("docs")                           filelist <- dir(object, pattern = ".csv", full.names = TRUE)
15      setGeneric("docs", fun)                           tdl <- sapply(filelist,
16  }                                         function(file) {
17  setMethod("docs", "textdoccol", function(object) object@docs)                                             m <- as.matrix(read.csv(file, header = FALSE))
18                                               l <- vector("list", dim(m)[1])
19  setGeneric("textdoccol", function(docs) standardGeneric("textdoccol"))                                             for (i in 1:dim(m)[1]) {
20  # Read in XML text documents                                                 author <- ""
21  # Reuters Corpus Volume 1 (RCV1)                                                 datetimestamp <- date()
22  setMethod("textdoccol", "character", function(docs) {                                                 description <- ""
23      require(XML)                                                 id <- as.integer(m[i,1])
24                                                   corpus <- as.character(m[i,2:dim(m)[2]])
25                                                   if (stripWhiteSpace)
26                                                       corpus <- gsub("[[:space:]]+", " ", corpus)
27                                                   if (toLower)
28                                                       corpus <- tolower(corpus)
29                                                   origin <- "CSV"
30                                                   heading <- ""
31    
32      tree <- xmlTreeParse(docs)                                                 l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
33      root <- xmlRoot(tree)                                                               Description = description, ID = id, Origin = origin, Heading = heading)
34                                               }
35                                               l
36                                           })
37                             if (length(filelist) > 1)
38                                 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
39                             else
40                                 tdcl <- new("TextDocCol", .Data = tdl)
41                         },
42                         # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
43                         # The first argument is a directory with the RCV1 XML files
44                         "RCV1" = {
45                             filelist <- dir(object, pattern = ".xml", full.names = TRUE)
46                             tdl <- sapply(filelist,
47                                           function(file) {
48                                               tree <- xmlTreeParse(file)
49                                               xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)
50                                           })
51                             if (length(filelist) > 1)
52                                 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
53                             else
54                                 tdcl <- new("TextDocCol", .Data = tdl)
55                         },
56                         # Read in text documents in Reuters-21578 XML (not SGML) format
57                         # Typically the first argument will be a directory where we can
58                         # find the files reut2-000.xml ... reut2-021.xml
59                         "REUT21578" = {
60                             filelist <- dir(object, pattern = ".xml", full.names = TRUE)
61                             tdl <- sapply(filelist,
62                                           function(file) {
63                                               tree <- xmlTreeParse(file)
64                                               xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)
65                                           })
66                             if (length(filelist) > 1)
67                                 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
68                             else
69                                 tdcl <- new("TextDocCol", .Data = tdl)
70                         },
71                         "REUT21578_XML" = {
72                             filelist <- dir(object, pattern = ".xml", full.names = TRUE)
73                             tdl <- sapply(filelist,
74                                           function(file) {
75                                               parseReutersXML(file)
76                                           })
77                             tdcl <- new("TextDocCol", .Data = tdl)
78                         },
79                         # Read in HTML documents as used by http://ris.bka.gv.at/vwgh
80                         "RIS" = {
81                             filelist <- dir(object, pattern = ".html", full.names = TRUE)
82                             tdl <- sapply(filelist,
83                                           function(file) {
84                                               # Ignore warnings from misformed HTML documents
85                                               suppressWarnings(RISDoc <- parseRISPlain(file, stripWhiteSpace, toLower))
86                                               if (!is.null(RISDoc)) {
87                                                   l <- list()
88                                                   l[[length(l) + 1]] <- RISDoc
89                                                   l
90                                               }
91                                           })
92                             tdcl <- new("TextDocCol", .Data = tdl)
93                         })
94                  tdcl
95              })
96    
97    # Parse an Austrian RIS HTML document
98    parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {
99        author <- ""
100        datetimestamp <- date()
101        description <- ""
102    
103        tree <- htmlTreeParse(file)
104        htmlElem <- unlist(tree$children$html$children)
105    
106        if (is.null(htmlElem))
107            stop(paste("Empty document", file, "cannot be processed."))
108    
109      # TODO: At each loop node points to the current newsitem      textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]
110      node <- root      names(textElem) <- NULL
111    
112      # TODO: Implement lacking fields.      corpus <- paste(textElem, collapse = " ")
113      # For this we need the full RCV1 XML set to know where to find those things  
114        year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)
115        senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)
116        number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)
117    
118        id <- as.integer(paste(year, senat, number, sep = ""))
119    
120        if (is.na(id))
121            stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))
122        origin <- ""
123    
124        if (stripWhiteSpace)
125            corpus <- gsub("[[:space:]]+", " ", corpus)
126        if (toLower)
127            corpus <- tolower(corpus)
128    
129        heading <- ""
130    
131        new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
132            Description = description, ID = id, Origin = origin, Heading = heading)
133    }
134    
135    # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
136    parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
137      author <- "Not yet implemented"      author <- "Not yet implemented"
138      timestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
139      description <- "Not yet implemented"      description <- "Not yet implemented"
140      id <- as.integer(xmlAttrs(node)[["itemid"]])      id <- as.integer(xmlAttrs(node)[["itemid"]])
141      origin <- "Not yet implemented"      origin <- "Reuters Corpus Volume 1 XML"
142      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
143    
144        if (stripWhiteSpace)
145            corpus <- gsub("[[:space:]]+", " ", corpus)
146        if (toLower)
147            corpus <- tolower(corpus)
148    
149      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
150    
151      doc <- new("textdocument", author = author, timestamp = timestamp, description = description,      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
152                 id = id, origin = origin, corpus = corpus, heading = heading)          Description = description, ID = id, Origin = origin, Heading = heading)
153    }
154    
155    # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
156    parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
157        # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
158        if (!is.null(node[["TEXT"]][["AUTHOR"]]))
159            author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
160        else
161            author <- ""
162    
163        datetimestamp <- xmlValue(node[["DATE"]])
164        description <- ""
165        id <- as.integer(xmlAttrs(node)[["NEWID"]])
166    
167        origin <- "Reuters-21578 XML"
168    
169      new("textdoccol", docs = list(doc), tdm = matrix())      # The <BODY></BODY> tag is unfortunately NOT obligatory!
170        if (!is.null(node[["TEXT"]][["BODY"]]))
171            corpus <- xmlValue(node[["TEXT"]][["BODY"]])
172        else
173            corpus <- ""
174    
175        if (stripWhiteSpace)
176            corpus <- gsub("[[:space:]]+", " ", corpus)
177        if (toLower)
178            corpus <- tolower(corpus)
179    
180        # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
181        if (!is.null(node[["TEXT"]][["TITLE"]]))
182            heading <- xmlValue(node[["TEXT"]][["TITLE"]])
183        else
184            heading <- ""
185    
186        topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
187    
188        new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,
189            Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
190    }
191    
192    # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
193    parseReutersXML<- function(file) {
194        new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),
195            Description = "Reuters21578 file containing several news articles", ID = as.integer(0),
196            Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")
197    }
198    
199    setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))
200    setMethod("loadFileIntoMem",
201              c("XMLTextDocument"),
202              function(object) {
203                  if (object@Cached == 0) {
204                      file <- object@FileName
205                      doc <- xmlTreeParse(file)
206                      class(doc) <- "list"
207                      object@.Data <- doc
208                      object@Cached <- 1
209                      return(object)
210                  } else {
211                      return(object)
212                  }
213              })
214    
215    setGeneric("transformTextDocCol", function(object, FUN, ...) standardGeneric("transformTextDocCol"))
216    setMethod("transformTextDocCol",
217              c("TextDocCol"),
218              function(object, FUN, ...) {
219                  lapply(object, FUN, ...)
220              })
221    
222    setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
223    setMethod("toPlainTextDocument",
224              c("PlainTextDocument"),
225              function(object, FUN, ...) {
226                  return(object)
227              })
228    setMethod("toPlainTextDocument",
229              c("XMLTextDocument"),
230              function(object, FUN, ...) {
231                  if (object@Cached == 0)
232                      object <- loadFileIntoMem(object)
233    
234                  corpus <- object@.Data
235    
236                  # As XMLDocument is no native S4 class, restore valid information
237                  class(corpus) <- "XMLDocument"
238                  names(corpus) <- c("doc","dtd")
239    
240                  return(xmlApply(xmlRoot(corpus), FUN, ...))
241              })
242    
243    setGeneric("stemTextDocument", function(object) standardGeneric("stemTextDocument"))
244    setMethod("stemTextDocument",
245              c("PlainTextDocument"),
246              function(object) {
247                  require(Rstem)
248                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
249                  stemmedCorpus <- wordStem(splittedCorpus)
250                  object@.Data <- paste(stemmedCorpus, collapse = " ")
251                  return (object)
252              })
253    
254    setGeneric("removeStopWordsInTextDocument", function(object, stopwords) standardGeneric("removeStopWordsInTextDocument"))
255    setMethod("removeStopWordsInTextDocument",
256              c("PlainTextDocument", "character"),
257              function(object, stopwords) {
258                  require(Rstem)
259                  splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
260                  noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
261                  object@.Data <- paste(noStopwordsCorpus, collapse = " ")
262                  return (object)
263              })
264    
265    setGeneric("filterTextDocCol", function(object, FUN, ...) standardGeneric("filterTextDocCol"))
266    setMethod("filterTextDocCol",
267              c("TextDocCol"),
268              function(object, FUN, ...) {
269                  sapply(object, FUN, ...)
270              })
271    
272    setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))
273    setMethod("filterREUT21578Topics",
274              c("PlainTextDocument", "character"),
275              function(object, topics, ...) {
276                  if (object@Cached == 0)
277                      object <- loadFileIntoMem(object)
278    
279                  if (any(object@LocalMetaData$Topics %in% topics))
280                      return(TRUE)
281                  else
282                      return(FALSE)
283  })  })

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

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