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 1313, Sun Mar 30 09:28:00 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"))
         readerControl$language <- "eng"  
     readerControl  
 }  
9    
10  ## Fast Corpus      readerControl <- prepareReader(readerControl, x$defaultreader)
11  ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus  
12  ##   - allows performance tests and comparisons to other corpus types      if (is.function(readerControl$init))
13  #FCorpus <- function(object, readerControl = list(language = "eng")) {          readerControl$init()
 #    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)  
 #}  
14    
15  PCorpus <- function(object,      if (is.function(readerControl$exit))
16                      readerControl = list(reader = object@DefaultReader, language = "eng"),          on.exit(readerControl$exit())
                     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)
24          vector("list", as.integer(object@Length))          vector("list", as.integer(x$length))
25      else      else
26          list()          list()
27    
28      counter <- 1      counter <- 1
29      while (!eoi(object)) {      while (!eoi(x)) {
30          object <- stepNext(object)          x <- stepNext(x)
31          elem <- getElem(object)          elem <- getElem(x)
32          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))          id <- if (is.null(x$names) || is.na(x$names))
33          filehash::dbInsert(db, ID(doc), doc)              as.character(counter)
34          if (object@Length > 0) tdl[[counter]] <- ID(doc)          else
35          else tdl <- c(tdl, ID(doc))              x$names[counter]
36            doc <- readerControl$reader(elem, readerControl$language, id)
37            filehash::dbInsert(db, meta(doc, "id"), doc)
38            if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
39            else tdl <- c(tdl, meta(doc, "id"))
40          counter <- counter + 1          counter <- counter + 1
41      }      }
42        if (!is.null(x$names) && !is.na(x$names))
43            names(tdl) <- x$names
44    
45        structure(list(content = tdl,
46                       meta = CorpusMeta(),
47                       dmeta = data.frame(row.names = seq_along(tdl)),
48                       dbcontrol = dbControl),
49                  class = c("PCorpus", "Corpus"))
50    }
51    
52    VCorpus <- Corpus <-
53    function(x, readerControl = list(reader = x$defaultreader, language = "en"))
54    {
55        stopifnot(inherits(x, "Source"))
56    
57        readerControl <- prepareReader(readerControl, x$defaultreader)
58    
59      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      if (is.function(readerControl$init))
60      filehash::dbInsert(db, "DMetaData", df)          readerControl$init()
61      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))  
62        if (is.function(readerControl$exit))
63      cmeta.node <- new("MetaDataNode",          on.exit(readerControl$exit())
                       NodeID = 0,  
                       MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),  
                       children = list())  
   
     new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)  
 }  
   
 # The "..." are additional arguments for the FunctionGenerator reader  
 VCorpus <- Corpus <- function(object,  
                     readerControl = list(reader = object@DefaultReader, language = "eng"),  
                     ...) {  
     readerControl <- prepareReader(readerControl, object@DefaultReader, ...)  
64    
65      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
66      tdl <- if (object@Length > 0)      tdl <- if (x$length > 0)
67          vector("list", as.integer(object@Length))          vector("list", as.integer(x$length))
68      else      else
69          list()          list()
70    
71      if (object@Vectorized)      if (x$vectorized)
72          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),          tdl <- mapply(function(elem, id)
73                        function(x) readerControl$reader(x[c("content", "uri")],                            readerControl$reader(elem, readerControl$language, id),
74                                                         readerControl$language,                        pGetElem(x),
75                                                         as.character(x$id)))                        id = if (is.null(x$names) || is.na(x$names))
76                              as.character(seq_len(x$length))
77                          else x$names,
78                          SIMPLIFY = FALSE)
79      else {      else {
80          counter <- 1          counter <- 1
81          while (!eoi(object)) {          while (!eoi(x)) {
82              object <- stepNext(object)              x <- stepNext(x)
83              elem <- getElem(object)              elem <- getElem(x)
84              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))              id <- if (is.null(x$names) || is.na(x$names))
85              if (object@Length > 0)                  as.character(counter)
86                else
87                    x$names[counter]
88                doc <- readerControl$reader(elem, readerControl$language, id)
89                if (x$length > 0)
90                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
91              else              else
92                  tdl <- c(tdl, list(doc))                  tdl <- c(tdl, list(doc))
93              counter <- counter + 1              counter <- counter + 1
94          }          }
95      }      }
96        if (!is.null(x$names) && !is.na(x$names))
97            names(tdl) <- x$names
98    
99      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      structure(list(content = tdl,
100      cmeta.node <- new("MetaDataNode",                     meta = CorpusMeta(),
101                        NodeID = 0,                     dmeta = data.frame(row.names = seq_along(tdl))),
102                        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)))  
                   }  
                   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))  
