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 1064, Fri Apr 9 10:43:22 2010 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
4  setGeneric("TextDocCol", function(object,      attr(x, "CMetaData") <- cmeta
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),      attr(x, "DMetaData") <- dmeta
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),      attr(x, "DBControl") <- dbcontrol
7                                    ...) standardGeneric("TextDocCol"))      class(x) <- c("PCorpus", "Corpus", "list")
8  setMethod("TextDocCol",      x
9            signature(object = "Source"),  }
10            function(object,  DBControl <- function(x) attr(x, "DBControl")
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),  
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  PCorpus <- function(x,
13                        readerControl = list(reader = x$DefaultReader, language = "eng"),
14                        dbControl = list(dbName = "", dbType = "DB1"),
15                     ...) {                     ...) {
16                if (attr(readerControl$reader, "FunctionGenerator"))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
                   readerControl$reader <- readerControl$reader(...)  
17    
18                if (dbControl$useDb) {      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
                   if (!dbCreate(dbControl$dbName, dbControl$dbType))  
19                        stop("error in creating database")                        stop("error in creating database")
20                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
21    
22                tdl <- list()      # Allocate memory in advance if length is known
23                counter <- 1      tdl <- if (x$Length > 0)
24                while (!eoi(object)) {          vector("list", as.integer(x$Length))
                   object <- stepNext(object)  
                   elem <- getElem(object)  
                   # If there is no Load on Demand support  
                   # we need to load the corpus into memory at startup  
                   if (!object@LoDSupport)  
                       readerControl$load <- TRUE  
                   doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))  
                   if (dbControl$useDb) {  
                       dbInsert(db, ID(doc), doc)  
                       tdl <- c(tdl, ID(doc))  
                   }  
25                    else                    else
26                        tdl <- c(tdl, list(doc))          list()
27    
28        counter <- 1
29        while (!eoi(x)) {
30            x <- stepNext(x)
31            elem <- getElem(x)
32            doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
33            filehash::dbInsert(db, ID(doc), doc)
34            if (x$Length > 0) tdl[[counter]] <- ID(doc)
35            else tdl <- c(tdl, ID(doc))
36                    counter <- counter + 1                    counter <- counter + 1
37                }                }
38        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)
                   dbInsert(db, "DMetaData", df)  
42                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
43                    dbDisconnect(db)  
44        .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
45                }                }
               else  
                   dmeta.df <- df  
46    
47                cmeta.node <- new("MetaDataNode",  .VCorpus <- function(x, cmeta, dmeta) {
48                              NodeID = 0,      attr(x, "CMetaData") <- cmeta
49                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      attr(x, "DMetaData") <- dmeta
50                              children = list())      class(x) <- c("VCorpus", "Corpus", "list")
51        x
52                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(...)  
53    
54                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))  # Register S3 corpus classes to be recognized by S4 methods. This is
55                new.files <- setdiff(origin@FileList, object.filelist)  # 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                for (filename in new.files) {  # The "..." are additional arguments for the FunctionGenerator reader
61                    elem <- list(content = readLines(filename),  VCorpus <- Corpus <- function(x,
62                                 uri = substitute(file(filename)))                                readerControl = list(reader = x$DefaultReader, language = "eng"),
63                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))                                ...) {
64                }      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
   
               return(object)  
           })  
   
 setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "TextDocCol", FUN = "function"),  
           function(object, FUN, ...) {  
               result <- object  
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   i <- 1  
                   for (id in unlist(object)) {  
                       db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                       i <- i + 1  
                   }  
                   dbDisconnect(db)  
               }  
               else  
                   result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))  
               return(result)  
           })  
   
 setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  
 setMethod("asPlain",  
           signature(object = "PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("asPlain",  
           signature(object = "XMLTextDocument", FUN = "function"),  
           function(object, FUN, ...) {  
               corpus <- Corpus(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),  
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
   
 setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))  
 setMethod("tmTolower",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
   
 setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))  
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
           })  
   
 setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))  
 setMethod("stemDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, language = "english", ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- if (require("Rstem"))  
                   Rstem::wordStem(splittedCorpus, language)  
               else  
                   SnowballStemmer(splittedCorpus, Weka_control(S = language))  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
           })  
   
 setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))  
 setMethod("removePunctuation",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
           })  
   
 setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))  
 setMethod("removeWords",  
           signature(object = "PlainTextDocument", stopwords = "character"),  
           function(object, stopwords, ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  
               return(object)  
           })  
   
 setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  
 setMethod("tmFilter",  
           signature(object = "TextDocCol"),  
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
               else  
                   return(object[FUN(object, ...)])  
           })  
