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

revision 744, Mon Apr 23 00:35:10 2007 UTC revision 853, Sun May 18 13:09:35 2008 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  # The "..." are additional arguments for the FunctionGenerator reader
4  setGeneric("TextDocCol", function(object,  setGeneric("Corpus", function(object,
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
7                                    ...) standardGeneric("TextDocCol"))                                    ...) standardGeneric("Corpus"))
8  setMethod("TextDocCol",  setMethod("Corpus",
9            signature(object = "Source"),            signature(object = "Source"),
10            function(object,            function(object,
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
13                     ...) {                     ...) {
14                if (attr(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
15                      readerControl$reader <- object@DefaultReader
16                  if (is(readerControl$reader, "FunctionGenerator"))
17                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
18                  if (is.null(readerControl$language))
19                      readerControl$language = "en_US"
20                  if (is.null(readerControl$load))
21                      readerControl$load = TRUE
22    
23                if (dbControl$useDb) {                if (dbControl$useDb) {
24                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
# Line 43  Line 49 
49                if (dbControl$useDb) {                if (dbControl$useDb) {
50                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
51                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
52                }                }
53                else                else
54                    dmeta.df <- df                    dmeta.df <- df
# Line 53  Line 58 
58                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
59                              children = list())                              children = list())
60    
61                return(new("TextDocCol", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))
62            })            })
63    
64  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))
# Line 64  Line 69 
69                    con <- eval(URI(object))                    con <- eval(URI(object))
70                    corpus <- readLines(con)                    corpus <- readLines(con)
71                    close(con)                    close(con)
72                    Corpus(object) <- corpus                    Content(object) <- corpus
73                    Cached(object) <- TRUE                    Cached(object) <- TRUE
74                    return(object)                    return(object)
75                } else {                } else {
# Line 80  Line 85 
85                    close(con)                    close(con)
86                    doc <- xmlTreeParse(corpus, asText = TRUE)                    doc <- xmlTreeParse(corpus, asText = TRUE)
87                    class(doc) <- "list"                    class(doc) <- "list"
88                    Corpus(object) <- doc                    Content(object) <- doc
89                    Cached(object) <- TRUE                    Cached(object) <- TRUE
90                    return(object)                    return(object)
91                } else {                } else {
# Line 99  Line 104 
104                        if (mail[index] == "")                        if (mail[index] == "")
105                            break                            break
106                    }                    }
107                    Corpus(object) <- mail[(index + 1):length(mail)]                    Content(object) <- mail[(index + 1):length(mail)]
108                    return(object)                    return(object)
109                } else {                } else {
110                    return(object)                    return(object)
111                }                }
112            })            })
113    setMethod("loadDoc",
114              signature(object = "StructuredTextDocument"),
115              function(object, ...) {
116                  if (!Cached(object)) {
117                      warning("load on demand not (yet) supported for StructuredTextDocuments")
118                      return(object)
119                  } else
120                      return(object)
121              })
122    
123  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
124                                  origin,                                  origin,
125                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
126                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
127  # Update is only supported for directories  # Update is only supported for directories
128  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
129  setMethod("tmUpdate",  setMethod("tmUpdate",
130            signature(object = "TextDocCol", origin = "DirSource"),            signature(object = "Corpus", origin = "DirSource"),
131            function(object, origin,            function(object, origin,
132                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
133                     ...) {                     ...) {
134                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
135                      readerControl$reader <- origin@DefaultReader
136                  if (is(readerControl$reader, "FunctionGenerator"))
137                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
138                  if (is.null(readerControl$language))
139                      readerControl$language = "en_US"
140                  if (is.null(readerControl$load))
141                      readerControl$load = TRUE
142    
143                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))
144                new.files <- setdiff(origin@FileList, object.filelist)                new.files <- setdiff(origin@FileList, object.filelist)
145    
146                for (filename in new.files) {                for (filename in new.files) {
147                    elem <- list(content = readLines(filename),                    encoding <- origin@Encoding
148                                 uri = substitute(file(filename)))                    elem <- list(content = readLines(filename, encoding = encoding),
149                                   uri = substitute(file(filename, encoding = encoding)))
150                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))
151                }                }
152    
153                return(object)                return(object)
154            })            })
155    
156  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
157  setMethod("tmMap",  setMethod("tmMap",
158            signature(object = "TextDocCol", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
159            function(object, FUN, ...) {            function(object, FUN, ..., lazy = FALSE) {
160                result <- object                result <- object
161                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
162                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
163                      if (lazy)
164                          warning("lazy mapping is deactived when using database backend")
165                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
166                    i <- 1                    i <- 1
167                    for (id in unlist(object)) {                    for (id in unlist(object)) {
168                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
169                        i <- i + 1                        i <- i + 1
170                    }                    }
171                    dbDisconnect(db)                    # Suggested by Christian Buchta
172                      dbReorganize(db)
173                  }
174                  else {
175                      # Lazy mapping
176                      if (lazy) {
177                          lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
178                          if (is.null(lazyTmMap)) {
179                              meta(result, tag = "lazyTmMap", type = "corpus") <-
180                                  list(index = rep(TRUE, length(result)),
181                                       maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
182                          }
183                          else {
184                              lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
185                              meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
186                          }
187                }                }
188                else                else
189                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
190                  }
191                return(result)                return(result)
192            })            })
193    
194    # Materialize lazy mappings
195    # Improvements by Christian Buchta
196    materialize <- function(corpus, range = seq_along(corpus)) {
197        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
198        if (!is.null(lazyTmMap)) {
199           # Make valid and lazy index
200           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
201           if (any(idx)) {
202               res <- lapply(corpus@.Data[idx], loadDoc)
203               for (m in lazyTmMap$maps)
204                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
205               corpus@.Data[idx] <- res
206               lazyTmMap$index[idx] <- FALSE
207           }
208        }
209        # Clean up if everything is materialized
210        if (!any(lazyTmMap$index))
211            lazyTmMap <- NULL
212        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
213        return(corpus)
214    }
215    
216  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
217  setMethod("asPlain",  setMethod("asPlain",
218            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 161  Line 222 
222  setMethod("asPlain",  setMethod("asPlain",
223            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "XMLTextDocument", FUN = "function"),
224            function(object, FUN, ...) {            function(object, FUN, ...) {
225                corpus <- Corpus(object)                corpus <- Content(object)
226    
227                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
228                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 231 
231                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
232            })            })
233  setMethod("asPlain",  setMethod("asPlain",
234            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
235            function(object, FUN, ...) {            function(object, FUN, ...) {
236                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
237                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Content(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
238    
239  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
240  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
241            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
242    
243  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
244            })            })
245    setMethod("asPlain",
246              signature(object = "RCV1Document"),
247              function(object, FUN, ...) {
248                  FUN <- convertRCV1Plain
249                  corpus <- Content(object)
250    
251  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))                # As XMLDocument is no native S4 class, restore valid information
252  setMethod("stemDoc",                class(corpus) <- "XMLDocument"
253            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, language = "english", ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- if (require("Rstem"))  
                   Rstem::wordStem(splittedCorpus, language)  
               else  
                   SnowballStemmer(splittedCorpus, Weka_control(S = language))  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
           })  
254    
255  setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("removePunctuation",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
256            })            })
257    setMethod("asPlain",
258  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "NewsgroupDocument"),
259  setMethod("removeWords",            function(object, FUN, ...) {
260            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
261            function(object, stopwords, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
262                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
263                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    LocalMetaData = LocalMetaData(object))
264                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")            })
265                return(object)  setMethod("asPlain",
266              signature(object = "StructuredTextDocument"),
267              function(object, FUN, ...) {
268                  new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
269                      URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
270                      Description = Description(object), ID = ID(object), Origin = Origin(object),
271                      Heading = Heading(object), Language = Language(object),
272                      LocalMetaData = LocalMetaData(object))
273            })            })
274    
275  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
276  setMethod("tmFilter",  setMethod("tmFilter",
277            signature(object = "TextDocCol"),            signature(object = "Corpus"),
278            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
279                if (doclevel)                if (doclevel)
280                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
# Line 236  Line 284 
284    
285  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))
286  setMethod("tmIndex",  setMethod("tmIndex",
287            signature(object = "TextDocCol"),            signature(object = "Corpus"),
288            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
289                if (doclevel)                if (doclevel)
290                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
# Line 246  Line 294 
294    
295  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
296      con <- textConnection(s)      con <- textConnection(s)
297      tokens <- scan(con, "character")      tokens <- scan(con, "character", quiet = TRUE)
298      close(con)      close(con)
299      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
300      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
# Line 269  Line 317 
317      return(result)      return(result)
318  }  }
319    
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
320  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
321  setMethod("appendElem",  setMethod("appendElem",
322            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
323            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
324                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
325                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
326                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
327                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
328                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
329                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
330                }                }
331                else                else
# Line 296  Line 336 
336    
337  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
338  setMethod("appendMeta",  setMethod("appendMeta",
339            signature(object = "TextDocCol"),            signature(object = "Corpus"),
340            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
341                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
342                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 347 
347    
348  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
349  setMethod("removeMeta",  setMethod("removeMeta",
350            signature(object = "TextDocCol"),            signature(object = "Corpus"),
351            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
352                if (!is.null(cname))                if (!is.null(cname))
353                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]
# Line 318  Line 358 
358    
359  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
360  setMethod("prescindMeta",  setMethod("prescindMeta",
361            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
362            function(object, meta) {            function(object, meta) {
363                for (m in meta) {                for (m in meta) {
364                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
365                        local.m <- lapply(object, m)                        local.m <- lapply(object, m)
366                          local.m <- sapply(local.m, paste, collapse = " ")
367                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))
368                        local.m <- unlist(local.m)                        local.m <- unlist(local.m)
369                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))
# Line 344  Line 385 
385            })            })
386    
387  setMethod("[",  setMethod("[",
388            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
389            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
390                if(missing(i))                if(missing(i))
391                    return(x)                    return(x)
# Line 364  Line 405 
405            })            })
406    
407  setMethod("[<-",  setMethod("[<-",
408            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
409            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
410                object <- x                object <- x
411                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 378  Line 419 
419                        }                        }
420                        counter <- counter + 1                        counter <- counter + 1
421                    }                    }
                   dbDisconnect(db)  
