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

revision 950, Thu May 14 15:17:18 2009 UTC revision 995, Mon Sep 7 07:54:08 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  FCorpus <- function(object, readerControl = list(language = "eng")) {  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
4      if (is.null(readerControl$language))      attr(x, "CMetaData") <- cmeta
5          readerControl$language <- "eng"      attr(x, "DMetaData") <- dmeta
6        attr(x, "DBControl") <- dbcontrol
7      if (!object@Vectorized)      class(x) <- c("PCorpus", "Corpus", "list")
8          stop("Source is not vectorized")      x
   
     tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),  
                   function(x) readSlim(x[c("content", "uri")],  
                                        readerControl$language,  
                                        as.character(x$id)))  
   
     new("FCorpus", .Data = tdl)  
9  }  }
10    DBControl <- function(x) attr(x, "DBControl")
11    
12  PCorpus <- function(object,  PCorpus <- function(x,
13                      readerControl = list(reader = object@DefaultReader, language = "eng"),                      readerControl = list(reader = x$DefaultReader, language = "eng"),
14                      dbControl = list(dbName = "", dbType = "DB1"),                      dbControl = list(dbName = "", dbType = "DB1"),
15                      ...) {                      ...) {
16      if (is.null(readerControl$reader))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
         readerControl$reader <- object@DefaultReader  
     if (is(readerControl$reader, "FunctionGenerator"))  
         readerControl$reader <- readerControl$reader(...)  
     if (is.null(readerControl$language))  
         readerControl$language <- "eng"  
17    
18      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
19          stop("error in creating database")          stop("error in creating database")
20      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
21    
22      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
23      tdl <- if (object@Length > 0)      tdl <- if (x$Length > 0)
24          vector("list", as.integer(object@Length))          vector("list", as.integer(x$Length))
25      else      else
26          list()          list()
27    
28      counter <- 1      counter <- 1
29      while (!eoi(object)) {      while (!eoi(x)) {
30          object <- stepNext(object)          x <- stepNext(x)
31          elem <- getElem(object)          elem <- getElem(x)
32          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
33          filehash::dbInsert(db, ID(doc), doc)          filehash::dbInsert(db, ID(doc), doc)
34          if (object@Length > 0) tdl[[counter]] <- ID(doc)          if (x$Length > 0) tdl[[counter]] <- ID(doc)
35          else tdl <- c(tdl, ID(doc))          else tdl <- c(tdl, ID(doc))
36          counter <- counter + 1          counter <- counter + 1
37      }      }
# Line 51  Line 40 
40      filehash::dbInsert(db, "DMetaData", df)      filehash::dbInsert(db, "DMetaData", df)
41      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
42    
43      cmeta.node <- new("MetaDataNode",      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
44                        NodeID = 0,  }
                       MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),  
                       children = list())  
