SCM

SCM Repository

[tm] Diff of /pkg/R/corpus.R
ViewVC logotype

Diff of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/tm/R/textdoccol.R revision 837, Wed Apr 23 09:16:25 2008 UTC pkg/R/corpus.R revision 1306, Tue Mar 25 08:37:05 2014 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  .PCorpus <-
4  setGeneric("Corpus", function(object,  function(x, cmeta, dmeta, dbcontrol)
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),  {
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),      attr(x, "CMetaData") <- cmeta
7                                    ...) standardGeneric("Corpus"))      attr(x, "DMetaData") <- dmeta
8  setMethod("Corpus",      attr(x, "DBControl") <- dbcontrol
9            signature(object = "Source"),      class(x) <- c("PCorpus", "Corpus", "list")
10            function(object,      x
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),  }
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  
13                     ...) {  DBControl <-
14                if (is.null(readerControl$reader))  function(x)
15                    readerControl$reader <- object@DefaultReader      attr(x, "DBControl")
16                if (is(readerControl$reader, "FunctionGenerator"))  
17                    readerControl$reader <- readerControl$reader(...)  PCorpus <-
18                if (is.null(readerControl$language))  function(x,
19                    readerControl$language = "en_US"           readerControl = list(reader = x$defaultreader, language = "en"),
20                if (is.null(readerControl$load))           dbControl = list(dbName = "", dbType = "DB1"))
21                    readerControl$load = TRUE  {
22        stopifnot(inherits(x, "Source"))
23    
24        readerControl <- prepareReader(readerControl, x$defaultreader)
25    
26                if (dbControl$useDb) {      if (is.function(readerControl$init))
27                    if (!dbCreate(dbControl$dbName, dbControl$dbType))          readerControl$init()
28    
29        if (is.function(readerControl$exit))
30            on.exit(readerControl$exit())
31    
32        if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
33                        stop("error in creating database")                        stop("error in creating database")
34                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
35    
36                tdl <- list()      # Allocate memory in advance if length is known
37                counter <- 1      tdl <- if (x$length > 0)
38                while (!eoi(object)) {          vector("list", as.integer(x$length))
                   object <- stepNext(object)  
                   elem <- getElem(object)  
                   # If there is no Load on Demand support  
                   # we need to load the corpus into memory at startup  
                   if (!object@LoDSupport)  
                       readerControl$load <- TRUE  
                   doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))  
                   if (dbControl$useDb) {  
                       dbInsert(db, ID(doc), doc)  
                       tdl <- c(tdl, ID(doc))  
                   }  
39                    else                    else
40                        tdl <- c(tdl, list(doc))          list()
41    
42        counter <- 1
43        while (!eoi(x)) {
44            x <- stepNext(x)
45            elem <- getElem(x)
46            id <- if (is.null(x$names) || is.na(x$names))
47                    as.character(counter)
48                else
49                    x$names[counter]
50            doc <- readerControl$reader(elem, readerControl$language, id)
51            filehash::dbInsert(db, meta(doc, "id"), doc)
52            if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
53            else tdl <- c(tdl, meta(doc, "id"))
54                    counter <- counter + 1                    counter <- counter + 1
55                }                }
56        if (!is.null(x$names) && !is.na(x$names))
57            names(tdl) <- x$names
58    
59                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
60                if (dbControl$useDb) {      filehash::dbInsert(db, "DMetaData", df)
                   dbInsert(db, "DMetaData", df)  
61                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
               }  
               else  
                   dmeta.df <- df  
62    
63                cmeta.node <- new("MetaDataNode",      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
                             NodeID = 0,  
                             MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),  
                             children = list())  
   
               return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))  
           })  
   
 setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  
 setMethod("loadDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- readLines(con)  
                   close(con)  
                   Content(object) <- corpus  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object =  "XMLTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- paste(readLines(con), "\n", collapse = "")  
                   close(con)  
                   doc <- xmlTreeParse(corpus, asText = TRUE)  
                   class(doc) <- "list"  
                   Content(object) <- doc  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "NewsgroupDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   mail <- readLines(con)  
                   close(con)  
                   Cached(object) <- TRUE  
                   for (index in seq_along(mail)) {  
                       if (mail[index] == "")  
                           break  
                   }  
                   Content(object) <- mail[(index + 1):length(mail)]  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "StructuredTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   warning("load on demand not (yet) supported for StructuredTextDocuments")  
                   return(object)  
               } else  
                   return(object)  
           })  
   
 setGeneric("tmUpdate", function(object,  
                                 origin,  
                                 readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),  
                                 ...) standardGeneric("tmUpdate"))  
 # Update is only supported for directories  
 # At the moment no other LoD devices are available anyway  
 setMethod("tmUpdate",  
           signature(object = "Corpus", origin = "DirSource"),  
           function(object, origin,  
                    readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),  
                    ...) {  
               if (is.null(readerControl$reader))  
                   readerControl$reader <- origin@DefaultReader  
               if (is(readerControl$reader, "FunctionGenerator"))  
                   readerControl$reader <- readerControl$reader(...)  
               if (is.null(readerControl$language))  
                   readerControl$language = "en_US"  
               if (is.null(readerControl$load))  
                   readerControl$load = TRUE  
   
               object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))  
               new.files <- setdiff(origin@FileList, object.filelist)  
   
               for (filename in new.files) {  
                   encoding <- origin@Encoding  
                   elem <- list(content = readLines(filename, encoding = encoding),  
                                uri = substitute(file(filename, encoding = encoding)))  
                   object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))  
               }  
   
               return(object)  
           })  
   
 setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "Corpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               result <- object  
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]]) {  
                   if (lazy)  
                       warning("lazy mapping is deactived when using database backend")  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   i <- 1  
                   for (id in unlist(object)) {  
                       db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                       i <- i + 1  
                   }  
                   # Suggested by Christian Buchta  
                   dbReorganize(db)  
               }  
               else {  
                   # Lazy mapping  
                   if (lazy) {  
                       lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")  
                       if (is.null(lazyTmMap)) {  
                           meta(result, tag = "lazyTmMap", type = "corpus") <-  
                               list(index = rep(TRUE, length(result)),  
                                    maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  
64                        }                        }
65                        else {  
66                            lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  .VCorpus <-
67                            meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  function(x, cmeta, dmeta)
68                        }  {
69                    }      attr(x, "CMetaData") <- cmeta
70                    else      attr(x, "DMetaData") <- dmeta
71                        result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))      class(x) <- c("VCorpus", "Corpus", "list")
72        x
73                }                }
               return(result)  
           })  
