SCM

SCM Repository

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

Diff of /pkg/R/corpus.R

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

pkg/R/textdoccol.R revision 905, Sat Mar 21 10:13:08 2009 UTC pkg/R/corpus.R revision 962, Sun Jun 28 15:52:33 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  prepareReader <- function(readerControl, defaultReader = NULL, ...) {
 setGeneric("Corpus", function(object,  
                               readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),  
                               dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  
                               ...) standardGeneric("Corpus"))  
 setMethod("Corpus",  
           signature(object = "Source"),  
           function(object,  
                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),  
                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),  
                    ...) {  
4                if (is.null(readerControl$reader))                if (is.null(readerControl$reader))
5                    readerControl$reader <- object@DefaultReader          readerControl$reader <- defaultReader
6                if (is(readerControl$reader, "FunctionGenerator"))                if (is(readerControl$reader, "FunctionGenerator"))
7                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
8                if (is.null(readerControl$language))                if (is.null(readerControl$language))
9                    readerControl$language = "en_US"          readerControl$language <- "eng"
10                if (is.null(readerControl$load))      readerControl
11                    readerControl$load = TRUE  }
12    
13                if (dbControl$useDb && require("filehash")) {  ## Fast Corpus
14                    if (!dbCreate(dbControl$dbName, dbControl$dbType))  ##   - provides a prototype implementation of a more time and memory efficient representation of a corpus
15    ##   - allows performance tests and comparisons to other corpus types
16    #FCorpus <- function(object, readerControl = list(language = "eng")) {
17    #    readerControl <- prepareReader(readerControl)
18    #
19    #    if (!object@Vectorized)
20    #        stop("Source is not vectorized")
21    #
22    #    tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
23    #                  function(x) readSlim(x[c("content", "uri")],
24    #                                       readerControl$language,
25    #                                       as.character(x$id)))
26    #
27    #    new("FCorpus", .Data = tdl)
28    #}
29    
30    PCorpus <- function(object,
31                        readerControl = list(reader = object@DefaultReader, language = "eng"),
32                        dbControl = list(dbName = "", dbType = "DB1"),
33                        ...) {
34        readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
35    
36        if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
37                        stop("error in creating database")                        stop("error in creating database")
38                    db <- dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
               }  
39    
40                # Allocate memory in advance if length is known                # Allocate memory in advance if length is known
41                tdl <- if (object@Length > 0)                tdl <- if (object@Length > 0)
# Line 36  Line 47 
47                while (!eoi(object)) {                while (!eoi(object)) {
48                    object <- stepNext(object)                    object <- stepNext(object)
49                    elem <- getElem(object)                    elem <- getElem(object)
50                    # If there is no Load on Demand support          doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
51                    # we need to load the corpus into memory at startup          filehash::dbInsert(db, ID(doc), doc)
52                    if (!object@LoDSupport)          if (object@Length > 0) tdl[[counter]] <- ID(doc)
53                        readerControl$load <- TRUE          else tdl <- c(tdl, ID(doc))
                   doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))  
                   if (dbControl$useDb && require("filehash")) {  
                       dbInsert(db, ID(doc), doc)  
                       if (object@Length > 0)  
                           tdl[[counter]] <- ID(doc)  
                       else  
                           tdl <- c(tdl, ID(doc))  
                   }  
                   else {  
                       if (object@Length > 0)  
                           tdl[[counter]] <- doc  
                       else  
                           tdl <- c(tdl, list(doc))  
                   }  
54                    counter <- counter + 1                    counter <- counter + 1
55                }                }
56    
57                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
58                if (dbControl$useDb && require("filehash")) {      filehash::dbInsert(db, "DMetaData", df)
                   dbInsert(db, "DMetaData", df)  
59                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
               }  
               else  
                   dmeta.df <- df  
