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

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

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