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 780, Sat Sep 29 13:24:17 2007 UTC pkg/R/corpus.R revision 1114, Fri Nov 26 14:05:54 2010 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
4  setGeneric("TextDocCol", function(object,      attr(x, "CMetaData") <- cmeta
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),      attr(x, "DMetaData") <- dmeta
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),      attr(x, "DBControl") <- dbcontrol
7                                    ...) standardGeneric("TextDocCol"))      class(x) <- c("PCorpus", "Corpus", "list")
8  setMethod("TextDocCol",      x
9            signature(object = "Source"),  }
10            function(object,  DBControl <- function(x) attr(x, "DBControl")
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),  
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  PCorpus <- function(x,
13                        readerControl = list(reader = x$DefaultReader, language = "en"),
14                        dbControl = list(dbName = "", dbType = "DB1"),
15                     ...) {                     ...) {
16                if (is(readerControl$reader, "FunctionGenerator"))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
17                    readerControl$reader <- readerControl$reader(...)  
18        if (is.function(readerControl$init))
19            readerControl$init()
20    
21        if (is.function(readerControl$exit))
22            on.exit(readerControl$exit())
23    
24                if (dbControl$useDb) {      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
                   if (!dbCreate(dbControl$dbName, dbControl$dbType))  
25                        stop("error in creating database")                        stop("error in creating database")
26                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
27    
28                tdl <- list()      # Allocate memory in advance if length is known
29                counter <- 1      tdl <- if (x$Length > 0)
30                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))  
                   }  
31                    else                    else
32                        tdl <- c(tdl, list(doc))          list()
33    
34        counter <- 1
35        while (!eoi(x)) {
36            x <- stepNext(x)
37            elem <- getElem(x)
38            doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
39            filehash::dbInsert(db, ID(doc), doc)
40            if (x$Length > 0) tdl[[counter]] <- ID(doc)
41            else tdl <- c(tdl, ID(doc))
42                    counter <- counter + 1                    counter <- counter + 1
43                }                }
44        names(tdl) <- x$Names
45    
46                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
47                if (dbControl$useDb) {      filehash::dbInsert(db, "DMetaData", df)
                   dbInsert(db, "DMetaData", df)  
48                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
49    
50        .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
51                }                }
               else  
                   dmeta.df <- df  
52    
53                cmeta.node <- new("MetaDataNode",  .VCorpus <- function(x, cmeta, dmeta) {
54                              NodeID = 0,      attr(x, "CMetaData") <- cmeta
55                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      attr(x, "DMetaData") <- dmeta
56                              children = list())      class(x) <- c("VCorpus", "Corpus", "list")
57        x
58                return(new("TextDocCol", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))  }
59            })  
60    # Register S3 corpus classes to be recognized by S4 methods. This is
61  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  # mainly a fix to be compatible with packages which were originally
62  setMethod("loadDoc",  # developed to cooperate with corresponding S4 tm classes. Necessary
63            signature(object = "PlainTextDocument"),  # since tm's class architecture was changed to S3 since tm version 0.5.
64            function(object, ...) {  setOldClass(c("VCorpus", "Corpus", "list"))
65                if (!Cached(object)) {  
66                    con <- eval(URI(object))  # The "..." are additional arguments for the FunctionGenerator reader
67                    corpus <- readLines(con)  VCorpus <- Corpus <- function(x,
68                    close(con)                                readerControl = list(reader = x$DefaultReader, language = "en"),
                   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)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "StructuredTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   warning("load on demand not (yet) supported for StructuredTextDocuments")  
                   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),  
69                     ...) {                     ...) {
70                if (is(readerControl$reader, "FunctionGenerator"))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
                   readerControl$reader <- readerControl$reader(...)  
71    
72                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))      if (is.function(readerControl$init))
73                new.files <- setdiff(origin@FileList, object.filelist)          readerControl$init()
74    
75                for (filename in new.files) {      if (is.function(readerControl$exit))
76                    elem <- list(content = readLines(filename),          on.exit(readerControl$exit())
                                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  
                   }  
               }  
               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 = "Reuters21578Document"),  
           function(object, FUN, ...) {  
               FUN <- convertReut21578XMLPlain  
               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 = "RCV1Document"),  
           function(object, FUN, ...) {  
               FUN <- convertRCV1Plain  
               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))  
           })  
 setMethod("asPlain",  
           signature(object = "StructuredTextDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = unlist(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("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, ...)])  
           })  
