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/textmin/R/textdoccol.R revision 66, Tue Oct 31 22:03:33 2006 UTC pkg/R/corpus.R revision 966, Mon Jun 29 09:05:14 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the function_generator parser  prepareReader <- function(readerControl, defaultReader = NULL, ...) {
4  setGeneric("TextDocCol", function(object, parser = plaintext_parser, ...) standardGeneric("TextDocCol"))      if (is.null(readerControl$reader))
5  setMethod("TextDocCol",          readerControl$reader <- defaultReader
6            signature(object = "Source"),      if (is(readerControl$reader, "FunctionGenerator"))
7            function(object, parser = plaintext_parser) {          readerControl$reader <- readerControl$reader(...)
8                if (inherits(parser, "function_generator"))      if (is.null(readerControl$language))
9                    parser <- parser(...)          readerControl$language <- "eng"
10        readerControl
11    }
12    
13    ## Fast Corpus
14    ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus
15    ##   - allows performance tests and comparisons to other corpus types
16    #FCorpus <- function(object, readerControl = list(language = "eng")) {
17    #    readerControl <- prepareReader(readerControl)
18    #
19    #    if (!object@Vectorized)
20    #        stop("Source is not vectorized")
21    #
22    #    tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
23    #                  function(x) readSlim(x[c("content", "uri")],
24    #                                       readerControl$language,
25    #                                       as.character(x$id)))
26    #
27    #    new("FCorpus", .Data = tdl)
28    #}
29    
30    PCorpus <- function(object,
31                        readerControl = list(reader = object@DefaultReader, language = "eng"),
32                        dbControl = list(dbName = "", dbType = "DB1"),
33                        ...) {
34        readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
35    
36        if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
37            stop("error in creating database")
38        db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
39    
40        # Allocate memory in advance if length is known
41        tdl <- if (object@Length > 0)
42            vector("list", as.integer(object@Length))
43        else
44            list()
45    
               tdl <- list()  
46                counter <- 1                counter <- 1
47                while (!eoi(object)) {                while (!eoi(object)) {
48                    object <- step_next(object)          object <- stepNext(object)
49                    elem <- get_elem(object)          elem <- getElem(object)
50                    # If there is no Load on Demand support          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
51                    # we need to load the corpus into memory at startup          filehash::dbInsert(db, ID(doc), doc)
52                    if (object@LoDSupport)          if (object@Length > 0) tdl[[counter]] <- ID(doc)
53                        load <- object@Load          else tdl <- c(tdl, ID(doc))
                   else  
                       load <- TRUE  
                   tdl <- c(tdl, list(parser(elem, object@LoDSupport, load, as.character(counter))))  
54                    counter <- counter + 1                    counter <- counter + 1
55                }                }
56    
57                return(new("TextDocCol", .Data = tdl))      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
58            })      filehash::dbInsert(db, "DMetaData", df)
59        dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
60  setGeneric("DirSource", function(directory, load = FALSE) standardGeneric("DirSource"))  
61  setMethod("DirSource",      cmeta.node <- new("MetaDataNode",
62            signature(directory = "character"),                        NodeID = 0,
63            function(directory, load = FALSE) {                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
64                new("DirSource", LoDSupport = TRUE, FileList = dir(directory, full.names = TRUE),                        children = list())
65                    Position = 0, Load = load)  
66            })      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)
67    }
68  setGeneric("CSVSource", function(object, isConCall = FALSE) standardGeneric("CSVSource"))  
69  setMethod("CSVSource",  # The "..." are additional arguments for the FunctionGenerator reader
70            signature(object = "character"),  VCorpus <- Corpus <- function(object,
71            function(object, isConCall = FALSE) {                      readerControl = list(reader = object@DefaultReader, language = "eng"),
72                if (!isConCall)                      ...) {
73                    object <- paste('file("', object, '")', sep = "")      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
74                con <- eval(parse(text = object))  
75                content <- scan(con, what = "character")      # Allocate memory in advance if length is known
76                close(con)      tdl <- if (object@Length > 0)
77                new("CSVSource", LoDSupport = FALSE, URI = object,          vector("list", as.integer(object@Length))
78                    Content = content, Position = 0)      else
79            })          list()
80    
81  setGeneric("ReutersSource", function(object, isConCall = FALSE) standardGeneric("ReutersSource"))      if (object@Vectorized)
82  setMethod("ReutersSource",          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
83            signature(object = "character"),                        function(x) readerControl$reader(x[c("content", "uri")],
84            function(object, isConCall = FALSE) {                                                         readerControl$language,
85                if (!isConCall)                                                         as.character(x$id)))
                  object <- paste('file("', object, '")', sep = "")  
               con <- eval(parse(text = object))  
               corpus <- paste(readLines(con), "\n", collapse = "")  
               close(con)  
               tree <- xmlTreeParse(corpus, asText = TRUE)  
               content <- xmlRoot(tree)$children  
   
               new("ReutersSource", LoDSupport = FALSE, URI = object,  
                   Content = content, Position = 0)  
           })  
   
 setGeneric("step_next", function(object) standardGeneric("step_next"))  
 setMethod("step_next",  
           signature(object = "DirSource"),  
           function(object) {  
               object@Position <- object@Position + 1  
               object  
           })  
 setMethod("step_next",  
           signature(object = "CSVSource"),  
           function(object) {  
               object@Position <- object@Position + 1  
               object  
           })  
 setMethod("step_next",  
           signature(object = "ReutersSource"),  
           function(object) {  
               object@Position <- object@Position + 1  
               object  
           })  
   
 setGeneric("get_elem", function(object) standardGeneric("get_elem"))  
 setMethod("get_elem",  
           signature(object = "DirSource"),  
           function(object) {  
               list(content = readLines(object@FileList[object@Position]),  
                    uri = paste('file("', object@FileList[object@Position], '")', sep = ""))  
           })  
 setMethod("get_elem",  
           signature(object = "CSVSource"),  
           function(object) {  
               list(content = object@Content[object@Position],  
                    uri = object@URI)  
           })  
 setMethod("get_elem",  
           signature(object = "ReutersSource"),  
           function(object) {  
               # Construct a character representation from the XMLNode  
               con <- textConnection("virtual.file", "w")  
               saveXML(object@Content[[object@Position]], con)  
               close(con)  
   
               list(content = virtual.file, uri = object@URI)  
           })  
   
 setGeneric("eoi", function(object) standardGeneric("eoi"))  
 setMethod("eoi",  
           signature(object = "DirSource"),  
           function(object) {  
               if (length(object@FileList) <= object@Position)  
                   return(TRUE)  
               else  
                   return(FALSE)  
           })  
 setMethod("eoi",  
           signature(object = "CSVSource"),  
           function(object) {  
               if (length(object@Content) <= object@Position)  
                   return(TRUE)  
               else  
                   return(FALSE)  
           })  
 setMethod("eoi",  
           signature(object = "ReutersSource"),  
           function(object) {  
               if (length(object@Content) <= object@Position)  
                   return(TRUE)  
               else  
                   return(FALSE)  
           })  
   
 plaintext_parser <- function(...) {  
     function(elem, lodsupport, load, id) {  
         if (!lodsupport || (lodsupport && load)) {  
             doc <- new("PlainTextDocument", .Data = elem$content, URI = elem$uri, Cached = TRUE,  
                        Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")  
         }  
86          else {          else {
87              doc <- new("PlainTextDocument", URI = elem$uri, Cached = FALSE,          counter <- 1
88                         Author = "", DateTimeStamp = date(), Description = "", ID = id, Origin = "", Heading = "")          while (!eoi(object)) {
89          }              object <- stepNext(object)
90                elem <- getElem(object)
91          return(doc)              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
92      }              if (object@Length > 0)
93  }                  tdl[[counter]] <- doc
 class(plaintext_parser) <- "function_generator"  
   
 reut21578xml_parser <- function(...) {  
     function(elem, lodsupport, load, id) {  
         corpus <- paste(elem$content, "\n", collapse = "")  
         tree <- xmlTreeParse(corpus, asText = TRUE)  
         node <- xmlRoot(tree)  
   
         # Mask as list to bypass S4 checks  
         class(tree) <- "list"  
   
         # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!  
         if (!is.null(node[["TEXT"]][["AUTHOR"]]))  
             author <- xmlValue(node[["TEXT"]][["AUTHOR"]])  
         else  
             author <- ""  
   
         datetimestamp <- xmlValue(node[["DATE"]])  
         description <- ""  
         id <- xmlAttrs(node)[["NEWID"]]  
   
         # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
         if (!is.null(node[["TEXT"]][["TITLE"]]))  
             heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
94          else          else
95              heading <- ""                  tdl <- c(tdl, list(doc))
96                counter <- counter + 1
         topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)  
   
         if (!lodsupport || (lodsupport && load)) {  
             doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = author,  
                        DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",  
                        Heading = heading, LocalMetaData = list(Topics = topics))  
         } else {  
             doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = author,  
                        DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters-21578 XML",  
                        Heading = heading, LocalMetaData = list(Topics = topics))  
         }  
   
         return(doc)  
     }  
 }  
 class(reut21578xml_parser) <- "function_generator"  
   
 rcv1_parser <- function(...) {  
     function(elem, lodsupport, load, id) {  
         corpus <- paste(elem$content, "\n", collapse = "")  
         tree <- xmlTreeParse(corpus, asText = TRUE)  
         node <- xmlRoot(tree)  
   
         # Mask as list to bypass S4 checks  
         class(tree) <- "list"  
   
         datetimestamp <- xmlAttrs(node)[["date"]]  
         id <- xmlAttrs(node)[["itemid"]]  
         heading <- xmlValue(node[["title"]])  
   
         if (!lodsupport || (lodsupport && load)) {  
             doc <- new("XMLTextDocument", .Data = tree, URI = elem$uri, Cached = TRUE, Author = "",  
                        DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",  
                        Heading = heading)  
         } else {  
             doc <- new("XMLTextDocument", URI = elem$uri, Cached = FALSE, Author = "",  
                        DateTimeStamp = datetimestamp, Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML",  
                        Heading = heading)  
         }  
   
         return(doc)  
     }  
97  }  }
 class(rcv1_parser) <- "function_generator"  
   
 newsgroup_parser <- function(...) {  
     function(elem, lodsupport, load, id) {  
         mail <- elem$content  
         author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))  
         datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))  
         origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))  
         heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))  
         newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))  
   
         if (!lodsupport || (lodsupport && load)) {  
             # The header is separated from the body by a blank line.  
             # Reference: \url{http://en.wikipedia.org/wiki/E-mail#Internet_e-mail_format}  
             for (index in seq(along = mail)) {  
                 if (mail[index] == "")  
                     break  
98              }              }
             content <- mail[(index + 1):length(mail)]  
