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

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

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge