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

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

Legend:
Removed from v.984  
changed lines
  Added in v.985

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge