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 829, Mon Mar 10 22:55:39 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    ############################################
158    # Lazy mapping restrictions (at the moment):
159    #   *) No database backend support
160    #   *) No function composition
161    ############################################
162  setMethod("tmMap",  setMethod("tmMap",
163            signature(object = "TextDocCol", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
164            function(object, FUN, ...) {            function(object, FUN, lazy = FALSE, ...) {
165                result <- object                result <- object
166                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
167                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 145  Line 171 
171                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
172                        i <- i + 1                        i <- i + 1
173                    }                    }
                   dbDisconnect(db)  
174                }                }
175                  else {
176                      if (lazy)
177                          meta(result, tag = "lazyTmMap", type = "corpus") <-
178                              list(index = rep(TRUE, length(result)),
179                                   fun = FUN,
180                                   args = ...)
181                else                else
182                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
183                  }
184                return(result)                return(result)
185            })            })
186    
187    # Materialize lazy mappings
188    # ToDo: Clean up lazyTmMap markers (for the case that everything is materialized)
189    materialize <- function(corpus, range = seq_along(corpus)) {
190        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
191        if (!is.null(lazyTmMap)) {
192            for (i in range)
193                if (lazyTmMap$index[i]) {
194                    corpus@.Data[[i]] <- lazyTmMap$fun(corpus@.Data[[i]], lazyTmMap$args, DMetaData = DMetaData(corpus))
195                    lazyTmMap$index[i] <- FALSE
196                }
197        }
198        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
199        return(corpus)
200    }
201    
202  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
203  setMethod("asPlain",  setMethod("asPlain",
204            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 161  Line 208 
208  setMethod("asPlain",  setMethod("asPlain",
209            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "XMLTextDocument", FUN = "function"),
210            function(object, FUN, ...) {            function(object, FUN, ...) {
211                corpus <- Corpus(object)                corpus <- Content(object)
212    
213                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
214                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 217 
217                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
218            })            })
219  setMethod("asPlain",  setMethod("asPlain",
220            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
221            function(object, FUN, ...) {            function(object, FUN, ...) {
222                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
223                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Content(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
224    
225  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
226  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
227            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
228    
229  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
230            })            })
231    setMethod("asPlain",
232              signature(object = "RCV1Document"),
233              function(object, FUN, ...) {
234                  FUN <- convertRCV1Plain
235                  corpus <- Content(object)
236    
237  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))                # As XMLDocument is no native S4 class, restore valid information
238  setMethod("stemDoc",                class(corpus) <- "XMLDocument"
239            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)  
           })  