45    
46      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)  .VCorpus <- function(x, cmeta, dmeta) {
47        attr(x, "CMetaData") <- cmeta
48        attr(x, "DMetaData") <- dmeta
49        class(x) <- c("VCorpus", "Corpus", "list")
50        x
51  }  }
52    
53  # The "..." are additional arguments for the FunctionGenerator reader  # The "..." are additional arguments for the FunctionGenerator reader
54  SCorpus <- Corpus <- function(object,  VCorpus <- Corpus <- function(x,
55                      readerControl = list(reader = object@DefaultReader, language = "eng"),                      readerControl = list(reader = x$DefaultReader, language = "eng"),
56                      ...) {                      ...) {
57      if (is.null(readerControl$reader))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
         readerControl$reader <- object@DefaultReader  
     if (is(readerControl$reader, "FunctionGenerator"))  
         readerControl$reader <- readerControl$reader(...)  
     if (is.null(readerControl$language))  
         readerControl$language <- "eng"  
58    
59      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
60      tdl <- if (object@Length > 0)      tdl <- if (x$Length > 0)
61          vector("list", as.integer(object@Length))          vector("list", as.integer(x$Length))
62      else      else
63          list()          list()
64    
65      if (object@Vectorized)      if (x$Vectorized)
66          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
67                        function(x) readerControl$reader(x[c("content", "uri")],                        pGetElem(x),
68                                                         readerControl$language,                        id = as.character(seq_len(x$Length)),
69                                                         as.character(x$id)))                        SIMPLIFY = FALSE)
70      else {      else {
71          counter <- 1          counter <- 1
72          while (!eoi(object)) {          while (!eoi(x)) {
73              object <- stepNext(object)              x <- stepNext(x)
74              elem <- getElem(object)              elem <- getElem(x)
75              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
76              if (object@Length > 0)              if (x$Length > 0)
77                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
78              else              else
79                  tdl <- c(tdl, list(doc))                  tdl <- c(tdl, list(doc))
# Line 96  Line 82 
82      }      }
83    
84      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
85      cmeta.node <- new("MetaDataNode",      .VCorpus(tdl, .MetaDataNode(), df)
                       NodeID = 0,  
                       MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),  
                       children = list())  
   
     new("SCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)  
 }  
   
 setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "FCorpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               if (lazy)  
                   warning("lazy mapping is deactivated")  
   
               lapply(object, FUN, ..., DMetaData = data.frame())  
           })  
 setMethod("tmMap",  
           signature(object = "SCorpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               result <- object  
               # Lazy mapping  
               if (lazy) {  
                   lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")  
                   if (is.null(lazyTmMap)) {  
                       meta(result, tag = "lazyTmMap", type = "corpus") <-  
                           list(index = rep(TRUE, length(result)),  
                                maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  
                   }  
                   else {  
                       lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  
                       meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
                   }  
               }  
               else {  
                   result@.Data <- if (clusterAvailable())  
                       snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))  
                   else  
                       lapply(object, FUN, ..., DMetaData = DMetaData(object))  
               }  
               result  
           })  
 setMethod("tmMap",  
           signature(object = "PCorpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               # TODO: When should lazy mapping be conceptually available?  
               if (lazy)  
                   warning("lazy mapping is deactived when using database backend")  
               db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
               i <- 1  
               for (id in unlist(object)) {  
                   db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                   i <- i + 1  
               }  
               # Suggested by Christian Buchta  
               filehash::dbReorganize(db)  
   
               object  
           })  
   
 # Materialize lazy mappings  
 # Improvements by Christian Buchta  
 materialize <- function(corpus, range = seq_along(corpus)) {  
     lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")  
     if (!is.null(lazyTmMap)) {  
        # Make valid and lazy index  
        idx <- (seq_along(corpus) %in% range) & lazyTmMap$index  
        if (any(idx)) {  
            res <- corpus@.Data[idx]  
            for (m in lazyTmMap$maps)  
                res <- lapply(res, m, DMetaData = DMetaData(corpus))  
            corpus@.Data[idx] <- res  
            lazyTmMap$index[idx] <- FALSE  
        }  
     }  
     # Clean up if everything is materialized  
     if (!any(lazyTmMap$index))  
         lazyTmMap <- NULL  
     meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     corpus  
 }  
   
 setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  
 setMethod("asPlain", signature(object = "PlainTextDocument"),  
           function(object, FUN, ...) object)  
 setMethod("asPlain",  
           signature(object = "XMLTextDocument"),  
           function(object, FUN, ...) {  
               require("XML")  
   
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "Reuters21578Document"),  
           function(object, FUN, ...) {  
               require("XML")  
   
               FUN <- convertReut21578XMLPlain  
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain", signature(object = "RCV1Document"),  
           function(object, FUN, ...) convertRCV1Plain(object, ...))  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Content(object), Author = Author(object),  
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
 setMethod("asPlain",  
           signature(object = "StructuredTextDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = unlist(Content(object)),  
                   Author = Author(object), DateTimeStamp = DateTimeStamp(object),  
                   Description = Description(object), ID = ID(object), Origin = Origin(object),  
                   Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
   
 setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))  
 setMethod("tmFilter", signature(object = "Corpus"),  
           function(object, ..., FUN = searchFullText, doclevel = TRUE)  
               object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])  
   
 setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))  
 setMethod("tmIndex",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = searchFullText, doclevel = TRUE) {  
               if (!is.null(attr(FUN, "doclevel")))  
                   doclevel <- attr(FUN, "doclevel")  
               if (doclevel) {  
                   if (clusterAvailable())  
                       return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))  
                   else  
                       return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
               }  
               else  
                   return(FUN(object, ...))  
           })  
   
 # TODO: Replace with c(Corpus, TextDocument)?  
 setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  
 setMethod("appendElem",  
           signature(object = "Corpus", data = "TextDocument"),  
           function(object, data, meta = NULL) {  
               if (DBControl(object)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   if (dbExists(db, ID(data)))  
                       warning("document with identical ID already exists")  
                   dbInsert(db, ID(data), data)  
                   object@.Data[[length(object)+1]] <- ID(data)  
86                }                }
               else  
                   object@.Data[[length(object)+1]] <- data  
               DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
               return(object)  
           })  
