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 963, Mon Jun 29 07:01:19 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      heading <- xmlValue(node[["title"]])  # 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 = "NewsgroupDocument"),
216              function(object, FUN, ...) {
217                  new("PlainTextDocument", .Data = Content(object), Author = Author(object),
218                      DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
219                      Origin = Origin(object), Heading = Heading(object), Language = Language(object),
220                      LocalMetaData = LocalMetaData(object))
221              })
222    setMethod("asPlain",
223              signature(object = "StructuredTextDocument"),
224              function(object, FUN, ...) {
225                  new("PlainTextDocument", .Data = unlist(Content(object)),
226                      Author = Author(object), DateTimeStamp = DateTimeStamp(object),
227                      Description = Description(object), ID = ID(object), Origin = Origin(object),
228                      Heading = Heading(object), Language = Language(object),
229                      LocalMetaData = LocalMetaData(object))
230              })
231    
232    setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
233    setMethod("tmFilter", signature(object = "Corpus"),
234              function(object, ..., FUN = searchFullText, doclevel = TRUE)
235                  object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
236    
237    setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
238    setMethod("tmIndex",
239              signature(object = "Corpus"),
240              function(object, ..., FUN = searchFullText, doclevel = TRUE) {
241                  if (!is.null(attr(FUN, "doclevel")))
242                      doclevel <- attr(FUN, "doclevel")
243                  if (doclevel) {
244                      if (clusterAvailable())
245                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
246                      else
247                          return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
248                  }
249                  else
250                      return(FUN(object, ...))
251              })
252    
253    # TODO: Replace with c(Corpus, TextDocument)?
254    setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
255    setMethod("appendElem",
256              signature(object = "Corpus", data = "TextDocument"),
257              function(object, data, meta = NULL) {
258                  if (DBControl(object)[["useDb"]] && require("filehash")) {
259                      db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
260                      if (dbExists(db, ID(data)))
261                          warning("document with identical ID already exists")
262                      dbInsert(db, ID(data), data)
263                      object@.Data[[length(object)+1]] <- ID(data)
264                  }
265                  else
266                      object@.Data[[length(object)+1]] <- data
267                  DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))
268                  return(object)
269              })
270    
271      doc <- new("textdocument", author = author, timestamp = timestamp, description = description,  prescindMeta <- function(object, meta) {
272                 id = id, origin = origin, corpus = corpus, heading = heading)      df <- DMetaData(object)
273    
274        for (m in meta)
275            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
276    
277        df
278    }
279    
280    #setMethod("[",
281    #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
282    #          function(x, i, j, ... , drop) {
283    #              if (missing(i)) return(x)
284    #
285    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
286    #              x
287    #          })
288    setMethod("[",
289              signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
290              function(x, i, j, ... , drop) {
291                  if (missing(i)) return(x)
292    
293                  x@.Data <- x@.Data[i, ..., drop = FALSE]
294                  index <- x@DMetaData[[1 , "subset"]]
295                  if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
296                  else x@DMetaData[[1 , "subset"]] <- index[i]
297                  x
298              })
299    setMethod("[",
300              signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),
301              function(x, i, j, ... , drop) {
302                  if (missing(i)) return(x)
303    
304                  x@.Data <- x@.Data[i, ..., drop = FALSE]
305                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
306                  x
307              })
308    
309      new("textdoccol", docs = list(doc), tdm = matrix())  setMethod("[<-",
310              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
311              function(x, i, j, ... , value) {
312                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
313                  counter <- 1
314                  for (id in x@.Data[i, ...]) {
315                      if (identical(length(value), 1)) db[[id]] <- value
316                      else db[[id]] <- value[[counter]]
317                      counter <- counter + 1
318                  }
319                  x
320              })
321    setMethod("[<-",
322              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
323              function(x, i, j, ... , value) {
324                  x@.Data[i, ...] <- value
325                  x
326              })
327    
328    setMethod("[[",
329              signature(x = "PCorpus", i = "ANY", j = "ANY"),
330              function(x, i, j, ...) {
331                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
332                  filehash::dbFetch(db, x@.Data[[i]])
333              })
334    setMethod("[[",
335              signature(x = "VCorpus", i = "ANY", j = "ANY"),
336              function(x, i, j, ...) {
337                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
338                  if (!is.null(lazyTmMap))
339                      .Call("copyCorpus", x, materialize(x, i))
340                  x@.Data[[i]]
341              })
342    
343    setMethod("[[<-",
344              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
345              function(x, i, j, ..., value) {
346                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
347                  index <- x@.Data[[i]]
348                  db[[index]] <- value
349                  x
350              })
351    setMethod("[[<-",
352              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
353              function(x, i, j, ..., value) {
354                  # Mark new objects as not active for lazy mapping
355                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
356                  if (!is.null(lazyTmMap)) {
357                      lazyTmMap$index[i] <- FALSE
358                      meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
359                  }
360                  # Set the value
361                  x@.Data[[i, ...]] <- value
362    
363                  x
364              })
365    
366    # Update \code{NodeID}s of a CMetaData tree
367    update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
368        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
369        set_id <- function(object) {
370            object@NodeID <- id
371            id <<- id + 1
372            level <<- level + 1
373    
374            if (length(object@children) > 0) {
375                mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
376                left <- set_id(object@children[[1]])
377                if (level == 1) {
378                    left.mapping <<- mapping
379                    mapping <<- NULL
380                }
381                mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
382                right <- set_id(object@children[[2]])
383    
384                object@children <- list(left, right)
385            }
386            level <<- level - 1
387    
388            return(object)
389        }
390    
391        list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
392    }
393    
394    setMethod("c",
395              signature(x = "Corpus"),
396              function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
397                  args <- list(...)
398                  if (identical(length(args), 0)) return(x)
399    
400                  if (!all(sapply(args, inherits, class(x))))
401                      stop("not all arguments are of the same corpus type")
402    
403                  if (inherits(x, "PCorpus"))
404                      stop("concatenation of corpora with underlying databases is not supported")
405    
406                  Reduce(c2, base::c(list(x), args))
407              })
408    
409    setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
410    #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
411    #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
412    #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
413    #          })
414    setMethod("c2", signature(x = "VCorpus", y = "VCorpus"),
415              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
416                  object <- x
417                  # Concatenate data slots
418                  object@.Data <- c(as(x, "list"), as(y, "list"))
419    
420                  # Update the CMetaData tree
421                  cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
422                  update.struct <- update_id(cmeta)
423                  object@CMetaData <- update.struct$root
424    
425                  # Find indices to be updated for the left tree
426                  indices.mapping <- NULL
427                  for (m in levels(as.factor(DMetaData(x)$MetaID))) {
428                      indices <- (DMetaData(x)$MetaID == m)
429                      indices.mapping <- c(indices.mapping, list(m = indices))
430                      names(indices.mapping)[length(indices.mapping)] <- m
431                  }
432    
433                  # Update the DMetaData data frames for the left tree
434                  for (i in 1:ncol(update.struct$left.mapping)) {
435                      map <- update.struct$left.mapping[,i]
436                      x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
437                  }
438    
439                  # Find indices to be updated for the right tree
440                  indices.mapping <- NULL
441                  for (m in levels(as.factor(DMetaData(y)$MetaID))) {
442                      indices <- (DMetaData(y)$MetaID == m)
443                      indices.mapping <- c(indices.mapping, list(m = indices))
444                      names(indices.mapping)[length(indices.mapping)] <- m
445                  }
446    
447                  # Update the DMetaData data frames for the right tree
448                  for (i in 1:ncol(update.struct$right.mapping)) {
449                      map <- update.struct$right.mapping[,i]
450                      y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
451                  }
452    
453                  # Merge the DMetaData data frames
454                  labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
455                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
456                  x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
457                  labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
458                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
459                  y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
460                  object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
461    
462                  object
463              })
464    
465    setMethod("c",
466              signature(x = "TextDocument"),
467              function(x, ..., recursive = FALSE){
468                  args <- list(...)
469                  if (identical(length(args), 0)) return(x)
470    
471                  dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
472                  cmeta.node <- new("MetaDataNode",
473                                NodeID = 0,
474                                MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
475                                children = list())
476    
477                  new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
478              })
479    
480    setMethod("show",
481              signature(object = "Corpus"),
482              function(object){
483                  cat(sprintf(ngettext(length(object),
484                                       "A corpus with %d text document\n",
485                                       "A corpus with %d text documents\n"),
486                              length(object)))
487        })
488    
489    setMethod("summary",
490              signature(object = "Corpus"),
491              function(object){
492                  show(object)
493                  if (length(DMetaData(object)) > 0) {
494                      cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
495                                                  "\nThe metadata consists of %d tag-value pair and a data frame\n",
496                                                  "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
497                                           length(CMetaData(object)@MetaData)))
498                      cat("Available tags are:\n")
499                      cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
500                      cat("Available variables in the data frame are:\n")
501                      cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
502                  }
503        })
504    
505    inspect <- function(x) UseMethod("inspect", x)
506    inspect.PCorpus <- function(x) {
507        summary(x)
508        cat("\n")
509        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
510        show(filehash::dbMultiFetch(db, unlist(x)))
511    }
512    #inspect.FCorpus <-
513    inspect.VCorpus <- function(x) {
514        summary(x)
515        cat("\n")
516        print(noquote(lapply(x, identity)))
517    }
518    
519    # No metadata is checked
520    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
521    setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
522              function(x, y) {
523                  db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
524                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
525              })
526    setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),
527              function(x, y) x %in% y)
528    
529    setMethod("lapply",
530              signature(X = "VCorpus"),
531              function(X, FUN, ...) {
532                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
533                  if (!is.null(lazyTmMap))
534                      .Call("copyCorpus", X, materialize(X))
535                  base::lapply(X, FUN, ...)
536              })
537    setMethod("lapply",
538              signature(X = "PCorpus"),
539              function(X, FUN, ...) {
540                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
541                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
542              })
543    
544    setMethod("sapply",
545              signature(X = "VCorpus"),
546              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
547                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
548                  if (!is.null(lazyTmMap))
549                      .Call("copyCorpus", X, materialize(X))
550                  base::sapply(X, FUN, ...)
551              })
552    setMethod("sapply",
553              signature(X = "PCorpus"),
554              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
555                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
556                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
557              })
558    
559    setAs("list", "VCorpus", function(from) {
560        cmeta.node <- new("MetaDataNode",
561                          NodeID = 0,
562                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
563                          children = list())
564        data <- vector("list", length(from))
565        counter <- 1
566        for (f in from) {
567            data[[counter]] <- new("PlainTextDocument",
568                                   .Data = f,
569                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
570                                   ID = as.character(counter),
571                                   Language = "eng")
572            counter <- counter + 1
573        }
574        new("VCorpus", .Data = data,
575            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
576            CMetaData = cmeta.node)
577    })
578    
579    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
580    setMethod("writeCorpus",
581              signature(object = "Corpus"),
582              function(object, path = ".", filenames = NULL) {
583                  filenames <- file.path(path,
584                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
585                                         else filenames)
586                  i <- 1
587                  for (o in object) {
588                      writeLines(asPlain(o), filenames[i])
589                      i <- i + 1
590                  }
591  })  })

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

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