60    
61                cmeta.node <- new("MetaDataNode",                cmeta.node <- new("MetaDataNode",
62                              NodeID = 0,                              NodeID = 0,
63                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
64                              children = list())                              children = list())
65    
66                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))      new("PCorpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)
           })  
   
 setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  
 setMethod("loadDoc",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   corpus <- readLines(con)  
                   close(con)  
                   Content(object) <- corpus  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object =  "XMLTextDocument"),  
           function(object, ...) {  
               if (!Cached(object) && require("XML")) {  
                   con <- eval(URI(object))  
                   corpus <- paste(readLines(con), "\n", collapse = "")  
                   close(con)  
                   doc <- xmlTreeParse(corpus, asText = TRUE)  
                   class(doc) <- "list"  
                   Content(object) <- doc  
                   Cached(object) <- TRUE  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
 setMethod("loadDoc",  
           signature(object = "NewsgroupDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   con <- eval(URI(object))  
                   mail <- readLines(con)  
                   close(con)  
                   Cached(object) <- TRUE  
                   for (index in seq_along(mail)) {  
                       if (mail[index] == "")  
                           break  
                   }  
                   Content(object) <- mail[(index + 1):length(mail)]  
                   return(object)  
               } else {  
                   return(object)  
67                }                }
           })  
 setMethod("loadDoc",  
           signature(object = "StructuredTextDocument"),  
           function(object, ...) {  
               if (!Cached(object)) {  
                   warning("load on demand not (yet) supported for StructuredTextDocuments")  
                   return(object)  
               } else  
                   return(object)  
           })  
68    
69  setGeneric("tmUpdate", function(object,  # The "..." are additional arguments for the FunctionGenerator reader
70                                  origin,  SCorpus <- Corpus <- function(object,
71                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),                      readerControl = list(reader = object@DefaultReader, language = "eng"),
                                 ...) 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),  
72                     ...) {                     ...) {
73                if (is.null(readerControl$reader))      readerControl <- prepareReader(readerControl, object@DefaultReader, ...)
74                    readerControl$reader <- origin@DefaultReader  
75                if (is(readerControl$reader, "FunctionGenerator"))      # Allocate memory in advance if length is known
76                    readerControl$reader <- readerControl$reader(...)      tdl <- if (object@Length > 0)
77                if (is.null(readerControl$language))          vector("list", as.integer(object@Length))
78                    readerControl$language = "en_US"      else
79                if (is.null(readerControl$load))          list()
80                    readerControl$load = TRUE  
81        if (object@Vectorized)
82                object.filelist <- unlist(lapply(object, function(x) {summary(eval(URI(x)))$description}))          tdl <- lapply(mapply(c, pGetElem(object), id = seq_len(object@Length), SIMPLIFY = FALSE),
83                new.files <- setdiff(origin@FileList, object.filelist)                        function(x) readerControl$reader(x[c("content", "uri")],
84                                                           readerControl$language,
85                for (filename in new.files) {                                                         as.character(x$id)))
86                    encoding <- origin@Encoding      else {
87                    elem <- list(content = readLines(filename, encoding = encoding),          counter <- 1
88                                 uri = substitute(file(filename, encoding = encoding)))          while (!eoi(object)) {
89                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))              object <- stepNext(object)
90                elem <- getElem(object)
91                doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
92                if (object@Length > 0)
93                    tdl[[counter]] <- doc
94                else
95                    tdl <- c(tdl, list(doc))
96                counter <- counter + 1
97            }
98                }                }
99    
100                return(object)      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
101            })      cmeta.node <- new("MetaDataNode",
102                          NodeID = 0,
103                          MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
104                          children = list())
105    
106        new("SCorpus", .Data = tdl, DMetaData = df, CMetaData = cmeta.node)
107    }
108    
109  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
110    #setMethod("tmMap",
111    #          signature(object = "FCorpus", FUN = "function"),
112    #          function(object, FUN, ..., lazy = FALSE) {
113    #              if (lazy)
114    #                  warning("lazy mapping is deactivated")
115    #
116    #              new("FCorpus", .Data = lapply(object, FUN, ..., DMetaData = data.frame()))
117    #          })
118  setMethod("tmMap",  setMethod("tmMap",
119            signature(object = "Corpus", FUN = "function"),            signature(object = "SCorpus", FUN = "function"),
120            function(object, FUN, ..., lazy = FALSE) {            function(object, FUN, ..., lazy = FALSE) {
121                result <- object                result <- object
               # Note that text corpora are automatically loaded into memory via \code{[[}  
               if (DBControl(object)[["useDb"]] && require("filehash")) {  
                   if (lazy)  
                       warning("lazy mapping is deactived when using database backend")  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   i <- 1  
                   for (id in unlist(object)) {  
                       db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))  
                       i <- i + 1  
                   }  
                   # Suggested by Christian Buchta  
                   dbReorganize(db)  
               }  
               else {  
122                    # Lazy mapping                    # Lazy mapping
123                    if (lazy) {                    if (lazy) {
124                        lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")                        lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
# Line 203  Line 138 
138                        else                        else
139                            lapply(object, FUN, ..., DMetaData = DMetaData(object))                            lapply(object, FUN, ..., DMetaData = DMetaData(object))
140                    }                    }
141                  result
142              })
143    setMethod("tmMap",
144              signature(object = "PCorpus", FUN = "function"),
145              function(object, FUN, ..., lazy = FALSE) {
146                  if (lazy)
147                      warning("lazy mapping is deactived when using database backend")
148                  db <- filehash::dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
149                  i <- 1
150                  for (id in unlist(object)) {
151                      db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
152                      i <- i + 1
153                }                }
154                return(result)                # Suggested by Christian Buchta
155                  filehash::dbReorganize(db)
156    
157                  object
158            })            })
159    
160  # Materialize lazy mappings  # Materialize lazy mappings
# Line 215  Line 165 
165         # Make valid and lazy index         # Make valid and lazy index
166         idx <- (seq_along(corpus) %in% range) & lazyTmMap$index         idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
167         if (any(idx)) {         if (any(idx)) {
168             res <- lapply(corpus@.Data[idx], loadDoc)             res <- corpus@.Data[idx]
169             for (m in lazyTmMap$maps)             for (m in lazyTmMap$maps)
170                 res <- lapply(res, m, DMetaData = DMetaData(corpus))                 res <- lapply(res, m, DMetaData = DMetaData(corpus))
171             corpus@.Data[idx] <- res             corpus@.Data[idx] <- res
# Line 226  Line 176 
176      if (!any(lazyTmMap$index))      if (!any(lazyTmMap$index))
177          lazyTmMap <- NULL          lazyTmMap <- NULL
178      meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap      meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
179      return(corpus)      corpus
180  }  }
181    
182  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
183  setMethod("asPlain",  setMethod("asPlain", signature(object = "PlainTextDocument"),
184            signature(object = "PlainTextDocument"),            function(object, FUN, ...) object)
           function(object, FUN, ...) {  
               return(object)  
           })  
