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/tm/R/textdoccol.R revision 837, Wed Apr 23 09:16:25 2008 UTC pkg/R/corpus.R revision 988, Fri Sep 4 12:27:12 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
4  setGeneric("Corpus", function(object,      attr(x, "CMetaData") <- cmeta
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),      attr(x, "DMetaData") <- dmeta
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),      attr(x, "DBControl") <- dbcontrol
7                                    ...) standardGeneric("Corpus"))      class(x) <- c("PCorpus", "Corpus", "list")
8  setMethod("Corpus",      x
9            signature(object = "Source"),  }
10            function(object,  DBControl <- function(x) attr(x, "DBControl")
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),  
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  PCorpus <- function(x,
13                        readerControl = list(reader = x$DefaultReader, language = "eng"),
14                        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 = "en_US"  
               if (is.null(readerControl$load))  
                   readerControl$load = TRUE  
17    
18                if (dbControl$useDb) {      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
                   if (!dbCreate(dbControl$dbName, dbControl$dbType))  
19                        stop("error in creating database")                        stop("error in creating database")
20                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
21    
22                tdl <- list()      # Allocate memory in advance if length is known
23                counter <- 1      tdl <- if (x$Length > 0)
24                while (!eoi(object)) {          vector("list", as.integer(x$Length))
                   object <- stepNext(object)  
                   elem <- getElem(object)  
                   # If there is no Load on Demand support  
                   # we need to load the corpus into memory at startup  
                   if (!object@LoDSupport)  
                       readerControl$load <- TRUE  
                   doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))  
                   if (dbControl$useDb) {  
                       dbInsert(db, ID(doc), doc)  
                       tdl <- c(tdl, ID(doc))  
                   }  
25                    else                    else
26                        tdl <- c(tdl, list(doc))          list()
27    
28        counter <- 1
29        while (!eoi(x)) {
30            x <- stepNext(x)
31            elem <- getElem(x)
32            doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
33            filehash::dbInsert(db, ID(doc), doc)
34            if (x$Length > 0) tdl[[counter]] <- ID(doc)
35            else tdl <- c(tdl, ID(doc))
36                    counter <- counter + 1                    counter <- counter + 1
37                }                }
38    
39                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
40                if (dbControl$useDb) {      filehash::dbInsert(db, "DMetaData", df)
                   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)))
               }  
               else  
                   dmeta.df <- df  
42    
43                cmeta.node <- new("MetaDataNode",      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
                             NodeID = 0,  
                             MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),  
                             children = list())  
   
               return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))  
           })  
   
 setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  
 setMethod("loadDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- readLines(con)  
                   close(con)  
                   Content(object) <- corpus  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object =  "XMLTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- paste(readLines(con), "\n", collapse = "")  
                   close(con)  
                   doc <- xmlTreeParse(corpus, asText = TRUE)  
                   class(doc) <- "list"  
                   Content(object) <- doc  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "NewsgroupDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   mail <- readLines(con)  
                   close(con)  
                   Cached(object) <- TRUE  
                   for (index in seq_along(mail)) {  
                       if (mail[index] == "")  
                           break  
                   }  
                   Content(object) <- mail[(index + 1):length(mail)]  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "StructuredTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   warning("load on demand not (yet) supported for StructuredTextDocuments")  
                   return(object)  
               } else  
                   return(object)  
           })  
   
 setGeneric("tmUpdate", function(object,  
                                 origin,  
                                 readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),  
                                 ...) standardGeneric("tmUpdate"))  
 # Update is only supported for directories  
 # At the moment no other LoD devices are available anyway  
 setMethod("tmUpdate",  
           signature(object = "Corpus", origin = "DirSource"),  
           function(object, origin,  
                    readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),  
                    ...) {  
               if (is.null(readerControl$reader))  
                   readerControl$reader <- origin@DefaultReader  
               if (is(readerControl$reader, "FunctionGenerator"))  
                   readerControl$reader <- readerControl$reader(...)  
               if (is.null(readerControl$language))  
                   readerControl$language = "en_US"  
               if (is.null(readerControl$load))  
                   readerControl$load = TRUE  
   
               object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))  
               new.files <- setdiff(origin@FileList, object.filelist)  
   
               for (filename in new.files) {  
                   encoding <- origin@Encoding  
                   elem <- list(content = readLines(filename, encoding = encoding),  
                                uri = substitute(file(filename, encoding = encoding)))  
                   object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))  
               }  
   
               return(object)  
           })  
   
 setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "Corpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               result <- object  
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]]) {  
                   if (lazy)  
                       warning("lazy mapping is deactived when using database backend")  
                   db <- 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  
                   dbReorganize(db)  
               }  
               else {  
                   # 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  
44                        }                        }
                   }  
                   else  
                       result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))  
               }  
               return(result)  
           })  