74    
75  # Materialize lazy mappings  VCorpus <-
76  # Improvements by Christian Buchta  Corpus <-
77  materialize <- function(corpus, range = seq_along(corpus)) {  function(x, readerControl = list(reader = x$defaultreader, language = "en"))
78      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")  {
79      if (!is.null(lazyTmMap)) {      stopifnot(inherits(x, "Source"))
        # Make valid and lazy index  
        idx <- (seq_along(corpus) %in% range) & lazyTmMap$index  
        if (any(idx)) {  
            res <- lapply(corpus@.Data[idx], loadDoc)  
            for (m in lazyTmMap$maps)  
                res <- lapply(res, m, DMetaData = DMetaData(corpus))  
            corpus@.Data[idx] <- res  
            lazyTmMap$index[idx] <- FALSE  
        }  
     }  
     # Clean up if everything is materialized  
     if (!any(lazyTmMap$index))  
         lazyTmMap <- NULL  
     meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     return(corpus)  
 }  
   
 setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  
 setMethod("asPlain",  
           signature(object = "PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("asPlain",  
           signature(object = "XMLTextDocument", FUN = "function"),  
           function(object, FUN, ...) {  
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "Reuters21578Document"),  
           function(object, FUN, ...) {  
               FUN <- convertReut21578XMLPlain  
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "RCV1Document"),  
           function(object, FUN, ...) {  
               FUN <- convertRCV1Plain  
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
           })  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),  
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
 setMethod("asPlain",  
           signature(object = "StructuredTextDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,  
                   URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),  
                   Description = Description(object), ID = ID(object), Origin = Origin(object),  
                   Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
   
 setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  
 setMethod("tmFilter",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
               else  
                   return(object[FUN(object, ...)])  
           })  
80    
81  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))      readerControl <- prepareReader(readerControl, x$defaultreader)
 setMethod("tmIndex",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = sFilter, doclevel = FALSE) {  
               if (doclevel)  
                   return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
               else  
                   return(FUN(object, ...))  
           })  
