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 963, Mon Jun 29 07:01:19 2009 UTC revision 1333, Fri Apr 18 10:38:46 2014 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  prepareReader <- function(readerControl, defaultReader = NULL, ...) {  PCorpus <-
4      if (is.null(readerControl$reader))  function(x,
5          readerControl$reader <- defaultReader           readerControl = list(reader = x$defaultreader, language = "en"),
6      if (is(readerControl$reader, "FunctionGenerator"))           dbControl = list(dbName = "", dbType = "DB1"))
7          readerControl$reader <- readerControl$reader(...)  {
8      if (is.null(readerControl$language))      stopifnot(inherits(x, "Source"))
9          readerControl$language <- "eng"  
10      readerControl      readerControl <- prepareReader(readerControl, x$defaultreader)
11  }  
12        if (is.function(readerControl$init))
13  ## Fast Corpus          readerControl$init()
14  ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus  
15  ##   - allows performance tests and comparisons to other corpus types      if (is.function(readerControl$exit))
16  #FCorpus <- function(object, readerControl = list(language = "eng")) {          on.exit(readerControl$exit())
 #    readerControl <- prepareReader(readerControl)  
 #  
 #    if (!object@Vectorized)  
 #        stop("Source is not vectorized")  
 #  
 #    tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),  
 #                  function(x) readSlim(x[c("content", "uri")],  
 #                                       readerControl$language,  
 #                                       as.character(x$id)))  
 #  
 #    new("FCorpus", .Data = tdl)  
 #}  
   
 PCorpus <- function(object,  
                     readerControl = list(reader = object@DefaultReader, language = "eng"),  
                     dbControl = list(dbName = "", dbType = "DB1"),  
                     ...) {  
     readerControl <- prepareReader(readerControl, object@DefaultReader, ...)  
17    
18      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
19          stop("error in creating database")          stop("error in creating database")
20      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
21    
22      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
23      tdl <- if (object@Length > 0)      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
         vector("list", as.integer(object@Length))  
     else  
         list()  
24    
25      counter <- 1      counter <- 1
26      while (!eoi(object)) {      while (!eoi(x)) {
27          object <- stepNext(object)          x <- stepNext(x)
28          elem <- getElem(object)          elem <- getElem(x)
29          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))          id <- if (is.null(x$names) || is.na(x$names))
30          filehash::dbInsert(db, ID(doc), doc)              as.character(counter)
31          if (object@Length > 0) tdl[[counter]] <- ID(doc)          else
32          else tdl <- c(tdl, ID(doc))              x$names[counter]
33            doc <- readerControl$reader(elem, readerControl$language, id)
34            filehash::dbInsert(db, meta(doc, "id"), doc)
35            if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
36            else tdl <- c(tdl, meta(doc, "id"))
37          counter <- counter + 1          counter <- counter + 1
38      }      }
39        if (!is.null(x$names) && !is.na(x$names))
40            names(tdl) <- x$names
41    
42        structure(list(content = tdl,
43                       meta = CorpusMeta(),
44                       dmeta = data.frame(row.names = seq_along(tdl)),
45                       dbcontrol = dbControl),
46                  class = c("PCorpus", "Corpus"))
47    }
48    
49      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)  VCorpus <-
50      filehash::dbInsert(db, "DMetaData", df)  function(x, readerControl = list(reader = x$defaultreader, language = "en"))
51      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))  {
52        stopifnot(inherits(x, "Source"))
53      cmeta.node <- new("MetaDataNode",  
54                        NodeID = 0,      readerControl <- prepareReader(readerControl, x$defaultreader)
55                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),  
56                        children = list())      if (is.function(readerControl$init))
57            readerControl$init()
58      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)  
59  }      if (is.function(readerControl$exit))
60            on.exit(readerControl$exit())
 # The "..." are additional arguments for the FunctionGenerator reader  
 VCorpus <- Corpus <- function(object,  
                     readerControl = list(reader = object@DefaultReader, language = "eng"),  
                     ...) {  
     readerControl <- prepareReader(readerControl, object@DefaultReader, ...)  
61    
62      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
63      tdl <- if (object@Length > 0)      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
         vector("list", as.integer(object@Length))  
     else  
         list()  
64    
65      if (object@Vectorized)      if (x$vectorized)
66          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),          tdl <- mapply(function(elem, id)
67                        function(x) readerControl$reader(x[c("content", "uri")],                            readerControl$reader(elem, readerControl$language, id),
68                                                         readerControl$language,                        pGetElem(x),
69                                                         as.character(x$id)))                        id = if (is.null(x$names) || is.na(x$names))
70                              as.character(seq_len(x$length))
71                          else x$names,
72                          SIMPLIFY = FALSE)
73      else {      else {
74          counter <- 1          counter <- 1
75          while (!eoi(object)) {          while (!eoi(x)) {
76              object <- stepNext(object)              x <- stepNext(x)
77              elem <- getElem(object)              elem <- getElem(x)
78              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))              id <- if (is.null(x$names) || is.na(x$names))
79              if (object@Length > 0)                  as.character(counter)
80                else
81                    x$names[counter]
82                doc <- readerControl$reader(elem, readerControl$language, id)
83                if (x$length > 0)
84                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
85              else              else
86                  tdl <- c(tdl, list(doc))                  tdl <- c(tdl, list(doc))
87              counter <- counter + 1              counter <- counter + 1
88          }          }
89      }      }
90        if (!is.null(x$names) && !is.na(x$names))
91            names(tdl) <- x$names
92    
93      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      structure(list(content = tdl,
94      cmeta.node <- new("MetaDataNode",                     meta = CorpusMeta(),
95                        NodeID = 0,                     dmeta = data.frame(row.names = seq_along(tdl))),
96                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),                class = c("VCorpus", "Corpus"))
                       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)))  