185  setMethod("asPlain",  setMethod("asPlain",
186            signature(object = "XMLTextDocument"),            signature(object = "XMLTextDocument"),
187            function(object, FUN, ...) {            function(object, FUN, ...) {
# Line 262  Line 209 
209    
210                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
211            })            })
212  setMethod("asPlain",  setMethod("asPlain", signature(object = "RCV1Document"),
213            signature(object = "RCV1Document"),            function(object, FUN, ...) convertRCV1Plain(object, ...))
           function(object, FUN, ...) {  
               return(convertRCV1Plain(object, ...))  
           })  
214  setMethod("asPlain",  setMethod("asPlain",
215            signature(object = "NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
216            function(object, FUN, ...) {            function(object, FUN, ...) {
217                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),                new("PlainTextDocument", .Data = Content(object), Author = Author(object),
218                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
219                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
220                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(object))
# Line 278  Line 222 
222  setMethod("asPlain",  setMethod("asPlain",
223            signature(object = "StructuredTextDocument"),            signature(object = "StructuredTextDocument"),
224            function(object, FUN, ...) {            function(object, FUN, ...) {
225                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,                new("PlainTextDocument", .Data = unlist(Content(object)),
226                    URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),                    Author = Author(object), DateTimeStamp = DateTimeStamp(object),
227                    Description = Description(object), ID = ID(object), Origin = Origin(object),                    Description = Description(object), ID = ID(object), Origin = Origin(object),
228                    Heading = Heading(object), Language = Language(object),                    Heading = Heading(object), Language = Language(object),
229                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(object))
230            })            })
231    
232  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
233  setMethod("tmFilter",  setMethod("tmFilter", signature(object = "Corpus"),
234            signature(object = "Corpus"),            function(object, ..., FUN = searchFullText, doclevel = TRUE)
235            function(object, ..., FUN = searchFullText, doclevel = TRUE) {                object[tmIndex(object, ..., FUN = FUN, doclevel = doclevel)])
               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))])  
               }  
               else  
                   return(object[FUN(object, ...)])  
           })  