82    
83  sFilter <- function(object, s, ...) {      if (is.function(readerControl$init))
84      con <- textConnection(s)          readerControl$init()
85      tokens <- scan(con, "character", quiet = TRUE)  
86      close(con)      if (is.function(readerControl$exit))
87      localMetaNames <- unique(names(sapply(object, LocalMetaData)))          on.exit(readerControl$exit())
88      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
89      n <- names(DMetaData(object))      # Allocate memory in advance if length is known
90      tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)      tdl <- if (x$length > 0)
91      query.df <- DMetaData(prescindMeta(object, tags))          vector("list", as.integer(x$length))
     if (DBControl(object)[["useDb"]])  
         DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]  
     # Rename to avoid name conflicts  
     names(query.df)[names(query.df) == "Author"] <- "author"  
     names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"  
     names(query.df)[names(query.df) == "Description"] <- "description"  
     names(query.df)[names(query.df) == "ID"] <- "identifier"  
     names(query.df)[names(query.df) == "Origin"] <- "origin"  
     names(query.df)[names(query.df) == "Heading"] <- "heading"  
     names(query.df)[names(query.df) == "Language"] <- "language"  
     attach(query.df)  
     try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))  
     detach(query.df)  
     return(result)  
 }  
   
 setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  
 setMethod("appendElem",  
           signature(object = "Corpus", data = "TextDocument"),  
           function(object, data, meta = NULL) {  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   if (dbExists(db, ID(data)))  
                       warning("document with identical ID already exists")  
                   dbInsert(db, ID(data), data)  
                   object@.Data[[length(object)+1]] <- ID(data)  
               }  
92                else                else
93                    object@.Data[[length(object)+1]] <- data          list()
94                DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))  
95                return(object)      if (x$vectorized)
96            })          tdl <- mapply(function(elem, id) readerControl$reader(elem, readerControl$language, id),
97                          pGetElem(x),
98  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))                        id = if (is.null(x$names) || is.na(x$names)) as.character(seq_len(x$length)) else x$names,
99  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 <- 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  
                   }  
100                    else {                    else {
101                        local.meta <- lapply(object, LocalMetaData)          counter <- 1
102                        local.m <- lapply(local.meta, "[[", m)          while (!eoi(x)) {
103                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))              x <- stepNext(x)
104                        if (length(local.m) == length(unlist(local.m)))              elem <- getElem(x)
105                            local.m <- unlist(local.m)              id <- if (is.null(x$names) || is.na(x$names))
106                    as.character(counter)
107                else
108                    x$names[counter]
109                doc <- readerControl$reader(elem, readerControl$language, id)
110                if (x$length > 0)
111                    tdl[[counter]] <- doc
112                        else                        else
113                            local.m <- I(local.m)                  tdl <- c(tdl, list(doc))
114                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))              counter <- counter + 1
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
115                    }                    }
116                }                }
117                return(object)      if (!is.null(x$names) && !is.na(x$names))
118            })          names(tdl) <- x$names
119        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
120  setMethod("[",      .VCorpus(tdl, .MetaDataNode(), df)
           signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
                   return(x)  
   
               object <- x  
               object@.Data <- x@.Data[i, ..., drop = FALSE]  
               if (DBControl(object)[["useDb"]]) {  
                   index <- object@DMetaData[[1 , "subset"]]  
                   if (any(is.na(index)))  
                       object@DMetaData[[1 , "subset"]] <- i  
                   else  
                       object@DMetaData[[1 , "subset"]] <- index[i]  
121                }                }
122                else  
123                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  `[.PCorpus` <-
124                return(object)  function(x, i)
125            })  {
126        if (missing(i)) return(x)
127  setMethod("[<-",      index <- attr(x, "DMetaData")[[1 , "subset"]]
128            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
129            function(x, i, j, ... , value) {      dmeta <- attr(x, "DMetaData")
130                object <- x      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
131                if (DBControl(object)[["useDb"]]) {  }
132                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
133    `[.VCorpus` <-
134    function(x, i)
135    {
136        if (missing(i)) return(x)
137        .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
138    }
139    
140    `[<-.PCorpus` <-
141    function(x, i, value)
142    {
143        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
144                    counter <- 1                    counter <- 1
145                    for (id in object@.Data[i, ...]) {      for (id in unclass(x)[i]) {
146                        if (length(value) == 1)          if (identical(length(value), 1L)) db[[id]] <- value
147                            db[[id]] <- value          else db[[id]] <- value[[counter]]
                       else {  
                           db[[id]] <- value[[counter]]  
                       }  
148                        counter <- counter + 1                        counter <- counter + 1
149                    }                    }
150        x
151                }                }
152    
153    .map_name_index <-
154    function(x, i)
155    {
156        if (is.character(i)) {
157            if (is.null(names(x)))
158                match(i, meta(x, "id", type = "local"))
159                else                else
160                    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"]]) {  
                   db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
                   result <- dbFetch(db, x@.Data[[i]])  
                   return(loadDoc(result))  
161                }                }
162                else {      i
163    }
164    
165    `[[.PCorpus` <-
166    function(x, i)
167    {
168        i <- .map_name_index(x, i)
169        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
170        filehash::dbFetch(db, NextMethod("[["))
171    }
172    `[[.VCorpus` <-
173    function(x, i)
174    {
175        i <- .map_name_index(x, i)
176                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
177                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
178                        .Call("copyCorpus", x, materialize(x, i))                        .Call("copyCorpus", x, materialize(x, i))
179                    return(loadDoc(x@.Data[[i]]))      NextMethod("[[")
180                }                }
           })  
