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

revision 53, Thu Aug 24 13:06:50 2006 UTC revision 66, Tue Oct 31 22:03:33 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"))  # The "..." are additional arguments for the function_generator parser
4    setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))
5  setMethod("TextDocCol",  setMethod("TextDocCol",
6            c("character"),            signature(object = "Source"),
7            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {            function(object, parser = plaintext_parser) {
8                # Add a new type for each unique input source format                if (inherits(parser, "function_generator"))
9                type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "REUT21578_XML", "RIS"))                    parser <- parser(...)
10                switch(type,  
11                       # Text in a special CSV format                tdl <- list()
12                       # For details on the file format see the R documentation file                counter <- 1
13                       # The first argument is a directory with .csv files                while (!eoi(object)) {
14                       "CSV" = {                    object <- step_next(object)
15                           filelist <- dir(object, pattern = ".csv", full.names = TRUE)                    elem <- get_elem(object)
16                           tdl <- sapply(filelist,                    # If there is no Load on Demand support
17                                         function(file) {                    # we need to load the corpus into memory at startup
18                                             m <- as.matrix(read.csv(file, header = FALSE))                    if (object@LoDSupport)
19                                             l <- vector("list", dim(m)[1])                        load <- object@Load
20                                             for (i in 1:dim(m)[1]) {                    else
21                                                 author <- ""                        load <- TRUE
22                                                 datetimestamp <- date()                    tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))
23                                                 description <- ""                    counter <- counter + 1
                                                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 <- ""  
   
                                                l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
                                                              Description = description, ID = id, Origin = origin, Heading = heading)  
24                                             }                                             }
25                                             l  
26                  return(new("TextDocCol", .Data = tdl))
27              })
28    
29    setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))
30    setMethod("DirSource",
31              signature(directory = "character"),
32              function(directory, load = FALSE) {
33                  new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),
34                      Position = 0, Load = load)
35              })
36    
37    setGeneric("CSVSource", function(object, isConCall = FALSE) standardGeneric("CSVSource"))
38    setMethod("CSVSource",
39              signature(object = "character"),
40              function(object, isConCall = FALSE) {
41                  if (!isConCall)
42                      object <- paste('file("', object, '")', sep = "")
43                  con <- eval(parse(text = object))
44                  content <- scan(con, what = "character")
45                  close(con)
46                  new("CSVSource", LoDSupport = FALSE, URI = object,
47                      Content = content, Position = 0)
48              })
49    
50    setGeneric("ReutersSource", function(object, isConCall = FALSE) standardGeneric("ReutersSource"))
51    setMethod("ReutersSource",
52              signature(object = "character"),
53              function(object, isConCall = FALSE) {
54                  if (!isConCall)
55                     object <- paste('file("', object, '")', sep = "")
56                  con <- eval(parse(text = object))
57                  corpus <- paste(readLines(con), "\n", collapse = "")
58                  close(con)
59                  tree <- xmlTreeParse(corpus, asText = TRUE)
60                  content <- xmlRoot(tree)$children
61    
62                  new("ReutersSource", LoDSupport = FALSE, URI = object,
63                      Content = content, Position = 0)
64              })
65    
66    setGeneric("step_next", function(object) standardGeneric("step_next"))
67    setMethod("step_next",
68              signature(object = "DirSource"),
69              function(object) {
70                  object@Position <- object@Position + 1
71                  object
72              })
73    setMethod("step_next",
74              signature(object = "CSVSource"),
75              function(object) {
76                  object@Position <- object@Position + 1
77                  object
78              })
79    setMethod("step_next",
80              signature(object = "ReutersSource"),
81              function(object) {
82                  object@Position <- object@Position + 1
83                  object
84              })
85    
86    setGeneric("get_elem", function(object) standardGeneric("get_elem"))
87    setMethod("get_elem",
88              signature(object = "DirSource"),
89              function(object) {
90                  list(content = readLines(object@FileList[object@Position]),
91                       uri = paste('file("', object@FileList[object@Position], '")', sep = ""))
92              })
93    setMethod("get_elem",
94              signature(object = "CSVSource"),
95              function(object) {
96                  list(content = object@Content[object@Position],
97                       uri = object@URI)
98                                         })                                         })
99                           if (length(filelist) > 1)  setMethod("get_elem",
100                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))            signature(object = "ReutersSource"),
101              function(object) {
102                  # Construct a character representation from the XMLNode
103                  con <- textConnection("virtual.file", "w")
104                  saveXML(object@Content[[object@Position]], con)
105                  close(con)
106    
107                  list(content = virtual.file, uri = object@URI)
108              })
109    
110    setGeneric("eoi", function(object) standardGeneric("eoi"))
111    setMethod("eoi",
112              signature(object = "DirSource"),
113              function(object) {
114                  if (length(object@FileList) <= object@Position)
115                      return(TRUE)
116                           else                           else
117                               tdcl <- new("TextDocCol", .Data = tdl)                    return(FALSE)
                      },  
                      # 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)  
                      },  
                      # 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  
                                            }  
