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/tm/R/textdoccol.R revision 744, Mon Apr 23 00:35:10 2007 UTC pkg/R/corpus.R revision 1259, Sat Sep 21 07:36:25 2013 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  .PCorpus <-
4  setGeneric("TextDocCol", function(object,  function(x, cmeta, dmeta, dbcontrol)
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),  {
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),      attr(x, "CMetaData") <- cmeta
7                                    ...) standardGeneric("TextDocCol"))      attr(x, "DMetaData") <- dmeta
8  setMethod("TextDocCol",      attr(x, "DBControl") <- dbcontrol
9            signature(object = "Source"),      class(x) <- c("PCorpus", "Corpus", "list")
10            function(object,      x
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),  }
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  
13                     ...) {  DBControl <-
14                if (attr(readerControl$reader, "FunctionGenerator"))  function(x)
15                    readerControl$reader <- readerControl$reader(...)      attr(x, "DBControl")
16    
17    PCorpus <-
18    function(x,
19             readerControl = list(reader = x$DefaultReader, language = "en"),
20             dbControl = list(dbName = "", dbType = "DB1"))
21    {
22        readerControl <- prepareReader(readerControl, x$DefaultReader)
23    
24                if (dbControl$useDb) {      if (is.function(readerControl$init))
25                    if (!dbCreate(dbControl$dbName, dbControl$dbType))          readerControl$init()
26    
27        if (is.function(readerControl$exit))
28            on.exit(readerControl$exit())
29    
30        if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
31                        stop("error in creating database")                        stop("error in creating database")
32                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
33    
34                tdl <- list()      # Allocate memory in advance if length is known
35                counter <- 1      tdl <- if (x$Length > 0)
36                while (!eoi(object)) {          vector("list", as.integer(x$Length))
                   object <- stepNext(object)  
                   elem <- getElem(object)  
                   # If there is no Load on Demand support  
                   # we need to load the corpus into memory at startup  
                   if (!object@LoDSupport)  
                       readerControl$load <- TRUE  
                   doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))  
                   if (dbControl$useDb) {  
                       dbInsert(db, ID(doc), doc)  
                       tdl <- c(tdl, ID(doc))  
                   }  
37                    else                    else
38                        tdl <- c(tdl, list(doc))          list()
39    
40        counter <- 1
41        while (!eoi(x)) {
42            x <- stepNext(x)
43            elem <- getElem(x)
44            id <- if (is.null(x$Names) || is.na(x$Names))
45                    as.character(counter)
46                else
47                    x$Names[counter]
48            doc <- readerControl$reader(elem, readerControl$language, id)
49            filehash::dbInsert(db, ID(doc), doc)
50            if (x$Length > 0) tdl[[counter]] <- ID(doc)
51            else tdl <- c(tdl, ID(doc))
52                    counter <- counter + 1                    counter <- counter + 1
53                }                }
54        names(tdl) <- x$Names
55    
56                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
57                if (dbControl$useDb) {      filehash::dbInsert(db, "DMetaData", df)
                   dbInsert(db, "DMetaData", df)  
58                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
               }  
               else  
                   dmeta.df <- df  
59    
60                cmeta.node <- new("MetaDataNode",      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
                             NodeID = 0,  
                             MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),  
                             children = list())  
   
               return(new("TextDocCol", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))  
           })  
   
 setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  
 setMethod("loadDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- readLines(con)  
                   close(con)  
                   Corpus(object) <- corpus  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object =  "XMLTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(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)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "NewsgroupDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(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)  
               }  
           })  
   
 setGeneric("tmUpdate", function(object,  
                                 origin,  
                                 readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),  
                                 ...) standardGeneric("tmUpdate"))  
 # Update is only supported for directories  
 # At the moment no other LoD devices are available anyway  
 setMethod("tmUpdate",  
           signature(object = "TextDocCol", origin = "DirSource"),  
           function(object, origin,  
                    readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),  
                    ...) {  
               if (inherits(readerControl$reader, "FunctionGenerator"))  
                   readerControl$reader <- readerControl$reader(...)  
   
               object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))  
               new.files <- setdiff(origin@FileList, object.filelist)  
   
               for (filename in new.files) {  
                   elem <- list(content = readLines(filename),  
                                uri = substitute(file(filename)))  
                   object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))  
               }  
   
               return(object)  
           })  
   
 setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "TextDocCol", FUN = "function"),  
           function(object, FUN, ...) {  
               result <- object  
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   i <- 1  
                   for (id in unlist(object)) {  
                       db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                       i <- i + 1  
61                    }                    }
62                    dbDisconnect(db)  
63    .VCorpus <-
64    function(x, cmeta, dmeta)
65    {
66        attr(x, "CMetaData") <- cmeta
67        attr(x, "DMetaData") <- dmeta
68        class(x) <- c("VCorpus", "Corpus", "list")
69        x
70                }                }
               else  
                   result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))  
               return(result)  
           })  
   
 setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  
 setMethod("asPlain",  
           signature(object = "PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("asPlain",  
           signature(object = "XMLTextDocument", FUN = "function"),  
           function(object, FUN, ...) {  
               corpus <- Corpus(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),  
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
   
 setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))  
 setMethod("tmTolower",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
   
 setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))  
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
           })  
   
 setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))  
 setMethod("stemDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, language = "english", ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- if (require("Rstem"))  
                   Rstem::wordStem(splittedCorpus, language)  
               else  
                   SnowballStemmer(splittedCorpus, Weka_control(S = language))  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
           })  
   
 setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))  
 setMethod("removePunctuation",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
           })  
   
 setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))  
 setMethod("removeWords",  
           signature(object = "PlainTextDocument", stopwords = "character"),  
           function(object, stopwords, ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  
               return(object)  
           })  
   
 setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  
 setMethod("tmFilter",  
           signature(object = "TextDocCol"),  
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
               else  
                   return(object[FUN(object, ...)])  
           })  
