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

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

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