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

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

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