103                }                }
               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)  
   
     for (m in meta)  
         df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))  
104    
105      df  `[.PCorpus` <- `[.VCorpus` <-
106    function(x, i)
107    {
108        if (!missing(i)) {
109            x$content <- x$content[i]
110            x$dmeta <- x$dmeta[i, , drop = FALSE]
111  }  }
   
 #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]  
112                x                x
113            })  }
 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  
           })  
114    
115  setMethod("[<-",  .map_name_index <-
116            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  function(x, i)
117            function(x, i, j, ... , value) {  {
118                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      if (is.character(i))
119                counter <- 1          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))
120                for (id in x@.Data[i, ...]) {      else
121                    if (identical(length(value), 1)) db[[id]] <- value          i
                   else db[[id]] <- value[[counter]]  
                   counter <- counter + 1  
122                }                }
               x  
           })  
 setMethod("[<-",  
           signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               x@.Data[i, ...] <- value  
               x  
           })  
123    
124  setMethod("[[",  `[[.PCorpus` <-
125            signature(x = "PCorpus", i = "ANY", j = "ANY"),  function(x, i)
126            function(x, i, j, ...) {  {
127                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      i <- .map_name_index(x, i)
128                filehash::dbFetch(db, x@.Data[[i]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
129            })      filehash::dbFetch(db, x$content[[i]])
130  setMethod("[[",  }
131            signature(x = "VCorpus", i = "ANY", j = "ANY"),  `[[.VCorpus` <-
132            function(x, i, j, ...) {  function(x, i)
133    {
134        i <- .map_name_index(x, i)
135                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
136                if (!is.null(lazyTmMap))                if (!is.null(lazyTmMap))
137                    .Call("copyCorpus", x, materialize(x, i))                    .Call("copyCorpus", x, materialize(x, i))
138                x@.Data[[i]]      x$content[[i]]
139            })  }
140    
141  setMethod("[[<-",  `[[<-.PCorpus` <-
142            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  function(x, i, value)
143            function(x, i, j, ..., value) {  {
144                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      i <- .map_name_index(x, i)
145                index <- x@.Data[[i]]      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
146                db[[index]] <- value      db[[x$content[[i]]]] <- value
147                x                x
148            })  }
149  setMethod("[[<-",  `[[<-.VCorpus` <-
150            signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),  function(x, i, value)
151            function(x, i, j, ..., value) {  {
152        i <- .map_name_index(x, i)
153                # Mark new objects as not active for lazy mapping                # Mark new objects as not active for lazy mapping
154                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
155                if (!is.null(lazyTmMap)) {                if (!is.null(lazyTmMap)) {
156                    lazyTmMap$index[i] <- FALSE                    lazyTmMap$index[i] <- FALSE
157                    meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap                    meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
158                }                }
159                # Set the value      x$content[[i]] <- value
               x@.Data[[i, ...]] <- value  
   
160                x                x
161            })  }
162    
163  # Update \code{NodeID}s of a CMetaData tree  # Update NodeIDs of a CMetaData tree
164  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {  .update_id <-
165      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s  function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)
166      set_id <- function(object) {  {
167          object@NodeID <- id      # Traversal of (binary) CMetaData tree with setup of NodeIDs
168        set_id <- function(x) {
169            x$NodeID <- id
170          id <<- id + 1          id <<- id + 1
171          level <<- level + 1          level <<- level + 1
172            if (length(x$Children)) {
173          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
174              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
175              if (level == 1) {              if (level == 1) {
176                  left.mapping <<- mapping                  left.mapping <<- mapping
177                  mapping <<- NULL                  mapping <<- NULL
178              }              }
179              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
180              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
181    
182              object@children <- list(left, right)              x$Children <- list(left, right)
183          }          }
184          level <<- level - 1          level <<- level - 1
185            x
186          return(object)      }
187        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
188      }      }
189    
190      list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)  # Find indices to be updated for a CMetaData tree
191    .find_indices <-
192    function(x)
193    {
194        indices.mapping <- NULL
195        for (m in levels(as.factor(CorpusDMeta(x)$MetaID))) {
196            indices <- (CorpusDMeta(x)$MetaID == m)
197            indices.mapping <- c(indices.mapping, list(m = indices))
198            names(indices.mapping)[length(indices.mapping)] <- m
199        }
200        indices.mapping
201  }  }
202    
203  setMethod("c",  #c2 <-
204            signature(x = "Corpus"),  #function(x, y, ...)
205            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {  #{
206    #    # Update the CMetaData tree
207    #    cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
208    #    update.struct <- .update_id(cmeta)
209    #
210    #    new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
211    #
212    #    # Find indices to be updated for the left tree
213    #    indices.mapping <- .find_indices(x)
214    #
215    #    # Update the CorpusDMeta data frames for the left tree
216    #    for (i in 1:ncol(update.struct$left.mapping)) {
217    #        map <- update.struct$left.mapping[,i]
218    #        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
222    #    indices.mapping <- .find_indices(y)
223    #
224    #    # Update the CorpusDMeta data frames for the right tree
225    #    for (i in 1:ncol(update.struct$right.mapping)) {
226    #        map <- update.struct$right.mapping[,i]
227    #        DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
228    #    }
229    #
230    #    # Merge the CorpusDMeta data frames
231    #    labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
232    #    na.matrix <- matrix(NA,
233    #                        nrow = nrow(DMetaData(x)),
234    #                        ncol = length(labels),
235    #                        dimnames = list(row.names(DMetaData(x)), labels))
236    #    x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
237    #    labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
238    #    na.matrix <- matrix(NA,
239    #                        nrow = nrow(DMetaData(y)),
240    #                        ncol = length(labels),
241    #                        dimnames = list(row.names(DMetaData(y)), labels))
242    #    y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
243    #    DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
244    #
245    #    new
246    #}
247    
248    c.VCorpus <-
249    function(..., recursive = FALSE)
250    {
251                args <- list(...)                args <- list(...)
252                if (identical(length(args), 0)) return(x)      x <- args[[1L]]
253    
254                if (!all(sapply(args, inherits, class(x))))      if (length(args) == 1L)
255                    stop("not all arguments are of the same corpus type")          return(x)
256    
257                if (inherits(x, "PCorpus"))      if (!all(unlist(lapply(args, inherits, class(x)))))
258                    stop("concatenation of corpora with underlying databases is not supported")          stop("not all arguments are of the same corpus type")
259    
260                Reduce(c2, base::c(list(x), args))      if (recursive)
261            })          Reduce(c2, args)
262        else {
263            args <- do.call("c", lapply(args, content))
264            structure(list(content = args,
265                           meta = CorpusMeta(),
266                           dmeta = data.frame(row.names = seq_along(args))),
267                      class = c("VCorpus", "Corpus"))
268        }
269    }
270    
271  setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))  c.TextDocument <-
272  #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),  function(..., recursive = FALSE)
273  #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {  {
274  #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))      args <- list(...)
275  #          })      x <- args[[1L]]
 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  