236    
237  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
238  setMethod("tmIndex",  setMethod("tmIndex",
# Line 317  Line 250 
250                    return(FUN(object, ...))                    return(FUN(object, ...))
251            })            })
252    
253    # TODO: Replace with c(Corpus, TextDocument)?
254  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
255  setMethod("appendElem",  setMethod("appendElem",
256            signature(object = "Corpus", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
# Line 334  Line 268 
268                return(object)                return(object)
269            })            })
270    
271  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  prescindMeta <- function(object, meta) {
272  setMethod("appendMeta",      df <- DMetaData(object)
           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)  
           })  
273    
274  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))      for (m in meta)
275  setMethod("removeMeta",          df <- cbind(df, structure(data.frame(I(meta(object, tag = m, type = "local"))), names = m))
           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)  
           })  
276    
277  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))      df
 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  
                   }  
                   else {  
                       local.meta <- lapply(object, LocalMetaData)  
                       local.m <- lapply(local.meta, "[[", m)  
                       local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))  
                       if (length(local.m) == length(unlist(local.m)))  
                           local.m <- unlist(local.m)  
                       else  
                           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  
278                    }                    }
               }  
               return(object)  
           })  
279    
280    #setMethod("[",
281    #          signature(x = "FCorpus", i = "ANY", j = "ANY", drop = "ANY"),
282    #          function(x, i, j, ... , drop) {
283    #              if (missing(i)) return(x)
284    #
285    #              x@.Data <- x@.Data[i, ..., drop = FALSE]
286    #              x
287    #          })
288  setMethod("[",  setMethod("[",
289            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", drop = "ANY"),
290            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
291                if(missing(i))                if (missing(i)) return(x)
                   return(x)  
292    
293                object <- x                x@.Data <- x@.Data[i, ..., drop = FALSE]
294                object@.Data <- x@.Data[i, ..., drop = FALSE]                index <- x@DMetaData[[1 , "subset"]]
295                if (DBControl(object)[["useDb"]] && require("filehash")) {                if (any(is.na(index))) x@DMetaData[[1 , "subset"]] <- i
296                    index <- object@DMetaData[[1 , "subset"]]                else x@DMetaData[[1 , "subset"]] <- index[i]
297                    if (any(is.na(index)))                x
298                        object@DMetaData[[1 , "subset"]] <- i            })
299                    else  setMethod("[",
300                        object@DMetaData[[1 , "subset"]] <- index[i]            signature(x = "SCorpus", i = "ANY", j = "ANY", drop = "ANY"),
301                }            function(x, i, j, ... , drop) {
302                else                if (missing(i)) return(x)
303                    DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]  
304                return(object)                x@.Data <- x@.Data[i, ..., drop = FALSE]
305                  DMetaData(x) <- DMetaData(x)[i, , drop = FALSE]
306                  x
307            })            })
308    
309  setMethod("[<-",  setMethod("[<-",
310            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
311            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
312                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
               if (DBControl(object)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
313                    counter <- 1                    counter <- 1
314                    for (id in object@.Data[i, ...]) {                for (id in x@.Data[i, ...]) {
315                        if (length(value) == 1)                    if (identical(length(value), 1)) db[[id]] <- value
316                            db[[id]] <- value                    else db[[id]] <- value[[counter]]
                       else {  
                           db[[id]] <- value[[counter]]  
                       }  
317                        counter <- counter + 1                        counter <- counter + 1
318                    }                    }
319                }                x
320                else            })
321                    object@.Data[i, ...] <- value  setMethod("[<-",
322                return(object)            signature(x = "SCorpus", i = "ANY", j = "ANY", value = "ANY"),
323              function(x, i, j, ... , value) {
324                  x@.Data[i, ...] <- value
325                  x
326            })            })
327    
328  setMethod("[[",  setMethod("[[",
329            signature(x = "Corpus", i = "ANY", j = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY"),
330              function(x, i, j, ...) {
331                  db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
332                  filehash::dbFetch(db, x@.Data[[i]])
333              })
334    setMethod("[[",
335              signature(x = "SCorpus", i = "ANY", j = "ANY"),
336            function(x, i, j, ...) {            function(x, i, j, ...) {
               if (DBControl(x)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
                   result <- dbFetch(db, x@.Data[[i]])  
                   return(loadDoc(result))  
               }  
               else {  
337                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
338                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
339                        .Call("copyCorpus", x, materialize(x, i))                        .Call("copyCorpus", x, materialize(x, i))
340                    return(loadDoc(x@.Data[[i]]))                x@.Data[[i]]
               }  
341            })            })
342    
343  setMethod("[[<-",  setMethod("[[<-",
344            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "PCorpus", i = "ANY", j = "ANY", value = "ANY"),
345            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
346                object <- x                db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
347                if (DBControl(object)[["useDb"]] && require("filehash")) {                index <- x@.Data[[i]]
                   db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])  
                   index <- object@.Data[[i]]  
348                    db[[index]] <- value                    db[[index]] <- value
349                }                x
350                else {            })
351    setMethod("[[<-",
352              signature(x = "SCorpus", i = "ANY", j = "ANY", value = "ANY"),
353              function(x, i, j, ..., value) {
354                    # Mark new objects as not active for lazy mapping                    # Mark new objects as not active for lazy mapping
355                    lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")                lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
356                    if (!is.null(lazyTmMap)) {                    if (!is.null(lazyTmMap)) {
357                        lazyTmMap$index[i] <- FALSE                        lazyTmMap$index[i] <- FALSE
358                        meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap                    meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
359                    }                    }
360                    # Set the value                    # Set the value
361                    object@.Data[[i, ...]] <- value                x@.Data[[i, ...]] <- value
362                }  
363                return(object)                x
364            })            })
365    
366  # Update \code{NodeID}s of a CMetaData tree  # Update \code{NodeID}s of a CMetaData tree
# Line 488  Line 388 
388          return(object)          return(object)
389      }      }
390    
391      return(list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping))      list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)
392  }  }
393    
394  setMethod("c",  setMethod("c",
395            signature(x = "Corpus"),            signature(x = "Corpus"),
396            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = FALSE) {
397                args <- list(...)                args <- list(...)
398                if (length(args) == 0)                if (identical(length(args), 0)) return(x)
399                    return(x)  
400                  if (!all(sapply(args, inherits, class(x))))
401                      stop("not all arguments are of the same corpus type")
402    
403                if (!all(sapply(args, inherits, "Corpus")))                if (inherits(x, "PCorpus"))
404                    stop("not all arguments are corpora")                    stop("concatenation of corpora with underlying databases is not supported")
               if (DBControl(x)[["useDb"]] || any(unlist(sapply(args, DBControl)["useDb", ])))  
                   stop("concatenating corpora with activated database is not supported")  
405    
406                Reduce(c2, base::c(list(x), args))                Reduce(c2, base::c(list(x), args))
407            })            })
408    
409  setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  setGeneric("c2", function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) standardGeneric("c2"))
410  setMethod("c2",  #setMethod("c2", signature(x = "FCorpus", y = "FCorpus"),
411            signature(x = "Corpus", y = "Corpus"),  #          function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
412            function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {  #              new("FCorpus", .Data = c(as(x, "list"), as(y, "list")))
413    #          })
414    setMethod("c2", signature(x = "SCorpus", y = "SCorpus"),
415              function(x, y, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME"))) {
416                object <- x                object <- x
417                # Concatenate data slots                # Concatenate data slots
418                object@.Data <- c(as(x, "list"), as(y, "list"))                object@.Data <- c(as(x, "list"), as(y, "list"))
419    
               # Set the DBControl slot  
               object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")  
   
420                # Update the CMetaData tree                # Update the CMetaData tree
421                cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))                cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
422                update.struct <- update_id(cmeta)                update.struct <- update_id(cmeta)
# Line 559  Line 459 
459                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)                y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
460                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)                object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
461    
462                return(object)                object
463            })            })
464    
465  setMethod("c",  setMethod("c",
466            signature(x = "TextDocument"),            signature(x = "TextDocument"),
467            function(x, ..., recursive = TRUE){            function(x, ..., recursive = FALSE){
468                args <- list(...)                args <- list(...)
469                if(length(args) == 0)                if (identical(length(args), 0)) return(x)
                   return(x)  
470    
471                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
472                cmeta.node <- new("MetaDataNode",                cmeta.node <- new("MetaDataNode",
# Line 575  Line 474 
474                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
475                              children = list())                              children = list())
476    
477                return(new("Corpus",                new("SCorpus", .Data = list(x, ...), DMetaData = dmeta.df, CMetaData = cmeta.node)
                          .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")))  
478      })      })
479    
480  setMethod("show",  setMethod("show",
# Line 613  Line 502 
502                }                }
503      })      })
504    
505  setGeneric("inspect", function(object) standardGeneric("inspect"))  inspect <- function(x) UseMethod("inspect", x)
506  setMethod("inspect",  inspect.PCorpus <- function(x) {
507            signature("Corpus"),      summary(x)
           function(object) {  
               summary(object)  
508                cat("\n")                cat("\n")
509                if (DBControl(object)[["useDb"]] && require("filehash")) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
510                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])      show(filehash::dbMultiFetch(db, unlist(x)))
511                    show(dbMultiFetch(db, unlist(object)))  }
512    #inspect.FCorpus <-
513    inspect.SCorpus <- function(x) {
514        summary(x)
515        cat("\n")
516        print(noquote(lapply(x, identity)))
517                }                }
               else  
                   print(noquote(lapply(object, identity)))  
           })  
