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

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

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