276    
277                # Find indices to be updated for the left tree      if (length(args) == 1L)
278                indices.mapping <- NULL          return(x)
               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  
               }  
279    
280                # Update the DMetaData data frames for the left tree      if (!all(unlist(lapply(args, inherits, class(x)))))
281                for (i in 1:ncol(update.struct$left.mapping)) {          stop("not all arguments are text documents")
                   map <- update.struct$left.mapping[,i]  
                   x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])  
               }  
282    
283                # Find indices to be updated for the right tree      structure(list(content = args,
284                indices.mapping <- NULL                     meta = CorpusMeta(),
285                for (m in levels(as.factor(DMetaData(y)$MetaID))) {                     dmeta = data.frame(row.names = seq_along(args))),
286                    indices <- (DMetaData(y)$MetaID == m)                class = c("VCorpus", "Corpus"))
                   indices.mapping <- c(indices.mapping, list(m = indices))  
                   names(indices.mapping)[length(indices.mapping)] <- m  
287                }                }
288    
289                # Update the DMetaData data frames for the right tree  as.list.PCorpus <- as.list.VCorpus <-
290                for (i in 1:ncol(update.struct$right.mapping)) {  function(x, ...)
291                    map <- update.struct$right.mapping[,i]      content(x)
                   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)  
292    
293                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)  content.VCorpus <-
294                cmeta.node <- new("MetaDataNode",  function(x)
295                              NodeID = 0,  {
296                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
297                              children = list())      if (!is.null(lazyTmMap))
298            .Call("copyCorpus", x, materialize(x))
299                new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)      x$content
           })  
   
 setMethod("show",  
           signature(object = "Corpus"),  
           function(object){  
               cat(sprintf(ngettext(length(object),  
                                    "A corpus with %d text document\n",  
                                    "A corpus with %d text documents\n"),  
                           length(object)))  
     })  
   
 setMethod("summary",  
           signature(object = "Corpus"),  
           function(object){  
               show(object)  
               if (length(DMetaData(object)) > 0) {  
                   cat(sprintf(ngettext(length(CMetaData(object)@MetaData),  
                                               "\nThe metadata consists of %d tag-value pair and a data frame\n",  
                                               "\nThe metadata consists of %d tag-value pairs and a data frame\n"),  
                                        length(CMetaData(object)@MetaData)))  
                   cat("Available tags are:\n")  
                   cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")  
                   cat("Available variables in the data frame are:\n")  
                   cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")  
               }  
     })  
   
 inspect <- function(x) UseMethod("inspect", x)  
 inspect.PCorpus <- function(x) {  
     summary(x)  
     cat("\n")  
     db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
     show(filehash::dbMultiFetch(db, unlist(x)))  
300  }  }
301  #inspect.FCorpus <-  
302  inspect.VCorpus <- function(x) {  content.PCorpus <-
303      summary(x)  function(x)
304    {
305        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
306        filehash::dbMultiFetch(db, unlist(x$content))
307    }
308    
309    length.PCorpus <- length.VCorpus <-
310    function(x)
311        length(x$content)
312    
313    print.PCorpus <- print.VCorpus <-
314    function(x, ...)
315    {
316        cat(sprintf(ngettext(length(x),
317                             "A corpus with %d text document\n\n",
318                             "A corpus with %d text documents\n\n"),
319                    length(x)))
320    
321        meta <- meta(x, type = "corpus")
322        dmeta <- meta(x, type = "indexed")
323    
324        cat("Metadata:\n")
325        cat(sprintf("  Tag-value pairs. Tags: %s\n",
326                    paste(names(meta), collapse = " ")))
327        cat("  Data frame. Variables:", colnames(dmeta), "\n")
328    
329        invisible(x)
330    }
331    
332    inspect <-
333    function(x)
334        UseMethod("inspect", x)
335    inspect.PCorpus <- inspect.VCorpus <-
336    function(x)
337    {
338        print(x)
339      cat("\n")      cat("\n")
340      print(noquote(lapply(x, identity)))      print(noquote(content(x)))
341        invisible(x)
342  }  }
343    
344  # No metadata is checked  writeCorpus <-
345  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  function(x, path = ".", filenames = NULL)
346  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) {  
347                filenames <- file.path(path,                filenames <- file.path(path,
348                                       if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))        if (is.null(filenames))
349              sprintf("%s.txt", as.character(meta(x, "id", "local")))
350                                       else filenames)                                       else filenames)
351                i <- 1  
352                for (o in object) {      stopifnot(length(x) == length(filenames))
353                    writeLines(asPlain(o), filenames[i])  
354                    i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
355    
356        invisible(x)
357                }                }
           })  

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

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