99    
100              doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
101                         Author = author, DateTimeStamp = datetimestamp,      cmeta.node <- new("MetaDataNode",
102                         Description = "", ID = id, Origin = origin,                        NodeID = 0,
103                         Heading = heading, Newsgroup = newsgroup)                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
104          } else {                        children = list())
105              doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,  
106                         Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)      new("VCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)
107    }
108    
109    setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
110    #setMethod("tmMap",
111    #          signature(object = "FCorpus", FUN = "function"),
112    #          function(object, FUN, ..., lazy = FALSE) {
113    #              if (lazy)
114    #                  warning("lazy mapping is deactivated")
115    #
116    #              new("FCorpus", .Data = lapply(object, FUN, ..., DMetaData = data.frame()))
117    #          })
118    setMethod("tmMap",
119              signature(object = "VCorpus", FUN = "function"),
120              function(object, FUN, ..., lazy = FALSE) {
121                  result <- object
122                  # Lazy mapping
123                  if (lazy) {
124                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
125                      if (is.null(lazyTmMap)) {
126                          meta(result, tag = "lazyTmMap", type = "corpus") <-
127                              list(index = rep(TRUE, length(result)),
128                                   maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
129          }          }
130                      else {
131          return(doc)                        lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
132                          meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
133      }      }
134  }  }
135  class(newsgroup_parser) <- "function_generator"                else {
136                      result@.Data <- if (clusterAvailable())
137  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file                        snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))
 rcv1_to_plain <- function(node, ...) {  
     datetimestamp <- xmlAttrs(node)[["date"]]  
     id <- xmlAttrs(node)[["itemid"]]  
     origin <- "Reuters Corpus Volume 1 XML"  
     corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)  
     heading <- xmlValue(node[["title"]])  
   
     new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = "", DateTimeStamp = datetimestamp,  
         Description = "", ID = id, Origin = "Reuters Corpus Volume 1 XML", Heading = heading)  
 }  
   
 # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  
 reut21578xml_to_plain <- function(node, ...) {  
     # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["AUTHOR"]]))  
         author <- xmlValue(node[["TEXT"]][["AUTHOR"]])  
     else  
         author <- ""  
   
     datetimestamp <- xmlValue(node[["DATE"]])  
     description <- ""  
     id <- xmlAttrs(node)[["NEWID"]]  
   
     origin <- "Reuters-21578 XML"  
   
     # The <BODY></BODY> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["BODY"]]))  
         corpus <- xmlValue(node[["TEXT"]][["BODY"]])  
     else  
         corpus <- ""  
   
     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["TITLE"]]))  
         heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
