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 984, Fri Aug 14 16:32:35 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)  
     }  
 }  
 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  
97              }              }
             content <- mail[(index + 1):length(mail)]  
   
             doc <- new("NewsgroupDocument", .Data = content, URI = elem$uri, Cached = TRUE,  
                        Author = author, DateTimeStamp = datetimestamp,  
                        Description = "", ID = id, Origin = origin,  
                        Heading = heading, Newsgroup = newsgroup)  
         } else {  
             doc <- new("NewsgroupDocument", URI = elem$uri, Cached = FALSE, Author = author, DateTimeStamp = datetimestamp,  
                        Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)  
98          }          }
99    
100          return(doc)      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
101        cmeta.node <- new("MetaDataNode",
102                          NodeID = 0,
103                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
104                          children = list())
105    
106        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                          lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
132                          meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
133  }  }
 class(newsgroup_parser) <- "function_generator"  
   
 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  
 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)  
134  }  }
135                  else {
136  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file                    result@.Data <- if (clusterAvailable())
137  reut21578xml_to_plain <- function(node, ...) {                        snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))
     # 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)  
               }  
           })  
 setMethod("load_doc",  
           signature(object =  "XMLTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(parse(text = URI(object)))  
                   corpus <- paste(readLines(con), "\n", collapse = "")  
                   close(con)  
                   doc <- xmlTreeParse(corpus, asText = TRUE)  
                   class(doc) <- "list"  
                   Corpus(object) <- doc  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
140                }                }
141                  result
142            })            })
143  setMethod("load_doc",  setMethod("tmMap",
144            signature(object = "NewsgroupDocument"),            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                    mail <- readLines(con)                db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
149                    close(con)                i <- 1
150                    Cached(object) <- TRUE                for (id in unlist(object)) {
151                    for (index in seq(along = mail)) {                    db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
152                        if (mail[index] == "")                    i <- i + 1
                           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            function(object, FUN, ...) {      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
164                return(object)      if (!is.null(lazyTmMap)) {
165            })         # Make valid and lazy index
166  setMethod("as.plaintext_doc",         idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
167            signature(object = "XMLTextDocument", FUN = "function"),         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                if (!Cached(object))                require("XML")
                   object <- load_doc(object)  
189    
190                corpus <- Corpus(object)                corpus <- Content(object)
191    
192                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
193                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 374  Line 195 
195    
196                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
197            })            })
198    setMethod("asPlain",
199              signature(object = "Reuters21578Document"),
200              function(object, FUN, ...) {
201                  require("XML")
202    
203  setGeneric("stem_doc", function(object, ...) standardGeneric("stem_doc"))                FUN <- convertReut21578XMLPlain
204  setMethod("stem_doc",                corpus <- Content(object)
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object))  
                   object <- load_doc(object)  
   
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- wordStem(splittedCorpus, ...)  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
           })  
205    
206  setGeneric("remove_words", function(object, stopwords, ...) standardGeneric("remove_words"))                # As XMLDocument is no native S4 class, restore valid information
207  setMethod("remove_words",                class(corpus) <- "XMLDocument"
208            signature(object = "PlainTextDocument", stopwords = "character"),                names(corpus) <- c("doc","dtd")
           function(object, stopwords, ...) {  
               if (!Cached(object))  
                   object <- load_doc(object)  
   
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  
               return(object)  
           })  