118                                         })                                         })
119                           tdcl <- new("TextDocCol", .Data = tdl)  setMethod("eoi",
120              signature(object = "CSVSource"),
121              function(object) {
122                  if (length(object@Content) <= object@Position)
123                      return(TRUE)
124                  else
125                      return(FALSE)
126                       })                       })
127                tdcl  setMethod("eoi",
128              signature(object = "ReutersSource"),
129              function(object) {
130                  if (length(object@Content) <= object@Position)
131                      return(TRUE)
132                  else
133                      return(FALSE)
134            })            })
135    
136  # Parse an Austrian RIS HTML document  plaintext_parser <- function(...) {
137  parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {      function(elem, lodsupport, load, id) {
138            if (!lodsupport || (lodsupport && load)) {
139                doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,
140                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
141            }
142            else {
143                doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,
144                           Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")
145            }
146    
147            return(doc)
148        }
149    }
150    class(plaintext_parser) <- "function_generator"
151    
152    reut21578xml_parser <- function(...) {
153        function(elem, lodsupport, load, id) {
154            corpus <- paste(elem$content, "\n", collapse = "")
155            tree <- xmlTreeParse(corpus, asText = TRUE)
156            node <- xmlRoot(tree)
157    
158            # Mask as list to bypass S4 checks
159            class(tree) <- "list"
160    
161            # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
162            if (!is.null(node[["TEXT"]][["AUTHOR"]]))
163                author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
164            else
165      author <- ""      author <- ""
166      datetimestamp <- date()  
167            datetimestamp <- xmlValue(node[["DATE"]])
168      description <- ""      description <- ""
169            id <- xmlAttrs(node)[["NEWID"]]
170    
171            # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
172            if (!is.null(node[["TEXT"]][["TITLE"]]))
173                heading <- xmlValue(node[["TEXT"]][["TITLE"]])
174            else
175                heading <- ""
176    
177      tree <- htmlTreeParse(file)          topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
     htmlElem <- unlist(tree$children$html$children)  
178    
179      if (is.null(htmlElem))          if (!lodsupport || (lodsupport && load)) {
180          stop(paste("Empty document", file, "cannot be processed."))              doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,
181                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
182                           Heading = heading, LocalMetaData = list(Topics = topics))
183            } else {
184                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,
185                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",
186                           Heading = heading, LocalMetaData = list(Topics = topics))
187            }
188    
189      textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]          return(doc)
190      names(textElem) <- NULL      }
191    }
192    class(reut21578xml_parser) <- "function_generator"
193    
194      corpus <- paste(textElem, collapse = " ")  rcv1_parser <- function(...) {
195        function(elem, lodsupport, load, id) {
196            corpus <- paste(elem$content, "\n", collapse = "")
197            tree <- xmlTreeParse(corpus, asText = TRUE)
198            node <- xmlRoot(tree)
199    
200      year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)          # Mask as list to bypass S4 checks
201      senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)          class(tree) <- "list"
     number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)  