138      else      else
139          heading <- ""                        lapply(object, FUN, ..., DMetaData = DMetaData(object))
   
     topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)  
   
     new("PlainTextDocument", .Data = corpus, Cached = TRUE, URI = "", Author = author, DateTimeStamp = datetimestamp,  
         Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))  
 }  
   
 setGeneric("load_doc", function(object, ...) standardGeneric("load_doc"))  
 setMethod("load_doc",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(parse(text = URI(object)))  
                   corpus <- readLines(con)  
                   close(con)  
                   Corpus(object) <- corpus  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
140                }                }
141                  result
142            })            })
143  setMethod("load_doc",  setMethod("tmMap",
144            signature(object =  "XMLTextDocument"),            signature(object = "PCorpus", FUN = "function"),
145            function(object, ...) {            function(object, FUN, ..., lazy = FALSE) {
146                if (!Cached(object)) {                if (lazy)
147                    con <- eval(parse(text = URI(object)))                    warning("lazy mapping is deactived when using database backend")
148                    corpus <- paste(readLines(con), "\n", collapse = "")                db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
149                    close(con)                i <- 1
150                    doc <- xmlTreeParse(corpus, asText = TRUE)                for (id in unlist(object)) {
151                    class(doc) <- "list"                    db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
152                    Corpus(object) <- doc                    i <- i + 1
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("load_doc",  
           signature(object = "NewsgroupDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(parse(text = URI(object)))  
                   mail <- readLines(con)  
                   close(con)  
                   Cached(object) <- TRUE  
                   for (index in seq(along = mail)) {  
                       if (mail[index] == "")  
                           break  
153                    }                    }
154                    Corpus(object) <- mail[(index + 1):length(mail)]                # Suggested by Christian Buchta
155                    return(object)                filehash::dbReorganize(db)
               } else {  
                   return(object)  
               }  
           })  
156    
157  setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))                object
 setMethod("tm_transform",  
           signature(object = "TextDocCol", FUN = "function"),  
           function(object, FUN, ...) {  
               result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")  
               result@GlobalMetaData <- GlobalMetaData(object)  
               return(result)  
158            })            })
159    
160  setGeneric("as.plaintext_doc", function(object, FUN, ...) standardGeneric("as.plaintext_doc"))  # Materialize lazy mappings
161  setMethod("as.plaintext_doc",  # Improvements by Christian Buchta
162            signature(object = "PlainTextDocument"),  materialize <- function(corpus, range = seq_along(corpus)) {
163        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
164        if (!is.null(lazyTmMap)) {
165           # Make valid and lazy index
166           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
167           if (any(idx)) {
168               res <- corpus@.Data[idx]
169               for (m in lazyTmMap$maps)
170                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
171               corpus@.Data[idx] <- res
172               lazyTmMap$index[idx] <- FALSE
173           }
174        }
175        # Clean up if everything is materialized
176        if (!any(lazyTmMap$index))
177            lazyTmMap <- NULL
178        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
179        corpus
180    }
181    
182    setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
183    setMethod("asPlain", signature(object = "PlainTextDocument"),
184              function(object, FUN, ...) object)
185    setMethod("asPlain",
186              signature(object = "XMLTextDocument"),
187            function(object, FUN, ...) {            function(object, FUN, ...) {
188                return(object)                require("XML")
189    
190                  corpus <- Content(object)
191    
192                  # As XMLDocument is no native S4 class, restore valid information
193                  class(corpus) <- "XMLDocument"
194                  names(corpus) <- c("doc","dtd")
195    
196                  return(FUN(xmlRoot(corpus), ...))
197            })            })
198  setMethod("as.plaintext_doc",  setMethod("asPlain",
199            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "Reuters21578Document"),
200            function(object, FUN, ...) {            function(object, FUN, ...) {
201                if (!Cached(object))                require("XML")
                   object <- load_doc(object)  
202    
203                corpus <- Corpus(object)                FUN <- convertReut21578XMLPlain
204                  corpus <- Content(object)
205    
206                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
207                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 374  Line 209 
209    
210                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
211            })            })
212    setMethod("asPlain", signature(object = "RCV1Document"),
213  setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))            function(object, FUN, ...) convertRCV1Plain(object, ...))
214  setMethod("stem_doc",  setMethod("asPlain",
215            signature(object = "PlainTextDocument"),            signature(object = "NewsgroupDocument"),
216            function(object, ...) {            function(object, FUN, ...) {
217                if (!Cached(object))                new("PlainTextDocument", .Data = Content(object), Author = Author(object),
218                    object <- load_doc(object)                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
219                      Origin = Origin(object), Heading = Heading(object), Language = Language(object),
220                require(Rstem)                    LocalMetaData = LocalMetaData(object))
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- wordStem(splittedCorpus, ...)  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
221            })            })
222    setMethod("asPlain",
223  setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))            signature(object = "StructuredTextDocument"),
224  setMethod("remove_words",            function(object, FUN, ...) {
225            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = unlist(Content(object)),
226            function(object, stopwords, ...) {                    Author = Author(object), DateTimeStamp = DateTimeStamp(object),
227                if (!Cached(object))                    Description = Description(object), ID = ID(object), Origin = Origin(object),
228                    object <- load_doc(object)                    Heading = Heading(object), Language = Language(object),
229                      LocalMetaData = LocalMetaData(object))
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  
               return(object)  
230            })            })
231    
232  setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
233  setMethod("tm_filter",  setMethod("tmFilter", signature(object = "Corpus"),
234            signature(object = "TextDocCol"),            function(object, ..., FUN = searchFullText, doclevel = TRUE)
235            function(object, ..., FUN = s_filter) {                object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
               object[tm_index(object, ..., FUN)]  
           })  
   
 setGeneric("tm_index", function(object, ..., FUN = s_filter) standardGeneric("tm_index"))  
 setMethod("tm_index",  
           signature(object = "TextDocCol"),  
           function(object, ..., FUN = s_filter) {  
               sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))  
           })  
   
 s_filter <- function(object, s, ..., GlobalMetaData) {  
     b <- TRUE  
     for (tag in names(s)) {  
         if (tag %in% names(LocalMetaData(object))) {  
             b <- b && any(grep(s[[tag]], LocalMetaData(object)[[tag]]))  
         } else if (tag %in% names(GlobalMetaData)){  
             b <- b && any(grep(s[[tag]], GlobalMetaData[[tag]]))  
         } else {  
             b <- b && any(grep(s[[tag]], eval(call(tag, object))))  
         }  
     }  
     return(b)  
 }  
   
 setGeneric("fulltext_search_filter", function(object, pattern, ...) standardGeneric("fulltext_search_filter"))  
 setMethod("fulltext_search_filter",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               if (!Cached(object))  
                   object <- load_doc(object)  
   
               return(any(grep(pattern, Corpus(object))))  
           })  
   
 setGeneric("attach_data", function(object, data) standardGeneric("attach_data"))  
 setMethod("attach_data",  
           signature(object = "TextDocCol", data = "TextDocument"),  
           function(object, data) {  
               data <- as(list(data), "TextDocCol")  
               object@.Data <- as(c(object@.Data, data), "TextDocCol")  
               return(object)  
           })  
