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

pkg/R/textdoccol.R revision 938, Sat Apr 25 19:05:50 2009 UTC pkg/R/corpus.R revision 1114, Fri Nov 26 14:05:54 2010 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 = "en"),
14                        dbControl = list(dbName = "", dbType = "DB1"),
15                     ...) {                     ...) {
16                if (is.null(readerControl$reader))      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
17                    readerControl$reader <- object@DefaultReader  
18                if (is(readerControl$reader, "FunctionGenerator"))      if (is.function(readerControl$init))
19                    readerControl$reader <- readerControl$reader(...)          readerControl$init()
               if (is.null(readerControl$language))  
                   readerControl$language <- "en_US"  
               if (is.null(readerControl$load) || (!object@LoDSupport))  
                   readerControl$load <- TRUE  
20    
21                if (dbControl$useDb && require("filehash")) {      if (is.function(readerControl$exit))
22                    if (!dbCreate(dbControl$dbName, dbControl$dbType))          on.exit(readerControl$exit())
23    
24        if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
25                        stop("error in creating database")                        stop("error in creating database")
26                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
27    
28                # Allocate memory in advance if length is known                # Allocate memory in advance if length is known
29                tdl <- if (object@Length > 0)      tdl <- if (x$Length > 0)
30                    vector("list", as.integer(object@Length))          vector("list", as.integer(x$Length))
31                else                else
32                    list()                    list()
33    
               if ((!dbControl$useDb) && object@Vectorized)  
                   tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),  
                                 function(x) readerControl$reader(x[c("content", "uri")],  
                                                                  readerControl$load,  
                                                                  readerControl$language,  
                                                                  as.character(x$id)))  
               else {  
34                    counter <- 1                    counter <- 1
35                    while (!eoi(object)) {      while (!eoi(x)) {
36                        object <- stepNext(object)          x <- stepNext(x)
37                        elem <- getElem(object)          elem <- getElem(x)
38                        doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))          doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
39                        if (dbControl$useDb && require("filehash")) {          filehash::dbInsert(db, ID(doc), doc)
40                            dbInsert(db, ID(doc), doc)          if (x$Length > 0) tdl[[counter]] <- ID(doc)
41                            if (object@Length > 0)          else tdl <- c(tdl, ID(doc))
                               tdl[[counter]] <- ID(doc)  
                           else  
                               tdl <- c(tdl, ID(doc))  
                       }  
                       else {  
                           if (object@Length > 0)  
                               tdl[[counter]] <- doc  
                           else  
                               tdl <- c(tdl, list(doc))  
                       }  
42                        counter <- counter + 1                        counter <- counter + 1
43                    }                    }
44                }      names(tdl) <- x$Names
45    
46                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
47                if (dbControl$useDb && require("filehash")) {      filehash::dbInsert(db, "DMetaData", df)
                   dbInsert(db, "DMetaData", df)  
48                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
               }  
               else  
                   dmeta.df <- df  
49    
50                cmeta.node <- new("MetaDataNode",      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
                             NodeID = 0,  
                             MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), 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) && require("XML")) {  
                   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) {summary(eval(URI(x)))$description}))  
               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"]] && require("filehash")) {  
                   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  
51                        }                        }
                   }  
                   else {  
                       result@.Data <- if (clusterAvailable())  
                           snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))  
                       else  
                           lapply(object, FUN, ..., DMetaData = DMetaData(object))  
                   }  
               }  
               return(result)  
           })  
52    
53  # Materialize lazy mappings  .VCorpus <- function(x, cmeta, dmeta) {
54  # Improvements by Christian Buchta      attr(x, "CMetaData") <- cmeta
55  materialize <- function(corpus, range = seq_along(corpus)) {      attr(x, "DMetaData") <- dmeta
56      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")      class(x) <- c("VCorpus", "Corpus", "list")
57      if (!is.null(lazyTmMap)) {      x
        # 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"),  
           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, ...) {  
               return(convertRCV1Plain(object, ...))  
           })  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, 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 = NULL, 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) {  
               if (!is.null(attr(FUN, "doclevel")))  
                   doclevel <- attr(FUN, "doclevel")  
               if (doclevel) {  
                   if (clusterAvailable())  
                       return(object[snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))])  
                   else  
                       return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
58                }                }
               else  
                   return(object[FUN(object, ...)])  
           })  
59    
60  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))  # Register S3 corpus classes to be recognized by S4 methods. This is
61  setMethod("tmIndex",  # mainly a fix to be compatible with packages which were originally
62            signature(object = "Corpus"),  # developed to cooperate with corresponding S4 tm classes. Necessary
63            function(object, ..., FUN = searchFullText, doclevel = TRUE) {  # since tm's class architecture was changed to S3 since tm version 0.5.
64                if (!is.null(attr(FUN, "doclevel")))  setOldClass(c("VCorpus", "Corpus", "list"))
                   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, ...))  
           })  