87    
88  prescindMeta <- function(object, meta) {  `[.PCorpus` <- function(x, i) {
     df <- DMetaData(object)  
   
     for (m in meta)  
         df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))  
   
     df  
 }  
   
 setMethod("[",  
           signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
89                if (missing(i)) return(x)                if (missing(i)) return(x)
90        index <- attr(x, "DMetaData")[[1 , "subset"]]
91        attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
92        dmeta <- attr(x, "DMetaData")
93        .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
94    }
95    
96                x@.Data <- x@.Data[i, ..., drop = FALSE]  `[.VCorpus` <- function(x, i) {
               index <- x@DMetaData[[1 , "subset"]]  
               if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i  
               else x@DMetaData[[1 , "subset"]] <- index[i]  
               x  
           })  
   
 setMethod("[",  
           signature(x = "SCorpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
97                if (missing(i)) return(x)                if (missing(i)) return(x)
98        .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
99    }
100    
101                x@.Data <- x@.Data[i, ..., drop = FALSE]  `[<-.PCorpus` <- function(x, i, value) {
               DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]  
               x  
           })  
   
 setMethod("[<-",  
           signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
102                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
103                counter <- 1                counter <- 1
104                for (id in x@.Data[i, ...]) {      for (id in unclass(x)[i]) {
105                    if (identical(length(value), 1)) db[[id]] <- value                    if (identical(length(value), 1)) db[[id]] <- value
106                    else db[[id]] <- value[[counter]]                    else db[[id]] <- value[[counter]]
107                    counter <- counter + 1                    counter <- counter + 1
108                }                }
109                x                x
110            })  }
 setMethod("[<-",  
           signature(x = "SCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               x@.Data[i, ...] <- value  
               x  
           })  
111    
112  setMethod("[[",  `[[.PCorpus` <-  function(x, i) {
           signature(x = "PCorpus", i = "ANY", j = "ANY"),  
           function(x, i, j, ...) {  
113                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
114                filehash::dbFetch(db, x@.Data[[i]])      filehash::dbFetch(db, NextMethod("[["))
115            })  }
116  setMethod("[[",  `[[.VCorpus` <-  function(x, i) {
           signature(x = "SCorpus", i = "ANY", j = "ANY"),  
           function(x, i, j, ...) {  
               # TODO: For which corpora should lazy mapping be available?  
117                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
118                if (!is.null(lazyTmMap))                if (!is.null(lazyTmMap))
119                    .Call("copyCorpus", x, materialize(x, i))                    .Call("copyCorpus", x, materialize(x, i))
120                x@.Data[[i]]      NextMethod("[[")
121            })  }
122    
123  setMethod("[[<-",  `[[<-.PCorpus` <-  function(x, i, value) {
           signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ..., value) {  
124                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
125                index <- x@.Data[[i]]      index <- unclass(x)[[i]]
126                db[[index]] <- value                db[[index]] <- value
127                x                x
128            })  }
129  setMethod("[[<-",  `[[<-.VCorpus` <-  function(x, i, value) {
           signature(x = "SCorpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ..., value) {  
130                # Mark new objects as not active for lazy mapping                # Mark new objects as not active for lazy mapping
131                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
132                if (!is.null(lazyTmMap)) {                if (!is.null(lazyTmMap)) {
# Line 351  Line 134 
134                    meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap                    meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
135                }                }
136                # Set the value                # Set the value
137                x@.Data[[i, ...]] <- value      cl <- class(x)
138        y <- NextMethod("[[<-")
139                x      class(y) <- cl
140            })      y
141    }
142    
143  # Update \code{NodeID}s of a CMetaData tree  # Update \code{NodeID}s of a CMetaData tree
144  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {  update_id <- function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
145      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
146      set_id <- function(object) {      set_id <- function(x) {
147          object@NodeID <- id          x$NodeID <- id
148          id <<- id + 1          id <<- id + 1
149          level <<- level + 1          level <<- level + 1
150            if (length(x$Children) > 0) {
151          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
152              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
153              if (level == 1) {              if (level == 1) {
154                  left.mapping <<- mapping                  left.mapping <<- mapping
155                  mapping <<- NULL                  mapping <<- NULL
156              }              }
157              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
158              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
159    
160              object@children <- list(left, right)              x$Children <- list(left, right)
161          }          }
162          level <<- level - 1          level <<- level - 1
163            x
         return(object)  
164      }      }
165        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
     return(list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping))  
