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 32, Thu Dec 15 13:13:54 2005 UTC pkg/R/corpus.R revision 982, Tue Aug 11 07:48:04 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  setClass("textdoccol",          readerControl$reader <- defaultReader
6           contains = c("list"))      if (is(readerControl$reader, "FunctionGenerator"))
7            readerControl$reader <- readerControl$reader(...)
8  # Constructors      if (is.null(readerControl$language))
9            readerControl$language <- "eng"
10  setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))      readerControl
11  setMethod("textdoccol",  }
12            c("character", "character", "logical", "logical"),  
13            function(object, inputType = "RCV1", stripWhiteSpace = FALSE, toLower = FALSE) {  ## Fast Corpus
14    ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus
15                # Add a new type for each unique input source format  ##   - allows performance tests and comparisons to other corpus types
16                type <- match.arg(inputType,c("RCV1","CSV","REUT21578"))  #FCorpus <- function(object, readerControl = list(language = "eng")) {
17                switch(type,  #    readerControl <- prepareReader(readerControl)
18                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  #
19                       # For the moment the first argument is still a single file  #    if (!object@Vectorized)
20                       # This will be changed to a directory as soon as we have the full RCV1 data set  #        stop("Source is not vectorized")
21                       "RCV1" = {  #
22                           tree <- xmlTreeParse(object)  #    tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
23                           tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))  #                  function(x) readSlim(x[c("content", "uri")],
24                       },  #                                       readerControl$language,
25                       # Text in a special CSV format (as e.g. exported from an Excel sheet)  #                                       as.character(x$id)))
26                       # For details on the file format see data/Umfrage.csv  #
27                       # The first argument has to be a single file  #    new("FCorpus", .Data = tdl)
28                       "CSV" = {  #}
29                           m <- as.matrix(read.csv(object))  
30                           l <- vector("list", dim(m)[1])  PCorpus <- function(object,
31                           for (i in 1:dim(m)[1]) {                      readerControl = list(reader = object@DefaultReader, language = "eng"),
32                               author <- "Not yet implemented"                      dbControl = list(dbName = "", dbType = "DB1"),
33                               timestamp <- date()                      ...) {
34                               description <- "Not yet implemented"      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
35                               id <- i  
36                               corpus <- as.character(m[i,2:dim(m)[2]])      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
37                               if (stripWhiteSpace)          stop("error in creating database")
38                                   corpus <- gsub("[[:space:]]+", " ", corpus)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
39                               if (toLower)  
40                                   corpus <- tolower(corpus)      # Allocate memory in advance if length is known
41                               origin <- "Not yet implemented"      tdl <- if (object@Length > 0)
42                               heading <- "Not yet implemented"          vector("list", as.integer(object@Length))
43        else
44                               l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,          list()
45                                   description = description, id = id, origin = origin, heading = heading)  
46                           }      counter <- 1
47                           tdcl <- new("textdoccol", .Data = l)      while (!eoi(object)) {
48                       },          object <- stepNext(object)
49                       # Read in text documents in Reuters-21578 XML (not SGML) format          elem <- getElem(object)
50                       # Typically the first argument will be a directory where we can          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
51                       # find the files reut2-000.xml ... reut2-021.xml          filehash::dbInsert(db, ID(doc), doc)
52                       "REUT21578" = {          if (object@Length > 0) tdl[[counter]] <- ID(doc)
53                           tdl <- sapply(dir(object,          else tdl <- c(tdl, ID(doc))
54                                             pattern = ".xml",          counter <- counter + 1
55                                             full.names = TRUE),      }
56                                         function(file) {  
57                                             tree <- xmlTreeParse(file)      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
58                                             xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)      filehash::dbInsert(db, "DMetaData", df)
59                                         })      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
60    
61                           tdcl <- new("textdoccol", .Data = tdl)      cmeta.node <- new("MetaDataNode",
62                       })                        NodeID = 0,
63                tdcl                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
64            })                        children = list())
65    
66  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)
67  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  }
68      author <- "Not yet implemented"  
69      timestamp <- xmlAttrs(node)[["date"]]  # The "..." are additional arguments for the FunctionGenerator reader
70      description <- "Not yet implemented"  VCorpus <- Corpus <- function(object,
71      id <- as.integer(xmlAttrs(node)[["itemid"]])                      readerControl = list(reader = object@DefaultReader, language = "eng"),
72      origin <- "Not yet implemented"                      ...) {
73      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
74    
75      if (stripWhiteSpace)      # Allocate memory in advance if length is known
76          corpus <- gsub("[[:space:]]+", " ", corpus)      tdl <- if (object@Length > 0)
77      if (toLower)          vector("list", as.integer(object@Length))
78          corpus <- tolower(corpus)      else
79            list()
80      heading <- xmlValue(node[["title"]])  
81        if (object@Vectorized)
82      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
83          description = description, id = id, origin = origin, heading = heading)                        function(x) readerControl$reader(x[c("content", "uri")],
84  }                                                         readerControl$language,
85                                                           as.character(x$id)))
86  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file      else {
87  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {          counter <- 1
88      author <- "Not yet implemented"          while (!eoi(object)) {
89      timestamp <- xmlValue(node[["DATE"]])              object <- stepNext(object)
90      description <- "Not yet implemented"              elem <- getElem(object)
91      id <- as.integer(xmlAttrs(node)[["NEWID"]])              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
92                if (object@Length > 0)
93      origin <- "Not yet implemented"                  tdl[[counter]] <- doc
94                else
95      # The <BODY></BODY> tag is unfortunately NOT obligatory!                  tdl <- c(tdl, list(doc))
96      if (!is.null(node[["TEXT"]][["BODY"]]))              counter <- counter + 1
97          corpus <- xmlValue(node[["TEXT"]][["BODY"]])          }
98      else      }
99          corpus <- ""  
100        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
101      if (stripWhiteSpace)      cmeta.node <- new("MetaDataNode",
102          corpus <- gsub("[[:space:]]+", " ", corpus)                        NodeID = 0,
103      if (toLower)                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
104          corpus <- tolower(corpus)                        children = list())
105    
106      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      new("VCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)
107      if (!is.null(node[["TEXT"]][["TITLE"]]))  }
108          heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
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    setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
246    setMethod("appendElem",
247              signature(object = "Corpus", data = "TextDocument"),
248              function(object, data, meta = NULL) {
249                  if (DBControl(object)[["useDb"]] && require("filehash")) {
250                      db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
251                      if (filehash::dbExists(db, ID(data)))
252                          warning("document with identical ID already exists")
253                      filehash::dbInsert(db, ID(data), data)
254                      object@.Data[[length(object)+1]] <- ID(data)
255                  }
256      else      else
257          heading <- ""                    object@.Data[[length(object)+1]] <- data
258                  DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))
259                  return(object)
260              })
261    
262    prescindMeta <- function(object, meta) {
263        df <- DMetaData(object)
264    
265        for (m in meta)
266            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
267    
268        df
269    }
270    
271      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,  #setMethod("[",
272          description = description, id = id, origin = origin, heading = heading)  #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
273    #          function(x, i, j, ... , drop) {
274    #              if (missing(i)) return(x)
275    #
276    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
277    #              x
278    #          })
279    setMethod("[",
280              signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
281              function(x, i, j, ... , drop) {
282                  if (missing(i)) return(x)
283    
284                  x@.Data <- x@.Data[i, ..., drop = FALSE]
285                  index <- x@DMetaData[[1 , "subset"]]
286                  if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
287                  else x@DMetaData[[1 , "subset"]] <- index[i]
288                  x
289              })
290    setMethod("[",
291              signature(x = "VCorpus", i = "ANY", j = "ANY", drop = "ANY"),
292              function(x, i, j, ... , drop) {
293                  if (missing(i)) return(x)
294    
295                  x@.Data <- x@.Data[i, ..., drop = FALSE]
296                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
297                  x
298              })
299    
300    setMethod("[<-",
301              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
302              function(x, i, j, ... , value) {
303                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
304                  counter <- 1
305                  for (id in x@.Data[i, ...]) {
306                      if (identical(length(value), 1)) db[[id]] <- value
307                      else db[[id]] <- value[[counter]]
308                      counter <- counter + 1
309  }  }
310                  x
311              })
312    setMethod("[<-",
313              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
314              function(x, i, j, ... , value) {
315                  x@.Data[i, ...] <- value
316                  x
317              })
318    
319    setMethod("[[",
320              signature(x = "PCorpus", i = "ANY", j = "ANY"),
321              function(x, i, j, ...) {
322                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
323                  filehash::dbFetch(db, x@.Data[[i]])
324              })
325    setMethod("[[",
326              signature(x = "VCorpus", i = "ANY", j = "ANY"),
327              function(x, i, j, ...) {
328                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
329                  if (!is.null(lazyTmMap))
330                      .Call("copyCorpus", x, materialize(x, i))
331                  x@.Data[[i]]
332              })
333    
334    setMethod("[[<-",
335              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
336              function(x, i, j, ..., value) {
337                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
338                  index <- x@.Data[[i]]
339                  db[[index]] <- value
340                  x
341              })
342    setMethod("[[<-",
343              signature(x = "VCorpus", i = "ANY", j = "ANY", value = "ANY"),
344              function(x, i, j, ..., value) {
345                  # Mark new objects as not active for lazy mapping
346                  lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
347                  if (!is.null(lazyTmMap)) {
348                      lazyTmMap$index[i] <- FALSE
349                      meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
350                  }
351                  # Set the value
352                  x@.Data[[i, ...]] <- value
353    
354                  x
355              })
356    
357    # Update \code{NodeID}s of a CMetaData tree
358    update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
359        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
360        set_id <- function(object) {
361            object@NodeID <- id
362            id <<- id + 1
363            level <<- level + 1
364    
365            if (length(object@children) > 0) {
366                mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
367                left <- set_id(object@children[[1]])
368                if (level == 1) {
369                    left.mapping <<- mapping
370                    mapping <<- NULL
371                }
372                mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
373                right <- set_id(object@children[[2]])
374    
375                object@children <- list(left, right)
376            }
377            level <<- level - 1
378    
379            return(object)
380        }
381    
382        list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
383    }
384    
385    setMethod("c",
386              signature(x = "Corpus"),
387              function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
388                  args <- list(...)
389                  if (identical(length(args), 0)) return(x)
390    
391                  if (!all(sapply(args, inherits, class(x))))
392                      stop("not all arguments are of the same corpus type")
393    
394                  if (inherits(x, "PCorpus"))
395                      stop("concatenation of corpora with underlying databases is not supported")
396    
397                  Reduce(c2, base::c(list(x), args))
398              })
399    
400    setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
401    #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
402    #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
403    #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
404    #          })
405    setMethod("c2", signature(x = "VCorpus", y = "VCorpus"),
406              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
407                  object <- x
408                  # Concatenate data slots
409                  object@.Data <- c(as(x, "list"), as(y, "list"))
410    
411                  # Update the CMetaData tree
412                  cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
413                  update.struct <- update_id(cmeta)
414                  object@CMetaData <- update.struct$root
415    
416                  # Find indices to be updated for the left tree
417                  indices.mapping <- NULL
418                  for (m in levels(as.factor(DMetaData(x)$MetaID))) {
419                      indices <- (DMetaData(x)$MetaID == m)
420                      indices.mapping <- c(indices.mapping, list(m = indices))
421                      names(indices.mapping)[length(indices.mapping)] <- m
422                  }
423    
424                  # Update the DMetaData data frames for the left tree
425                  for (i in 1:ncol(update.struct$left.mapping)) {
426                      map <- update.struct$left.mapping[,i]
427                      x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
428                  }
429    
430                  # Find indices to be updated for the right tree
431                  indices.mapping <- NULL
432                  for (m in levels(as.factor(DMetaData(y)$MetaID))) {
433                      indices <- (DMetaData(y)$MetaID == m)
434                      indices.mapping <- c(indices.mapping, list(m = indices))
435                      names(indices.mapping)[length(indices.mapping)] <- m
436                  }
437    
438                  # Update the DMetaData data frames for the right tree
439                  for (i in 1:ncol(update.struct$right.mapping)) {
440                      map <- update.struct$right.mapping[,i]
441                      y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
442                  }
443    
444                  # Merge the DMetaData data frames
445                  labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
446                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
447                  x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
448                  labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
449                  na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
450                  y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
451                  object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
452    
453                  object
454              })
455    
456    setMethod("c",
457              signature(x = "TextDocument"),
458              function(x, ..., recursive = FALSE){
459                  args <- list(...)
460                  if (identical(length(args), 0)) return(x)
461    
462                  dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
463                  cmeta.node <- new("MetaDataNode",
464                                NodeID = 0,
465                                MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
466                                children = list())
467    
468                  new("VCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
469              })
470    
471    setMethod("show",
472              signature(object = "Corpus"),
473              function(object){
474                  cat(sprintf(ngettext(length(object),
475                                       "A corpus with %d text document\n",
476                                       "A corpus with %d text documents\n"),
477                              length(object)))
478        })
479    
480    setMethod("summary",
481              signature(object = "Corpus"),
482              function(object){
483                  show(object)
484                  if (length(DMetaData(object)) > 0) {
485                      cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
486                                                  "\nThe metadata consists of %d tag-value pair and a data frame\n",
487                                                  "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
488                                           length(CMetaData(object)@MetaData)))
489                      cat("Available tags are:\n")
490                      cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
491                      cat("Available variables in the data frame are:\n")
492                      cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
493                  }
494        })
495    
496    inspect <- function(x) UseMethod("inspect", x)
497    inspect.PCorpus <- function(x) {
498        summary(x)
499        cat("\n")
500        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
501        show(filehash::dbMultiFetch(db, unlist(x)))
502    }
503    #inspect.FCorpus <-
504    inspect.VCorpus <- function(x) {
505        summary(x)
506        cat("\n")
507        print(noquote(lapply(x, identity)))
508    }
509    
510    # No metadata is checked
511    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
512    setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
513              function(x, y) {
514                  db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
515                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
516              })
517    setMethod("%IN%", signature(x = "TextDocument", y = "VCorpus"),
518              function(x, y) x %in% y)
519    
520    setMethod("lapply",
521              signature(X = "VCorpus"),
522              function(X, FUN, ...) {
523                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
524                  if (!is.null(lazyTmMap))
525                      .Call("copyCorpus", X, materialize(X))
526                  base::lapply(X, FUN, ...)
527              })
528    setMethod("lapply",
529              signature(X = "PCorpus"),
530              function(X, FUN, ...) {
531                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
532                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
533              })
534    
535    setMethod("sapply",
536              signature(X = "VCorpus"),
537              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
538                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
539                  if (!is.null(lazyTmMap))
540                      .Call("copyCorpus", X, materialize(X))
541                  base::sapply(X, FUN, ...)
542              })
543    setMethod("sapply",
544              signature(X = "PCorpus"),
545              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
546                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
547                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
548              })
549    
550    setAs("list", "VCorpus", function(from) {
551        cmeta.node <- new("MetaDataNode",
552                          NodeID = 0,
553                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
554                          children = list())
555        data <- vector("list", length(from))
556        counter <- 1
557        for (f in from) {
558            data[[counter]] <- new("PlainTextDocument",
559                                   .Data = f,
560                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
561                                   ID = as.character(counter),
562                                   Language = "eng")
563            counter <- counter + 1
564        }
565        new("VCorpus", .Data = data,
566            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
567            CMetaData = cmeta.node)
568    })
569    
570    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
571    setMethod("writeCorpus",
572              signature(object = "Corpus"),
573              function(object, path = ".", filenames = NULL) {
574                  filenames <- file.path(path,
575                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
576                                         else filenames)
577                  i <- 1
578                  for (o in object) {
579                      writeLines(asPlain(o), filenames[i])
580                      i <- i + 1
581                  }
582              })

Legend:
Removed from v.32  
changed lines
  Added in v.982

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