SCM

SCM Repository

[tm] Diff of /trunk/R/textmin/R/textdoccol.R
ViewVC logotype

Diff of /trunk/R/textmin/R/textdoccol.R

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

revision 57, Sun Sep 24 14:27:54 2006 UTC revision 60, Sun Oct 22 17:57:47 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, parser = plaintext.parser, lod = FALSE) standardGeneric("TextDocCol"))
4  setMethod("TextDocCol",  setMethod("TextDocCol",
5            c("character"),            signature(object = "character"),
6            function(object, inputType = "PLAIN", stripWhiteSpace = FALSE, toLower = FALSE) {            function(object, parser = plaintext.parser, lod = FALSE) {
               # Add a new type for each unique input source format  
               type <- match.arg(inputType,c("PLAIN", "CSV", "RCV1", "REUT21578", "REUT21578_XML", "NEWSGROUP", "RIS"))  
               switch(type,  
                      # Plain text  
                      "PLAIN" = {  
7                           filelist <- dir(object, full.names = TRUE)                           filelist <- dir(object, full.names = TRUE)
8                           filenameIDs <- list(FileNames = filelist, IDs = 1:length(filelist))                tdl <- lapply(filelist, parser, lod)
9                           tdl <- sapply(filelist,                return(new("TextDocCol", .Data = tdl))
                                        function(file, FileNameIDs = filenameIDs) {  
                                            id <- FileNameIDs$IDs[grep(file, FileNameIDs$FileNames)]  
                                            origin <- dirname(file)  
                                            new("PlainTextDocument", FileName = file, Cached = 0, Author = "Unknown", DateTimeStamp = date(),  
                                                Description = "", ID = id, Origin = origin, Heading = "")  
10                                         })                                         })
                          tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Text in a special CSV format  
                      # For details on the file format see the R documentation file  
                      # The first argument is a directory with .csv files  
                      "CSV" = {  
                          filelist <- dir(object, pattern = "\\.csv", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            m <- as.matrix(read.csv(file, header = FALSE))  
                                            l <- vector("list", dim(m)[1])  
                                            for (i in 1:dim(m)[1]) {  
                                                author <- ""  
                                                datetimestamp <- date()  
                                                description <- ""  
                                                id <- as.integer(m[i,1])  
                                                corpus <- as.character(m[i,2:dim(m)[2]])  
                                                if (stripWhiteSpace)  
                                                    corpus <- gsub("[[:space:]]+", " ", corpus)  
                                                if (toLower)  
                                                    corpus <- tolower(corpus)  
                                                origin <- "CSV"  
                                                heading <- ""  
11    
12                                                 l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  plaintext.parser <- function(file, lod) {
13                                                               Description = description, ID = id, Origin = origin, Heading = heading)      id <- file
14        origin <- dirname(file)
15    
16        doc <- new("PlainTextDocument", FileName = file, Cached = FALSE, Author = "Unknown",
17                   DateTimeStamp = date(), Description = "", ID = id, Origin = origin, Heading = "")
18    
19        if (lod) {
20            doc <- loadFileIntoMem(doc)
21                                             }                                             }
22                                             l  
23                                         })      return(doc)
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  
                      # The first argument is a directory with the RCV1 XML files  
                      "RCV1" = {  
                          filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in text documents in Reuters-21578 XML (not SGML) format  
                      # Typically the first argument will be a directory where we can  
                      # find the files reut2-000.xml ... reut2-021.xml  
                      "REUT21578" = {  
                          filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      "REUT21578_XML" = {  
                          filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            parseReutersXML(file)  
                                        })  
                          tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      "NEWSGROUP" = {  
                          filelist <- dir(object, full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            parseMail(file)  
                                        })  
                          new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in HTML documents as used by http://ris.bka.gv.at/vwgh  
                      "RIS" = {  
                          filelist <- dir(object, pattern = "\\..html", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            # Ignore warnings from misformed HTML documents  
                                            suppressWarnings(RISDoc <- parseRISPlain(file, stripWhiteSpace, toLower))  
                                            if (!is.null(RISDoc)) {  
                                                l <- list()  
                                                l[[length(l) + 1]] <- RISDoc  
                                                l  
24                                             }                                             }
                                        })  
                          tdcl <- new("TextDocCol", .Data = tdl)  
                      })  
               tdcl  
           })  
