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

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

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