71    
72  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  VCorpus <-
73  setMethod("tmIndex",  Corpus <-
74            signature(object = "TextDocCol"),  function(x, readerControl = list(reader = x$DefaultReader, language = "en"))
75            function(object, ..., FUN = sFilter, doclevel = FALSE) {  {
76                if (doclevel)      readerControl <- prepareReader(readerControl, x$DefaultReader)
                   return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
               else  
                   return(FUN(object, ...))  
           })  
77    
78  sFilter <- function(object, s, ...) {      if (is.function(readerControl$init))
79      con <- textConnection(s)          readerControl$init()
80      tokens <- scan(con, "character")  
81      close(con)      if (is.function(readerControl$exit))
82      localMetaNames <- unique(names(sapply(object, LocalMetaData)))          on.exit(readerControl$exit())
83      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
84      n <- names(DMetaData(object))      # Allocate memory in advance if length is known
85      tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)      tdl <- if (x$Length > 0)
86      query.df <- DMetaData(prescindMeta(object, tags))          vector("list", as.integer(x$Length))
     if (DBControl(object)[["useDb"]])  
         DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]  
     # Rename to avoid name conflicts  
     names(query.df)[names(query.df) == "Author"] <- "author"  
     names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"  
     names(query.df)[names(query.df) == "Description"] <- "description"  
     names(query.df)[names(query.df) == "ID"] <- "identifier"  
     names(query.df)[names(query.df) == "Origin"] <- "origin"  
     names(query.df)[names(query.df) == "Heading"] <- "heading"  
     names(query.df)[names(query.df) == "Language"] <- "language"  
     attach(query.df)  
     try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))  
     detach(query.df)  
     return(result)  
 }  
   
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
 setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  
 setMethod("appendElem",  
           signature(object = "TextDocCol", data = "TextDocument"),  
           function(object, data, meta = NULL) {  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   if (dbExists(db, ID(data)))  
                       warning("document with identical ID already exists")  
                   dbInsert(db, ID(data), data)  
                   dbDisconnect(db)  
                   object@.Data[[length(object)+1]] <- ID(data)  
               }  
87                else                else
88                    object@.Data[[length(object)+1]] <- data          list()
89                DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
90                return(object)      if (x$Vectorized)
91            })          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
92                          pGetElem(x),
93  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))                        id = if (is.null(x$Names) || is.na(x$Names)) as.character(seq_len(x$Length)) else x$Names,
94  setMethod("appendMeta",                        SIMPLIFY = FALSE)
           signature(object = "TextDocCol"),  
           function(object, cmeta = NULL, dmeta = NULL) {  
               object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)  
               if (!is.null(dmeta)) {  
                   DMetaData(object) <- cbind(DMetaData(object), eval(dmeta))  
               }  
               return(object)  
           })  
   
 setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  
 setMethod("removeMeta",  
           signature(object = "TextDocCol"),  
           function(object, cname = NULL, dname = NULL) {  
               if (!is.null(cname))  
                   object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]  
               if (!is.null(dname))  
                   DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE]  
               return(object)  
           })  
   
 setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  
 setMethod("prescindMeta",  
           signature(object = "TextDocCol", meta = "character"),  
           function(object, meta) {  
               for (m in meta) {  
                   if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {  
                       local.m <- lapply(object, m)  
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       local.m <- unlist(local.m)  
                       DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))  
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
                   }  
95                    else {                    else {
96                        local.meta <- lapply(object, LocalMetaData)          counter <- 1
97                        local.m <- lapply(local.meta, "[[", m)          while (!eoi(x)) {
98                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))              x <- stepNext(x)
99                        if (length(local.m) == length(unlist(local.m)))              elem <- getElem(x)
100                            local.m <- unlist(local.m)              id <- if (is.null(x$Names) || is.na(x$Names))
101                    as.character(counter)
102                else
103                    x$Names[counter]
104                doc <- readerControl$reader(elem, readerControl$language, id)
105                if (x$Length > 0)
106                    tdl[[counter]] <- doc
107                        else                        else
108                            local.m <- I(local.m)                  tdl <- c(tdl, list(doc))
109                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))              counter <- counter + 1
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
110                    }                    }
111                }                }
112                return(object)      names(tdl) <- x$Names
113            })      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
114        .VCorpus(tdl, .MetaDataNode(), df)
 setMethod("[",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
   
               object <- x  
               object@.Data <- x@.Data[i, ..., drop = FALSE]  
               if (DBControl(object)[["useDb"]]) {  
                   index <- object@DMetaData[[1 , "subset"]]  
                   if (any(is.na(index)))  
                       object@DMetaData[[1 , "subset"]] <- i  
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
115                }                }
116                else  
117                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[.PCorpus` <-
118                return(object)  function(x, i)
119            })  {
120        if (missing(i)) return(x)
121  setMethod("[<-",      index <- attr(x, "DMetaData")[[1 , "subset"]]
122            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
123            function(x, i, j, ... , value) {      dmeta <- attr(x, "DMetaData")
124                object <- x      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
125                if (DBControl(object)[["useDb"]]) {  }
126                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
127    `[.VCorpus` <-
128    function(x, i)
129    {
130        if (missing(i)) return(x)
131        .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
132    }
133    
134    `[<-.PCorpus` <-
135    function(x, i, value)
136    {
137        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
138                    counter <- 1                    counter <- 1
139                    for (id in object@.Data[i, ...]) {      for (id in unclass(x)[i]) {
140                        if (length(value) == 1)          if (identical(length(value), 1L)) db[[id]] <- value
141                            db[[id]] <- value          else db[[id]] <- value[[counter]]
                       else {  
                           db[[id]] <- value[[counter]]  
                       }  
142                        counter <- counter + 1                        counter <- counter + 1
143                    }                    }
144                    dbDisconnect(db)      x
145                }                }
               else  
                   object@.Data[i, ...] <- value  
               return(object)  
           })  
   
 setMethod("[[",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY"),  
           function(x, i, j, ...) {  
               if (DBControl(x)[["useDb"]]) {  
                   db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
                   result <- dbFetch(db, x@.Data[[i]])  
                   dbDisconnect(db)  
                   return(loadDoc(result))  
               }  
               else  
                   return(loadDoc(x@.Data[[i]]))  
           })  
146    
147  setMethod("[[<-",  .map_name_index <-
148            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),  function(x, i)
149            function(x, i, j, ..., value) {  {
150                object <- x      if (is.character(i)) {
151                if (DBControl(object)[["useDb"]]) {          if (is.null(names(x)))
152                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])              match(i, meta(x, "ID", type = "local"))
153                    index <- object@.Data[[i]]          else
154                match(i, names(x))
155        }
156        i
157    }
158    
159    `[[.PCorpus` <-
160    function(x, i)
161    {
162        i <- .map_name_index(x, i)
163        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
164        filehash::dbFetch(db, NextMethod("[["))
165    }
166    `[[.VCorpus` <-
167    function(x, i)
168    {
169        i <- .map_name_index(x, i)
170        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
171        if (!is.null(lazyTmMap))
172            .Call("copyCorpus", x, materialize(x, i))
173        NextMethod("[[")
174    }
175    
176    `[[<-.PCorpus` <-
177    function(x, i, value)
178    {
179        i <- .map_name_index(x, i)
180        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
181        index <- unclass(x)[[i]]
182                    db[[index]] <- value                    db[[index]] <- value
183                    dbDisconnect(db)      x
184                }                }
185                else  `[[<-.VCorpus` <-
186                    object@.Data[[i, ...]] <- value  function(x, i, value)
187                return(object)  {
188            })      i <- .map_name_index(x, i)
189        # Mark new objects as not active for lazy mapping
190  # Update \code{NodeID}s of a CMetaData tree      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
191  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {      if (!is.null(lazyTmMap)) {
192      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s          lazyTmMap$index[i] <- FALSE
193      set_id <- function(object) {          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
194          object@NodeID <- id      }
195        # Set the value
196        cl <- class(x)
197        y <- NextMethod("[[<-")
198        class(y) <- cl
199        y
200    }
201    
202    # Update NodeIDs of a CMetaData tree
203    .update_id <-
204    function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)
205    {
206        # Traversal of (binary) CMetaData tree with setup of NodeIDs
207        set_id <- function(x) {
208            x$NodeID <- id
209          id <<- id + 1          id <<- id + 1
210          level <<- level + 1          level <<- level + 1
211            if (length(x$Children) > 0) {
212          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
213              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
214              if (level == 1) {              if (level == 1) {
215                  left.mapping <<- mapping                  left.mapping <<- mapping
216                  mapping <<- NULL                  mapping <<- NULL
217              }              }
218              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
219              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
220    
221              object@children <- list(left, right)              x$Children <- list(left, right)
222          }          }
223          level <<- level - 1          level <<- level - 1
224            x
         return(object)  
225      }      }
226        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
     return(list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping))  
227  }  }
228    
229  setMethod("c",  # Find indices to be updated for a CMetaData tree
230            signature(x = "TextDocCol"),  .find_indices <-
231            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  function(x)
232                args <- list(...)  {
               if (length(args) == 0)  
                   return(x)  
   
               if (!all(sapply(args, inherits, "TextDocCol")))  
                   stop("not all arguments are text document collections")  
               if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating text document collections with activated database is not supported")  
   
               result <- x  
               for (c in args) {  
                   result <- c2(result, c)  
               }  
               return(result)  
           })  
   
 setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  
 setMethod("c2",  
           signature(x = "TextDocCol", y = "TextDocCol"),  
           function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               object <- x  
               # Concatenate data slots  
               object@.Data <- c(as(x, "list"), as(y, "list"))  
   
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
               # Update the CMetaData tree  
               cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))  
               update.struct <- update_id(cmeta)  
               object@CMetaData <- update.struct$root  
   
               # Find indices to be updated for the left tree  
233                indices.mapping <- NULL                indices.mapping <- NULL
234                for (m in levels(as.factor(DMetaData(x)$MetaID))) {                for (m in levels(as.factor(DMetaData(x)$MetaID))) {
235                    indices <- (DMetaData(x)$MetaID == m)                    indices <- (DMetaData(x)$MetaID == m)
236                    indices.mapping <- c(indices.mapping, list(m = indices))                    indices.mapping <- c(indices.mapping, list(m = indices))
237                    names(indices.mapping)[length(indices.mapping)] <- m                    names(indices.mapping)[length(indices.mapping)] <- m
238                }                }
239        indices.mapping
240    }
241    
242    c2 <-
243    function(x, y, ...)
244    {
245        # Update the CMetaData tree
246        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
247        update.struct <- .update_id(cmeta)
248    
249        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
250    
251        # Find indices to be updated for the left tree
252        indices.mapping <- .find_indices(x)
253    
254                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
255                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
256                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
257                    x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])          DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
258                }                }
259    
260                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
261                indices.mapping <- NULL      indices.mapping <- .find_indices(y)
               for (m in levels(as.factor(DMetaData(y)$MetaID))) {  
                   indices <- (DMetaData(y)$MetaID == m)  
                   indices.mapping <- c(indices.mapping, list(m = indices))  
                   names(indices.mapping)[length(indices.mapping)] <- m  
               }  
262    
263                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
264                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
265                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
266                    y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])          DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
267                }                }
268    
269                # Merge the DMetaData data frames                # Merge the DMetaData data frames
270                labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))                labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
271                na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))      na.matrix <- matrix(NA,
272                            nrow = nrow(DMetaData(x)),
273                            ncol = length(labels),
274                            dimnames = list(row.names(DMetaData(x)), labels))
275                x.dmeta.aug <- cbind(DMetaData(x), na.matrix)                x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
276                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
277                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))      na.matrix <- matrix(NA,
278                            nrow = nrow(DMetaData(y)),
279                            ncol = length(labels),
280                            dimnames = list(row.names(DMetaData(y)), labels))
281                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
282                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
283    
284        new
285    }
286    
287    c.Corpus <-
288    function(..., recursive = FALSE)
289    {
290        args <- list(...)
291        x <- args[[1L]]
292    
293        if(length(args) == 1L)
294            return(x)
295    
296        if (!all(unlist(lapply(args, inherits, class(x)))))
297            stop("not all arguments are of the same corpus type")
298    
299        if (inherits(x, "PCorpus"))
300            stop("concatenation of corpora with underlying databases is not supported")
301    
302                return(object)      if (recursive)
303            })          Reduce(c2, args)
304        else {
305            args <- do.call("c", lapply(args, unclass))
306            .VCorpus(args,
307                     cmeta = .MetaDataNode(),
308                     dmeta = data.frame(MetaID = rep(0, length(args)),
309                                        stringsAsFactors = FALSE))
310        }
311    }
312    
313  setMethod("c",  c.TextDocument <-
314            signature(x = "TextDocument"),  function(..., recursive = FALSE)
315            function(x, ..., recursive = TRUE){  {
316                args <- list(...)                args <- list(...)
317                if(length(args) == 0)      x <- args[[1L]]
318    
319        if(length(args) == 1L)
320                    return(x)                    return(x)
321    
322                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
323                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
324                              NodeID = 0,  
325                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(args)),
326                              children = list())                          stringsAsFactors = FALSE)
327        .VCorpus(args, .MetaDataNode(), dmeta)
328                return(new("TextDocCol",  }
329                           .Data = list(x, ...),  
330                           DMetaData = dmeta.df,  print.Corpus <-
331                           CMetaData = cmeta.node,  function(x, ...)
332                           DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))  {
333            })      cat(sprintf(ngettext(length(x),
334                             "A corpus with %d text document\n",
335  setMethod("length",                           "A corpus with %d text documents\n"),
336            signature(x = "TextDocCol"),                  length(x)))
337            function(x){      invisible(x)
338                return(length(as(x, "list")))  }
339      })  
340    summary.Corpus <-
341  setMethod("show",  function(object, ...)
342            signature(object = "TextDocCol"),  {
343            function(object){      print(object)
               cat(sprintf(ngettext(length(object),  
                                    "A text document collection with %d text document\n",  
                                    "A text document collection with %d text documents\n"),  
                           length(object)))  
     })  
   
 setMethod("summary",  
           signature(object = "TextDocCol"),  
           function(object){  
               show(object)  
344                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
345                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
346                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",
347                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
348                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
349                    cat("Available tags are:\n")                    cat("Available tags are:\n")
350                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")          cat(strwrap(paste(names(CMetaData(object)$MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
351                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
352                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
353                }                }
354      })  }
355    
356  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <-
357  setMethod("inspect",  function(x)
358            signature("TextDocCol"),      UseMethod("inspect", x)
359            function(object) {  inspect.PCorpus <-
360                summary(object)  function(x)
361    {
362        summary(x)
363                cat("\n")                cat("\n")
364                if (DBControl(object)[["useDb"]]) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
365                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])      show(filehash::dbMultiFetch(db, unlist(x)))
                   show(dbMultiFetch(db, unlist(object)))  
                   dbDisconnect(db)  
366                }                }
367                else  inspect.VCorpus <-
368                    show(object@.Data)  function(x)
369            })  {
370        summary(x)
371  # No metadata is checked      cat("\n")
372  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))      print(noquote(lapply(x, identity)))
 setMethod("%IN%",  
           signature(x = "TextDocument", y = "TextDocCol"),  
           function(x, y) {  
               if (DBControl(y)[["useDb"]]) {  
                   db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  
                   result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))  
                   dbDisconnect(db)  
373                }                }
374                else  
375                    result <- x %in% y  lapply.PCorpus <-
376                return(result)  function(X, FUN, ...)
377            })  {
378        db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
379  setMethod("lapply",      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
380            signature(X = "TextDocCol"),  }
381            function(X, FUN, ...) {  lapply.VCorpus <-
382                if (DBControl(X)[["useDb"]]) {  function(X, FUN, ...)
383                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  {
384                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
385                    dbDisconnect(db)      if (!is.null(lazyTmMap))
386            .Call("copyCorpus", X, materialize(X))
387        base::lapply(X, FUN, ...)
388    }
389    
390    writeCorpus <-
391    function(x, path = ".", filenames = NULL)
392    {
393        filenames <- file.path(path,
394                               if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
395                               else filenames)
396        i <- 1
397        for (o in x) {
398            writeLines(as.PlainTextDocument(o), filenames[i])
399            i <- i + 1
400                }                }
               else  
                   result <- base::lapply(X, FUN, ...)  
               return(result)  
           })  
   
 setMethod("sapply",  
           signature(X = "TextDocCol"),  
           function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  
               if (DBControl(X)[["useDb"]]) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
                   dbDisconnect(db)  
401                }                }
               else  
                   result <- base::sapply(X, FUN, ...)  
               return(result)  
           })  

Legend:
Removed from v.744  
changed lines
  Added in v.1259

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