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 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  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", "REUT21578", "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" = {
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" = {
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                             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                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        textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]
110        names(textElem) <- NULL
111    
112        corpus <- paste(textElem, collapse = " ")
113    
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  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
136  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  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)      if (stripWhiteSpace)
# Line 79  Line 148 
148    
149      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
150    
151      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
152          description = description, id = id, origin = origin, 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  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
156  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
157      author <- "Not yet implemented"      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
158      timestamp <- xmlValue(node[["DATE"]])      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
159      description <- "Not yet implemented"          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
160        else
161            author <- ""
162    
163        datetimestamp <- xmlValue(node[["DATE"]])
164        description <- ""
165      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- as.integer(xmlAttrs(node)[["NEWID"]])
166    
167      origin <- "Not yet implemented"      origin <- "Reuters-21578 XML"
168    
169      # The <BODY></BODY> tag is unfortunately NOT obligatory!      # The <BODY></BODY> tag is unfortunately NOT obligatory!
170      if (!is.null(node[["TEXT"]][["BODY"]]))      if (!is.null(node[["TEXT"]][["BODY"]]))
# Line 109  Line 183 
183      else      else
184          heading <- ""          heading <- ""
185    
186      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
187          description = description, id = id, origin = origin, heading = heading)  
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.32  
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