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 826, Sat Feb 23 14:38:15 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    
# Line 134  Line 155 
155    
156  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ...) 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, ...) {
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{[[}
# Line 145  Line 166 
166                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
167                        i <- i + 1                        i <- i + 1
168                    }                    }
                   dbDisconnect(db)  
169                }                }
170                else                else
171                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
# Line 161  Line 181 
181  setMethod("asPlain",  setMethod("asPlain",
182            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "XMLTextDocument", FUN = "function"),
183            function(object, FUN, ...) {            function(object, FUN, ...) {
184                corpus <- Corpus(object)                corpus <- Content(object)
185    
186                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
187                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 190 
190                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
191            })            })
192  setMethod("asPlain",  setMethod("asPlain",
193            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
194            function(object, FUN, ...) {            function(object, FUN, ...) {
195                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
196                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Content(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
197    
198  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
199  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
200            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
201    
202  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
203            })            })
204    setMethod("asPlain",
205              signature(object = "RCV1Document"),
206              function(object, FUN, ...) {
207                  FUN <- convertRCV1Plain
208                  corpus <- Content(object)
209    
210  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))                # As XMLDocument is no native S4 class, restore valid information
211  setMethod("stemDoc",                class(corpus) <- "XMLDocument"
212            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)  
           })  
213    
214  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)  
215            })            })
216    setMethod("asPlain",
217  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "NewsgroupDocument"),
218  setMethod("removeWords",            function(object, FUN, ...) {
219            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
220            function(object, stopwords, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
221                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
222                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    LocalMetaData = LocalMetaData(object))
223                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")            })
224                return(object)  setMethod("asPlain",
225              signature(object = "StructuredTextDocument"),
226              function(object, FUN, ...) {
227                  new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
228                      URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
229                      Description = Description(object), ID = ID(object), Origin = Origin(object),
230                      Heading = Heading(object), Language = Language(object),
231                      LocalMetaData = LocalMetaData(object))
232            })            })
233    
234  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
235  setMethod("tmFilter",  setMethod("tmFilter",
236            signature(object = "TextDocCol"),            signature(object = "Corpus"),
237            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
238                if (doclevel)                if (doclevel)
239                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
# Line 236  Line 243 
243    
244  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))
245  setMethod("tmIndex",  setMethod("tmIndex",
246            signature(object = "TextDocCol"),            signature(object = "Corpus"),
247            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = sFilter, doclevel = FALSE) {
248                if (doclevel)                if (doclevel)
249                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
# Line 246  Line 253 
253    
254  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
255      con <- textConnection(s)      con <- textConnection(s)
256      tokens <- scan(con, "character")      tokens <- scan(con, "character", quiet = TRUE)
257      close(con)      close(con)
258      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
259      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
# Line 269  Line 276 
276      return(result)      return(result)
277  }  }
278    
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
279  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
280  setMethod("appendElem",  setMethod("appendElem",
281            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
282            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
283                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
284                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
285                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
286                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
287                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
288                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
289                }                }
290                else                else
# Line 296  Line 295 
295    
296  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
297  setMethod("appendMeta",  setMethod("appendMeta",
298            signature(object = "TextDocCol"),            signature(object = "Corpus"),
299            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
300                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
301                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 306 
306    
307  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
308  setMethod("removeMeta",  setMethod("removeMeta",
309            signature(object = "TextDocCol"),            signature(object = "Corpus"),
310            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
311                if (!is.null(cname))                if (!is.null(cname))
312                    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 317 
317    
318  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
319  setMethod("prescindMeta",  setMethod("prescindMeta",
320            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
321            function(object, meta) {            function(object, meta) {
322                for (m in meta) {                for (m in meta) {
323                    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 343 
343            })            })
344    
345  setMethod("[",  setMethod("[",
346            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
347            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
348                if(missing(i))                if(missing(i))
349                    return(x)                    return(x)
# Line 364  Line 363 
363            })            })
364    
365  setMethod("[<-",  setMethod("[<-",
366            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
367            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
368                object <- x                object <- x
369                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 378  Line 377 
377                        }                        }
378                        counter <- counter + 1                        counter <- counter + 1
379                    }                    }
                   dbDisconnect(db)  
380                }                }
381                else                else
382                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 386  Line 384 
384            })            })
385    
386  setMethod("[[",  setMethod("[[",
387            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
388            function(x, i, j, ...) {            function(x, i, j, ...) {
389                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
390                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
391                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
392                    return(loadDoc(result))                    return(loadDoc(result))
393                }                }
394                else                else
# Line 399  Line 396 
396            })            })
397    
398  setMethod("[[<-",  setMethod("[[<-",
399            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
400            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
401                object <- x                object <- x
402                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
403                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
404                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
405                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
406                }                }
407                else                else
408                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
# Line 442  Line 438 
438  }  }
439    
440  setMethod("c",  setMethod("c",
441            signature(x = "TextDocCol"),            signature(x = "Corpus"),
442            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) {
443                args <- list(...)                args <- list(...)
444                if (length(args) == 0)                if (length(args) == 0)
445                    return(x)                    return(x)
446    
447                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
448                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
449                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
450                    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 458 
458    
459  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"))
460  setMethod("c2",  setMethod("c2",
461            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
462            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) {
463                object <- x                object <- x
464                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 525 
525                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
526                              children = list())                              children = list())
527    
528                return(new("TextDocCol",                return(new("Corpus",
529                           .Data = list(x, ...),                           .Data = list(x, ...),
530                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
531                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 533 
533            })            })
534    
535  setMethod("length",  setMethod("length",
536            signature(x = "TextDocCol"),            signature(x = "Corpus"),
537            function(x){            function(x){
538                return(length(as(x, "list")))                return(length(as(x, "list")))
539      })      })
540    
541  setMethod("show",  setMethod("show",
542            signature(object = "TextDocCol"),            signature(object = "Corpus"),
543            function(object){            function(object){
544                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
545                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 548 
548      })      })
549    
550  setMethod("summary",  setMethod("summary",
551            signature(object = "TextDocCol"),            signature(object = "Corpus"),
552            function(object){            function(object){
553                show(object)                show(object)
554                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 565 
565    
566  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
567  setMethod("inspect",  setMethod("inspect",
568            signature("TextDocCol"),            signature("Corpus"),
569            function(object) {            function(object) {
570                summary(object)                summary(object)
571                cat("\n")                cat("\n")
572                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
573                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
574                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
575                }                }
576                else                else
577                    show(object@.Data)                    show(object@.Data)
# Line 585  Line 580 
580  # No metadata is checked  # No metadata is checked
581  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
582  setMethod("%IN%",  setMethod("%IN%",
583            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
584            function(x, y) {            function(x, y) {
585                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
586                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
587                    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)  
588                }                }
589                else                else
590                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 592 
592            })            })
593    
594  setMethod("lapply",  setMethod("lapply",
595            signature(X = "TextDocCol"),            signature(X = "Corpus"),
596            function(X, FUN, ...) {            function(X, FUN, ...) {
597                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
598                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
599                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
600                }                }
601                else                else
602                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
# Line 611  Line 604 
604            })            })
605    
606  setMethod("sapply",  setMethod("sapply",
607            signature(X = "TextDocCol"),            signature(X = "Corpus"),
608            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
609                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
610                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
611                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
612                }                }
613                else                else
614                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
615                return(result)                return(result)
616            })            })
617    
618    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
619    setMethod("writeCorpus",
620              signature(object = "Corpus"),
621              function(object, path = ".", filenames = NULL) {
622                  filenames <- file.path(path,
623                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
624                                         else filenames)
625                  i <- 1
626                  for (o in object) {
627                      writeLines(o, filenames[i])
628                      i <- i + 1
629                  }
630              })

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

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