202    
203      id <- as.integer(paste(year, senat, number, sep = ""))          datetimestamp <- xmlAttrs(node)[["date"]]
204            id <- xmlAttrs(node)[["itemid"]]
205            heading <- xmlValue(node[["title"]])
206    
207      if (is.na(id))          if (!lodsupport || (lodsupport && load)) {
208          stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))              doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",
209      origin <- ""                         DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
210                           Heading = heading)
211            } else {
212                doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",
213                           DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",
214                           Heading = heading)
215            }
216    
217      if (stripWhiteSpace)          return(doc)
218          corpus <- gsub("[[:space:]]+", " ", corpus)      }
219      if (toLower)  }
220          corpus <- tolower(corpus)  class(rcv1_parser) <- "function_generator"
221    
222      heading <- ""  newsgroup_parser <- function(...) {
223        function(elem, lodsupport, load, id) {
224            mail <- elem$content
225            author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
226            datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
227            origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
228            heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
229            newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
230    
231            if (!lodsupport || (lodsupport && load)) {
232                # The header is separated from the body by a blank line.
233                # Reference: \url{http://en.wikipedia.org/wiki/E-mail#Internet_e-mail_format}
234                for (index in seq(along = mail)) {
235                    if (mail[index] == "")
236                        break
237                }
238                content <- mail[(index + 1):length(mail)]
239    
240      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,              doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,
241          Description = description, ID = id, Origin = origin, Heading = heading)                         Author = author, DateTimeStamp = datetimestamp,
242                           Description = "", ID = id, Origin = origin,
243                           Heading = heading, Newsgroup = newsgroup)
244            } else {
245                doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,
246                           Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
247  }  }
248    
249            return(doc)
250        }
251    }
252    class(newsgroup_parser) <- "function_generator"
253    
254  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
255  parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  rcv1_to_plain <- function(node, ...) {
     author <- "Not yet implemented"  
256      datetimestamp <- xmlAttrs(node)[["date"]]      datetimestamp <- xmlAttrs(node)[["date"]]
257      description <- "Not yet implemented"      id <- xmlAttrs(node)[["itemid"]]
     id <- as.integer(xmlAttrs(node)[["itemid"]])  
258      origin <- "Reuters Corpus Volume 1 XML"      origin <- "Reuters Corpus Volume 1 XML"
259      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)  
   