166  }  }
167    
168  # TODO: Implement concatenation for other corpus types  c2 <- function(x, y, ...) {
 setMethod("c",  
           signature(x = "Corpus"),  
           function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               args <- list(...)  
               if (length(args) == 0)  
                   return(x)  
   
               if (!all(sapply(args, inherits, "SCorpus")))  
                   stop("not all arguments are standard corpora")  
   
               Reduce(c2, base::c(list(x), args))  
           })  
   
 setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  
 setMethod("c2",  
           signature(x = "SCorpus", y = "SCorpus"),  
           function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               object <- x  
               # Concatenate data slots  
               object@.Data <- c(as(x, "list"), as(y, "list"))  
   
169                # Update the CMetaData tree                # Update the CMetaData tree
170                cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))      cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
171                update.struct <- update_id(cmeta)                update.struct <- update_id(cmeta)
172                object@CMetaData <- update.struct$root  
173        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
174    
175                # Find indices to be updated for the left tree                # Find indices to be updated for the left tree
176                indices.mapping <- NULL                indices.mapping <- NULL
# Line 422  Line 183 
183                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
184                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
185                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
186                    x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])          DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
187                }                }
188    
189                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
# Line 436  Line 197 
197                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
198                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
199                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
200                    y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])          DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
201                }                }
202    
203                # Merge the DMetaData data frames                # Merge the DMetaData data frames
# Line 446  Line 207 
207                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
208                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
209                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
210                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
211    
212        new
213    }
214    
215    c.Corpus <-
216    function(x, ..., recursive = FALSE)
217    {
218        args <- list(...)
219    
220                return(object)      if (identical(length(args), 0))
221            })          return(x)
222    
223        if (!all(unlist(lapply(args, inherits, class(x)))))
224            stop("not all arguments are of the same corpus type")
225    
226        if (inherits(x, "PCorpus"))
227            stop("concatenation of corpora with underlying databases is not supported")
228    
229        Reduce(c2, base::c(list(x), args))
230    }
231    
232  setMethod("c",  c.TextDocument <- function(x, ..., recursive = FALSE) {
           signature(x = "TextDocument"),  
           function(x, ..., recursive = TRUE){  
233                args <- list(...)                args <- list(...)
               if (identical(length(args), 0)) return(x)  
234    
235                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (identical(length(args), 0))
236                cmeta.node <- new("MetaDataNode",          return(x)
237                              NodeID = 0,  
238                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),      if (!all(unlist(lapply(args, inherits, class(x)))))
239                              children = list())          stop("not all arguments are text documents")
240    
241                new("SCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)      dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
242            })      .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
243    }
244  setMethod("show",  
245            signature(object = "Corpus"),  print.Corpus <- function(x, ...) {
246            function(object){      cat(sprintf(ngettext(length(x),
               cat(sprintf(ngettext(length(object),  
247                                     "A corpus with %d text document\n",                                     "A corpus with %d text document\n",
248                                     "A corpus with %d text documents\n"),                                     "A corpus with %d text documents\n"),
249                            length(object)))                  length(x)))
250      })      invisible(x)
251    }
252    
253  setMethod("summary",  summary.Corpus <- function(object, ...) {
254            signature(object = "Corpus"),      print(object)
           function(object){  
               show(object)  
255                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
256                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
257                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",                                                "\nThe metadata consists of %d tag-value pair and a data frame\n",
258                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
259                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
260                    cat("Available tags are:\n")                    cat("Available tags are:\n")
261                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")          cat(strwrap(paste(names(CMetaData(object)$MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
262                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
263                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
264                }                }
265      })  }
266    
267  inspect <- function(x) UseMethod("inspect", x)  inspect <- function(x) UseMethod("inspect", x)
268  inspect.PCorpus <- function(x) {  inspect.PCorpus <- function(x) {
# Line 498  Line 271 
271      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
272      show(filehash::dbMultiFetch(db, unlist(x)))      show(filehash::dbMultiFetch(db, unlist(x)))
273  }  }
274  inspect.FCorpus <- inspect.SCorpus <- function(x) {  inspect.VCorpus <- function(x) {
275      summary(x)      summary(x)
276      cat("\n")      cat("\n")
277      print(noquote(lapply(x, identity)))      print(noquote(lapply(x, identity)))
278  }  }
279    
280  # No metadata is checked  lapply.PCorpus <- function(X, FUN, ...) {
 setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  
 setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),  
           function(x, y) {  
               db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  
               any(sapply(y, function(x, z) {x %in% Content(z)}, x))  
           })  
 setMethod("%IN%", signature(x = "TextDocument", y = "SCorpus"),  
           function(x, y) x %in% y)  
   
 setMethod("lapply",  
           signature(X = "SCorpus"),  
           function(X, FUN, ...) {  
               lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  
               if (!is.null(lazyTmMap))  
                   .Call("copyCorpus", X, materialize(X))  
               base::lapply(X, FUN, ...)  
           })  
 setMethod("lapply",  
           signature(X = "PCorpus"),  
           function(X, FUN, ...) {  
281                db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
282                lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)                lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
283            })  }
284    lapply.VCorpus <- function(X, FUN, ...) {
 setMethod("sapply",  
           signature(X = "SCorpus"),  
           function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  
285                lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
286                if (!is.null(lazyTmMap))                if (!is.null(lazyTmMap))
287                    .Call("copyCorpus", X, materialize(X))                    .Call("copyCorpus", X, materialize(X))
288                base::sapply(X, FUN, ...)      base::lapply(X, FUN, ...)
           })  
 setMethod("sapply",  
           signature(X = "PCorpus"),  
           function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  
               db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
               sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)  
           })  
   
 setAs("list", "SCorpus", function(from) {  
     cmeta.node <- new("MetaDataNode",  
                       NodeID = 0,  
                       MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),  
                       children = list())  
     data <- list()  
     counter <- 1  
     for (f in from) {  
         doc <- new("PlainTextDocument",  
                    .Data = f,  
                    Author = "", DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),  
                    Description = "", ID = as.character(counter),  
                    Origin = "", Heading = "", Language = "eng")  
         data <- c(data, list(doc))  
         counter <- counter + 1  
289      }      }
290      new("SCorpus", .Data = data,  
291          DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),  writeCorpus <-  function(x, path = ".", filenames = NULL) {
         CMetaData = cmeta.node)  
 })  
   
 setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))  
 setMethod("writeCorpus",  
           signature(object = "Corpus"),  
           function(object, path = ".", filenames = NULL) {  
292                filenames <- file.path(path,                filenames <- file.path(path,
293                                       if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
294                                       else filenames)                                       else filenames)
295                i <- 1                i <- 1
296                for (o in object) {      for (o in x) {
297                    writeLines(asPlain(o), filenames[i])          writeLines(as.PlainTextDocument(o), filenames[i])
298                    i <- i + 1                    i <- i + 1
299                }                }
300            })  }

Legend:
Removed from v.950  
changed lines
  Added in v.995

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