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

Legend:
Removed from v.37  
changed lines
  Added in v.966

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