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 958, Sat Jun 13 06:06:42 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" = {  FCorpus <- function(object, readerControl = list(language = "eng")) {
14                           tdl <- sapply(dir(object,      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
15                                             pattern = ".csv",  
16                                             full.names = TRUE),      if (!object@Vectorized)
17                                         function(file) {          stop("Source is not vectorized")
18                                             m <- as.matrix(read.csv(file, header = FALSE))  
19                                             l <- vector("list", dim(m)[1])      tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
20                                             for (i in 1:dim(m)[1]) {                    function(x) readSlim(x[c("content", "uri")],
21                                                 author <- ""                                         readerControl$language,
22                                                 timestamp <- date()                                         as.character(x$id)))
23                                                 description <- ""  
24                                                 id <- as.integer(m[i,1])      new("FCorpus", .Data = tdl)
25                                                 corpus <- as.character(m[i,2:dim(m)[2]])  }
26                                                 if (stripWhiteSpace)  
27                                                     corpus <- gsub("[[:space:]]+", " ", corpus)  PCorpus <- function(object,
28                                                 if (toLower)                      readerControl = list(reader = object@DefaultReader, language = "eng"),
29                                                     corpus <- tolower(corpus)                      dbControl = list(dbName = "", dbType = "DB1"),
30                                                 origin <- "CSV"                      ...) {
31                                                 heading <- ""      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
32    
33                                                 l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
34                                                               description = description, id = id, origin = origin, heading = heading)          stop("error in creating database")
35                                             }      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
36                                             l  
37                                         })      # Allocate memory in advance if length is known
38                           tdcl <- new("textdoccol", .Data = tdl)      tdl <- if (object@Length > 0)
39                       },          vector("list", as.integer(object@Length))
40                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format      else
41                       # The first argument is a directory with the RCV1 XML files          list()
42                       "RCV1" = {  
43                           tdl <- sapply(dir(object,      counter <- 1
44                                             pattern = ".xml",      while (!eoi(object)) {
45                                             full.names = TRUE),          object <- stepNext(object)
46                                         function(file) {          elem <- getElem(object)
47                                             tree <- xmlTreeParse(file)          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
48                                             xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)          filehash::dbInsert(db, ID(doc), doc)
49                                         })          if (object@Length > 0) tdl[[counter]] <- ID(doc)
50                           tdcl <- new("textdoccol", .Data = tdl)          else tdl <- c(tdl, ID(doc))
51                       },          counter <- counter + 1
52                       # Read in text documents in Reuters-21578 XML (not SGML) format      }
53                       # Typically the first argument will be a directory where we can  
54                       # find the files reut2-000.xml ... reut2-021.xml      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
55                       "REUT21578" = {      filehash::dbInsert(db, "DMetaData", df)
56                           tdl <- sapply(dir(object,      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
57                                             pattern = ".xml",  
58                                             full.names = TRUE),      cmeta.node <- new("MetaDataNode",
59                                         function(file) {                        NodeID = 0,
60                                             tree <- xmlTreeParse(file)                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
61                                             xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)                        children = list())
62                                         })  
63                           tdcl <- new("textdoccol", .Data = tdl)      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)
64                       })  }
65                tdcl  
66            })  # The "..." are additional arguments for the FunctionGenerator reader
67    SCorpus <- Corpus <- function(object,
68  # TODO: Implement lacking fields as soon I have access to the original RCV1                      readerControl = list(reader = object@DefaultReader, language = "eng"),
69  # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file                      ...) {
70  parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
71      author <- "Not yet implemented"  
72      timestamp <- xmlAttrs(node)[["date"]]      # Allocate memory in advance if length is known
73      description <- "Not yet implemented"      tdl <- if (object@Length > 0)
74      id <- as.integer(xmlAttrs(node)[["itemid"]])          vector("list", as.integer(object@Length))
75      origin <- "Reuters Corpus Volume 1 XML"      else
76      corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)          list()
77    
78      if (stripWhiteSpace)      if (object@Vectorized)
79          corpus <- gsub("[[:space:]]+", " ", corpus)          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
80      if (toLower)                        function(x) readerControl$reader(x[c("content", "uri")],
81          corpus <- tolower(corpus)                                                         readerControl$language,
82                                                           as.character(x$id)))
83      heading <- xmlValue(node[["title"]])      else {
84            counter <- 1
85      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,          while (!eoi(object)) {
86          description = description, id = id, origin = origin, heading = heading)              object <- stepNext(object)
87  }              elem <- getElem(object)
88                doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
89  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file              if (object@Length > 0)
90  parseReuters <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {                  tdl[[counter]] <- doc
     # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["AUTHOR"]]))  
         author <- xmlValue(node[["TEXT"]][["AUTHOR"]])  
     else  
         author <- ""  
   
     timestamp <- xmlValue(node[["DATE"]])  
     description <- ""  
     id <- as.integer(xmlAttrs(node)[["NEWID"]])  
   
     origin <- "Reuters-21578 XML"  
   
     # The <BODY></BODY> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["BODY"]]))  
         corpus <- xmlValue(node[["TEXT"]][["BODY"]])  
     else  
         corpus <- ""  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["TITLE"]]))  
         heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