77    
78  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))      # Allocate memory in advance if length is known
79  setMethod("tmIndex",      tdl <- if (x$Length > 0)
80            signature(object = "TextDocCol"),          vector("list", as.integer(x$Length))
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
81                else                else
82                    return(FUN(object, ...))          list()
           })  
83    
84  sFilter <- function(object, s, ...) {      if (x$Vectorized)
85      con <- textConnection(s)          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
86      tokens <- scan(con, "character", quiet = TRUE)                        pGetElem(x),
87      close(con)                        id = if (is.null(x$Names)) as.character(seq_len(x$Length)) else x$Names,
88      localMetaNames <- unique(names(sapply(object, LocalMetaData)))                        SIMPLIFY = FALSE)
     localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
     n <- names(DMetaData(object))  
     tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)  
     query.df <- DMetaData(prescindMeta(object, tags))  
     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)  
                   object@.Data[[length(object)+1]] <- ID(data)  
               }  
               else  
                   object@.Data[[length(object)+1]] <- data  
               DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
               return(object)  
           })  
   
 setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  
 setMethod("appendMeta",  
           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  
                   }  
89                    else {                    else {
90                        local.meta <- lapply(object, LocalMetaData)          counter <- 1
91                        local.m <- lapply(local.meta, "[[", m)          while (!eoi(x)) {
92                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))              x <- stepNext(x)
93                        if (length(local.m) == length(unlist(local.m)))              elem <- getElem(x)
94                            local.m <- unlist(local.m)              doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
95                if (x$Length > 0)
96                    tdl[[counter]] <- doc
97                        else                        else
98                            local.m <- I(local.m)                  tdl <- c(tdl, list(doc))
99                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))              counter <- counter + 1
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
100                    }                    }
101                }                }
102                return(object)      names(tdl) <- x$Names
103            })      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
104        .VCorpus(tdl, .MetaDataNode(), df)
105  setMethod("[",  }
           signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