45    
46  # Materialize lazy mappings  .VCorpus <- function(x, cmeta, dmeta) {
47  # Improvements by Christian Buchta      attr(x, "CMetaData") <- cmeta
48  materialize <- function(corpus, range = seq_along(corpus)) {      attr(x, "DMetaData") <- dmeta
49      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")      class(x) <- c("VCorpus", "Corpus", "list")
50      if (!is.null(lazyTmMap)) {      x
51         # Make valid and lazy index  }
        idx <- (seq_along(corpus) %in% range) & lazyTmMap$index  
        if (any(idx)) {  
            res <- lapply(corpus@.Data[idx], loadDoc)  
            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  
     return(corpus)  
 }  
   
 setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  
 setMethod("asPlain",  
           signature(object = "PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("asPlain",  
           signature(object = "XMLTextDocument", FUN = "function"),  
           function(object, FUN, ...) {  
               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, ...) {  
               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, ...) {  
               FUN <- convertRCV1Plain  
               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 = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", 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)), Cached = TRUE,  
                   URI = "", 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 = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  
 setMethod("tmFilter",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
               else  
                   return(object[FUN(object, ...)])  
           })  
52    
53  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  # The "..." are additional arguments for the FunctionGenerator reader
54  setMethod("tmIndex",  VCorpus <- Corpus <- function(x,
55            signature(object = "Corpus"),                      readerControl = list(reader = x$DefaultReader, language = "eng"),
56            function(object, ..., FUN = sFilter, doclevel = FALSE) {                      ...) {
57                if (doclevel)      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
                   return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
               else  
                   return(FUN(object, ...))  
           })  
58    
59  sFilter <- function(object, s, ...) {      # Allocate memory in advance if length is known
60      con <- textConnection(s)      tdl <- if (x$Length > 0)
61      tokens <- scan(con, "character", quiet = TRUE)          vector("list", as.integer(x$Length))
62      close(con)      else
63      localMetaNames <- unique(names(sapply(object, LocalMetaData)))          list()
64      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
65      n <- names(DMetaData(object))      if (x$Vectorized)
66      tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
67      query.df <- DMetaData(prescindMeta(object, tags))                        pGetElem(x),
68      if (DBControl(object)[["useDb"]])                        id = as.character(seq_len(x$Length)),
69          DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]                        SIMPLIFY = FALSE)
     # Rename to avoid name conflicts  
     names(query.df)[names(query.df) == "Author"] <- "author"  
     names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"  
     names(query.df)[names(query.df) == "Description"] <- "description"  
     names(query.df)[names(query.df) == "ID"] <- "identifier"  
     names(query.df)[names(query.df) == "Origin"] <- "origin"  
     names(query.df)[names(query.df) == "Heading"] <- "heading"  
     names(query.df)[names(query.df) == "Language"] <- "language"  
     attach(query.df)  
     try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))  
     detach(query.df)  
     return(result)  
 }  
   
 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"]]) {  
                   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)  
               }  
               else  
                   object@.Data[[length(object)+1]] <- data  
               DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
               return(object)  
           })  
   
 setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  
 setMethod("appendMeta",  
           signature(object = "Corpus"),  
           function(object, cmeta = NULL, dmeta = NULL) {  
               object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)  
               if (!is.null(dmeta)) {  
                   DMetaData(object) <- cbind(DMetaData(object), eval(dmeta))  
               }  
               return(object)  
           })  
   
 setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  
 setMethod("removeMeta",  
           signature(object = "Corpus"),  
           function(object, cname = NULL, dname = NULL) {  
               if (!is.null(cname))  
                   object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]  
               if (!is.null(dname))  
                   DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE]  
               return(object)  
           })  
   
 setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  
 setMethod("prescindMeta",  
           signature(object = "Corpus", meta = "character"),  
           function(object, meta) {  
               for (m in meta) {  
                   if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {  
                       local.m <- lapply(object, m)  
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       local.m <- unlist(local.m)  
                       DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))  
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
                   }  
70                    else {                    else {
71                        local.meta <- lapply(object, LocalMetaData)          counter <- 1
72                        local.m <- lapply(local.meta, "[[", m)          while (!eoi(x)) {
73                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))              x <- stepNext(x)
74                        if (length(local.m) == length(unlist(local.m)))              elem <- getElem(x)
75                            local.m <- unlist(local.m)              doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
76                if (x$Length > 0)
77                    tdl[[counter]] <- doc
78                        else                        else
79                            local.m <- I(local.m)                  tdl <- c(tdl, list(doc))
80                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))              counter <- counter + 1
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
81                    }                    }
82                }                }
               return(object)  
           })  
   
 setMethod("[",  
           signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
83    
84                object <- x      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
85                object@.Data <- x@.Data[i, ..., drop = FALSE]      .VCorpus(tdl, .MetaDataNode(), df)
               if (DBControl(object)[["useDb"]]) {  
                   index <- object@DMetaData[[1 , "subset"]]  
                   if (any(is.na(index)))  
                       object@DMetaData[[1 , "subset"]] <- i  
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
86                }                }
87                else  
88                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[.PCorpus` <- function(x, i) {
89                return(object)      if (missing(i)) return(x)
90            })      cmeta <- CMetaData(x)
91        index <- attr(x, "DMetaData")[[1 , "subset"]]
92  setMethod("[<-",      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
93            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),      dmeta <- attr(x, "DMetaData")
94            function(x, i, j, ... , value) {      dbcontrol <- DBControl(x)
95                object <- x      class(x) <- "list"
96                if (DBControl(object)[["useDb"]]) {      .PCorpus(x[i, drop = FALSE], cmeta, dmeta, dbcontrol)
97                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  }
98                    counter <- 1  
99                    for (id in object@.Data[i, ...]) {  `[.VCorpus` <- function(x, i) {
100                        if (length(value) == 1)      if (missing(i)) return(x)
101                            db[[id]] <- value      cmeta <- CMetaData(x)
102                        else {      dmeta <- DMetaData(x)[i, , drop = FALSE]
103                            db[[id]] <- value[[counter]]      class(x) <- "list"
104        .VCorpus(x[i, drop = FALSE], cmeta, dmeta)
105                        }                        }
106    
107    `[<-.PCorpus` <- function(x, i, value) {
108        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
109        counter <- 1
110        for (id in unclass(x)[i]) {
111            if (identical(length(value), 1)) db[[id]] <- value
112            else db[[id]] <- value[[counter]]
113                        counter <- counter + 1                        counter <- counter + 1
114                    }                    }
115        x
116                }                }
117                else  
118                    object@.Data[i, ...] <- value  `[[.PCorpus` <-  function(x, i) {
119                return(object)      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
120            })      class(x) <- "list"
121        filehash::dbFetch(db, x[[i]])
 setMethod("[[",  
           signature(x = "Corpus", i = "ANY", j = "ANY"),  
           function(x, i, j, ...) {  
               if (DBControl(x)[["useDb"]]) {  
                   db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
                   result <- dbFetch(db, x@.Data[[i]])  
                   return(loadDoc(result))  
122                }                }
123                else {  `[[.VCorpus` <-  function(x, i) {
124                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
125                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
126                        .Call("copyCorpus", x, materialize(x, i))                        .Call("copyCorpus", x, materialize(x, i))
127                    return(loadDoc(x@.Data[[i]]))      class(x) <- "list"
128        x[[i]]
129                }                }
           })  
130    
131  setMethod("[[<-",  `[[<-.PCorpus` <-  function(x, i, value) {
132            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
133            function(x, i, j, ..., value) {      index <- unclass(x)[[i]]
               object <- x  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   index <- object@.Data[[i]]  
134                    db[[index]] <- value                    db[[index]] <- value
135        x
136                }                }
137                else {  `[[<-.VCorpus` <-  function(x, i, value) {
138                    # Mark new objects as not active for lazy mapping                    # Mark new objects as not active for lazy mapping
139                    lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
140                    if (!is.null(lazyTmMap)) {                    if (!is.null(lazyTmMap)) {
141                        lazyTmMap$index[i] <- FALSE                        lazyTmMap$index[i] <- FALSE
142                        meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
143                    }                    }
144                    # Set the value                    # Set the value
145                    object@.Data[[i, ...]] <- value      cl <- class(x)
146        class(x) <- "list"
147        x[[i]] <- value
148        class(x) <- cl
149        x
150                }                }
               return(object)  
           })  
151    
152  # Update \code{NodeID}s of a CMetaData tree  # Update \code{NodeID}s of a CMetaData tree
153  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) {
154      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
155      set_id <- function(object) {      set_id <- function(x) {
156          object@NodeID <- id          x$NodeID <- id
157          id <<- id + 1          id <<- id + 1
158          level <<- level + 1          level <<- level + 1
159            if (length(x$Children) > 0) {
160          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
161              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
162              if (level == 1) {              if (level == 1) {
163                  left.mapping <<- mapping                  left.mapping <<- mapping
164                  mapping <<- NULL                  mapping <<- NULL
165              }              }
166              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
167              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
168    
169              object@children <- list(left, right)              x$Children <- list(left, right)
170          }          }
171          level <<- level - 1          level <<- level - 1
172            x
         return(object)  
173      }      }
174        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))  
175  }  }
176    
177  setMethod("c",  c2 <- function(x, y, ...) {
           signature(x = "Corpus"),  
           function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               args <- list(...)  
               if (length(args) == 0)  
                   return(x)  
   
               if (!all(sapply(args, inherits, "Corpus")))  
                   stop("not all arguments are text document collections")  
               if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating text document collections with activated database is not supported")  
   
               result <- x  
               for (c in args) {  
                   result <- c2(result, c)  
               }  
               return(result)  
           })  
   
 setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  
 setMethod("c2",  
           signature(x = "Corpus", y = "Corpus"),  
           function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               object <- x  
               # Concatenate data slots  
               object@.Data <- c(as(x, "list"), as(y, "list"))  
   
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
178                # Update the CMetaData tree                # Update the CMetaData tree
179                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)))
180                update.struct <- update_id(cmeta)                update.struct <- update_id(cmeta)
181                object@CMetaData <- update.struct$root  
182        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
183    
184                # Find indices to be updated for the left tree                # Find indices to be updated for the left tree
185                indices.mapping <- NULL                indices.mapping <- NULL
# Line 536  Line 192 
192                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
193                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
194                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
195                    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])
196                }                }
197    
198                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
# Line 550  Line 206 
206                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
207                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
208                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
209                    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])
210                }                }
211    
212                # Merge the DMetaData data frames                # Merge the DMetaData data frames
# Line 560  Line 216 
216                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
217                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))
218                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
219                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
220    
221                return(object)      new
222            })  }
223    
224  setMethod("c",  c.Corpus <-
225            signature(x = "TextDocument"),  function(x, ..., recursive = FALSE)
226            function(x, ..., recursive = TRUE){  {
227                args <- list(...)                args <- list(...)
228                if(length(args) == 0)  
229        if (identical(length(args), 0))
230            return(x)
231    
232        if (!all(unlist(lapply(args, inherits, class(x)))))
233            stop("not all arguments are of the same corpus type")
234    
235        if (inherits(x, "PCorpus"))
236            stop("concatenation of corpora with underlying databases is not supported")
237    
238        Reduce(c2, base::c(list(x), args))
239    }
240    
241    c.TextDocument <- function(x, ..., recursive = FALSE) {
242        args <- list(...)
243    
244        if (identical(length(args), 0))
245                    return(x)                    return(x)
246    
247                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
248                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
249                              NodeID = 0,  
250                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
251                              children = list())      .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
252    }
253                return(new("Corpus",  
254                           .Data = list(x, ...),  print.Corpus <- function(x, ...) {
255                           DMetaData = dmeta.df,      cat(sprintf(ngettext(length(x),
256                           CMetaData = cmeta.node,                           "A corpus with %d text document\n",
257                           DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))                           "A corpus with %d text documents\n"),
258            })                  length(x)))
259        invisible(x)
260  setMethod("length",  }
261            signature(x = "Corpus"),  
262            function(x){  summary.Corpus <- function(object, ...) {
263                return(length(as(x, "list")))      print(object)
     })  
   
 setMethod("show",  
           signature(object = "Corpus"),  
           function(object){  
               cat(sprintf(ngettext(length(object),  
                                    "A text document collection with %d text document\n",  
                                    "A text document collection with %d text documents\n"),  
                           length(object)))  
     })  
   
 setMethod("summary",  
           signature(object = "Corpus"),  
           function(object){  
               show(object)  
264                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
265                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
266                                                "\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",
267                                                "\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"),
268                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
269                    cat("Available tags are:\n")                    cat("Available tags are:\n")
270                    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")
271                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
272                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
273                }                }
     })  
   
 setGeneric("inspect", function(object) standardGeneric("inspect"))  
 setMethod("inspect",  
           signature("Corpus"),  
           function(object) {  
               summary(object)  
               cat("\n")  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   show(dbMultiFetch(db, unlist(object)))  
274                }                }
               else  
                   print(noquote(lapply(object, identity)))  
           })  
275    
276  # No metadata is checked  inspect <- function(x) UseMethod("inspect", x)
277  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  inspect.PCorpus <- function(x) {
278  setMethod("%IN%",      summary(x)
279            signature(x = "TextDocument", y = "Corpus"),      cat("\n")
280            function(x, y) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
281                if (DBControl(y)[["useDb"]]) {      show(filehash::dbMultiFetch(db, unlist(x)))
                   db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  
                   result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))  
               }  
               else  
                   result <- x %in% y  
               return(result)  
           })  
   
 setMethod("lapply",  
           signature(X = "Corpus"),  
           function(X, FUN, ...) {  
               print("lapply")  
               if (DBControl(X)[["useDb"]]) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
282                }                }
283                else {  inspect.VCorpus <- function(x) {
284                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")      summary(x)
285                    if (!is.null(lazyTmMap))      cat("\n")
286                        .Call("copyCorpus", X, materialize(X))      print(noquote(lapply(x, identity)))
                   result <- base::lapply(X, FUN, ...)  
287                }                }
               return(result)  
           })  
288    
289  setMethod("sapply",  lapply.PCorpus <- function(X, FUN, ...) {
290            signature(X = "Corpus"),      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
291            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
               if (DBControl(X)[["useDb"]]) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
292                }                }
293                else {  lapply.VCorpus <- function(X, FUN, ...) {
294                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
295                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
296                        .Call("copyCorpus", X, materialize(X))                        .Call("copyCorpus", X, materialize(X))
297                    result <- base::sapply(X, FUN, ...)      base::lapply(X, FUN, ...)
298                }                }
               return(result)  
           })  
299    
300  setAs("list", "Corpus", function(from) {  writeCorpus <-  function(x, path = ".", filenames = NULL) {
     cmeta.node <- new("MetaDataNode",  
                       NodeID = 0,  
                       MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),  
                       children = list())  
     data <- list()  
     counter <- 1  
     for (f in from) {  
         doc <- new("PlainTextDocument",  
                    .Data = f, URI = NULL, Cached = TRUE,  
                    Author = "", DateTimeStamp = Sys.time(),  
                    Description = "", ID = as.character(counter),  
                    Origin = "", Heading = "", Language = "en_US")  
         data <- c(data, list(doc))  
         counter <- counter + 1  
     }  
     return(new("Corpus", .Data = data,  
                DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),  
                CMetaData = cmeta.node,  
                DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))  
 })  
   
 setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))  
 setMethod("writeCorpus",  
           signature(object = "Corpus"),  
           function(object, path = ".", filenames = NULL) {  
301                filenames <- file.path(path,                filenames <- file.path(path,
302                                       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))))
303                                       else filenames)                                       else filenames)
304                i <- 1                i <- 1
305                for (o in object) {      for (o in x) {
306                    writeLines(o, filenames[i])          writeLines(as.PlainTextDocument(o), filenames[i])
307                    i <- i + 1                    i <- i + 1
308                }                }
309            })  }

Legend:
Removed from v.837  
changed lines
  Added in v.988

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