65    
66  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  # The "..." are additional arguments for the FunctionGenerator reader
67  setMethod("appendElem",  VCorpus <- Corpus <- function(x,
68            signature(object = "Corpus", data = "TextDocument"),                                readerControl = list(reader = x$DefaultReader, language = "en"),
69            function(object, data, meta = NULL) {                                ...) {
70                if (DBControl(object)[["useDb"]] && require("filehash")) {      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
71                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
72                    if (dbExists(db, ID(data)))      if (is.function(readerControl$init))
73                        warning("document with identical ID already exists")          readerControl$init()
74                    dbInsert(db, ID(data), data)  
75                    object@.Data[[length(object)+1]] <- ID(data)      if (is.function(readerControl$exit))
76                }          on.exit(readerControl$exit())
77    
78        # Allocate memory in advance if length is known
79        tdl <- if (x$Length > 0)
80            vector("list", as.integer(x$Length))
81                else                else
82                    object@.Data[[length(object)+1]] <- data          list()
83                DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
84                return(object)      if (x$Vectorized)
85            })          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
86                          pGetElem(x),
87  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))                        id = if (is.null(x$Names)) as.character(seq_len(x$Length)) else x$Names,
88  setMethod("appendMeta",                        SIMPLIFY = FALSE)
           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 <- sapply(local.m, paste, collapse = " ")  
                       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  
                   }  
89                    else {                    else {
90                        local.meta <- lapply(object, LocalMetaData)          counter <- 1
91                        local.m <- lapply(local.meta, "[[", m)          while (!eoi(x)) {
92                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))              x <- stepNext(x)
93                        if (length(local.m) == length(unlist(local.m)))              elem <- getElem(x)
94                            local.m <- unlist(local.m)              doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
95                if (x$Length > 0)
96                    tdl[[counter]] <- doc
97                        else                        else
98                            local.m <- I(local.m)                  tdl <- c(tdl, list(doc))
99                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))              counter <- counter + 1
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
100                    }                    }
101                }                }
102                return(object)      names(tdl) <- x$Names
103            })      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
104        .VCorpus(tdl, .MetaDataNode(), df)
105  setMethod("[",  }
           signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
