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

Legend:
Removed from v.900  
changed lines
  Added in v.1108

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