240    
241  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)  
242            })            })
243    setMethod("asPlain",
244  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "NewsgroupDocument"),
245  setMethod("removeWords",            function(object, FUN, ...) {
246            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
247            function(object, stopwords, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
248                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
249                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    LocalMetaData = LocalMetaData(object))
250                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")            })
251                return(object)  setMethod("asPlain",
252              signature(object = "StructuredTextDocument"),
253              function(object, FUN, ...) {
254                  new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
255                      URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
256                      Description = Description(object), ID = ID(object), Origin = Origin(object),
257                      Heading = Heading(object), Language = Language(object),
258                      LocalMetaData = LocalMetaData(object))
259            })            })
260    
261  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
262  setMethod("tmFilter",  setMethod("tmFilter",
263            signature(object = "TextDocCol"),            signature(object = "Corpus"),
264            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
265                if (doclevel)                if (doclevel)
266                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
# Line 236  Line 270 
270    
271  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))
272  setMethod("tmIndex",  setMethod("tmIndex",
273            signature(object = "TextDocCol"),            signature(object = "Corpus"),
274            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
275                if (doclevel)                if (doclevel)
276                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
# Line 246  Line 280 
280    
281  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
282      con <- textConnection(s)      con <- textConnection(s)
283      tokens <- scan(con, "character")      tokens <- scan(con, "character", quiet = TRUE)
284      close(con)      close(con)
285      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
286      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
# Line 269  Line 303 
303      return(result)      return(result)
304  }  }
305    
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
306  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
307  setMethod("appendElem",  setMethod("appendElem",
308            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
309            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
310                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
311                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
312                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
313                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
314                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
315                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
316                }                }
317                else                else
# Line 296  Line 322 
322    
323  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
324  setMethod("appendMeta",  setMethod("appendMeta",
325            signature(object = "TextDocCol"),            signature(object = "Corpus"),
326            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
327                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
328                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 333 
333    
334  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
335  setMethod("removeMeta",  setMethod("removeMeta",
336            signature(object = "TextDocCol"),            signature(object = "Corpus"),
337            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
338                if (!is.null(cname))                if (!is.null(cname))
339                    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 344 
344    
345  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
346  setMethod("prescindMeta",  setMethod("prescindMeta",
347            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
348            function(object, meta) {            function(object, meta) {
349                for (m in meta) {                for (m in meta) {
350                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
# Line 344  Line 370 
370            })            })
371    
372  setMethod("[",  setMethod("[",
373            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
374            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
375                if(missing(i))                if(missing(i))
376                    return(x)                    return(x)
# Line 364  Line 390 
390            })            })
391    
392  setMethod("[<-",  setMethod("[<-",
393            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
394            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
395                object <- x                object <- x
396                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 378  Line 404 
404                        }                        }
405                        counter <- counter + 1                        counter <- counter + 1
406                    }                    }
                   dbDisconnect(db)  
407                }                }
408                else                else
409                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
410                return(object)                return(object)
411            })            })
412    
413    # ToDo: Implement on-demand materialization of lazy mappings
414    ############################################
415    # Lazy mapping restrictions (at the moment):
416    #   *) No database backend support
417    ############################################
418  setMethod("[[",  setMethod("[[",
419            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
420            function(x, i, j, ...) {            function(x, i, j, ...) {
421                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
422                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
423                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
424                    return(loadDoc(result))                    return(loadDoc(result))
425                }                }
426                else                else {
427                      # ToDo: Ensure that loadDoc is called and cached
428                      .Call("copyCorpus", x, materialize(x, i))
429                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
430                  }
431            })            })
432    
433    # ToDo: Mark set objects as not active for lazy mapping
434  setMethod("[[<-",  setMethod("[[<-",
435            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
436            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
437                object <- x                object <- x
438                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
439                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
440                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
441                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
442                }                }
443                else                else
444                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
# Line 442  Line 474 
474  }  }
475    
476  setMethod("c",  setMethod("c",
477            signature(x = "TextDocCol"),            signature(x = "Corpus"),
478            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) {
479                args <- list(...)                args <- list(...)
480                if (length(args) == 0)                if (length(args) == 0)
481                    return(x)                    return(x)
482    
483                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
484                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
485                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
486                    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 494 
494    
495  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"))
496  setMethod("c2",  setMethod("c2",
497            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
498            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) {
499                object <- x                object <- x
500                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 561 
561                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
562                              children = list())                              children = list())
563    
564                return(new("TextDocCol",                return(new("Corpus",
565                           .Data = list(x, ...),                           .Data = list(x, ...),
566                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
567                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 569 
569            })            })
570    
571  setMethod("length",  setMethod("length",
572            signature(x = "TextDocCol"),            signature(x = "Corpus"),
573            function(x){            function(x){
574                return(length(as(x, "list")))                return(length(as(x, "list")))
575      })      })
576    
577  setMethod("show",  setMethod("show",
578            signature(object = "TextDocCol"),            signature(object = "Corpus"),
579            function(object){            function(object){
580                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
581                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 584 
584      })      })
585    
586  setMethod("summary",  setMethod("summary",
587            signature(object = "TextDocCol"),            signature(object = "Corpus"),
588            function(object){            function(object){
589                show(object)                show(object)
590                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 601 
601    
602  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
603  setMethod("inspect",  setMethod("inspect",
604            signature("TextDocCol"),            signature("Corpus"),
605            function(object) {            function(object) {
606                summary(object)                summary(object)
607                cat("\n")                cat("\n")
608                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
609                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
610                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
611                }                }
612                else                else
613                    show(object@.Data)                    show(object@.Data)
# Line 585  Line 616 
616  # No metadata is checked  # No metadata is checked
617  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
618  setMethod("%IN%",  setMethod("%IN%",
619            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
620            function(x, y) {            function(x, y) {
621                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
622                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
623                    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)  
624                }                }
625                else                else
626                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 628 
628            })            })
629    
630  setMethod("lapply",  setMethod("lapply",
631            signature(X = "TextDocCol"),            signature(X = "Corpus"),
632            function(X, FUN, ...) {            function(X, FUN, ...) {
633                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
634                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
635                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
636                }                }
637                else                else
638                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
# Line 611  Line 640 
640            })            })
641    
642  setMethod("sapply",  setMethod("sapply",
643            signature(X = "TextDocCol"),            signature(X = "Corpus"),
644            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
645                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
646                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
647                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
648                }                }
649                else                else
650                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
651                return(result)                return(result)
652            })            })
653    
654    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
655    setMethod("writeCorpus",
656              signature(object = "Corpus"),
657              function(object, path = ".", filenames = NULL) {
658                  filenames <- file.path(path,
659                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
660                                         else filenames)
661                  i <- 1
662                  for (o in object) {
663                      writeLines(o, filenames[i])
664                      i <- i + 1
665                  }
666              })

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

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