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 757, Thu Jun 7 17:41:56 2007 UTC revision 837, Wed Apr 23 09:16:25 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 52  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 63  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 79  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 98  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                      # 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 159  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 171  Line 234 
234            signature(object = "Reuters21578Document"),            signature(object = "Reuters21578Document"),
235            function(object, FUN, ...) {            function(object, FUN, ...) {
236                FUN <- convertReut21578XMLPlain                FUN <- convertReut21578XMLPlain
237                corpus <- Corpus(object)                corpus <- Content(object)
238    
239                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
240                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 183  Line 246 
246            signature(object = "RCV1Document"),            signature(object = "RCV1Document"),
247            function(object, FUN, ...) {            function(object, FUN, ...) {
248                FUN <- convertRCV1Plain                FUN <- convertRCV1Plain
249                corpus <- Corpus(object)                corpus <- Content(object)
250    
251                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
252                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 194  Line 257 
257  setMethod("asPlain",  setMethod("asPlain",
258            signature(object = "NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
259            function(object, FUN, ...) {            function(object, FUN, ...) {
260                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
261                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
262                    Origin = Origin(object), Heading = Heading(object), Language = Language(object))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
263            })                    LocalMetaData = LocalMetaData(object))
   
 setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))  
 setMethod("tmTolower",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
   
 setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))  
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
           })  
   
 setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))  
 setMethod("stemDoc",  
           signature(object = "PlainTextDocument"),  
           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)  
           })  
   
 setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))  
 setMethod("removePunctuation",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
           })  
   
 setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))  
 setMethod("removeWords",  
           signature(object = "PlainTextDocument", stopwords = "character"),  
           function(object, stopwords, ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  
               return(object)  
264            })            })
265    setMethod("asPlain",
266  setGeneric("replaceWords", function(object, words, by, ...) standardGeneric("replaceWords"))            signature(object = "StructuredTextDocument"),
267  setMethod("replaceWords",            function(object, FUN, ...) {
268            signature(object = "PlainTextDocument", words = "character", by = "character"),                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
269            function(object, words, by, ...) {                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
270                pattern <- paste(words, collapse = "|")                    Description = Description(object), ID = ID(object), Origin = Origin(object),
271                Corpus(object) <- gsub(pattern, by, Corpus(object))                    Heading = Heading(object), Language = Language(object),
272                return(object)                    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 267  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 277  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 300  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"]])
# Line 326  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 337  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 348  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")) {
# Line 374  Line 384 
384            })            })
385    
386  setMethod("[",  setMethod("[",
387            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
388            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
389                if(missing(i))                if(missing(i))
390                    return(x)                    return(x)
# Line 394  Line 404 
404            })            })
405    
406  setMethod("[<-",  setMethod("[<-",
407            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
408            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
409                object <- x                object <- x
410                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 415  Line 425 
425            })            })
426    
427  setMethod("[[",  setMethod("[[",
428            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
429            function(x, i, j, ...) {            function(x, i, j, ...) {
430                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
431                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
432                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
433                    return(loadDoc(result))                    return(loadDoc(result))
434                }                }
435                else                else {
436                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
437                      if (!is.null(lazyTmMap))
438                          .Call("copyCorpus", x, materialize(x, i))
439                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
440                  }
441            })            })
442    
443  setMethod("[[<-",  setMethod("[[<-",
444            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
445            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
446                object <- x                object <- x
447                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 435  Line 449 
449                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
450                    db[[index]] <- value                    db[[index]] <- value
451                }                }
452                else                else {
453                      # Mark new objects as not active for lazy mapping
454                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
455                      if (!is.null(lazyTmMap)) {
456                          lazyTmMap$index[i] <- FALSE
457                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
458                      }
459                      # Set the value
460                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
461                  }
462                return(object)                return(object)
463            })            })
464    
# Line 469  Line 491 
491  }  }
492    
493  setMethod("c",  setMethod("c",
494            signature(x = "TextDocCol"),            signature(x = "Corpus"),
495            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) {
496                args <- list(...)                args <- list(...)
497                if (length(args) == 0)                if (length(args) == 0)
498                    return(x)                    return(x)
499    
500                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
501                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
502                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
503                    stop("concatenating text document collections with activated database is not supported")                    stop("concatenating text document collections with activated database is not supported")
# Line 489  Line 511 
511    
512  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"))
513  setMethod("c2",  setMethod("c2",
514            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
515            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) {
516                object <- x                object <- x
517                # Concatenate data slots                # Concatenate data slots
# Line 556  Line 578 
578                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
579                              children = list())                              children = list())
580    
581                return(new("TextDocCol",                return(new("Corpus",
582                           .Data = list(x, ...),                           .Data = list(x, ...),
583                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
584                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 564  Line 586 
586            })            })
587    
588  setMethod("length",  setMethod("length",
589            signature(x = "TextDocCol"),            signature(x = "Corpus"),
590            function(x){            function(x){
591                return(length(as(x, "list")))                return(length(as(x, "list")))
592      })      })
593    
594  setMethod("show",  setMethod("show",
595            signature(object = "TextDocCol"),            signature(object = "Corpus"),
596            function(object){            function(object){
597                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
598                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 579  Line 601 
601      })      })
602    
603  setMethod("summary",  setMethod("summary",
604            signature(object = "TextDocCol"),            signature(object = "Corpus"),
605            function(object){            function(object){
606                show(object)                show(object)
607                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 596  Line 618 
618    
619  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
620  setMethod("inspect",  setMethod("inspect",
621            signature("TextDocCol"),            signature("Corpus"),
622            function(object) {            function(object) {
623                summary(object)                summary(object)
624                cat("\n")                cat("\n")
# Line 605  Line 627 
627                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
628                }                }
629                else                else
630                    show(object@.Data)                    print(noquote(lapply(object, identity)))
631            })            })
632    
633  # No metadata is checked  # No metadata is checked
634  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
635  setMethod("%IN%",  setMethod("%IN%",
636            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
637            function(x, y) {            function(x, y) {
638                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
639                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
640                    result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
641                }                }
642                else                else
643                    result <- x %in% y                    result <- x %in% y
# Line 623  Line 645 
645            })            })
646    
647  setMethod("lapply",  setMethod("lapply",
648            signature(X = "TextDocCol"),            signature(X = "Corpus"),
649            function(X, FUN, ...) {            function(X, FUN, ...) {
650                  print("lapply")
651                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
652                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
653                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
654                }                }
655                else                else {
656                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
657                      if (!is.null(lazyTmMap))
658                          .Call("copyCorpus", X, materialize(X))
659                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
660                  }
661                return(result)                return(result)
662            })            })
663    
664  setMethod("sapply",  setMethod("sapply",
665            signature(X = "TextDocCol"),            signature(X = "Corpus"),
666            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
667                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
668                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
669                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
670                }                }
671                else                else {
672                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
673                      if (!is.null(lazyTmMap))
674                          .Call("copyCorpus", X, materialize(X))
675                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
676                  }
677                return(result)                return(result)
678            })            })
679    
680    setAs("list", "Corpus", function(from) {
681        cmeta.node <- new("MetaDataNode",
682                          NodeID = 0,
683                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
684                          children = list())
685        data <- list()
686        counter <- 1
687        for (f in from) {
688            doc <- new("PlainTextDocument",
689                       .Data = f, URI = NULL, Cached = TRUE,
690                       Author = "", DateTimeStamp = Sys.time(),
691                       Description = "", ID = as.character(counter),
692                       Origin = "", Heading = "", Language = "en_US")
693            data <- c(data, list(doc))
694            counter <- counter + 1
695        }
696        return(new("Corpus", .Data = data,
697                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
698                   CMetaData = cmeta.node,
699                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
700    })
701    
702    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
703    setMethod("writeCorpus",
704              signature(object = "Corpus"),
705              function(object, path = ".", filenames = NULL) {
706                  filenames <- file.path(path,
707                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
708                                         else filenames)
709                  i <- 1
710                  for (o in object) {
711                      writeLines(o, filenames[i])
712                      i <- i + 1
713                  }
714              })

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

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