106    
107                object <- x  `[.PCorpus` <- function(x, i) {
108                object@.Data <- x@.Data[i, ..., drop = FALSE]      if (missing(i)) return(x)
109                if (DBControl(object)[["useDb"]]) {      index <- attr(x, "DMetaData")[[1 , "subset"]]
110                    index <- object@DMetaData[[1 , "subset"]]      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
111                    if (any(is.na(index)))      dmeta <- attr(x, "DMetaData")
112                        object@DMetaData[[1 , "subset"]] <- i      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
113                }                }
114                else  
115                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[.VCorpus` <- function(x, i) {
116                return(object)      if (missing(i)) return(x)
117            })      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
   
 setMethod("[<-",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               object <- x  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   counter <- 1  
                   for (id in object@.Data[i, ...]) {  
                       if (length(value) == 1)  
                           db[[id]] <- value  
                       else {  
                           db[[id]] <- value[[counter]]  
118                        }                        }
119    
120    `[<-.PCorpus` <- function(x, i, value) {
121        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
122        counter <- 1
123        for (id in unclass(x)[i]) {
124            if (identical(length(value), 1L)) db[[id]] <- value
125            else db[[id]] <- value[[counter]]
126                        counter <- counter + 1                        counter <- counter + 1
127                    }                    }
128        x
129                }                }
130    
131    .map_name_index <- function(x, i) {
132        if (is.character(i)) {
133            if (is.null(names(x)))
134                match(i, meta(x, "ID", type = "local"))
135                else                else
136                    object@.Data[i, ...] <- value              match(i, names(x))
137                return(object)      }
138            })      i
   
 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]])  
                   return(loadDoc(result))  
139                }                }
               else  
                   return(loadDoc(x@.Data[[i]]))  
           })  
140    
141  setMethod("[[<-",  `[[.PCorpus` <-  function(x, i) {
142            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),      i <- .map_name_index(x, i)
143            function(x, i, j, ..., value) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
144                object <- x      filehash::dbFetch(db, NextMethod("[["))
145                if (DBControl(object)[["useDb"]]) {  }
146                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  `[[.VCorpus` <-  function(x, i) {
147                    index <- object@.Data[[i]]      i <- .map_name_index(x, i)
148        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
149        if (!is.null(lazyTmMap))
150            .Call("copyCorpus", x, materialize(x, i))
151        NextMethod("[[")
152    }
153    
154    `[[<-.PCorpus` <-  function(x, i, value) {
155        i <- .map_name_index(x, i)
156        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
157        index <- unclass(x)[[i]]
158                    db[[index]] <- value                    db[[index]] <- value
159        x
160                }                }
161                else  `[[<-.VCorpus` <-  function(x, i, value) {
162                    object@.Data[[i, ...]] <- value      i <- .map_name_index(x, i)
163                return(object)      # Mark new objects as not active for lazy mapping
164            })      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
165        if (!is.null(lazyTmMap)) {
166  # Update \code{NodeID}s of a CMetaData tree          lazyTmMap$index[i] <- FALSE
167  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
168      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s      }
169      set_id <- function(object) {      # Set the value
170          object@NodeID <- id      cl <- class(x)
171        y <- NextMethod("[[<-")
172        class(y) <- cl
173        y
174    }
175    
176    # Update NodeIDs of a CMetaData tree
177    .update_id <- function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
178        # Traversal of (binary) CMetaData tree with setup of NodeIDs
179        set_id <- function(x) {
180            x$NodeID <- id
181          id <<- id + 1          id <<- id + 1
182          level <<- level + 1          level <<- level + 1
183            if (length(x$Children) > 0) {
184          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
185              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
186              if (level == 1) {              if (level == 1) {
187                  left.mapping <<- mapping                  left.mapping <<- mapping
188                  mapping <<- NULL                  mapping <<- NULL
189              }              }
190              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
191              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
192    
193              object@children <- list(left, right)              x$Children <- list(left, right)
194          }          }
195          level <<- level - 1          level <<- level - 1
196            x
         return(object)  
197      }      }
198        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))  
199  }  }
200    
201  setMethod("c",  # Find indices to be updated for a CMetaData tree
202            signature(x = "TextDocCol"),  .find_indices <- function(x) {
           function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               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  
203                indices.mapping <- NULL                indices.mapping <- NULL
204                for (m in levels(as.factor(DMetaData(x)$MetaID))) {                for (m in levels(as.factor(DMetaData(x)$MetaID))) {
205                    indices <- (DMetaData(x)$MetaID == m)                    indices <- (DMetaData(x)$MetaID == m)
206                    indices.mapping <- c(indices.mapping, list(m = indices))                    indices.mapping <- c(indices.mapping, list(m = indices))
207                    names(indices.mapping)[length(indices.mapping)] <- m                    names(indices.mapping)[length(indices.mapping)] <- m
208                }                }
209        indices.mapping
210    }
211    
212    c2 <- function(x, y, ...) {
213        # Update the CMetaData tree
214        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
215        update.struct <- .update_id(cmeta)
216    
217        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
218    
219        # Find indices to be updated for the left tree
220        indices.mapping <- .find_indices(x)
221    
222                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
223                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
224                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
225                    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])
226                }                }
227    
228                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
229                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  
               }  
230    
231                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
232                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
233                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
234                    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])
235                }                }
236    
237                # Merge the DMetaData data frames                # Merge the DMetaData data frames
# Line 499  Line 241 
241                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
242                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
243                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
244                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
245    
246        new
247    }
248    
249    c.Corpus <-
250    function(x, ..., recursive = FALSE)
251    {
252        args <- list(...)
253    
254        if (identical(length(args), 0L))
255            return(x)
256    
257        if (!all(unlist(lapply(args, inherits, class(x)))))
258            stop("not all arguments are of the same corpus type")
259    
260        if (inherits(x, "PCorpus"))
261            stop("concatenation of corpora with underlying databases is not supported")
262    
263                return(object)      l <- base::c(list(x), args)
264            })      if (recursive)
265            Reduce(c2, l)
266        else {
267            l <- do.call("c", lapply(l, unclass))
268            .VCorpus(l,
269                     cmeta = .MetaDataNode(),
270                     dmeta = data.frame(MetaID = rep(0, length(l)), stringsAsFactors = FALSE))
271        }
272    }
273    
274  setMethod("c",  c.TextDocument <- function(x, ..., recursive = FALSE) {
           signature(x = "TextDocument"),  
           function(x, ..., recursive = TRUE){  
275                args <- list(...)                args <- list(...)
276                if(length(args) == 0)  
277        if (identical(length(args), 0L))
278                    return(x)                    return(x)
279    
280                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
281                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
282                              NodeID = 0,  
283                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
284                              children = list())      .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
285    }
286                return(new("TextDocCol",  
287                           .Data = list(x, ...),  print.Corpus <- function(x, ...) {
288                           DMetaData = dmeta.df,      cat(sprintf(ngettext(length(x),
289                           CMetaData = cmeta.node,                           "A corpus with %d text document\n",
290                           DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))                           "A corpus with %d text documents\n"),
291            })                  length(x)))
292        invisible(x)
293  setMethod("length",  }
294            signature(x = "TextDocCol"),  
295            function(x){  summary.Corpus <- function(object, ...) {
296                return(length(as(x, "list")))      print(object)
     })  
   
 setMethod("show",  
           signature(object = "TextDocCol"),  
           function(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)  
297                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
298                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
299                                                "\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",
300                                                "\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"),
301                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
302                    cat("Available tags are:\n")                    cat("Available tags are:\n")
303                    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")
304                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
305                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
306                }                }
307      })  }
308    
309  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <- function(x) UseMethod("inspect", x)
310  setMethod("inspect",  inspect.PCorpus <- function(x) {
311            signature("TextDocCol"),      summary(x)
           function(object) {  
               summary(object)  
312                cat("\n")                cat("\n")
313                if (DBControl(object)[["useDb"]]) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
314                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])      show(filehash::dbMultiFetch(db, unlist(x)))
315                    show(dbMultiFetch(db, unlist(object)))  }
316    inspect.VCorpus <- function(x) {
317        summary(x)
318        cat("\n")
319        print(noquote(lapply(x, identity)))
320                }                }
               else  
                   show(object@.Data)  
           })  
321    
322  # No metadata is checked  lapply.PCorpus <- function(X, FUN, ...) {
323  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
324  setMethod("%IN%",      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
           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))  
325                }                }
326                else  lapply.VCorpus <- function(X, FUN, ...) {
327                    result <- x %in% y      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
328                return(result)      if (!is.null(lazyTmMap))
329            })          .Call("copyCorpus", X, materialize(X))
330        base::lapply(X, FUN, ...)
331  setMethod("lapply",  }
332            signature(X = "TextDocCol"),  
333            function(X, FUN, ...) {  writeCorpus <-  function(x, path = ".", filenames = NULL) {
334                if (DBControl(X)[["useDb"]]) {      filenames <- file.path(path,
335                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
336                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                             else filenames)
337        i <- 1
338        for (o in x) {
339            writeLines(as.PlainTextDocument(o), filenames[i])
340            i <- i + 1
341                }                }
               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, ...)  
342                }                }
               else  
                   result <- base::sapply(X, FUN, ...)  
               return(result)  
           })  

Legend:
Removed from v.780  
changed lines
  Added in v.1114

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