97                    }                    }
                   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))  
               }  
               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 = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = 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))  
           })  
 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, ...))  
           })  
98    
99  # TODO: Replace with c(Corpus, TextDocument)?  `[.PCorpus` <-
100  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  function(x, i)
101  setMethod("appendElem",  {
102            signature(object = "Corpus", data = "TextDocument"),      if (!missing(i)) {
103            function(object, data, meta = NULL) {          x$content <- x$content[i]
104                if (DBControl(object)[["useDb"]] && require("filehash")) {          x$dmeta <- x$dmeta[i, , drop = FALSE]
                   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)  
                   object@.Data[[length(object)+1]] <- ID(data)  
105                }                }
               else  
                   object@.Data[[length(object)+1]] <- data  
               DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
               return(object)  
           })  
   
 prescindMeta <- function(object, meta) {  
     df <- DMetaData(object)  
   
     for (m in meta)  
         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) {  
               if (missing(i)) return(x)  
   
               x@.Data <- x@.Data[i, ..., drop = FALSE]  
               index <- x@DMetaData[[1 , "subset"]]  
               if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i  
               else x@DMetaData[[1 , "subset"]] <- index[i]  
106                x                x
           })  
 setMethod("[",  
           signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if (missing(i)) return(x)  
   
               x@.Data <- x@.Data[i, ..., drop = FALSE]  
               DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]  
               x  
           })  
   
 setMethod("[<-",  
           signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
               counter <- 1  
               for (id in x@.Data[i, ...]) {  
                   if (identical(length(value), 1)) db[[id]] <- value  
                   else db[[id]] <- value[[counter]]  
                   counter <- counter + 1  
107                }                }
               x  
           })  
 setMethod("[<-",  
           signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               x@.Data[i, ...] <- value  
               x  
           })  