209    
210  setGeneric("tm_filter", function(object, ..., FUN = s_filter) standardGeneric("tm_filter"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("tm_filter",  
           signature(object = "TextDocCol"),  
           function(object, ..., FUN = s_filter) {  
               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)  
211            })            })
212    setMethod("asPlain", signature(object = "RCV1Document"),
213  setGeneric("attach_metadata", function(object, name, metadata) standardGeneric("attach_metadata"))            function(object, FUN, ...) convertRCV1Plain(object, ...))
214  setMethod("attach_metadata",  setMethod("asPlain",
215            signature(object = "TextDocCol"),            signature(object = "StructuredTextDocument"),
216            function(object, name, metadata) {            function(object, FUN, ...) {
217                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))                new("PlainTextDocument", .Data = unlist(Content(object)),
218                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name                    Author = Author(object), DateTimeStamp = DateTimeStamp(object),
219                return(object)                    Description = Description(object), ID = ID(object), Origin = Origin(object),
220                      Heading = Heading(object), Language = Language(object),
221                      LocalMetaData = LocalMetaData(object))
222            })            })
223    
224  setGeneric("set_subscriptable", function(object, name) standardGeneric("set_subscriptable"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
225  setMethod("set_subscriptable",  setMethod("tmFilter", signature(object = "Corpus"),
226            signature(object = "TextDocCol"),            function(object, ..., FUN = searchFullText, doclevel = TRUE)
227            function(object, name) {                object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
228                if (!is.character(GlobalMetaData(object)$subscriptable))  
229                    object <- attach_metadata(object, "subscriptable", name)  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
230    setMethod("tmIndex",
231              signature(object = "Corpus"),
232              function(object, ..., FUN = searchFullText, doclevel = TRUE) {
233                  if (!is.null(attr(FUN, "doclevel")))
234                      doclevel <- attr(FUN, "doclevel")
235                  if (doclevel) {
236                      if (clusterAvailable())
237                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
238                else                else
239                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)                        return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
240                return(object)                }
241                  else
242                      return(FUN(object, ...))
243            })            })
244    
245    prescindMeta <- function(object, meta) {
246        df <- DMetaData(object)
247    
248        for (m in meta)
249            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
250    
251        df
252    }
253    
254    #setMethod("[",
255    #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
256    #          function(x, i, j, ... , drop) {
257    #              if (missing(i)) return(x)
258    #
259    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
260    #              x
261    #          })
262  setMethod("[",  setMethod("[",
263            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
264            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
265                if(missing(i))                if (missing(i)) return(x)
                   return(x)  
266    
267                object <- x                x@.Data <- x@.Data[i, ..., drop = FALSE]
268                object@.Data <- x@.Data[i, ..., drop = FALSE]                index <- x@DMetaData[[1 , "subset"]]
269                for (m in names(GlobalMetaData(object))) {                if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
270                    if (m %in% GlobalMetaData(object)$subscriptable) {                else x@DMetaData[[1 , "subset"]] <- index[i]
271                        object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]                x
272                    }            })
273                }  setMethod("[",
274                return(object)            signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),
275              function(x, i, j, ... , drop) {
276                  if (missing(i)) return(x)
277    
278                  x@.Data <- x@.Data[i, ..., drop = FALSE]
279                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
280                  x
281            })            })
282    
283  setMethod("[<-",  setMethod("[<-",
284            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
285            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
286                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
287                object@.Data[i, ...] <- value                counter <- 1
288                return(object)                for (id in x@.Data[i, ...]) {
289                      if (identical(length(value), 1)) db[[id]] <- value
290                      else db[[id]] <- value[[counter]]
291                      counter <- counter + 1
292                  }
293                  x
294              })
295    setMethod("[<-",
296              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
297              function(x, i, j, ... , value) {
298                  x@.Data[i, ...] <- value
299                  x
300            })            })
301    
302  setMethod("[[",  setMethod("[[",
303            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY"),
304              function(x, i, j, ...) {
305                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
306                  filehash::dbFetch(db, x@.Data[[i]])
307              })
308    setMethod("[[",
309              signature(x = "VCorpus", i = "ANY", j = "ANY"),
310            function(x, i, j, ...) {            function(x, i, j, ...) {
311                return(x@.Data[[i, ...]])                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
312                  if (!is.null(lazyTmMap))
313                      .Call("copyCorpus", x, materialize(x, i))
314                  x@.Data[[i]]
315            })            })
316    
317  setMethod("[[<-",  setMethod("[[<-",
318            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
319            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
320                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
321                object@.Data[[i, ...]] <- value                index <- x@.Data[[i]]
322                return(object)                db[[index]] <- value
323                  x
324            })            })
325    setMethod("[[<-",
326              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
327              function(x, i, j, ..., value) {
328                  # Mark new objects as not active for lazy mapping
329                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
330                  if (!is.null(lazyTmMap)) {
331                      lazyTmMap$index[i] <- FALSE
332                      meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
333                  }
334                  # Set the value
335                  x@.Data[[i, ...]] <- value
336    
337                  x
338              })
339    
340    # Update \code{NodeID}s of a CMetaData tree
341    update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
342        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
343        set_id <- function(object) {
344            object@NodeID <- id
345            id <<- id + 1
346            level <<- level + 1
347    
348            if (length(object@children) > 0) {
349                mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
350                left <- set_id(object@children[[1]])
351                if (level == 1) {
352                    left.mapping <<- mapping
353                    mapping <<- NULL
354                }
355                mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
356                right <- set_id(object@children[[2]])
357    
358                object@children <- list(left, right)
359            }
360            level <<- level - 1
361    
362            return(object)
363        }
364    
365        list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
366    }
367    
368  setMethod("c",  setMethod("c",
369            signature(x = "TextDocCol"),            signature(x = "Corpus"),
370            function(x, ..., recursive = TRUE){            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
371                args <- list(...)                args <- list(...)
372                if(length(args) == 0)                if (identical(length(args), 0)) return(x)
373                    return(x)  
374                return(as(c(as(x, "list"), ...), "TextDocCol"))                if (!all(sapply(args, inherits, class(x))))
375                      stop("not all arguments are of the same corpus type")
376    
377                  if (inherits(x, "PCorpus"))
378                      stop("concatenation of corpora with underlying databases is not supported")
379    
380                  Reduce(c2, base::c(list(x), args))
381              })
382    
383    setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
384    #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
385    #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
386    #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
387    #          })
388    setMethod("c2", signature(x = "VCorpus", y = "VCorpus"),
389              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
390                  object <- x
391                  # Concatenate data slots
392                  object@.Data <- c(as(x, "list"), as(y, "list"))
393    
394                  # Update the CMetaData tree
395                  cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
396                  update.struct <- update_id(cmeta)
397                  object@CMetaData <- update.struct$root
398    
399                  # Find indices to be updated for the left tree
400                  indices.mapping <- NULL
401                  for (m in levels(as.factor(DMetaData(x)$MetaID))) {
402                      indices <- (DMetaData(x)$MetaID == m)
403                      indices.mapping <- c(indices.mapping, list(m = indices))
404                      names(indices.mapping)[length(indices.mapping)] <- m
405                  }
406    
407                  # Update the DMetaData data frames for the left tree
408                  for (i in 1:ncol(update.struct$left.mapping)) {
409                      map <- update.struct$left.mapping[,i]
410                      x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
411                  }
412    
413                  # Find indices to be updated for the right tree
414                  indices.mapping <- NULL
415                  for (m in levels(as.factor(DMetaData(y)$MetaID))) {
416                      indices <- (DMetaData(y)$MetaID == m)
417                      indices.mapping <- c(indices.mapping, list(m = indices))
418                      names(indices.mapping)[length(indices.mapping)] <- m
419                  }
420    
421                  # Update the DMetaData data frames for the right tree
422                  for (i in 1:ncol(update.struct$right.mapping)) {
423                      map <- update.struct$right.mapping[,i]
424                      y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
425                  }
426    
427                  # Merge the DMetaData data frames
428                  labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
429                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
430                  x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
431                  labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
432                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
433                  y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
434                  object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
435    
436                  object
437      })      })
438    
439  setMethod("c",  setMethod("c",
440            signature(x = "TextDocument"),            signature(x = "TextDocument"),
441            function(x, ..., recursive = TRUE){            function(x, ..., recursive = FALSE){
442                args <- list(...)                args <- list(...)
443                if(length(args) == 0)                if (identical(length(args), 0)) return(x)
444                    return(x)  
445                return(new("TextDocCol", .Data = list(x, ...)))                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
446      })                cmeta.node <- new("MetaDataNode",
447                                NodeID = 0,
448                                MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
449                                children = list())
450    
451  setMethod("length",                new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
           signature(x = "TextDocCol"),  
           function(x){  
               return(length(as(x, "list")))  
452      })      })
453    
454  setMethod("show",  setMethod("show",
455            signature(object = "TextDocCol"),            signature(object = "Corpus"),
456            function(object){            function(object){
457                cat("A text document collection with", length(object), "text document")                cat(sprintf(ngettext(length(object),
458                if (length(object) == 1)                                     "A corpus with %d text document\n",
459                    cat("\n")                                     "A corpus with %d text documents\n"),
460                else                            length(object)))
                   cat("s\n")  
461      })      })
462    
463  setMethod("summary",  setMethod("summary",
464            signature(object = "TextDocCol"),            signature(object = "Corpus"),
465            function(object){            function(object){
466                show(object)                show(object)
467                if (length(GlobalMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
468                    cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
469                    if (length(GlobalMetaData(object)) == 1)                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",
470                        cat(".\n")                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
471                    else                                         length(CMetaData(object)@MetaData)))
                       cat("s.\n")  
472                    cat("Available tags are:\n")                    cat("Available tags are:\n")
473                    cat(names(GlobalMetaData(object)), "\n")                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
474                      cat("Available variables in the data frame are:\n")
475                      cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
476                }                }
477      })      })
478    
479  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <- function(x) UseMethod("inspect", x)
480  setMethod("inspect",  inspect.PCorpus <- function(x) {
481            signature("TextDocCol"),      summary(x)
           function(object) {  
               summary(object)  
482                cat("\n")                cat("\n")
483                show(as(object, "list"))      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
484            })      show(filehash::dbMultiFetch(db, unlist(x)))
485    }
486    #inspect.FCorpus <-
487    inspect.VCorpus <- function(x) {
488        summary(x)
489        cat("\n")
490        print(noquote(lapply(x, identity)))
491    }
492    
493  # No metadata is checked  # No metadata is checked
494  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
495  setMethod("%IN%",  setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
           signature(x = "TextDocument", y = "TextDocCol"),  
496            function(x, y) {            function(x, y) {
497                x %in% y                db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
498                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
499              })
500    setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),
501              function(x, y) x %in% y)
502    
503    setMethod("lapply",
504              signature(X = "VCorpus"),
505              function(X, FUN, ...) {
506                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
507                  if (!is.null(lazyTmMap))
508                      .Call("copyCorpus", X, materialize(X))
509                  base::lapply(X, FUN, ...)
510              })
511    setMethod("lapply",
512              signature(X = "PCorpus"),
513              function(X, FUN, ...) {
514                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
515                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
516              })
517    
518    setMethod("sapply",
519              signature(X = "VCorpus"),
520              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
521                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
522                  if (!is.null(lazyTmMap))
523                      .Call("copyCorpus", X, materialize(X))
524                  base::sapply(X, FUN, ...)
525              })
526    setMethod("sapply",
527              signature(X = "PCorpus"),
528              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
529                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
530                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
531              })
532    
533    setAs("list", "VCorpus", function(from) {
534        cmeta.node <- new("MetaDataNode",
535                          NodeID = 0,
536                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
537                          children = list())
538        data <- vector("list", length(from))
539        counter <- 1
540        for (f in from) {
541            data[[counter]] <- new("PlainTextDocument",
542                                   .Data = f,
543                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
544                                   ID = as.character(counter),
545                                   Language = "eng")
546            counter <- counter + 1
547        }
548        new("VCorpus", .Data = data,
549            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
550            CMetaData = cmeta.node)
551    })
552    
553    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
554    setMethod("writeCorpus",
555              signature(object = "Corpus"),
556              function(object, path = ".", filenames = NULL) {
557                  filenames <- file.path(path,
558                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
559                                         else filenames)
560                  i <- 1
561                  for (o in object) {
562                      writeLines(asPlain(o), filenames[i])
563                      i <- i + 1
564                  }
565            })            })

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

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