422                }                }
423                else                else
424                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 386  Line 426 
426            })            })
427    
428  setMethod("[[",  setMethod("[[",
429            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
430            function(x, i, j, ...) {            function(x, i, j, ...) {
431                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
432                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
433                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
434                    return(loadDoc(result))                    return(loadDoc(result))
435                }                }
436                else                else {
437                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
438                      if (!is.null(lazyTmMap))
439                          .Call("copyCorpus", x, materialize(x, i))
440                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
441                  }
442            })            })
443    
444  setMethod("[[<-",  setMethod("[[<-",
445            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
446            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
447                object <- x                object <- x
448                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
449                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
450                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
451                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
452                }                }
453                else                else {
454                      # Mark new objects as not active for lazy mapping
455                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
456                      if (!is.null(lazyTmMap)) {
457                          lazyTmMap$index[i] <- FALSE
458                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
459                      }
460                      # Set the value
461                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
462                  }
463                return(object)                return(object)
464            })            })
465    
# Line 442  Line 492 
492  }  }
493    
494  setMethod("c",  setMethod("c",
495            signature(x = "TextDocCol"),            signature(x = "Corpus"),
496            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
497                args <- list(...)                args <- list(...)
498                if (length(args) == 0)                if (length(args) == 0)
499                    return(x)                    return(x)
500    
501                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
502                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
503                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
504                    stop("concatenating text document collections with activated database is not supported")                    stop("concatenating text document collections with activated database is not supported")
# Line 462  Line 512 
512    
513  setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))
514  setMethod("c2",  setMethod("c2",
515            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
516            function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
517                object <- x                object <- x
518                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 579 
579                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
580                              children = list())                              children = list())
581    
582                return(new("TextDocCol",                return(new("Corpus",
583                           .Data = list(x, ...),                           .Data = list(x, ...),
584                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
585                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 587 
587            })            })
588    
589  setMethod("length",  setMethod("length",
590            signature(x = "TextDocCol"),            signature(x = "Corpus"),
591            function(x){            function(x){
592                return(length(as(x, "list")))                return(length(as(x, "list")))
593      })      })
594    
595  setMethod("show",  setMethod("show",
596            signature(object = "TextDocCol"),            signature(object = "Corpus"),
597            function(object){            function(object){
598                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
599                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 602 
602      })      })
603    
604  setMethod("summary",  setMethod("summary",
605            signature(object = "TextDocCol"),            signature(object = "Corpus"),
606            function(object){            function(object){
607                show(object)                show(object)
608                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 619 
619    
620  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
621  setMethod("inspect",  setMethod("inspect",
622            signature("TextDocCol"),            signature("Corpus"),
623            function(object) {            function(object) {
624                summary(object)                summary(object)
625                cat("\n")                cat("\n")
626                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
627                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
628                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
629                }                }
630                else                else
631                    show(object@.Data)                    print(noquote(lapply(object, identity)))
632            })            })
633    
634  # No metadata is checked  # No metadata is checked
635  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
636  setMethod("%IN%",  setMethod("%IN%",
637            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
638            function(x, y) {            function(x, y) {
639                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
640                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
641                    result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
                   dbDisconnect(db)  
642                }                }
643                else                else
644                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 646 
646            })            })
647    
648  setMethod("lapply",  setMethod("lapply",
649            signature(X = "TextDocCol"),            signature(X = "Corpus"),
650            function(X, FUN, ...) {            function(X, FUN, ...) {
651                  print("lapply")
652                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
653                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
654                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
655                }                }
656                else                else {
657                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
658                      if (!is.null(lazyTmMap))
659                          .Call("copyCorpus", X, materialize(X))
660                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
661                  }
662                return(result)                return(result)
663            })            })
664    
665  setMethod("sapply",  setMethod("sapply",
666            signature(X = "TextDocCol"),            signature(X = "Corpus"),
667            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
668                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
669                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
670                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
671                }                }
672                else                else {
673                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
674                      if (!is.null(lazyTmMap))
675                          .Call("copyCorpus", X, materialize(X))
676                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
677                  }
678                return(result)                return(result)
679            })            })
680    
681    setAs("list", "Corpus", function(from) {
682        cmeta.node <- new("MetaDataNode",
683                          NodeID = 0,
684                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
685                          children = list())
686        data <- list()
687        counter <- 1
688        for (f in from) {
689            doc <- new("PlainTextDocument",
690                       .Data = f, URI = NULL, Cached = TRUE,
691                       Author = "", DateTimeStamp = Sys.time(),
692                       Description = "", ID = as.character(counter),
693                       Origin = "", Heading = "", Language = "en_US")
694            data <- c(data, list(doc))
695            counter <- counter + 1
696        }
697        return(new("Corpus", .Data = data,
698                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
699                   CMetaData = cmeta.node,
700                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
701    })
702    
703    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
704    setMethod("writeCorpus",
705              signature(object = "Corpus"),
706              function(object, path = ".", filenames = NULL) {
707                  filenames <- file.path(path,
708                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
709                                         else filenames)
710                  i <- 1
711                  for (o in object) {
712                      writeLines(o, filenames[i])
713                      i <- i + 1
714                  }
715              })

Legend:
Removed from v.744  
changed lines
  Added in v.853

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