SCM

SCM Repository

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

Diff of /pkg/R/corpus.R

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

pkg/tm/R/textdoccol.R revision 884, Wed Jan 28 10:24:27 2009 UTC pkg/R/corpus.R revision 1307, Tue Mar 25 12:15:51 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                # Allocate memory in advance if length is known                # Allocate memory in advance if length is known
29                tdl <- if (object@Length > 0)      tdl <- if (x$length > 0)
30                    vector("list", as.integer(object@Length))          vector("list", as.integer(x$length))
31                else                else
32                    list()                    list()
33    
34                counter <- 1                counter <- 1
35                while (!eoi(object)) {      while (!eoi(x)) {
36                    object <- stepNext(object)          x <- stepNext(x)
37                    elem <- getElem(object)          elem <- getElem(x)
38                    # If there is no Load on Demand support          id <- if (is.null(x$names) || is.na(x$names))
39                    # we need to load the corpus into memory at startup              as.character(counter)
40                    if (!object@LoDSupport)          else
41                        readerControl$load <- TRUE              x$names[counter]
42                    doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))          doc <- readerControl$reader(elem, readerControl$language, id)
43                    if (dbControl$useDb) {          filehash::dbInsert(db, meta(doc, "id"), doc)
44                        dbInsert(db, ID(doc), doc)          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
45                        if (object@Length > 0)          else tdl <- c(tdl, meta(doc, "id"))
                           tdl[[counter]] <- ID(doc)  
                       else  
                           tdl <- c(tdl, ID(doc))  
                   }  
                   else {  
                       if (object@Length > 0)  
                           tdl[[counter]] <- doc  
                       else  
                           tdl <- c(tdl, list(doc))  
                   }  
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) {summary(eval(URI(x)))$description}))  
               new.files <- setdiff(origin@FileList, object.filelist)  
   
               for (filename in new.files) {  
                   encoding <- origin@Encoding  
                   elem <- list(content = readLines(filename, encoding = encoding),  
                                uri = substitute(file(filename, encoding = encoding)))  
                   object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))  
               }  
   
               return(object)  
           })  
   
 setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))  
 setMethod("tmMap",  
           signature(object = "Corpus", FUN = "function"),  
           function(object, FUN, ..., lazy = FALSE) {  
               result <- object  
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]]) {  
                   if (lazy)  
                       warning("lazy mapping is deactived when using database backend")  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   i <- 1  
                   for (id in unlist(object)) {  
                       db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                       i <- i + 1  
                   }  
                   # Suggested by Christian Buchta  
                   dbReorganize(db)  
               }  
               else {  
                   # Lazy mapping  
                   if (lazy) {  
                       lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")  
                       if (is.null(lazyTmMap)) {  
                           meta(result, tag = "lazyTmMap", type = "corpus") <-  
                               list(index = rep(TRUE, length(result)),  
                                    maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  
                       }  
                       else {  
                           lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))  
                           meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
                       }  
                   }  
91                    else {                    else {
92                        result@.Data <- if (clusterAvailable())          counter <- 1
93                            snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))          while (!eoi(x)) {
94                x <- stepNext(x)
95                elem <- getElem(x)
96                id <- if (is.null(x$names) || is.na(x$names))
97                    as.character(counter)
98                else
99                    x$names[counter]
100                doc <- readerControl$reader(elem, readerControl$language, id)
101                if (x$length > 0)
102                    tdl[[counter]] <- doc
103                        else                        else
104                            lapply(object, FUN, ..., DMetaData = DMetaData(object))                  tdl <- c(tdl, list(doc))
105                    }              counter <- counter + 1
106                }                }
               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"),  
           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, ...) {  
               return(convertRCV1Plain(object, ...))  
           })  
 setMethod("asPlain",  
           signature(object = "NewsgroupDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),  
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
 setMethod("asPlain",  
           signature(object = "StructuredTextDocument"),  
           function(object, FUN, ...) {  
               new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,  
                   URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),  
                   Description = Description(object), ID = ID(object), Origin = Origin(object),  
                   Heading = Heading(object), Language = Language(object),  
                   LocalMetaData = LocalMetaData(object))  
           })  
   
 setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))  
 setMethod("tmFilter",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = searchFullText, doclevel = TRUE) {  
               if (!is.null(attr(FUN, "doclevel")))  
                   doclevel <- attr(FUN, "doclevel")  
               if (doclevel) {  
                   if (clusterAvailable())  
                       return(object[snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))])  
                   else  
                       return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])  
