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

Legend:
Removed from v.713  
changed lines
  Added in v.1108

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