65    
66  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))      # Allocate memory in advance if length is known
67  setMethod("tmIndex",      tdl <- if (x$Length > 0)
68            signature(object = "TextDocCol"),          vector("list", as.integer(x$Length))
69            function(object, ..., FUN = sFilter, doclevel = FALSE) {      else
70                if (doclevel)          list()
71                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
72        if (x$Vectorized)
73            tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
74                          pGetElem(x),
75                          id = as.character(seq_len(x$Length)),
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, as.character(counter))
83                if (x$Length > 0)
84                    tdl[[counter]] <- doc
85                else                else
86                    return(FUN(object, ...))                  tdl <- c(tdl, list(doc))
87            })              counter <- counter + 1
   
 sFilter <- function(object, s, ...) {  
     con <- textConnection(s)  
     tokens <- scan(con, "character")  
     close(con)  
     localMetaNames <- unique(names(sapply(object, LocalMetaData)))  
     localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
     n <- names(DMetaData(object))  
     tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)  
     query.df <- DMetaData(prescindMeta(object, tags))  
     if (DBControl(object)[["useDb"]])  
         DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]  
     # Rename to avoid name conflicts  
     names(query.df)[names(query.df) == "Author"] <- "author"  
     names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"  
     names(query.df)[names(query.df) == "Description"] <- "description"  
     names(query.df)[names(query.df) == "ID"] <- "identifier"  
     names(query.df)[names(query.df) == "Origin"] <- "origin"  
     names(query.df)[names(query.df) == "Heading"] <- "heading"  
     names(query.df)[names(query.df) == "Language"] <- "language"  
     attach(query.df)  
     try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))  
     detach(query.df)  
     return(result)  
 }  
   
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
 setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  
 setMethod("appendElem",  
           signature(object = "TextDocCol", data = "TextDocument"),  
           function(object, data, meta = NULL) {  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   if (dbExists(db, ID(data)))  
                       warning("document with identical ID already exists")  
                   dbInsert(db, ID(data), data)  
                   dbDisconnect(db)  
                   object@.Data[[length(object)+1]] <- ID(data)  
88                }                }
               else  
                   object@.Data[[length(object)+1]] <- data  
               DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
               return(object)  
           })  
   
 setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  
 setMethod("appendMeta",  
           signature(object = "TextDocCol"),  
           function(object, cmeta = NULL, dmeta = NULL) {  
               object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)  
               if (!is.null(dmeta)) {  
                   DMetaData(object) <- cbind(DMetaData(object), eval(dmeta))  
               }  
               return(object)  
           })  
   
 setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  
 setMethod("removeMeta",  
           signature(object = "TextDocCol"),  
           function(object, cname = NULL, dname = NULL) {  
               if (!is.null(cname))  
                   object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]  
               if (!is.null(dname))  
                   DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE]  
               return(object)  
           })  
   
 setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  
 setMethod("prescindMeta",  
           signature(object = "TextDocCol", meta = "character"),  
           function(object, meta) {  
               for (m in meta) {  
                   if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {  
                       local.m <- lapply(object, m)  
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       local.m <- unlist(local.m)  
                       DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))  
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
89                    }                    }
90                    else {      names(tdl) <- x$Names
91                        local.meta <- lapply(object, LocalMetaData)      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
92                        local.m <- lapply(local.meta, "[[", m)      .VCorpus(tdl, .MetaDataNode(), df)
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       if (length(local.m) == length(unlist(local.m)))  
                           local.m <- unlist(local.m)  
                       else  
                           local.m <- I(local.m)  
                       DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))  
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
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                }                }
               return(object)  
           })  
   
 setMethod("[",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
102    
103                object <- x  `[.VCorpus` <- function(x, i) {
104                object@.Data <- x@.Data[i, ..., drop = FALSE]      if (missing(i)) return(x)
105                if (DBControl(object)[["useDb"]]) {      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
                   index <- object@DMetaData[[1 , "subset"]]  
                   if (any(is.na(index)))  
                       object@DMetaData[[1 , "subset"]] <- i  
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
106                }                }
107                else  
108                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[<-.PCorpus` <- function(x, i, value) {
109                return(object)      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
           })  
   
 setMethod("[<-",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               object <- x  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
110                    counter <- 1                    counter <- 1
111                    for (id in object@.Data[i, ...]) {      for (id in unclass(x)[i]) {
112                        if (length(value) == 1)          if (identical(length(value), 1L)) db[[id]] <- value
113                            db[[id]] <- value          else db[[id]] <- value[[counter]]
                       else {  
                           db[[id]] <- value[[counter]]  
                       }  
114                        counter <- counter + 1                        counter <- counter + 1
115                    }                    }
116                    dbDisconnect(db)      x
117                }                }
118                else  
119                    object@.Data[i, ...] <- value  `[[.PCorpus` <-  function(x, i) {
120                return(object)      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
121            })      filehash::dbFetch(db, NextMethod("[["))
122    }
123  setMethod("[[",  `[[.VCorpus` <-  function(x, i) {
124            signature(x = "TextDocCol", i = "ANY", j = "ANY"),      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
125            function(x, i, j, ...) {      if (!is.null(lazyTmMap))
126                if (DBControl(x)[["useDb"]]) {          .Call("copyCorpus", x, materialize(x, i))
127                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      NextMethod("[[")
                   result <- dbFetch(db, x@.Data[[i]])  
                   dbDisconnect(db)  
                   return(loadDoc(result))  
128                }                }
               else  
                   return(loadDoc(x@.Data[[i]]))  
           })  
129    
130  setMethod("[[<-",  `[[<-.PCorpus` <-  function(x, i, value) {
131            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
132            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]]  
133                    db[[index]] <- value                    db[[index]] <- value
134                    dbDisconnect(db)      x
135                }                }
136                else  `[[<-.VCorpus` <-  function(x, i, value) {
137                    object@.Data[[i, ...]] <- value      # Mark new objects as not active for lazy mapping
138                return(object)      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
139            })      if (!is.null(lazyTmMap)) {
140            lazyTmMap$index[i] <- FALSE
141  # Update \code{NodeID}s of a CMetaData tree          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
142  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {      }
143      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s      # Set the value
144      set_id <- function(object) {      cl <- class(x)
145          object@NodeID <- id      y <- NextMethod("[[<-")
146        class(y) <- cl
147        y
148    }
149    
150    # Update NodeIDs of a CMetaData tree
151    .update_id <- function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
152        # Traversal of (binary) CMetaData tree with setup of NodeIDs
153        set_id <- function(x) {
154            x$NodeID <- id
155          id <<- id + 1          id <<- id + 1
156          level <<- level + 1          level <<- level + 1
157            if (length(x$Children) > 0) {
158          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
159              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
160              if (level == 1) {              if (level == 1) {
161                  left.mapping <<- mapping                  left.mapping <<- mapping
162                  mapping <<- NULL                  mapping <<- NULL
163              }              }
164              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
165              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
166    
167              object@children <- list(left, right)              x$Children <- list(left, right)
168          }          }
169          level <<- level - 1          level <<- level - 1
170            x
         return(object)  
171      }      }
172        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))  
173  }  }
174    
175  setMethod("c",  # Find indices to be updated for a CMetaData tree
176            signature(x = "TextDocCol"),  .find_indices <- function(x) {
           function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               args <- list(...)  
               if (length(args) == 0)  
                   return(x)  
   
               if (!all(sapply(args, inherits, "TextDocCol")))  
                   stop("not all arguments are text document collections")  
               if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating text document collections with activated database is not supported")  
   
               result <- x  
               for (c in args) {  
                   result <- c2(result, c)  
               }  
               return(result)  
           })  
   
 setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  
 setMethod("c2",  
           signature(x = "TextDocCol", y = "TextDocCol"),  
           function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               object <- x  
               # Concatenate data slots  
               object@.Data <- c(as(x, "list"), as(y, "list"))  
   
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
               # Update the CMetaData tree  
               cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))  
               update.struct <- update_id(cmeta)  
               object@CMetaData <- update.struct$root  
   
               # Find indices to be updated for the left tree  
177                indices.mapping <- NULL                indices.mapping <- NULL
178                for (m in levels(as.factor(DMetaData(x)$MetaID))) {                for (m in levels(as.factor(DMetaData(x)$MetaID))) {
179                    indices <- (DMetaData(x)$MetaID == m)                    indices <- (DMetaData(x)$MetaID == m)
180                    indices.mapping <- c(indices.mapping, list(m = indices))                    indices.mapping <- c(indices.mapping, list(m = indices))
181                    names(indices.mapping)[length(indices.mapping)] <- m                    names(indices.mapping)[length(indices.mapping)] <- m
182                }                }
183        indices.mapping
184    }
185    
186    c2 <- function(x, y, ...) {
187        # Update the CMetaData tree
188        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
189        update.struct <- .update_id(cmeta)
190    
191        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
192    
193        # Find indices to be updated for the left tree
194        indices.mapping <- .find_indices(x)
195    
196                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
197                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
198                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
199                    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])
200                }                }
201    
202                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
203                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  
               }  
204    
205                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
206                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
207                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
208                    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])
209                }                }
210    
211                # Merge the DMetaData data frames                # Merge the DMetaData data frames
# Line 511  Line 215 
215                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
216                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))
217                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
218                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
219    
220        new
221    }
222    
223    c.Corpus <-
224    function(x, ..., recursive = FALSE)
225    {
226        args <- list(...)
227    
228                return(object)      if (identical(length(args), 0L))
229            })          return(x)
230    
231        if (!all(unlist(lapply(args, inherits, class(x)))))
232            stop("not all arguments are of the same corpus type")
233    
234        if (inherits(x, "PCorpus"))
235            stop("concatenation of corpora with underlying databases is not supported")
236    
237  setMethod("c",      Reduce(c2, base::c(list(x), args))
238            signature(x = "TextDocument"),  }
239            function(x, ..., recursive = TRUE){  
240    c.TextDocument <- function(x, ..., recursive = FALSE) {
241                args <- list(...)                args <- list(...)
242                if(length(args) == 0)  
243        if (identical(length(args), 0L))
244                    return(x)                    return(x)
245    
246                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
247                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
248                              NodeID = 0,  
249                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
250                              children = list())      .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
251    }
252                return(new("TextDocCol",  
253                           .Data = list(x, ...),  print.Corpus <- function(x, ...) {
254                           DMetaData = dmeta.df,      cat(sprintf(ngettext(length(x),
255                           CMetaData = cmeta.node,                           "A corpus with %d text document\n",
256                           DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))                           "A corpus with %d text documents\n"),
257            })                  length(x)))
258        invisible(x)
259  setMethod("length",  }
260            signature(x = "TextDocCol"),  
261            function(x){  summary.Corpus <- function(object, ...) {
262                return(length(as(x, "list")))      print(object)
     })  
   
 setMethod("show",  
           signature(object = "TextDocCol"),  
           function(object){  
               cat(sprintf(ngettext(length(object),  
                                    "A text document collection with %d text document\n",  
                                    "A text document collection with %d text documents\n"),  
                           length(object)))  
     })  
   
 setMethod("summary",  
           signature(object = "TextDocCol"),  
           function(object){  
               show(object)  
263                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
264                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
265                                                "\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",
266                                                "\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"),
267                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
268                    cat("Available tags are:\n")                    cat("Available tags are:\n")
269                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")          cat(strwrap(paste(names(CMetaData(object)$MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
270                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
271                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
272                }                }
273      })  }
274    
275  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <- function(x) UseMethod("inspect", x)
276  setMethod("inspect",  inspect.PCorpus <- function(x) {
277            signature("TextDocCol"),      summary(x)
           function(object) {  
               summary(object)  
278                cat("\n")                cat("\n")
279                if (DBControl(object)[["useDb"]]) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
280                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])      show(filehash::dbMultiFetch(db, unlist(x)))
281                    show(dbMultiFetch(db, unlist(object)))  }
282                    dbDisconnect(db)  inspect.VCorpus <- function(x) {
283        summary(x)
284        cat("\n")
285        print(noquote(lapply(x, identity)))
286                }                }
               else  
                   show(object@.Data)  
           })  
287    
288  # No metadata is checked  lapply.PCorpus <- function(X, FUN, ...) {
289  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
290  setMethod("%IN%",      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
           signature(x = "TextDocument", y = "TextDocCol"),  
           function(x, y) {  
               if (DBControl(y)[["useDb"]]) {  
                   db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  
                   result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))  
                   dbDisconnect(db)  
291                }                }
292                else  lapply.VCorpus <- function(X, FUN, ...) {
293                    result <- x %in% y      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
294                return(result)      if (!is.null(lazyTmMap))
295            })          .Call("copyCorpus", X, materialize(X))
296        base::lapply(X, FUN, ...)
297  setMethod("lapply",  }
298            signature(X = "TextDocCol"),  
299            function(X, FUN, ...) {  writeCorpus <-  function(x, path = ".", filenames = NULL) {
300                if (DBControl(X)[["useDb"]]) {      filenames <- file.path(path,
301                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
302                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                             else filenames)
303                    dbDisconnect(db)      i <- 1
304        for (o in x) {
305            writeLines(as.PlainTextDocument(o), filenames[i])
306            i <- i + 1
307                }                }
               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)  
308                }                }
               else  
                   result <- base::sapply(X, FUN, ...)  
               return(result)  
           })  

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

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