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

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

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