108    
109  setMethod("[[",  `[.VCorpus` <-
110            signature(x = "PCorpus", i = "ANY", j = "ANY"),  function(x, i)
111            function(x, i, j, ...) {  {
112                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      if (!missing(i)) {
113                filehash::dbFetch(db, x@.Data[[i]])          x$content <- x$content[i]
114            })          x$dmeta <- x$dmeta[i, , drop = FALSE]
115  setMethod("[[",          if (!is.null(x$lazy))
116            signature(x = "VCorpus", i = "ANY", j = "ANY"),              x$lazy$index <- x$lazy$index[i]
           function(x, i, j, ...) {  
               lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")  
               if (!is.null(lazyTmMap))  
                   .Call("copyCorpus", x, materialize(x, i))  
               x@.Data[[i]]  
           })  
   
 setMethod("[[<-",  
           signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ..., value) {  
               db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
               index <- x@.Data[[i]]  
               db[[index]] <- value  
               x  
           })  
 setMethod("[[<-",  
           signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ..., value) {  
               # Mark new objects as not active for lazy mapping  
               lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")  
               if (!is.null(lazyTmMap)) {  
                   lazyTmMap$index[i] <- FALSE  
                   meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
117                }                }
               # Set the value  
               x@.Data[[i, ...]] <- value  
   
118                x                x
           })  
   
 # Update \code{NodeID}s of a CMetaData tree  
 update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {  
     # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s  
     set_id <- function(object) {  
         object@NodeID <- id  
         id <<- id + 1  
         level <<- level + 1  
   
         if (length(object@children) > 0) {  
             mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))  
             left <- set_id(object@children[[1]])  
             if (level == 1) {  
                 left.mapping <<- mapping  
                 mapping <<- NULL  
119              }              }
             mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))  
             right <- set_id(object@children[[2]])  
120    
121              object@children <- list(left, right)  .map_name_index <-
122    function(x, i)
123    {
124        if (is.character(i))
125            match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))
126        else
127            i
128          }          }
         level <<- level - 1  
