SCM

SCM Repository

[tm] Diff of /pkg/R/corpus.R
ViewVC logotype

Diff of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/R/trunk/R/textdoccol.R revision 18, Sat Nov 5 19:00:05 2005 UTC pkg/R/corpus.R revision 984, Fri Aug 14 16:32:35 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # S4 class definition  prepareReader <- function(readerControl, defaultReader = NULL, ...) {
4  # Text document collection      if (is.null(readerControl$reader))
5  # TODO: Define proper S4 term-document matrix          readerControl$reader <- defaultReader
6  setClass("textdoccol", representation(docs = "list",      if (is(readerControl$reader, "FunctionGenerator"))
7                                        tdm = "matrix"))          readerControl$reader <- readerControl$reader(...)
8        if (is.null(readerControl$language))
9  # Accessor function          readerControl$language <- "eng"
10  if (!isGeneric("docs")) {      readerControl
11      if (is.function("docs"))  }
12          fun <- docs  
13      else  ## Fast Corpus
14          fun <- function(object) standardGeneric("docs")  ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus
15      setGeneric("docs", fun)  ##   - allows performance tests and comparisons to other corpus types
16  }  #FCorpus <- function(object, readerControl = list(language = "eng")) {
17  setMethod("docs", "textdoccol", function(object) object@docs)  #    readerControl <- prepareReader(readerControl)
18    #
19  setGeneric("textdoccol", function(docs) standardGeneric("textdoccol"))  #    if (!object@Vectorized)
20  # Read in XML text documents  #        stop("Source is not vectorized")
21  # Reuters Corpus Volume 1 (RCV1)  #
22  setMethod("textdoccol", "character", function(docs) {  #    tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
23      require(XML)  #                  function(x) readSlim(x[c("content", "uri")],
24    #                                       readerControl$language,
25      tree <- xmlTreeParse(docs)  #                                       as.character(x$id)))
26      root <- xmlRoot(tree)  #
27    #    new("FCorpus", .Data = tdl)
28      # TODO: At each loop node points to the current newsitem  #}
29      node <- root  
30    PCorpus <- function(object,
31      # TODO: Implement lacking fields.                      readerControl = list(reader = object@DefaultReader, language = "eng"),
32      # For this we need the full RCV1 XML set to know where to find those things                      dbControl = list(dbName = "", dbType = "DB1"),
33      author <- "Not yet implemented"                      ...) {
34      timestamp <- xmlAttrs(node)[["date"]]      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
35      description <- "Not yet implemented"  
36      id <- as.integer(xmlAttrs(node)[["itemid"]])      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
37      origin <- "Not yet implemented"          stop("error in creating database")
38      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
39    
40        # Allocate memory in advance if length is known
41        tdl <- if (object@Length > 0)
42            vector("list", as.integer(object@Length))
43        else
44            list()
45    
46        counter <- 1
47        while (!eoi(object)) {
48            object <- stepNext(object)
49            elem <- getElem(object)
50            doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
51            filehash::dbInsert(db, ID(doc), doc)
52            if (object@Length > 0) tdl[[counter]] <- ID(doc)
53            else tdl <- c(tdl, ID(doc))
54            counter <- counter + 1
55        }
56    
57        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
58        filehash::dbInsert(db, "DMetaData", df)
59        dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
60    
61        cmeta.node <- new("MetaDataNode",
62                          NodeID = 0,
63                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
64                          children = list())
65    
66        new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)
67    }
68    
69    # The "..." are additional arguments for the FunctionGenerator reader
70    VCorpus <- Corpus <- function(object,
71                        readerControl = list(reader = object@DefaultReader, language = "eng"),
72                        ...) {
73        readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
74    
75        # Allocate memory in advance if length is known
76        tdl <- if (object@Length > 0)
77            vector("list", as.integer(object@Length))
78        else
79            list()
80    
81        if (object@Vectorized)
82            tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
83                          function(x) readerControl$reader(x[c("content", "uri")],
84                                                           readerControl$language,
85                                                           as.character(x$id)))
86        else {
87            counter <- 1
88            while (!eoi(object)) {
89                object <- stepNext(object)
90                elem <- getElem(object)
91                doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
92                if (object@Length > 0)
93                    tdl[[counter]] <- doc
94                else
95                    tdl <- c(tdl, list(doc))
96                counter <- counter + 1
97            }
98        }
99    
100        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
101        cmeta.node <- new("MetaDataNode",
102                          NodeID = 0,
103                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
104                          children = list())
105    
106        new("VCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)
107    }
108    
109    setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
110    #setMethod("tmMap",
111    #          signature(object = "FCorpus", FUN = "function"),
112    #          function(object, FUN, ..., lazy = FALSE) {
113    #              if (lazy)
114    #                  warning("lazy mapping is deactivated")
115    #
116    #              new("FCorpus", .Data = lapply(object, FUN, ..., DMetaData = data.frame()))
117    #          })
118    setMethod("tmMap",
119              signature(object = "VCorpus", FUN = "function"),
120              function(object, FUN, ..., lazy = FALSE) {
121                  result <- object
122                  # Lazy mapping
123                  if (lazy) {
124                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
125                      if (is.null(lazyTmMap)) {
126                          meta(result, tag = "lazyTmMap", type = "corpus") <-
127                              list(index = rep(TRUE, length(result)),
128                                   maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
129                      }
130                      else {
131                          lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
132                          meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
133                      }
134                  }
135                  else {
136                      result@.Data <- if (clusterAvailable())
137                          snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))
138                      else
139                          lapply(object, FUN, ..., DMetaData = DMetaData(object))
140                  }
141                  result
142              })
143    setMethod("tmMap",
144              signature(object = "PCorpus", FUN = "function"),
145              function(object, FUN, ..., lazy = FALSE) {
146                  if (lazy)
147                      warning("lazy mapping is deactived when using database backend")
148                  db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
149                  i <- 1
150                  for (id in unlist(object)) {
151                      db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
152                      i <- i + 1
153                  }
154                  # Suggested by Christian Buchta
155                  filehash::dbReorganize(db)
156    
157                  object
158              })
159    
160    # Materialize lazy mappings
161    # Improvements by Christian Buchta
162    materialize <- function(corpus, range = seq_along(corpus)) {
163        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
164        if (!is.null(lazyTmMap)) {
165           # Make valid and lazy index
166           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
167           if (any(idx)) {
168               res <- corpus@.Data[idx]
169               for (m in lazyTmMap$maps)
170                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
171               corpus@.Data[idx] <- res
172               lazyTmMap$index[idx] <- FALSE
173           }
174        }
175        # Clean up if everything is materialized
176        if (!any(lazyTmMap$index))
177            lazyTmMap <- NULL
178        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
179        corpus
180    }
181    
182    setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
183    setMethod("asPlain", signature(object = "PlainTextDocument"),
184              function(object, FUN, ...) object)
185    setMethod("asPlain",
186              signature(object = "XMLTextDocument"),
187              function(object, FUN, ...) {
188                  require("XML")
189    
190                  corpus <- Content(object)
191    
192                  # As XMLDocument is no native S4 class, restore valid information
193                  class(corpus) <- "XMLDocument"
194                  names(corpus) <- c("doc","dtd")
195    
196                  return(FUN(xmlRoot(corpus), ...))
197              })
198    setMethod("asPlain",
199              signature(object = "Reuters21578Document"),
200              function(object, FUN, ...) {
201                  require("XML")
202    
203                  FUN <- convertReut21578XMLPlain
204                  corpus <- Content(object)
205    
206                  # As XMLDocument is no native S4 class, restore valid information
207                  class(corpus) <- "XMLDocument"
208                  names(corpus) <- c("doc","dtd")
209    
210                  return(FUN(xmlRoot(corpus), ...))
211              })
212    setMethod("asPlain", signature(object = "RCV1Document"),
213              function(object, FUN, ...) convertRCV1Plain(object, ...))
214    setMethod("asPlain",
215              signature(object = "StructuredTextDocument"),
216              function(object, FUN, ...) {
217                  new("PlainTextDocument", .Data = unlist(Content(object)),
218                      Author = Author(object), DateTimeStamp = DateTimeStamp(object),
219                      Description = Description(object), ID = ID(object), Origin = Origin(object),
220                      Heading = Heading(object), Language = Language(object),
221                      LocalMetaData = LocalMetaData(object))
222              })
223    
224    setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
225    setMethod("tmFilter", signature(object = "Corpus"),
226              function(object, ..., FUN = searchFullText, doclevel = TRUE)
227                  object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
228    
229    setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
230    setMethod("tmIndex",
231              signature(object = "Corpus"),
232              function(object, ..., FUN = searchFullText, doclevel = TRUE) {
233                  if (!is.null(attr(FUN, "doclevel")))
234                      doclevel <- attr(FUN, "doclevel")
235                  if (doclevel) {
236                      if (clusterAvailable())
237                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
238                      else
239                          return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
240                  }
241                  else
242                      return(FUN(object, ...))
243              })
244    
245    prescindMeta <- function(object, meta) {
246        df <- DMetaData(object)
247    
248        for (m in meta)
249            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
250    
251        df
252    }
253    
254    #setMethod("[",
255    #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
256    #          function(x, i, j, ... , drop) {
257    #              if (missing(i)) return(x)
258    #
259    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
260    #              x
261    #          })
262    setMethod("[",
263              signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
264              function(x, i, j, ... , drop) {
265                  if (missing(i)) return(x)
266    
267                  x@.Data <- x@.Data[i, ..., drop = FALSE]
268                  index <- x@DMetaData[[1 , "subset"]]
269                  if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
270                  else x@DMetaData[[1 , "subset"]] <- index[i]
271                  x
272              })
273    setMethod("[",
274              signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),
275              function(x, i, j, ... , drop) {
276                  if (missing(i)) return(x)
277    
278                  x@.Data <- x@.Data[i, ..., drop = FALSE]
279                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
280                  x
281              })
282    
283      heading <- xmlValue(node[["title"]])  setMethod("[<-",
284              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
285              function(x, i, j, ... , value) {
286                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
287                  counter <- 1
288                  for (id in x@.Data[i, ...]) {
289                      if (identical(length(value), 1)) db[[id]] <- value
290                      else db[[id]] <- value[[counter]]
291                      counter <- counter + 1
292                  }
293                  x
294              })
295    setMethod("[<-",
296              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
297              function(x, i, j, ... , value) {
298                  x@.Data[i, ...] <- value
299                  x
300              })
301    
302    setMethod("[[",
303              signature(x = "PCorpus", i = "ANY", j = "ANY"),
304              function(x, i, j, ...) {
305                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
306                  filehash::dbFetch(db, x@.Data[[i]])
307              })
308    setMethod("[[",
309              signature(x = "VCorpus", i = "ANY", j = "ANY"),
310              function(x, i, j, ...) {
311                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
312                  if (!is.null(lazyTmMap))
313                      .Call("copyCorpus", x, materialize(x, i))
314                  x@.Data[[i]]
315              })
316    
317    setMethod("[[<-",
318              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
319              function(x, i, j, ..., value) {
320                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
321                  index <- x@.Data[[i]]
322                  db[[index]] <- value
323                  x
324              })
325    setMethod("[[<-",
326              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
327              function(x, i, j, ..., value) {
328                  # Mark new objects as not active for lazy mapping
329                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
330                  if (!is.null(lazyTmMap)) {
331                      lazyTmMap$index[i] <- FALSE
332                      meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
333                  }
334                  # Set the value
335                  x@.Data[[i, ...]] <- value
336    
337                  x
338              })
339    
340    # Update \code{NodeID}s of a CMetaData tree
341    update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
342        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
343        set_id <- function(object) {
344            object@NodeID <- id
345            id <<- id + 1
346            level <<- level + 1
347    
348      doc <- new("textdocument", author = author, timestamp = timestamp, description = description,          if (length(object@children) > 0) {
349                 id = id, origin = origin, corpus = corpus, heading = heading)              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
350                left <- set_id(object@children[[1]])
351                if (level == 1) {
352                    left.mapping <<- mapping
353                    mapping <<- NULL
354                }
355                mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
356                right <- set_id(object@children[[2]])
357    
358                object@children <- list(left, right)
359            }
360            level <<- level - 1
361    
362      new("textdoccol", docs = list(doc), tdm = matrix())          return(object)
363        }
364    
365        list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
366    }
367    
368    setMethod("c",
369              signature(x = "Corpus"),
370              function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
371                  args <- list(...)
372                  if (identical(length(args), 0)) return(x)
373    
374                  if (!all(sapply(args, inherits, class(x))))
375                      stop("not all arguments are of the same corpus type")
376    
377                  if (inherits(x, "PCorpus"))
378                      stop("concatenation of corpora with underlying databases is not supported")
379    
380                  Reduce(c2, base::c(list(x), args))
381              })
382    
383    setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
384    #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
385    #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
386    #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
387    #          })
388    setMethod("c2", signature(x = "VCorpus", y = "VCorpus"),
389              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
390                  object <- x
391                  # Concatenate data slots
392                  object@.Data <- c(as(x, "list"), as(y, "list"))
393    
394                  # Update the CMetaData tree
395                  cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
396                  update.struct <- update_id(cmeta)
397                  object@CMetaData <- update.struct$root
398    
399                  # Find indices to be updated for the left tree
400                  indices.mapping <- NULL
401                  for (m in levels(as.factor(DMetaData(x)$MetaID))) {
402                      indices <- (DMetaData(x)$MetaID == m)
403                      indices.mapping <- c(indices.mapping, list(m = indices))
404                      names(indices.mapping)[length(indices.mapping)] <- m
405                  }
406    
407                  # Update the DMetaData data frames for the left tree
408                  for (i in 1:ncol(update.struct$left.mapping)) {
409                      map <- update.struct$left.mapping[,i]
410                      x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
411                  }
412    
413                  # Find indices to be updated for the right tree
414                  indices.mapping <- NULL
415                  for (m in levels(as.factor(DMetaData(y)$MetaID))) {
416                      indices <- (DMetaData(y)$MetaID == m)
417                      indices.mapping <- c(indices.mapping, list(m = indices))
418                      names(indices.mapping)[length(indices.mapping)] <- m
419                  }
420    
421                  # Update the DMetaData data frames for the right tree
422                  for (i in 1:ncol(update.struct$right.mapping)) {
423                      map <- update.struct$right.mapping[,i]
424                      y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
425                  }
426    
427                  # Merge the DMetaData data frames
428                  labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
429                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
430                  x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
431                  labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
432                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
433                  y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
434                  object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
435    
436                  object
437              })
438    
439    setMethod("c",
440              signature(x = "TextDocument"),
441              function(x, ..., recursive = FALSE){
442                  args <- list(...)
443                  if (identical(length(args), 0)) return(x)
444    
445                  dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
446                  cmeta.node <- new("MetaDataNode",
447                                NodeID = 0,
448                                MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
449                                children = list())
450    
451                  new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
452              })
453    
454    setMethod("show",
455              signature(object = "Corpus"),
456              function(object){
457                  cat(sprintf(ngettext(length(object),
458                                       "A corpus with %d text document\n",
459                                       "A corpus with %d text documents\n"),
460                              length(object)))
461        })
462    
463    setMethod("summary",
464              signature(object = "Corpus"),
465              function(object){
466                  show(object)
467                  if (length(DMetaData(object)) > 0) {
468                      cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
469                                                  "\nThe metadata consists of %d tag-value pair and a data frame\n",
470                                                  "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
471                                           length(CMetaData(object)@MetaData)))
472                      cat("Available tags are:\n")
473                      cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
474                      cat("Available variables in the data frame are:\n")
475                      cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
476                  }
477        })
478    
479    inspect <- function(x) UseMethod("inspect", x)
480    inspect.PCorpus <- function(x) {
481        summary(x)
482        cat("\n")
483        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
484        show(filehash::dbMultiFetch(db, unlist(x)))
485    }
486    #inspect.FCorpus <-
487    inspect.VCorpus <- function(x) {
488        summary(x)
489        cat("\n")
490        print(noquote(lapply(x, identity)))
491    }
492    
493    # No metadata is checked
494    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
495    setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
496              function(x, y) {
497                  db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
498                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
499              })
500    setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),
501              function(x, y) x %in% y)
502    
503    setMethod("lapply",
504              signature(X = "VCorpus"),
505              function(X, FUN, ...) {
506                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
507                  if (!is.null(lazyTmMap))
508                      .Call("copyCorpus", X, materialize(X))
509                  base::lapply(X, FUN, ...)
510              })
511    setMethod("lapply",
512              signature(X = "PCorpus"),
513              function(X, FUN, ...) {
514                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
515                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
516              })
517    
518    setMethod("sapply",
519              signature(X = "VCorpus"),
520              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
521                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
522                  if (!is.null(lazyTmMap))
523                      .Call("copyCorpus", X, materialize(X))
524                  base::sapply(X, FUN, ...)
525              })
526    setMethod("sapply",
527              signature(X = "PCorpus"),
528              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
529                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
530                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
531              })
532    
533    setAs("list", "VCorpus", function(from) {
534        cmeta.node <- new("MetaDataNode",
535                          NodeID = 0,
536                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
537                          children = list())
538        data <- vector("list", length(from))
539        counter <- 1
540        for (f in from) {
541            data[[counter]] <- new("PlainTextDocument",
542                                   .Data = f,
543                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
544                                   ID = as.character(counter),
545                                   Language = "eng")
546            counter <- counter + 1
547        }
548        new("VCorpus", .Data = data,
549            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
550            CMetaData = cmeta.node)
551    })
552    
553    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
554    setMethod("writeCorpus",
555              signature(object = "Corpus"),
556              function(object, path = ".", filenames = NULL) {
557                  filenames <- file.path(path,
558                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
559                                         else filenames)
560                  i <- 1
561                  for (o in object) {
562                      writeLines(asPlain(o), filenames[i])
563                      i <- i + 1
564                  }
565  })  })

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

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