SCM

SCM Repository

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

Diff of /pkg/R/textdoccol.R

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

revision 48, Thu Jul 13 13:47:31 2006 UTC revision 49, Sun Aug 6 10:12:13 2006 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  setGeneric("textdoccol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("textdoccol"))  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))
4  setMethod("textdoccol",  setMethod("TextDocCol",
5            c("character"),            c("character"),
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {            function(object, inputType = "CSV", 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", "RIS"))                type <- match.arg(inputType,c("CSV", "RCV1_PLAIN", "REUT21578_PLAIN", "REUT21578_XML", "RIS"))
9                switch(type,                switch(type,
10                       # Text in a special CSV format                       # Text in a special CSV format
11                       # For details on the file format see the R documentation file                       # For details on the file format see the R documentation file
# Line 29  Line 29 
29                                                 origin <- "CSV"                                                 origin <- "CSV"
30                                                 heading <- ""                                                 heading <- ""
31    
32                                                 l[[i]] <- new("textdocument", .Data = corpus, author = author, datetimestamp = datetimestamp,                                                 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                                             l                                             l
36                                         })                                         })
37                           if (length(filelist) > 1)                           if (length(filelist) > 1)
38                               tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
39                           else                           else
40                               tdcl <- new("textdoccol", .Data = tdl)                               tdcl <- new("TextDocCol", .Data = tdl)
41                       },                       },
42                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
43                       # The first argument is a directory with the RCV1 XML files                       # The first argument is a directory with the RCV1 XML files
44                       "RCV1" = {                       "RCV1_PLAIN" = {
45                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)
46                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
47                                         function(file) {                                         function(file) {
48                                             tree <- xmlTreeParse(file)                                             tree <- xmlTreeParse(file)
49                                             xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)                                             xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)
50                                         })                                         })
51                           if (length(filelist) > 1)                           if (length(filelist) > 1)
52                               tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
53                           else                           else
54                               tdcl <- new("textdoccol", .Data = tdl)                               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                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)
61                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
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)                           if (length(filelist) > 1)
67                               tdcl <- new("textdoccol", .Data = unlist(tdl, recursive = FALSE))                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
68                           else                           else
69                               tdcl <- new("textdoccol", .Data = tdl)                               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                       # Read in HTML documents as used by http://ris.bka.gv.at/vwgh
83                       "RIS" = {                       "RIS" = {
# Line 74  Line 85 
85                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
86                                         function(file) {                                         function(file) {
87                                             # Ignore warnings from misformed HTML documents                                             # Ignore warnings from misformed HTML documents
88                                             suppressWarnings(RISDoc <- parseHTML(file, stripWhiteSpace, toLower))                                             suppressWarnings(RISDoc <- parseHTMLPlain(file, stripWhiteSpace, toLower))
89                                             if (!is.null(RISDoc)) {                                             if (!is.null(RISDoc)) {
90                                                 l <- list()                                                 l <- list()
91                                                 l[[length(l) + 1]] <- RISDoc                                                 l[[length(l) + 1]] <- RISDoc
92                                                 l                                                 l
93                                             }                                             }
94                                         })                                         })
95                           tdcl <- new("textdoccol", .Data = tdl)                           tdcl <- new("TextDocCol", .Data = tdl)
96                       })                       })
97                tdcl                tdcl
98            })            })
99    
100  # Parse an Austrian RIS HTML document  # Parse an Austrian RIS HTML document
101  parseHTML <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {  parseHTMLPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {
102      author <- ""      author <- ""
103      datetimestamp <- date()      datetimestamp <- date()
104      description <- ""      description <- ""
# Line 120  Line 131 
131    
132      heading <- ""      heading <- ""
133    
134      new("textdocument", .Data = corpus, author = author, datetimestamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
135          description = description, id = id, origin = origin, heading = heading)          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      datetimestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
142      description <- "Not yet implemented"      description <- "Not yet implemented"
# Line 140  Line 151 
151    
152      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
153    
154      new("textdocument", .Data = corpus, author = author, datetimestamp = datetimestamp,      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      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
161      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
162          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
# Line 175  Line 186 
186      else      else
187          heading <- ""          heading <- ""
188    
189      new("textdocument", .Data = corpus, author = author, datetimestamp = datetimestamp,      # 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.48  
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