129    
130          return(object)  `[[.PCorpus` <-
131    function(x, i)
132    {
133        i <- .map_name_index(x, i)
134        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
135        filehash::dbFetch(db, x$content[[i]])
136    }
137    `[[.VCorpus` <-
138    function(x, i)
139    {
140        i <- .map_name_index(x, i)
141        if (!is.null(x$lazy))
142            .Call(copyCorpus, x, materialize(x, i))
143        x$content[[i]]
144    }
145    
146    `[[<-.PCorpus` <-
147    function(x, i, value)
148    {
149        i <- .map_name_index(x, i)
150        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
151        db[[x$content[[i]]]] <- value
152        x
153      }      }
154    `[[<-.VCorpus` <-
155      list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)  function(x, i, value)
156    {
157        i <- .map_name_index(x, i)
158        # Mark new objects as inactive for lazy mapping
159        if (!is.null(x$lazy))
160            x$lazy$index[i] <- FALSE
161        x$content[[i]] <- value
162        x
163  }  }
164    
165  setMethod("c",  outer_union <-
166            signature(x = "Corpus"),  function(x, y, ...)
167            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {  {
168        if (nrow(x) > 0L)
169            x[, setdiff(names(y), names(x))] <- NA
170        if (nrow(y) > 0L)
171            y[, setdiff(names(x), names(y))] <- NA
172        res <- rbind(x, y)
173        if (ncol(res) == 0L)
174            res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
175        res
176    }
177    
178    c.VCorpus <-
179    function(..., recursive = FALSE)
180    {
181                args <- list(...)                args <- list(...)
182                if (identical(length(args), 0)) return(x)      x <- args[[1L]]
183    
184                if (!all(sapply(args, inherits, class(x))))      if (length(args) == 1L)
185                    stop("not all arguments are of the same corpus type")          return(x)
186    
187                if (inherits(x, "PCorpus"))      if (!all(unlist(lapply(args, inherits, class(x)))))
188                    stop("concatenation of corpora with underlying databases is not supported")          stop("not all arguments are of the same corpus type")
   
               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"))  
   
               # 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  
               indices.mapping <- NULL  
               for (m in levels(as.factor(DMetaData(x)$MetaID))) {  
                   indices <- (DMetaData(x)$MetaID == m)  
                   indices.mapping <- c(indices.mapping, list(m = indices))  
                   names(indices.mapping)[length(indices.mapping)] <- m  
               }  
   
               # Update the DMetaData data frames for the left tree  
               for (i in 1:ncol(update.struct$left.mapping)) {  
                   map <- update.struct$left.mapping[,i]  
                   x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])  
               }  
   
               # Find indices to be updated for the right tree  
               indices.mapping <- NULL  
               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  
               }  
   
               # Update the DMetaData data frames for the right tree  
               for (i in 1:ncol(update.struct$right.mapping)) {  
                   map <- update.struct$right.mapping[,i]  
                   y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])  
               }  
   
               # Merge the DMetaData data frames  
               labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))  
               na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))  
               x.dmeta.aug <- cbind(DMetaData(x), na.matrix)  
               labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))  
               na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))  
               y.dmeta.aug <- cbind(DMetaData(y), na.matrix)  
               object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)  
   
               object  
           })  
   
 setMethod("c",  
           signature(x = "TextDocument"),  
           function(x, ..., recursive = FALSE){  
               args <- list(...)  
               if (identical(length(args), 0)) return(x)  
189    
190                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      structure(list(content = do.call("c", lapply(args, content)),
191                cmeta.node <- new("MetaDataNode",                     meta = structure(do.call("c",
192                              NodeID = 0,                       lapply(args, function(a) meta(a, type = "corpus"))),
193                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),                                      class = "CorpusMeta"),
194                              children = list())                     dmeta = Reduce(outer_union, lapply(args, meta))),
195                  class = c("VCorpus", "Corpus"))
196                new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)  }
197            })  
198    as.list.PCorpus <- as.list.VCorpus <-
199  setMethod("show",  function(x, ...)
200            signature(object = "Corpus"),      content(x)
201            function(object){  
202                cat(sprintf(ngettext(length(object),  content.VCorpus <-
203                                     "A corpus with %d text document\n",  function(x)
204                                     "A corpus with %d text documents\n"),  {
205                            length(object)))      if (!is.null(x$lazy))
206      })          .Call(copyCorpus, x, materialize(x))
207        x$content
208  setMethod("summary",  }
209            signature(object = "Corpus"),  
210            function(object){  content.PCorpus <-
211                show(object)  function(x)
212                if (length(DMetaData(object)) > 0) {  {
213                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
214                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",      filehash::dbMultiFetch(db, unlist(x$content))
215                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),  }
216                                         length(CMetaData(object)@MetaData)))  
217                    cat("Available tags are:\n")  length.PCorpus <- length.VCorpus <-
218                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")  function(x)
219                    cat("Available variables in the data frame are:\n")      length(x$content)
220                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")  
221                }  print.PCorpus <- print.VCorpus <-
222      })  function(x, ...)
223    {
224  inspect <- function(x) UseMethod("inspect", x)      writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
225  inspect.PCorpus <- function(x) {                         class(x)[1],
226      summary(x)                         length(x),
227      cat("\n")                         length(meta(x, type = "corpus")),
228      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                         ncol(meta(x, type = "indexed"))))
229      show(filehash::dbMultiFetch(db, unlist(x)))      invisible(x)
230  }  }
231  #inspect.FCorpus <-  
232  inspect.VCorpus <- function(x) {  inspect <-
233      summary(x)  function(x)
234        UseMethod("inspect", x)
235    inspect.PCorpus <- inspect.VCorpus <-
236    function(x)
237    {
238        print(x)
239      cat("\n")      cat("\n")
240      print(noquote(lapply(x, identity)))      print(noquote(content(x)))
241        invisible(x)
242  }  }
243    
244  # No metadata is checked  writeCorpus <-
245  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  function(x, path = ".", filenames = NULL)
246  setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),  {
           function(x, y) {  
               db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  
               any(sapply(y, function(x, z) {x %in% Content(z)}, x))  
           })  
 setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),  
           function(x, y) x %in% y)  
   
 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, ...) {  
               db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
               lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)  
           })  
   
 setMethod("sapply",  
           signature(X = "VCorpus"),  
           function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  
               lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  
               if (!is.null(lazyTmMap))  
                   .Call("copyCorpus", X, materialize(X))  
               base::sapply(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  
     }  
     new("VCorpus", .Data = data,  
         DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),  
         CMetaData = cmeta.node)  
 })  
   
 setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))  
 setMethod("writeCorpus",  
           signature(object = "Corpus"),  
           function(object, path = ".", filenames = NULL) {  
247                filenames <- file.path(path,                filenames <- file.path(path,
248                                       if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))        if (is.null(filenames))
249              sprintf("%s.txt", as.character(meta(x, "id", "local")))
250                                       else filenames)                                       else filenames)
251                i <- 1  
252                for (o in object) {      stopifnot(length(x) == length(filenames))
253                    writeLines(asPlain(o), filenames[i])  
254                    i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
255    
256        invisible(x)
257                }                }
           })  

Legend:
Removed from v.963  
changed lines
  Added in v.1333

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