106    
107                object <- x  `[.PCorpus` <- function(x, i) {
108                object@.Data <- x@.Data[i, ..., drop = FALSE]      if (missing(i)) return(x)
109                if (DBControl(object)[["useDb"]] && require("filehash")) {      index <- attr(x, "DMetaData")[[1 , "subset"]]
110                    index <- object@DMetaData[[1 , "subset"]]      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
111                    if (any(is.na(index)))      dmeta <- attr(x, "DMetaData")
112                        object@DMetaData[[1 , "subset"]] <- i      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
113                }                }
114                else  
115                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[.VCorpus` <- function(x, i) {
116                return(object)      if (missing(i)) return(x)
117            })      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
   
 setMethod("[<-",  
           signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),  
           function(x, i, j, ... , value) {  
               object <- x  
               if (DBControl(object)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   counter <- 1  
                   for (id in object@.Data[i, ...]) {  
                       if (length(value) == 1)  
                           db[[id]] <- value  
                       else {  
                           db[[id]] <- value[[counter]]  
118                        }                        }
119    
120    `[<-.PCorpus` <- function(x, i, value) {
121        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
122        counter <- 1
123        for (id in unclass(x)[i]) {
124            if (identical(length(value), 1L)) db[[id]] <- value
125            else db[[id]] <- value[[counter]]
126                        counter <- counter + 1                        counter <- counter + 1
127                    }                    }
128        x
129                }                }
130    
131    .map_name_index <- function(x, i) {
132        if (is.character(i)) {
133            if (is.null(names(x)))
134                match(i, meta(x, "ID", type = "local"))
135                else                else
136                    object@.Data[i, ...] <- value              match(i, names(x))
               return(object)  
           })  
   
 setMethod("[[",  
           signature(x = "Corpus", i = "ANY", j = "ANY"),  
           function(x, i, j, ...) {  
               if (DBControl(x)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
                   result <- dbFetch(db, x@.Data[[i]])  
                   return(loadDoc(result))  
137                }                }
138                else {      i
139    }
140    
141    `[[.PCorpus` <-  function(x, i) {
142        i <- .map_name_index(x, i)
143        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
144        filehash::dbFetch(db, NextMethod("[["))
145    }
146    `[[.VCorpus` <-  function(x, i) {
147        i <- .map_name_index(x, i)
148                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
149                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
150                        .Call("copyCorpus", x, materialize(x, i))                        .Call("copyCorpus", x, materialize(x, i))
151                    return(loadDoc(x@.Data[[i]]))      NextMethod("[[")
152                }                }
           })  
153    
154  setMethod("[[<-",  `[[<-.PCorpus` <-  function(x, i, value) {
155            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),      i <- .map_name_index(x, i)
156            function(x, i, j, ..., value) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
157                object <- x      index <- unclass(x)[[i]]
               if (DBControl(object)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   index <- object@.Data[[i]]  
158                    db[[index]] <- value                    db[[index]] <- value
159        x
160                }                }
161                else {  `[[<-.VCorpus` <-  function(x, i, value) {
162        i <- .map_name_index(x, i)
163                    # Mark new objects as not active for lazy mapping                    # Mark new objects as not active for lazy mapping
164                    lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
165                    if (!is.null(lazyTmMap)) {                    if (!is.null(lazyTmMap)) {
166                        lazyTmMap$index[i] <- FALSE                        lazyTmMap$index[i] <- FALSE
167                        meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
168                    }                    }
169                    # Set the value                    # Set the value
170                    object@.Data[[i, ...]] <- value      cl <- class(x)
171        y <- NextMethod("[[<-")
172        class(y) <- cl
173        y
174                }                }
               return(object)  
           })  
175    
176  # Update \code{NodeID}s of a CMetaData tree  # Update NodeIDs of a CMetaData tree
177  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) {
178      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s      # Traversal of (binary) CMetaData tree with setup of NodeIDs
179      set_id <- function(object) {      set_id <- function(x) {
180          object@NodeID <- id          x$NodeID <- id
181          id <<- id + 1          id <<- id + 1
182          level <<- level + 1          level <<- level + 1
183            if (length(x$Children) > 0) {
184          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
185              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
186              if (level == 1) {              if (level == 1) {
187                  left.mapping <<- mapping                  left.mapping <<- mapping
188                  mapping <<- NULL                  mapping <<- NULL
189              }              }
190              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
191              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
192    
193              object@children <- list(left, right)              x$Children <- list(left, right)
194          }          }
195          level <<- level - 1          level <<- level - 1
196            x
         return(object)  
197      }      }
198        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))  
199  }  }
200    
201  setMethod("c",  # Find indices to be updated for a CMetaData tree
202            signature(x = "Corpus"),  .find_indices <- function(x) {
           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, "Corpus")))  
                   stop("not all arguments are corpora")  
               if (DBControl(x)[["useDb"]] || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating corpora with activated database is not supported")  
   
               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 = "Corpus", y = "Corpus"),  
           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"))  
   
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
               # Update the CMetaData tree  
               cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))  
               update.struct <- update_id(cmeta)  
               object@CMetaData <- update.struct$root  
   
               # Find indices to be updated for the left tree  
203                indices.mapping <- NULL                indices.mapping <- NULL
204                for (m in levels(as.factor(DMetaData(x)$MetaID))) {                for (m in levels(as.factor(DMetaData(x)$MetaID))) {
205                    indices <- (DMetaData(x)$MetaID == m)                    indices <- (DMetaData(x)$MetaID == m)
206                    indices.mapping <- c(indices.mapping, list(m = indices))                    indices.mapping <- c(indices.mapping, list(m = indices))
207                    names(indices.mapping)[length(indices.mapping)] <- m                    names(indices.mapping)[length(indices.mapping)] <- m
208                }                }
209        indices.mapping
210    }
211    
212    c2 <- function(x, y, ...) {
213        # Update the CMetaData tree
214        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
215        update.struct <- .update_id(cmeta)
216    
217        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
218    
219        # Find indices to be updated for the left tree
220        indices.mapping <- .find_indices(x)
221    
222                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
223                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
224                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
225                    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])
226                }                }
227    
228                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
229                indices.mapping <- NULL      indices.mapping <- .find_indices(y)
               for (m in levels(as.factor(DMetaData(y)$MetaID))) {  
                   indices <- (DMetaData(y)$MetaID == m)  
                   indices.mapping <- c(indices.mapping, list(m = indices))  
                   names(indices.mapping)[length(indices.mapping)] <- m  
               }  
230    
231                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
232                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
233                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
234                    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])
235                }                }
236    
237                # Merge the DMetaData data frames                # Merge the DMetaData data frames
# Line 561  Line 241 
241                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
242                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))
243                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
244                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
245    
246        new
247    }
248    
249    c.Corpus <-
250    function(x, ..., recursive = FALSE)
251    {
252        args <- list(...)
253    
254                return(object)      if (identical(length(args), 0L))
255            })          return(x)
256    
257        if (!all(unlist(lapply(args, inherits, class(x)))))
258            stop("not all arguments are of the same corpus type")
259    
260        if (inherits(x, "PCorpus"))
261            stop("concatenation of corpora with underlying databases is not supported")
262    
263        l <- base::c(list(x), args)
264        if (recursive)
265            Reduce(c2, l)
266        else {
267            l <- do.call("c", lapply(l, unclass))
268            .VCorpus(l,
269                     cmeta = .MetaDataNode(),
270                     dmeta = data.frame(MetaID = rep(0, length(l)), stringsAsFactors = FALSE))
271        }
272    }
273    
274  setMethod("c",  c.TextDocument <- function(x, ..., recursive = FALSE) {
           signature(x = "TextDocument"),  
           function(x, ..., recursive = TRUE){  
275                args <- list(...)                args <- list(...)
276                if(length(args) == 0)  
277        if (identical(length(args), 0L))
278                    return(x)                    return(x)
279    
280                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
281                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
282                              NodeID = 0,  
283                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
284                              children = list())      .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
285    }
286                return(new("Corpus",  
287                           .Data = list(x, ...),  print.Corpus <- function(x, ...) {
288                           DMetaData = dmeta.df,      cat(sprintf(ngettext(length(x),
                          CMetaData = cmeta.node,  
                          DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))  
           })  
   
 setMethod("length",  
           signature(x = "Corpus"),  
           function(x){  
               return(length(as(x, "list")))  
     })  
   
 setMethod("show",  
           signature(object = "Corpus"),  
           function(object){  
               cat(sprintf(ngettext(length(object),  
289                                     "A corpus with %d text document\n",                                     "A corpus with %d text document\n",
290                                     "A corpus with %d text documents\n"),                                     "A corpus with %d text documents\n"),
291                            length(object)))                  length(x)))
292      })      invisible(x)
293    }
294    
295  setMethod("summary",  summary.Corpus <- function(object, ...) {
296            signature(object = "Corpus"),      print(object)
           function(object){  
               show(object)  
297                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
298                    cat(sprintf(ngettext(length(CMetaData(object)@MetaData),          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
299                                                "\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",
300                                                "\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"),
301                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
302                    cat("Available tags are:\n")                    cat("Available tags are:\n")
303                    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")
304                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
305                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
306                }                }
307      })  }
308    
309  inspect <- function(x) UseMethod("inspect", x)  inspect <- function(x) UseMethod("inspect", x)
310  inspect.Corpus <- function(x) {  inspect.PCorpus <- function(x) {
311      summary(x)      summary(x)
312      cat("\n")      cat("\n")
313      if (DBControl(x)[["useDb"]] && require("filehash")) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
314          db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      show(filehash::dbMultiFetch(db, unlist(x)))
         show(dbMultiFetch(db, unlist(x)))  
315      }      }
316      else  inspect.VCorpus <- function(x) {
317        summary(x)
318        cat("\n")
319          print(noquote(lapply(x, identity)))          print(noquote(lapply(x, identity)))
320  }  }
321    
322  # No metadata is checked  lapply.PCorpus <- function(X, FUN, ...) {
323  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
324  setMethod("%IN%",      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
           signature(x = "TextDocument", y = "Corpus"),  
           function(x, y) {  
               if (DBControl(y)[["useDb"]] && require("filehash")) {  
                   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, ...) {  
               if (DBControl(X)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
325                }                }
326                else {  lapply.VCorpus <- function(X, FUN, ...) {
327                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
328                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
329                        .Call("copyCorpus", X, materialize(X))                        .Call("copyCorpus", X, materialize(X))
330                    result <- base::lapply(X, FUN, ...)      base::lapply(X, FUN, ...)
331                }                }
               return(result)  
           })  
332    
333  setMethod("sapply",  writeCorpus <-  function(x, path = ".", filenames = NULL) {
           signature(X = "Corpus"),  
           function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  
               if (DBControl(X)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
               }  
               else {  
                   lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  
                   if (!is.null(lazyTmMap))  
                       .Call("copyCorpus", X, materialize(X))  
                   result <- base::sapply(X, FUN, ...)  
               }  
               return(result)  
           })  
   
 setAs("list", "Corpus", 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, URI = NULL, Cached = TRUE,  
                    Author = "", DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),  
                    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) {  
334                filenames <- file.path(path,                filenames <- file.path(path,
335                                       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))))
336                                       else filenames)                                       else filenames)
337                i <- 1                i <- 1
338                for (o in object) {      for (o in x) {
339                    writeLines(asPlain(o), filenames[i])          writeLines(as.PlainTextDocument(o), filenames[i])
340                    i <- i + 1                    i <- i + 1
341                }                }
342            })  }

Legend:
Removed from v.938  
changed lines
  Added in v.1114

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