107                }                }
108                else      if (!is.null(x$names) && !is.na(x$names))
109                    return(object[FUN(object, ...)])          names(tdl) <- x$names
110            })      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
111        .VCorpus(tdl, CorpusMeta(), df)
 setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))  
 setMethod("tmIndex",  
           signature(object = "Corpus"),  
           function(object, ..., FUN = searchFullText, doclevel = TRUE) {  
               if (!is.null(attr(FUN, "doclevel")))  
                   doclevel <- attr(FUN, "doclevel")  
               if (doclevel) {  
                   if (clusterAvailable())  
                       return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))  
                   else  
                       return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))  
112                }                }
               else  
                   return(FUN(object, ...))  
           })  
113    
114  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  `[.PCorpus` <-
115  setMethod("appendElem",  function(x, i)
116            signature(object = "Corpus", data = "TextDocument"),  {
117            function(object, data, meta = NULL) {      if (!missing(i)) {
118                if (DBControl(object)[["useDb"]]) {          x$content <- x$content[i]
119                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])          index <- x$dmeta[[1 , "subset"]]
120                    if (dbExists(db, ID(data)))          x$dmeta[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
                       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 <- sapply(local.m, paste, collapse = " ")  
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       local.m <- unlist(local.m)  
                       DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))  
                       names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m  
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, unclass))
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      dmeta <- data.frame(MetaID = rep(0, length(args)),
322  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))                          stringsAsFactors = FALSE)
323  setMethod("%IN%",      .VCorpus(args, CorpusMeta(), dmeta)
324            signature(x = "TextDocument", y = "Corpus"),  }
325            function(x, y) {  
326                if (DBControl(y)[["useDb"]]) {  content.Corpus <-
327                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])  function(x)
328                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))      x$content
329                }  
330                else  `content<-.Corpus` <-
331                    result <- x %in% y  function(x, value)
332                return(result)  {
333            })      x$content <- value
334        x
335  setMethod("lapply",  }
336            signature(X = "Corpus"),  
337            function(X, FUN, ...) {  length.Corpus <-
338                if (DBControl(X)[["useDb"]]) {  function(x)
339                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])      length(content(x))
340                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
341                }  print.Corpus <-
342                else {  function(x, ...)
343                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  {
344                    if (!is.null(lazyTmMap))      cat(sprintf(ngettext(length(x),
345                        .Call("copyCorpus", X, materialize(X))                           "A corpus with %d text document\n\n",
346                    result <- base::lapply(X, FUN, ...)                           "A corpus with %d text documents\n\n"),
347                    length(x)))
348    
349        meta <- meta(x, type = "corpus")$value
350        dmeta <- meta(x, type = "indexed")
351    
352        cat("Metadata:\n")
353        cat(sprintf("  Tag-value pairs. Tags: %s\n",
354                    paste(names(meta), collapse = " ")))
355        cat("  Data frame. Variables:", colnames(dmeta), "\n")
356    
357        invisible(x)
358    }
359    
360    inspect <-
361    function(x)
362        UseMethod("inspect", x)
363    inspect.PCorpus <-
364    function(x)
365    {
366        print(x)
367        cat("\n")
368        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
369        show(filehash::dbMultiFetch(db, unlist(x)))
370        invisible(x)
371    }
372    inspect.VCorpus <-
373    function(x)
374    {
375        print(x)
376        cat("\n")
377        print(noquote(content(x)))
378        invisible(x)
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(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])
385                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])      lapply(filehash::dbMultiFetch(db, unlist(content(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, ...)      lapply(content(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(asPlain(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.884  
changed lines
  Added in v.1307

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