25    
26  # Parse an Austrian RIS HTML document  reuter21578xml.parser <- function(file, lod) {
27  parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {      tree <- xmlTreeParse(file)
28        node <- xmlRoot(tree)
29    
30        # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
31        if (!is.null(node[["TEXT"]][["AUTHOR"]]))
32            author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
33        else
34      author <- ""      author <- ""
35      datetimestamp <- date()  
36        datetimestamp <- xmlValue(node[["DATE"]])
37      description <- ""      description <- ""
38        id <- xmlAttrs(node)[["NEWID"]]
39    
40        # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
41        if (!is.null(node[["TEXT"]][["TITLE"]]))
42            heading <- xmlValue(node[["TEXT"]][["TITLE"]])
43        else
44            heading <- ""
45    
46      tree <- htmlTreeParse(file)      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
     htmlElem <- unlist(tree$children$html$children)  
47    
48      if (is.null(htmlElem))      doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = author,
49          stop(paste("Empty document", file, "cannot be processed."))                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
50                   Heading = heading, LocalMetaData = list(Topics = topics))
51    
52      textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]      if (lod) {
53      names(textElem) <- NULL          doc <- loadFileIntoMem(doc)
54        }
55    
56      corpus <- paste(textElem, collapse = " ")      return(doc)
57    }
58    
59      year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)  rcv1.parser <- function(file, lod) {
60      senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)      tree <- xmlTreeParse(file)
61      number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)      node <- xmlRoot(tree)
62    
63      id <- as.integer(paste(year, senat, number, sep = ""))      datetimestamp <- xmlAttrs(node)[["date"]]
64        id <- xmlAttrs(node)[["itemid"]]
65        heading <- xmlValue(node[["title"]])
66    
67      if (is.na(id))      doc <- new("XMLTextDocument", FileName = file, Cached = FALSE, Author = "",
68          stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))                 DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
69      origin <- ""                 Heading = heading)
70    
71      if (stripWhiteSpace)      if (lod) {
72          corpus <- gsub("[[:space:]]+", " ", corpus)          doc <- loadFileIntoMem(doc)
73      if (toLower)      }
         corpus <- tolower(corpus)  
74    
75      heading <- ""      return(doc)
76    }
77    
78    uci.kdd.newsgroup.parser <-  function(file, lod) {
79        mail <- readLines(file)
80        author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
81        datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
82        origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
83        heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
84        newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
85    
86        new("NewsgroupDocument", FileName = file, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
87            Description = "", ID = file, Origin = origin, Heading = heading, Newsgroup = newsgroup)
88    
89      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,      if (lod) {
90          Description = description, ID = id, Origin = origin, Heading = heading)          doc <- loadFileIntoMem(doc)
91        }
92    
93        return(doc)
94  }  }
95    
96  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
97  parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  # TODO: Check if it works with example
98      author <- "Not yet implemented"  rcv1.to.plain <- function(node) {
99      datetimestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
100      description <- "Not yet implemented"      id <- xmlAttrs(node)[["itemid"]]
     id <- as.integer(xmlAttrs(node)[["itemid"]])  
101      origin <- "Reuters Corpus Volume 1 XML"      origin <- "Reuters Corpus Volume 1 XML"
102      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
103      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
104    
105      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Author = "", DateTimeStamp = datetimestamp,
106          Description = description, ID = id, Origin = origin, Heading = heading)          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
107  }  }
108    
109  # 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
110  parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  # TODO: Ensure it works
111    reuters21578xml.to.plain <- function(node) {
112      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
113      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
114          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
# Line 183  Line 117 
117    
118      datetimestamp <- xmlValue(node[["DATE"]])      datetimestamp <- xmlValue(node[["DATE"]])
119      description <- ""      description <- ""
120      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- xmlAttrs(node)[["NEWID"]]
121    
122      origin <- "Reuters-21578 XML"      origin <- "Reuters-21578 XML"
123    
# Line 193  Line 127 
127      else      else
128          corpus <- ""          corpus <- ""
129    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
130      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
131      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
132          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
# Line 206  Line 135 
135    
136      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
137    
138      new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, Author = author, DateTimeStamp = datetimestamp,
139          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
140  }  }
141    
 # Set up metadata for a well-formed Reuters-21578 XML file  
 parseReutersXML<- function(file) {  
     new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),  
         Description = "Reuters21578 file containing several news articles", ID = as.integer(0),  
         Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")  
 }  
   
 parseMail <- function(file) {  
     mail <- readLines(file)  
     author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))  
     datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))  
     id <- as.integer(file)  
     origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))  
     heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))  
     newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))  
   
     new("NewsgroupDocument", FileName = file, Cached = 0, Author = author, DateTimeStamp = datetimestamp,  
         Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)  
 }  
   