181    
182  setMethod("[[<-",  `[[<-.PCorpus` <-
183            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),  function(x, i, value)
184            function(x, i, j, ..., value) {  {
185                object <- x      i <- .map_name_index(x, i)
186                if (DBControl(object)[["useDb"]]) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
187                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])      index <- unclass(x)[[i]]
                   index <- object@.Data[[i]]  
188                    db[[index]] <- value                    db[[index]] <- value
189        x
190                }                }
191                else {  `[[<-.VCorpus` <-
192    function(x, i, value)
193    {
194        i <- .map_name_index(x, i)
195                    # Mark new objects as not active for lazy mapping                    # Mark new objects as not active for lazy mapping
196                    lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
197                    if (!is.null(lazyTmMap)) {                    if (!is.null(lazyTmMap)) {
198                        lazyTmMap$index[i] <- FALSE                        lazyTmMap$index[i] <- FALSE
199                        meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap          meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
200                    }                    }
201                    # Set the value                    # Set the value
202                    object@.Data[[i, ...]] <- value      cl <- class(x)
203        y <- NextMethod("[[<-")
204        class(y) <- cl
205        y
206                }                }
               return(object)  
           })  
207    
208  # Update \code{NodeID}s of a CMetaData tree  # Update NodeIDs of a CMetaData tree
209  update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {  .update_id <-
210      # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s  function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)
211      set_id <- function(object) {  {
212          object@NodeID <- id      # Traversal of (binary) CMetaData tree with setup of NodeIDs
213        set_id <- function(x) {
214            x$NodeID <- id
215          id <<- id + 1          id <<- id + 1
216          level <<- level + 1          level <<- level + 1
217            if (length(x$Children)) {
218          if (length(object@children) > 0) {              mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
219              mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))              left <- set_id(x$Children[[1]])
             left <- set_id(object@children[[1]])  
220              if (level == 1) {              if (level == 1) {
221                  left.mapping <<- mapping                  left.mapping <<- mapping
222                  mapping <<- NULL                  mapping <<- NULL
223              }              }
224              mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))              mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
225              right <- set_id(object@children[[2]])              right <- set_id(x$Children[[2]])
226    
227              object@children <- list(left, right)              x$Children <- list(left, right)
228          }          }
229          level <<- level - 1          level <<- level - 1
230            x
         return(object)  