518    
519  # No metadata is checked  # No metadata is checked
520  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
521  setMethod("%IN%",  setMethod("%IN%", signature(x = "TextDocument", y = "PCorpus"),
           signature(x = "TextDocument", y = "Corpus"),  
522            function(x, y) {            function(x, y) {
523                if (DBControl(y)[["useDb"]] && require("filehash")) {                db <- filehash::dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
524                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                any(sapply(y, function(x, z) {x %in% Content(z)}, x))
                   result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))  
               }  
               else  
                   result <- x %in% y  
               return(result)  
525            })            })
526    setMethod("%IN%", signature(x = "TextDocument", y = "SCorpus"),
527              function(x, y) x %in% y)
528    
529  setMethod("lapply",  setMethod("lapply",
530            signature(X = "Corpus"),            signature(X = "SCorpus"),
531            function(X, FUN, ...) {            function(X, FUN, ...) {
               if (DBControl(X)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
               }  
               else {  
532                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
533                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
534                        .Call("copyCorpus", X, materialize(X))                        .Call("copyCorpus", X, materialize(X))
535                    result <- base::lapply(X, FUN, ...)                base::lapply(X, FUN, ...)
536                }            })
537                return(result)  setMethod("lapply",
538              signature(X = "PCorpus"),
539              function(X, FUN, ...) {
540                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
541                  lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
542            })            })
543    
544  setMethod("sapply",  setMethod("sapply",
545            signature(X = "Corpus"),            signature(X = "SCorpus"),
546            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
               if (DBControl(X)[["useDb"]] && require("filehash")) {  
                   db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
                   result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)  
               }  
               else {  
547                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")                    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
548                    if (!is.null(lazyTmMap))                    if (!is.null(lazyTmMap))
549                        .Call("copyCorpus", X, materialize(X))                        .Call("copyCorpus", X, materialize(X))
550                    result <- base::sapply(X, FUN, ...)                base::sapply(X, FUN, ...)
551                }            })
552                return(result)  setMethod("sapply",
553              signature(X = "PCorpus"),
554              function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
555                  db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
556                  sapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
557            })            })
558    
559  setAs("list", "Corpus", function(from) {  setAs("list", "SCorpus", function(from) {
560      cmeta.node <- new("MetaDataNode",      cmeta.node <- new("MetaDataNode",
561                        NodeID = 0,                        NodeID = 0,
562                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
563                        children = list())                        children = list())
564      data <- list()      data <- vector("list", length(from))
565      counter <- 1      counter <- 1
566      for (f in from) {      for (f in from) {
567          doc <- new("PlainTextDocument",          data[[counter]] <- new("PlainTextDocument",
568                     .Data = f, URI = NULL, Cached = TRUE,                                 .Data = f,
569                     Author = "", DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),                                 DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
570                     Description = "", ID = as.character(counter),                                 ID = as.character(counter),
571                     Origin = "", Heading = "", Language = "en_US")                                 Language = "eng")
         data <- c(data, list(doc))  
572          counter <- counter + 1          counter <- counter + 1
573      }      }
574      return(new("Corpus", .Data = data,      new("SCorpus", .Data = data,
575                 DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),                 DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
576                 CMetaData = cmeta.node,          CMetaData = cmeta.node)
                DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))  
577  })  })
578    
579  setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))  setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))

Legend:
Removed from v.905  
changed lines
  Added in v.962

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