142  setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))  setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))
143  setMethod("loadFileIntoMem",  setMethod("loadFileIntoMem",
144            c("PlainTextDocument"),            c("PlainTextDocument"),
145            function(object, ...) {            function(object, ...) {
146                if (Cached(object) == 0) {                if (Cached(object) == FALSE) {
147                    corpus <- readLines(FileName(object))                    corpus <- readLines(FileName(object))
148                    Corpus(object) <- corpus                    Corpus(object) <- corpus
149                    Cached(object) <- 1                    Cached(object) <- TRUE
150                    return(object)                    return(object)
151                } else {                } else {
152                    return(object)                    return(object)
# Line 246  Line 155 
155  setMethod("loadFileIntoMem",  setMethod("loadFileIntoMem",
156            c("XMLTextDocument"),            c("XMLTextDocument"),
157            function(object, ...) {            function(object, ...) {
158                if (Cached(object) == 0) {                if (Cached(object) == FALSE) {
159                    file <- FileName(object)                    file <- FileName(object)
160                    doc <- xmlTreeParse(file)                    doc <- xmlTreeParse(file)
161                    class(doc) <- "list"                    class(doc) <- "list"
162                    Corpus(object) <- doc                    Corpus(object) <- doc
163                    Cached(object) <- 1                    Cached(object) <- TRUE
164                    return(object)                    return(object)
165                } else {                } else {
166                    return(object)                    return(object)
# Line 260  Line 169 
169  setMethod("loadFileIntoMem",  setMethod("loadFileIntoMem",
170            c("NewsgroupDocument"),            c("NewsgroupDocument"),
171            function(object, ...) {            function(object, ...) {
172                if (Cached(object) == 0) {                if (Cached(object) == FALSE) {
173                    mail <- readLines(FileName(object))                    mail <- readLines(FileName(object))
174                    Cached(object) <- 1                    Cached(object) <- TRUE
175                    index <- grep("^Lines:", mail)                    index <- grep("^Lines:", mail)
176                    Corpus(object) <- mail[(index + 1):length(mail)]                    Corpus(object) <- mail[(index + 1):length(mail)]
177                    return(object)                    return(object)
# Line 289  Line 198 
198  setMethod("toPlainTextDocument",  setMethod("toPlainTextDocument",
199            c("XMLTextDocument"),            c("XMLTextDocument"),
200            function(object, FUN, ...) {            function(object, FUN, ...) {
201                if (Cached(object) == 0)                if (Cached(object) == FALSE)
202                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
203    
204                corpus <- Corpus(object)                corpus <- Corpus(object)
# Line 298  Line 207 
207                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
208                names(corpus) <- c("doc","dtd")                names(corpus) <- c("doc","dtd")
209    
210                return(xmlApply(xmlRoot(corpus), FUN, ...))                return(FUN(xmlRoot(corpus), ...)))
211            })            })
212    
213  setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))  setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
214  setMethod("stemTextDocument",  setMethod("stemTextDocument",
215            c("PlainTextDocument"),            c("PlainTextDocument"),
216            function(object) {            function(object) {
217                if (Cached(object) == 0)                if (Cached(object) == FALSE)
218                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
219    
220                require(Rstem)                require(Rstem)
221                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
222                stemmedCorpus <- wordStem(splittedCorpus)                stemmedCorpus <- wordStem(splittedCorpus, ...)
223                Corpus(object) <- paste(stemmedCorpus, collapse = " ")                Corpus(object) <- paste(stemmedCorpus, collapse = " ")
224                return(object)                return(object)
225            })            })
226    
227  setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))  setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
228  setMethod("removeStopWords",  setMethod("removeStopWords",
229            c("PlainTextDocument", "character"),            signature(object = "PlainTextDocument", stopwords = "character"),
230            function(object, stopwords) {            function(object, stopwords) {
231                if (Cached(object) == 0)                if (Cached(object) == FALSE)
232                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
233    
234                require(Rstem)                require(Rstem)
# Line 340  Line 249 
249  setMethod("filterREUT21578Topics",  setMethod("filterREUT21578Topics",
250            c("PlainTextDocument", "character"),            c("PlainTextDocument", "character"),
251            function(object, topics) {            function(object, topics) {
252                if (Cached(object) == 0)                if (Cached(object) == FALSE)
253                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
254    
255                if (any(LocalMetaData(object)$Topics %in% topics))                if (any(LocalMetaData(object)$Topics %in% topics))

Legend:
Removed from v.57  
changed lines
  Added in v.60

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