231      }      }
232        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))  
233  }  }
234    
235  setMethod("c",  # Find indices to be updated for a CMetaData tree
236            signature(x = "Corpus"),  .find_indices <-
237            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  function(x)
238                args <- list(...)  {
               if (length(args) == 0)  
                   return(x)  
   
               if (!all(sapply(args, inherits, "Corpus")))  
                   stop("not all arguments are text document collections")  
               if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating text document collections with activated database is not supported")  
   
               result <- x  
               for (c in args) {  
                   result <- c2(result, c)  
               }  
               return(result)  
           })  
   
 setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  
 setMethod("c2",  
           signature(x = "Corpus", y = "Corpus"),  
           function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  
               object <- x  
               # Concatenate data slots  
               object@.Data <- c(as(x, "list"), as(y, "list"))  
   
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
               # 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  
239                indices.mapping <- NULL                indices.mapping <- NULL
240                for (m in levels(as.factor(DMetaData(x)$MetaID))) {                for (m in levels(as.factor(DMetaData(x)$MetaID))) {
241                    indices <- (DMetaData(x)$MetaID == m)                    indices <- (DMetaData(x)$MetaID == m)
242                    indices.mapping <- c(indices.mapping, list(m = indices))                    indices.mapping <- c(indices.mapping, list(m = indices))
243                    names(indices.mapping)[length(indices.mapping)] <- m                    names(indices.mapping)[length(indices.mapping)] <- m
244                }                }
245        indices.mapping
246    }
247    
248    c2 <-
249    function(x, y, ...)
250    {
251        # Update the CMetaData tree
252        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
253        update.struct <- .update_id(cmeta)
254    
255        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
256    
257        # Find indices to be updated for the left tree
258        indices.mapping <- .find_indices(x)
259    
260                # Update the DMetaData data frames for the left tree                # Update the DMetaData data frames for the left tree
261                for (i in 1:ncol(update.struct$left.mapping)) {                for (i in 1:ncol(update.struct$left.mapping)) {
262                    map <- update.struct$left.mapping[,i]                    map <- update.struct$left.mapping[,i]
263                    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])
264                }                }
265    
266                # Find indices to be updated for the right tree                # Find indices to be updated for the right tree
267                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  
               }  
268    
269                # Update the DMetaData data frames for the right tree                # Update the DMetaData data frames for the right tree
270                for (i in 1:ncol(update.struct$right.mapping)) {                for (i in 1:ncol(update.struct$right.mapping)) {
271                    map <- update.struct$right.mapping[,i]                    map <- update.struct$right.mapping[,i]
272                    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])
273                }                }
274    
275                # Merge the DMetaData data frames                # Merge the DMetaData data frames
276                labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))                labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
277                na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))      na.matrix <- matrix(NA,
278                            nrow = nrow(DMetaData(x)),
279                            ncol = length(labels),
280                            dimnames = list(row.names(DMetaData(x)), labels))
281                x.dmeta.aug <- cbind(DMetaData(x), na.matrix)                x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
282                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))                labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
283                na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))      na.matrix <- matrix(NA,
284                            nrow = nrow(DMetaData(y)),
285                            ncol = length(labels),
286                            dimnames = list(row.names(DMetaData(y)), labels))
287                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
288                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)      DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
289    
290        new
291    }
292    
293    c.Corpus <-
294    function(..., recursive = FALSE)
295    {
296        args <- list(...)
297        x <- args[[1L]]
298    
299        if(length(args) == 1L)
300            return(x)
301    
302        if (!all(unlist(lapply(args, inherits, class(x)))))
303            stop("not all arguments are of the same corpus type")
304    
305        if (inherits(x, "PCorpus"))
306            stop("concatenation of corpora with underlying databases is not supported")
307    
308                return(object)      if (recursive)
309            })          Reduce(c2, args)
310        else {
311            args <- do.call("c", lapply(args, unclass))
312            .VCorpus(args,
313                     cmeta = .MetaDataNode(),
314                     dmeta = data.frame(MetaID = rep(0, length(args)),
315                                        stringsAsFactors = FALSE))
316        }
317    }
318    
319  setMethod("c",  c.TextDocument <-
320            signature(x = "TextDocument"),  function(..., recursive = FALSE)
321            function(x, ..., recursive = TRUE){  {
322                args <- list(...)                args <- list(...)
323                if(length(args) == 0)      x <- args[[1L]]
324    
325        if(length(args) == 1L)
326                    return(x)                    return(x)
327    
328                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)      if (!all(unlist(lapply(args, inherits, class(x)))))
329                cmeta.node <- new("MetaDataNode",          stop("not all arguments are text documents")
330                              NodeID = 0,  
331                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),      dmeta <- data.frame(MetaID = rep(0, length(args)),
332                              children = list())                          stringsAsFactors = FALSE)
333        .VCorpus(args, .MetaDataNode(), dmeta)
334                return(new("Corpus",  }
335                           .Data = list(x, ...),  
336                           DMetaData = dmeta.df,  print.Corpus <-
337                           CMetaData = cmeta.node,  function(x, ...)
338                           DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))  {
339            })      cat(sprintf(ngettext(length(x),
340                             "A corpus with %d text document\n",
341  setMethod("length",                           "A corpus with %d text documents\n"),
342            signature(x = "Corpus"),                  length(x)))
343            function(x){      invisible(x)
344                return(length(as(x, "list")))  }
345      })  
346    summary.Corpus <-
347  setMethod("show",  function(object, ...)
348            signature(object = "Corpus"),  {
349            function(object){      print(object)
350                cat(sprintf(ngettext(length(object),      if (length(DMetaData(object))) {
351                                     "A text document collection with %d text document\n",          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
                                    "A text document collection with %d text documents\n"),  
                           length(object)))  
     })  
   
 setMethod("summary",  
           signature(object = "Corpus"),  
           function(object){  
               show(object)  
               if (length(DMetaData(object)) > 0) {  
                   cat(sprintf(ngettext(length(CMetaData(object)@MetaData),  
352                                                "\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",
353                                                "\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"),
354                                         length(CMetaData(object)@MetaData)))                      length(CMetaData(object)$MetaData)))
355                    cat("Available tags are:\n")                    cat("Available tags are:\n")
356                    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")
357                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
358                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
359                }                }
     })  
   
 setGeneric("inspect", function(object) standardGeneric("inspect"))  
 setMethod("inspect",  
           signature("Corpus"),  
           function(object) {  
               summary(object)  
               cat("\n")  
               if (DBControl(object)[["useDb"]]) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   show(dbMultiFetch(db, unlist(object)))  
360                }                }
               else  
                   print(noquote(lapply(object, identity)))  
           })  