236    
237  setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
238  setMethod("attach_metadata",  setMethod("tmIndex",
239            signature(object = "TextDocCol"),            signature(object = "Corpus"),
240            function(object, name, metadata) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
241                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))                if (!is.null(attr(FUN, "doclevel")))
242                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name                    doclevel <- attr(FUN, "doclevel")
243                return(object)                if (doclevel) {
244                      if (clusterAvailable())
245                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
246                      else
247                          return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
248                  }
249                  else
250                      return(FUN(object, ...))
251            })            })
252    
253  setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
254  setMethod("set_subscriptable",  setMethod("appendElem",
255            signature(object = "TextDocCol"),            signature(object = "Corpus", data = "TextDocument"),
256            function(object, name) {            function(object, data, meta = NULL) {
257                if (!is.character(GlobalMetaData(object)$subscriptable))                if (DBControl(object)[["useDb"]] && require("filehash")) {
258                    object <- attach_metadata(object, "subscriptable", name)                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
259                      if (dbExists(db, ID(data)))
260                          warning("document with identical ID already exists")
261                      dbInsert(db, ID(data), data)
262                      object@.Data[[length(object)+1]] <- ID(data)
263                  }
264                else                else
265                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)                    object@.Data[[length(object)+1]] <- data
266                  DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))
267                return(object)                return(object)
268            })            })
269    
270    prescindMeta <- function(object, meta) {
271        df <- DMetaData(object)
272    
273        for (m in meta)
274            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
275    
276        df
277    }
278    
279    #setMethod("[",
280    #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
281    #          function(x, i, j, ... , drop) {
282    #              if (missing(i)) return(x)
283    #
284    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
285    #              x
286    #          })
287  setMethod("[",  setMethod("[",
288            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
289            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
290                if(missing(i))                if (missing(i)) return(x)
                   return(x)  
291    
292                object <- x                x@.Data <- x@.Data[i, ..., drop = FALSE]
293                object@.Data <- x@.Data[i, ..., drop = FALSE]                index <- x@DMetaData[[1 , "subset"]]
294                for (m in names(GlobalMetaData(object))) {                if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
295                    if (m %in% GlobalMetaData(object)$subscriptable) {                else x@DMetaData[[1 , "subset"]] <- index[i]
296                        object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]                x
297                    }            })
298                }  setMethod("[",
299                return(object)            signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),
300              function(x, i, j, ... , drop) {
301                  if (missing(i)) return(x)
302    
303                  x@.Data <- x@.Data[i, ..., drop = FALSE]
304                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
305                  x
306            })            })
307    
308  setMethod("[<-",  setMethod("[<-",
309            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
310            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
311                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
312                object@.Data[i, ...] <- value                counter <- 1
313                return(object)                for (id in x@.Data[i, ...]) {
314                      if (identical(length(value), 1)) db[[id]] <- value
315                      else db[[id]] <- value[[counter]]
316                      counter <- counter + 1
317                  }
318                  x
319              })
320    setMethod("[<-",
321              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
322              function(x, i, j, ... , value) {
323                  x@.Data[i, ...] <- value
324                  x
325            })            })
326    
327  setMethod("[[",  setMethod("[[",
328            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY"),
329              function(x, i, j, ...) {
330                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
331                  filehash::dbFetch(db, x@.Data[[i]])
332              })
333    setMethod("[[",
334              signature(x = "VCorpus", i = "ANY", j = "ANY"),
335            function(x, i, j, ...) {            function(x, i, j, ...) {
336                return(x@.Data[[i, ...]])                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
337                  if (!is.null(lazyTmMap))
338                      .Call("copyCorpus", x, materialize(x, i))
339                  x@.Data[[i]]
340            })            })
341    
342  setMethod("[[<-",  setMethod("[[<-",
343            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
344            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
345                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
346                object@.Data[[i, ...]] <- value                index <- x@.Data[[i]]
347                return(object)                db[[index]] <- value
348                  x
349              })
350    setMethod("[[<-",
351              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
352              function(x, i, j, ..., value) {
353                  # Mark new objects as not active for lazy mapping
354                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
355                  if (!is.null(lazyTmMap)) {
356                      lazyTmMap$index[i] <- FALSE
357                      meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
358                  }
359                  # Set the value
360                  x@.Data[[i, ...]] <- value
361    
362                  x
363            })            })
364    
365    # Update \code{NodeID}s of a CMetaData tree
366    update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
367        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
368        set_id <- function(object) {
369            object@NodeID <- id
370            id <<- id + 1
371            level <<- level + 1
372    
373            if (length(object@children) > 0) {
374                mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
375                left <- set_id(object@children[[1]])
376                if (level == 1) {
377                    left.mapping <<- mapping
378                    mapping <<- NULL
379                }
380                mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
381                right <- set_id(object@children[[2]])
382    
383                object@children <- list(left, right)
384            }
385            level <<- level - 1
386    
387            return(object)
388        }
389    
390        list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
391    }
392    
393  setMethod("c",  setMethod("c",
394            signature(x = "TextDocCol"),            signature(x = "Corpus"),
395            function(x, ..., recursive = TRUE){            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
396                args <- list(...)                args <- list(...)
397                if(length(args) == 0)                if (identical(length(args), 0)) return(x)
398                    return(x)  
399                return(as(c(as(x, "list"), ...), "TextDocCol"))                if (!all(sapply(args, inherits, class(x))))
400                      stop("not all arguments are of the same corpus type")
401    
402                  if (inherits(x, "PCorpus"))
403                      stop("concatenation of corpora with underlying databases is not supported")
404    
405                  Reduce(c2, base::c(list(x), args))
406      })      })
407    
408    setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
409    #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
410    #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
411    #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
412    #          })
413    setMethod("c2", signature(x = "VCorpus", y = "VCorpus"),
414              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
415                  object <- x
416                  # Concatenate data slots
417                  object@.Data <- c(as(x, "list"), as(y, "list"))
418    
419                  # Update the CMetaData tree
420                  cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
421                  update.struct <- update_id(cmeta)
422                  object@CMetaData <- update.struct$root
423    
424                  # Find indices to be updated for the left tree
425                  indices.mapping <- NULL
426                  for (m in levels(as.factor(DMetaData(x)$MetaID))) {
427                      indices <- (DMetaData(x)$MetaID == m)
428                      indices.mapping <- c(indices.mapping, list(m = indices))
429                      names(indices.mapping)[length(indices.mapping)] <- m
430                  }
431    
432                  # Update the DMetaData data frames for the left tree
433                  for (i in 1:ncol(update.struct$left.mapping)) {
434                      map <- update.struct$left.mapping[,i]
435                      x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
436                  }
437    
438                  # Find indices to be updated for the right tree
439                  indices.mapping <- NULL
440                  for (m in levels(as.factor(DMetaData(y)$MetaID))) {
441                      indices <- (DMetaData(y)$MetaID == m)
442                      indices.mapping <- c(indices.mapping, list(m = indices))
443                      names(indices.mapping)[length(indices.mapping)] <- m
444                  }
445    
446                  # Update the DMetaData data frames for the right tree
447                  for (i in 1:ncol(update.struct$right.mapping)) {
448                      map <- update.struct$right.mapping[,i]
449                      y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
450                  }
451    
452                  # Merge the DMetaData data frames
453                  labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
454                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
455                  x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
456                  labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
457                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
458                  y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
459                  object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
460    
461                  object
462              })
463    
464  setMethod("c",  setMethod("c",
465            signature(x = "TextDocument"),            signature(x = "TextDocument"),
466            function(x, ..., recursive = TRUE){            function(x, ..., recursive = FALSE){
467                args <- list(...)                args <- list(...)
468                if(length(args) == 0)                if (identical(length(args), 0)) return(x)
469                    return(x)  
470                return(new("TextDocCol", .Data = list(x, ...)))                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
471      })                cmeta.node <- new("MetaDataNode",
472                                NodeID = 0,
473                                MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
474                                children = list())
475    
476  setMethod("length",                new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
           signature(x = "TextDocCol"),  
           function(x){  
               return(length(as(x, "list")))  
477      })      })
478    
479  setMethod("show",  setMethod("show",
480            signature(object = "TextDocCol"),            signature(object = "Corpus"),
481            function(object){            function(object){
482                cat("A text document collection with", length(object), "text document")                cat(sprintf(ngettext(length(object),
483                if (length(object) == 1)                                     "A corpus with %d text document\n",
484                    cat("\n")                                     "A corpus with %d text documents\n"),
485                else                            length(object)))
                   cat("s\n")  
486      })      })
487    
488  setMethod("summary",  setMethod("summary",
489            signature(object = "TextDocCol"),            signature(object = "Corpus"),
490            function(object){            function(object){
491                show(object)                show(object)
492                if (length(GlobalMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
493                    cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
494                    if (length(GlobalMetaData(object)) == 1)                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",
495                        cat(".\n")                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
496                    else                                         length(CMetaData(object)@MetaData)))
                       cat("s.\n")  
497                    cat("Available tags are:\n")                    cat("Available tags are:\n")
498                    cat(names(GlobalMetaData(object)), "\n")                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
499                      cat("Available variables in the data frame are:\n")
500                      cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
501                }                }
502      })      })
503    
504  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <- function(x) UseMethod("inspect", x)
505  setMethod("inspect",  inspect.PCorpus <- function(x) {
506            signature("TextDocCol"),      summary(x)
           function(object) {  
               summary(object)  
507                cat("\n")                cat("\n")
508                show(as(object, "list"))      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
509            })      show(filehash::dbMultiFetch(db, unlist(x)))
510    }
511    #inspect.FCorpus <-
512    inspect.VCorpus <- function(x) {
513        summary(x)
514        cat("\n")
515        print(noquote(lapply(x, identity)))
516    }
517    
518  # No metadata is checked  # No metadata is checked
519  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
520  setMethod("%IN%",  setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
           signature(x = "TextDocument", y = "TextDocCol"),  
521            function(x, y) {            function(x, y) {
522                x %in% y                db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
523                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
524              })
525    setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),
526              function(x, y) x %in% y)
527    
528    setMethod("lapply",
529              signature(X = "VCorpus"),
530              function(X, FUN, ...) {
531                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
532                  if (!is.null(lazyTmMap))
533                      .Call("copyCorpus", X, materialize(X))
534                  base::lapply(X, FUN, ...)
535              })
536    setMethod("lapply",
537              signature(X = "PCorpus"),
538              function(X, FUN, ...) {
539                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
540                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
541              })
542    
543    setMethod("sapply",
544              signature(X = "VCorpus"),
545              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
546                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
547                  if (!is.null(lazyTmMap))
548                      .Call("copyCorpus", X, materialize(X))
549                  base::sapply(X, FUN, ...)
550              })
551    setMethod("sapply",
552              signature(X = "PCorpus"),
553              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
554                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
555                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
556              })
557    
558    setAs("list", "VCorpus", function(from) {
559        cmeta.node <- new("MetaDataNode",
560                          NodeID = 0,
561                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
562                          children = list())
563        data <- vector("list", length(from))
564        counter <- 1
565        for (f in from) {
566            data[[counter]] <- new("PlainTextDocument",
567                                   .Data = f,
568                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
569                                   ID = as.character(counter),
570                                   Language = "eng")
571            counter <- counter + 1
572        }
573        new("VCorpus", .Data = data,
574            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
575            CMetaData = cmeta.node)
576    })
577    
578    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
579    setMethod("writeCorpus",
580              signature(object = "Corpus"),
581              function(object, path = ".", filenames = NULL) {
582                  filenames <- file.path(path,
583                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
584                                         else filenames)
585                  i <- 1
586                  for (o in object) {
587                      writeLines(asPlain(o), filenames[i])
588                      i <- i + 1
589                  }
590            })            })

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

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