260      heading <- xmlValue(node[["title"]])      heading <- xmlValue(node[["title"]])
261    
262      new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,
263          Description = description, ID = id, Origin = origin, Heading = heading)          Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)
264  }  }
265    
266  # 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
267  parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  reut21578xml_to_plain <- function(node, ...) {
268      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!      # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
269      if (!is.null(node[["TEXT"]][["AUTHOR"]]))      if (!is.null(node[["TEXT"]][["AUTHOR"]]))
270          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])          author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
# Line 162  Line 273 
273    
274      datetimestamp <- xmlValue(node[["DATE"]])      datetimestamp <- xmlValue(node[["DATE"]])
275      description <- ""      description <- ""
276      id <- as.integer(xmlAttrs(node)[["NEWID"]])      id <- xmlAttrs(node)[["NEWID"]]
277    
278      origin <- "Reuters-21578 XML"      origin <- "Reuters-21578 XML"
279    
# Line 172  Line 283 
283      else      else
284          corpus <- ""          corpus <- ""
285    
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
286      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
287      if (!is.null(node[["TEXT"]][["TITLE"]]))      if (!is.null(node[["TEXT"]][["TITLE"]]))
288          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          heading <- xmlValue(node[["TEXT"]][["TITLE"]])
# Line 185  Line 291 
291    
292      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
293    
294      new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,      new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,
295          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
296  }  }
297    
298  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))
299  parseReutersXML<- function(file) {  setMethod("load_doc",
300      new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),            signature(object = "PlainTextDocument"),
301          Description = "Reuters21578 file containing several news articles", ID = as.integer(0),            function(object, ...) {
302          Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")                if (!Cached(object)) {
303                      con <- eval(parse(text = URI(object)))
304                      corpus <- readLines(con)
305                      close(con)
306                      Corpus(object) <- corpus
307                      Cached(object) <- TRUE
308                      return(object)
309                  } else {
310                      return(object)
311  }  }
312              })
313  setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))  setMethod("load_doc",
314  setMethod("loadFileIntoMem",            signature(object =  "XMLTextDocument"),
315            c("XMLTextDocument"),            function(object, ...) {
316            function(object) {                if (!Cached(object)) {
317                if (object@Cached == 0) {                    con <- eval(parse(text = URI(object)))
318                    file <- object@FileName                    corpus <- paste(readLines(con), "\n", collapse = "")
319                    doc <- xmlTreeParse(file)                    close(con)
320                      doc <- xmlTreeParse(corpus, asText = TRUE)
321                    class(doc) <- "list"                    class(doc) <- "list"
322                    object@.Data <- doc                    Corpus(object) <- doc
323                    object@Cached <- 1                    Cached(object) <- TRUE
324                      return(object)
325                  } else {
326                      return(object)
327                  }
328              })
329    setMethod("load_doc",
330              signature(object = "NewsgroupDocument"),
331              function(object, ...) {
332                  if (!Cached(object)) {
333                      con <- eval(parse(text = URI(object)))
334                      mail <- readLines(con)
335                      close(con)
336                      Cached(object) <- TRUE
337                      for (index in seq(along = mail)) {
338                          if (mail[index] == "")
339                              break
340                      }
341                      Corpus(object) <- mail[(index + 1):length(mail)]
342                    return(object)                    return(object)
343                } else {                } else {
344                    return(object)                    return(object)
345                }                }
346            })            })
347    
348  setGeneric("transformTextDocCol", function(object, FUN, ...) standardGeneric("transformTextDocCol"))  setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
349  setMethod("transformTextDocCol",  setMethod("tm_transform",
350            c("TextDocCol"),            signature(object = "TextDocCol", FUN = "function"),
351            function(object, FUN, ...) {            function(object, FUN, ...) {
352                lapply(object, FUN, ...)                result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
353                  result@GlobalMetaData <- GlobalMetaData(object)
354                  return(result)
355            })            })
356    
357  setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))  setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))
358  setMethod("toPlainTextDocument",  setMethod("as.plaintext_doc",
359            c("PlainTextDocument"),            signature(object = "PlainTextDocument"),
360            function(object, FUN, ...) {            function(object, FUN, ...) {
361                return(object)                return(object)
362            })            })
363  setMethod("toPlainTextDocument",  setMethod("as.plaintext_doc",
364            c("XMLTextDocument"),            signature(object = "XMLTextDocument", FUN = "function"),
365            function(object, FUN, ...) {            function(object, FUN, ...) {
366                if (object@Cached == 0)                if (!Cached(object))
367                    object <- loadFileIntoMem(object)                    object <- load_doc(object)
368    
369                corpus <- object@.Data                corpus <- Corpus(object)
370    
371                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
372                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
373                names(corpus) <- c("doc","dtd")                names(corpus) <- c("doc","dtd")
374    
375                return(xmlApply(xmlRoot(corpus), FUN, ...))                return(FUN(xmlRoot(corpus), ...))
376            })            })
377    
378  setGeneric("stemTextDocument", function(object) standardGeneric("stemTextDocument"))  setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))
379  setMethod("stemTextDocument",  setMethod("stem_doc",
380            c("PlainTextDocument"),            signature(object = "PlainTextDocument"),
381            function(object) {            function(object, ...) {
382                  if (!Cached(object))
383                      object <- load_doc(object)
384    
385                require(Rstem)                require(Rstem)
386                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
387                stemmedCorpus <- wordStem(splittedCorpus)                stemmedCorpus <- wordStem(splittedCorpus, ...)
388                object@.Data <- paste(stemmedCorpus, collapse = " ")                Corpus(object) <- paste(stemmedCorpus, collapse = " ")
389                return (object)                return (object)
390            })            })
391    
392  setGeneric("removeStopWords", function(object, stopwords) standardGeneric("removeStopWords"))  setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))
393  setMethod("removeStopWords",  setMethod("remove_words",
394            c("PlainTextDocument", "character"),            signature(object = "PlainTextDocument", stopwords = "character"),
395            function(object, stopwords) {            function(object, stopwords, ...) {
396                  if (!Cached(object))
397                      object <- load_doc(object)
398    
399                require(Rstem)                require(Rstem)
400                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
401                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
402                object@.Data <- paste(noStopwordsCorpus, collapse = " ")                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
403                return (object)                return (object)
404            })            })
405    
406  setGeneric("filterTextDocCol", function(object, FUN, ...) standardGeneric("filterTextDocCol"))  setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))
407  setMethod("filterTextDocCol",  setMethod("tm_filter",
408            c("TextDocCol"),            signature(object = "TextDocCol"),
409            function(object, FUN, ...) {            function(object, ..., FUN = s_filter) {
410                sapply(object, FUN, ...)                object[tm_index(object, ..., FUN)]
411            })            })
412    
413  setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))  setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))
414  setMethod("filterREUT21578Topics",  setMethod("tm_index",
415            c("PlainTextDocument", "character"),            signature(object = "TextDocCol"),
416            function(object, topics, ...) {            function(object, ..., FUN = s_filter) {
417                if (object@Cached == 0)                sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
418                    object <- loadFileIntoMem(object)            })
419    
420                if (any(object@LocalMetaData$Topics %in% topics))  s_filter <- function(object, s, ..., GlobalMetaData) {
421                    return(TRUE)      b <- TRUE
422                else      for (tag in names(s)) {
423                    return(FALSE)          if (tag %in% names(LocalMetaData(object))) {
424            })              b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))
425            } else if (tag %in% names(GlobalMetaData)){
426                b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))
427            } else {
428                b <- b && any(grep(s[[tag]], eval(call(tag, object))))
429            }
430        }
431        return(b)
432    }
433    
434  setGeneric("filterIDs", function(object, IDs) standardGeneric("filterIDs"))  setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))
435  setMethod("filterIDs",  setMethod("fulltext_search_filter",
436            c("TextDocument", "numeric"),            signature(object = "PlainTextDocument", pattern = "character"),
437            function(object, IDs) {            function(object, pattern, ...) {
438                if (object@ID %in% IDs)                if (!Cached(object))
439                    return(TRUE)                    object <- load_doc(object)
440                else  
441                    return(FALSE)                return(any(grep(pattern, Corpus(object))))
442            })            })
443    
444  setGeneric("attachData", function(object, data) standardGeneric("attachData"))  setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))
445  setMethod("attachData",  setMethod("attach_data",
446            c("TextDocCol","TextDocument"),            signature(object = "TextDocCol", data = "TextDocument"),
447            function(object, data) {            function(object, data) {
448                data <- as(list(data), "TextDocCol")                data <- as(list(data), "TextDocCol")
449                object@.Data <- as(c(object@.Data, data), "TextDocCol")                object@.Data <- as(c(object@.Data, data), "TextDocCol")
450                return(object)                return(object)
451            })            })
452    
453  setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))  setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))
454  setMethod("attachMetaData",  setMethod("attach_metadata",
455            c("TextDocCol"),            signature(object = "TextDocCol"),
456            function(object, name, metadata) {            function(object, name, metadata) {
457                object@GlobalMetaData <- c(object@GlobalMetaData, new = list(metadata))                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
458                names(object@GlobalMetaData)[length(names(object@GlobalMetaData))] <- name                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
459                return(object)                return(object)
460            })            })
461    
462  setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))  setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))
463  setMethod("setSubscriptable",  setMethod("set_subscriptable",
464            c("TextDocCol"),            signature(object = "TextDocCol"),
465            function(object, name) {            function(object, name) {
466                if (!is.character(object@GlobalMetaData$subscriptable))                if (!is.character(GlobalMetaData(object)$subscriptable))
467                    object <- attachMetaData(object, "subscriptable", name)                    object <- attach_metadata(object, "subscriptable", name)
468                else                else
469                    object@GlobalMetaData$subscriptable <- c(object@GlobalMetaData$subscriptable, name)                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
470                return(object)                return(object)
471            })            })
472    
# Line 329  Line 478 
478    
479                object <- x                object <- x
480                object@.Data <- x@.Data[i, ..., drop = FALSE]                object@.Data <- x@.Data[i, ..., drop = FALSE]
481                for (m in names(object@GlobalMetaData)) {                for (m in names(GlobalMetaData(object))) {
482                    if (m %in% object@GlobalMetaData$subscriptable) {                    if (m %in% GlobalMetaData(object)$subscriptable) {
483                        object@GlobalMetaData[[m]] <- object@GlobalMetaData[[m]][i, ..., drop = FALSE]                        object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
484                    }                    }
485                }                }
486                return(object)                return(object)
487            })            })
488    
489    setMethod("[<-",
490              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
491              function(x, i, j, ... , value) {
492                  object <- x
493                  object@.Data[i, ...] <- value
494                  return(object)
495              })
496    
497    setMethod("[[",
498              signature(x = "TextDocCol", i = "ANY", j = "ANY"),
499              function(x, i, j, ...) {
500                  return(x@.Data[[i, ...]])
501              })
502    
503    setMethod("[[<-",
504              signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
505              function(x, i, j, ..., value) {
506                  object <- x
507                  object@.Data[[i, ...]] <- value
508                  return(object)
509              })
510    
511  setMethod("c",  setMethod("c",
512            signature(x = "TextDocCol"),            signature(x = "TextDocCol"),
513            function(x, ..., recursive = TRUE){            function(x, ..., recursive = TRUE){
# Line 345  Line 516 
516                    return(x)                    return(x)
517                return(as(c(as(x, "list"), ...), "TextDocCol"))                return(as(c(as(x, "list"), ...), "TextDocCol"))
518      })      })
519    setMethod("c",
520              signature(x = "TextDocument"),
521              function(x, ..., recursive = TRUE){
522                  args <- list(...)
523                  if(length(args) == 0)
524                      return(x)
525                  return(new("TextDocCol", .Data = list(x, ...)))
526        })
527    
528    setMethod("length",
529              signature(x = "TextDocCol"),
530              function(x){
531                  return(length(as(x, "list")))
532        })
533    
534    setMethod("show",
535              signature(object = "TextDocCol"),
536              function(object){
537                  cat("A text document collection with", length(object), "text document")
538                  if (length(object) == 1)
539                      cat("\n")
540                  else
541                      cat("s\n")
542        })
543    
544    setMethod("summary",
545              signature(object = "TextDocCol"),
546              function(object){
547                  show(object)
548                  if (length(GlobalMetaData(object)) > 0) {
549                      cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
550                      if (length(GlobalMetaData(object)) == 1)
551                          cat(".\n")
552                      else
553                          cat("s.\n")
554                      cat("Available tags are:\n")
555                      cat(names(GlobalMetaData(object)), "\n")
556                  }
557        })
558    
559    setGeneric("inspect", function(object) standardGeneric("inspect"))
560    setMethod("inspect",
561              signature("TextDocCol"),
562              function(object) {
563                  summary(object)
564                  cat("\n")
565                  show(as(object, "list"))
566              })
567    
568    # No metadata is checked
569    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
570    setMethod("%IN%",
571              signature(x = "TextDocument", y = "TextDocCol"),
572              function(x, y) {
573                  x %in% y
574              })

Legend:
Removed from v.53  
changed lines
  Added in v.66

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