361    
362  # No metadata is checked  inspect <-
363  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  function(x)
364  setMethod("%IN%",      UseMethod("inspect", x)
365            signature(x = "TextDocument", y = "Corpus"),  inspect.PCorpus <-
366            function(x, y) {  function(x)
367                if (DBControl(y)[["useDb"]]) {  {
368                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])      summary(x)
369                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))      cat("\n")
370                }      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
371                else      show(filehash::dbMultiFetch(db, unlist(x)))
                   result <- x %in% y  
               return(result)  
           })  
   
 setMethod("lapply",  
           signature(X = "Corpus"),  
           function(X, FUN, ...) {  
               print("lapply")  
               if (DBControl(X)[["useDb"]]) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
372                }                }
373                else {  inspect.VCorpus <-
374                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  function(x)
375                    if (!is.null(lazyTmMap))  {
376                        .Call("copyCorpus", X, materialize(X))      summary(x)
377                    result <- base::lapply(X, FUN, ...)      cat("\n")
378        print(noquote(lapply(x, identity)))
379                }                }
               return(result)  
           })  
380    
381  setMethod("sapply",  lapply.PCorpus <-
382            signature(X = "Corpus"),  function(X, FUN, ...)
383            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {  {
384                if (DBControl(X)[["useDb"]]) {      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
385                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
386                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)  }
387                }  lapply.VCorpus <-
388                else {  function(X, FUN, ...)
389    {
390                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
391                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
392                        .Call("copyCorpus", X, materialize(X))                        .Call("copyCorpus", X, materialize(X))
393                    result <- base::sapply(X, FUN, ...)      base::lapply(X, FUN, ...)
394                }                }
               return(result)  
           })  
395    
396  setAs("list", "Corpus", function(from) {  writeCorpus <-
397      cmeta.node <- new("MetaDataNode",  function(x, path = ".", filenames = NULL)
398                        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) {  
399                filenames <- file.path(path,                filenames <- file.path(path,
400                                       if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))        if (is.null(filenames))
401              sprintf("%s.txt", as.character(meta(x, "id", "local")))
402                                       else filenames)                                       else filenames)
403                i <- 1  
404                for (o in object) {      stopifnot(length(x) == length(filenames))
405                    writeLines(o, filenames[i])  
406                    i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
407    
408        invisible(x)
409                }                }
           })  

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

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