91      else      else
92          heading <- ""                  tdl <- c(tdl, list(doc))
93                counter <- counter + 1
94            }
95        }
96    
97        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
98        cmeta.node <- new("MetaDataNode",
99                          NodeID = 0,
100                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
101                          children = list())
102    
103        new("SCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)
104    }
105    
106    setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
107    setMethod("tmMap",
108              signature(object = "FCorpus", FUN = "function"),
109              function(object, FUN, ..., lazy = FALSE) {
110                  if (lazy)
111                      warning("lazy mapping is deactivated")
112    
113                  new("FCorpus", .Data = lapply(object, FUN, ..., DMetaData = data.frame()))
114              })
115    setMethod("tmMap",
116              signature(object = "SCorpus", FUN = "function"),
117              function(object, FUN, ..., lazy = FALSE) {
118                  result <- object
119                  # Lazy mapping
120                  if (lazy) {
121                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
122                      if (is.null(lazyTmMap)) {
123                          meta(result, tag = "lazyTmMap", type = "corpus") <-
124                              list(index = rep(TRUE, length(result)),
125                                   maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
126                      }
127                      else {
128                          lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
129                          meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
130                      }
131                  }
132                  else {
133                      result@.Data <- if (clusterAvailable())
134                          snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))
135                      else
136                          lapply(object, FUN, ..., DMetaData = DMetaData(object))
137                  }
138                  result
139              })
140    setMethod("tmMap",
141              signature(object = "PCorpus", FUN = "function"),
142              function(object, FUN, ..., lazy = FALSE) {
143                  # TODO: When should lazy mapping be conceptually available?
144                  if (lazy)
145                      warning("lazy mapping is deactived when using database backend")
146                  db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
147                  i <- 1
148                  for (id in unlist(object)) {
149                      db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
150                      i <- i + 1
151                  }
152                  # Suggested by Christian Buchta
153                  filehash::dbReorganize(db)
154    
155                  object
156              })
157    
158    # Materialize lazy mappings
159    # Improvements by Christian Buchta
160    materialize <- function(corpus, range = seq_along(corpus)) {
161        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
162        if (!is.null(lazyTmMap)) {
163           # Make valid and lazy index
164           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
165           if (any(idx)) {
166               res <- corpus@.Data[idx]
167               for (m in lazyTmMap$maps)
168                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
169               corpus@.Data[idx] <- res
170               lazyTmMap$index[idx] <- FALSE
171           }
172        }
173        # Clean up if everything is materialized
174        if (!any(lazyTmMap$index))
175            lazyTmMap <- NULL
176        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
177        corpus
178    }
179    
180    setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
181    setMethod("asPlain", signature(object = "PlainTextDocument"),
182              function(object, FUN, ...) object)
183    setMethod("asPlain",
184              signature(object = "XMLTextDocument"),
185              function(object, FUN, ...) {
186                  require("XML")
187    
188                  corpus <- Content(object)
189    
190                  # As XMLDocument is no native S4 class, restore valid information
191                  class(corpus) <- "XMLDocument"
192                  names(corpus) <- c("doc","dtd")
193    
194                  return(FUN(xmlRoot(corpus), ...))
195              })
196    setMethod("asPlain",
197              signature(object = "Reuters21578Document"),
198              function(object, FUN, ...) {
199                  require("XML")
200    
201                  FUN <- convertReut21578XMLPlain
202                  corpus <- Content(object)
203    
204                  # As XMLDocument is no native S4 class, restore valid information
205                  class(corpus) <- "XMLDocument"
206                  names(corpus) <- c("doc","dtd")
207    
208                  return(FUN(xmlRoot(corpus), ...))
209              })
210    setMethod("asPlain", signature(object = "RCV1Document"),
211              function(object, FUN, ...) convertRCV1Plain(object, ...))
212    setMethod("asPlain",
213              signature(object = "NewsgroupDocument"),
214              function(object, FUN, ...) {
215                  new("PlainTextDocument", .Data = Content(object), Author = Author(object),
216                      DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
217                      Origin = Origin(object), Heading = Heading(object), Language = Language(object),
218                      LocalMetaData = LocalMetaData(object))
219              })
220    setMethod("asPlain",
221              signature(object = "StructuredTextDocument"),
222              function(object, FUN, ...) {
223                  new("PlainTextDocument", .Data = unlist(Content(object)),
224                      Author = Author(object), DateTimeStamp = DateTimeStamp(object),
225                      Description = Description(object), ID = ID(object), Origin = Origin(object),
226                      Heading = Heading(object), Language = Language(object),
227                      LocalMetaData = LocalMetaData(object))
228              })
229    
230    setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
231    setMethod("tmFilter", signature(object = "Corpus"),
232              function(object, ..., FUN = searchFullText, doclevel = TRUE)
233                  object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
234    
235    setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
236    setMethod("tmIndex",
237              signature(object = "Corpus"),
238              function(object, ..., FUN = searchFullText, doclevel = TRUE) {
239                  if (!is.null(attr(FUN, "doclevel")))
240                      doclevel <- attr(FUN, "doclevel")
241                  if (doclevel) {
242                      if (clusterAvailable())
243                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
244                      else
245                          return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
246                  }
247                  else
248                      return(FUN(object, ...))
249              })
250    
251    # TODO: Replace with c(Corpus, TextDocument)?
252    setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
253    setMethod("appendElem",
254              signature(object = "Corpus", data = "TextDocument"),
255              function(object, data, meta = NULL) {
256                  if (DBControl(object)[["useDb"]] && require("filehash")) {
257                      db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
258                      if (dbExists(db, ID(data)))
259                          warning("document with identical ID already exists")
260                      dbInsert(db, ID(data), data)
261                      object@.Data[[length(object)+1]] <- ID(data)
262                  }
263                  else
264                      object@.Data[[length(object)+1]] <- data
265                  DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))
266                  return(object)
267              })
268    
269    prescindMeta <- function(object, meta) {
270        df <- DMetaData(object)
271    
272        for (m in meta)
273            df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
274    
275        df
276    }
277    
278    setMethod("[",
279              signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
280              function(x, i, j, ... , drop) {
281                  if (missing(i)) return(x)
282    
283                  x@.Data <- x@.Data[i, ..., drop = FALSE]
284                  x
285              })
286    setMethod("[",
287              signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
288              function(x, i, j, ... , drop) {
289                  if (missing(i)) return(x)
290    
291                  x@.Data <- x@.Data[i, ..., drop = FALSE]
292                  index <- x@DMetaData[[1 , "subset"]]
293                  if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
294                  else x@DMetaData[[1 , "subset"]] <- index[i]
295                  x
296              })
297    setMethod("[",
298              signature(x = "SCorpus", i = "ANY", j = "ANY", drop = "ANY"),
299              function(x, i, j, ... , drop) {
300                  if (missing(i)) return(x)
301    
302                  x@.Data <- x@.Data[i, ..., drop = FALSE]
303                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
304                  x
305              })
306    
307    setMethod("[<-",
308              signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
309              function(x, i, j, ... , value) {
310                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
311                  counter <- 1
312                  for (id in x@.Data[i, ...]) {
313                      if (identical(length(value), 1)) db[[id]] <- value
314                      else db[[id]] <- value[[counter]]
315                      counter <- counter + 1
316                  }
317                  x
318              })
319    setMethod("[<-",
320              signature(x = "SCorpus", i = "ANY", j = "ANY", value = "ANY"),
321              function(x, i, j, ... , value) {
322                  x@.Data[i, ...] <- value
323                  x
324              })
325    
326    setMethod("[[",
327              signature(x = "PCorpus", i = "ANY", j = "ANY"),
328              function(x, i, j, ...) {
329                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
330                  filehash::dbFetch(db, x@.Data[[i]])
331              })
332    setMethod("[[",
333              signature(x = "SCorpus", i = "ANY", j = "ANY"),
334              function(x, i, j, ...) {
335                  # TODO: For which corpora should lazy mapping be available?
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 = "SCorpus", 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 = "SCorpus", y = "SCorpus"),
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      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,                # Find indices to be updated for the right tree
439          description = description, id = id, origin = origin, heading = heading)                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                  # Update the DMetaData data frames for the right tree
447                  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("SCorpus", .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 <- inspect.SCorpus <- function(x) {
512        summary(x)
513        cat("\n")
514        print(noquote(lapply(x, identity)))
515    }
516    
517    # No metadata is checked
518    setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
519    setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
520              function(x, y) {
521                  db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
522                  any(sapply(y, function(x, z) {x %in% Content(z)}, x))
523              })
524    setMethod("%IN%", signature(x = "TextDocument", y = "SCorpus"),
525              function(x, y) x %in% y)
526    
527    setMethod("lapply",
528              signature(X = "SCorpus"),
529              function(X, FUN, ...) {
530                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
531                  if (!is.null(lazyTmMap))
532                      .Call("copyCorpus", X, materialize(X))
533                  base::lapply(X, FUN, ...)
534              })
535    setMethod("lapply",
536              signature(X = "PCorpus"),
537              function(X, FUN, ...) {
538                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
539                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
540              })
541    
542    setMethod("sapply",
543              signature(X = "SCorpus"),
544              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
545                  lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
546                  if (!is.null(lazyTmMap))
547                      .Call("copyCorpus", X, materialize(X))
548                  base::sapply(X, FUN, ...)
549              })
550    setMethod("sapply",
551              signature(X = "PCorpus"),
552              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
553                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
554                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
555              })
556    
557    setAs("list", "SCorpus", function(from) {
558        cmeta.node <- new("MetaDataNode",
559                          NodeID = 0,
560                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
561                          children = list())
562        data <- vector("list", length(from))
563        counter <- 1
564        for (f in from) {
565            data[[counter]] <- new("PlainTextDocument",
566                                   .Data = f,
567                                   DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
568                                   ID = as.character(counter),
569                                   Language = "eng")
570            counter <- counter + 1
571        }
572        new("SCorpus", .Data = data,
573            DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
574            CMetaData = cmeta.node)
575    })
576    
577    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
578    setMethod("writeCorpus",
579              signature(object = "Corpus"),
580              function(object, path = ".", filenames = NULL) {
581                  filenames <- file.path(path,
582                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
583                                         else filenames)
584                  i <- 1
585                  for (o in object) {
586                      writeLines(asPlain(o), filenames[i])
587                      i <- i + 1
588                  }
589              })

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

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