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

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

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