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 859, Wed Jul 9 13:39:52 2008 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  # The "..." are additional arguments for the FunctionGenerator reader
4  setGeneric("TextDocCol", function(object,  setGeneric("Corpus", function(object,
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
7                                    ...) standardGeneric("TextDocCol"))                                    ...) standardGeneric("Corpus"))
8  setMethod("TextDocCol",  setMethod("Corpus",
9            signature(object = "Source"),            signature(object = "Source"),
10            function(object,            function(object,
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
13                     ...) {                     ...) {
14                if (attr(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
15                      readerControl$reader <- object@DefaultReader
16                  if (is(readerControl$reader, "FunctionGenerator"))
17                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
18                  if (is.null(readerControl$language))
19                      readerControl$language = "en_US"
20                  if (is.null(readerControl$load))
21                      readerControl$load = TRUE
22    
23                if (dbControl$useDb) {                if (dbControl$useDb) {
24                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
# Line 43  Line 49 
49                if (dbControl$useDb) {                if (dbControl$useDb) {
50                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
51                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
52                }                }
53                else                else
54                    dmeta.df <- df                    dmeta.df <- df
# Line 53  Line 58 
58                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
59                              children = list())                              children = list())
60    
61                return(new("TextDocCol", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))
62            })            })
63    
64  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))
# Line 64  Line 69 
69                    con <- eval(URI(object))                    con <- eval(URI(object))
70                    corpus <- readLines(con)                    corpus <- readLines(con)
71                    close(con)                    close(con)
72                    Corpus(object) <- corpus                    Content(object) <- corpus
73                    Cached(object) <- TRUE                    Cached(object) <- TRUE
74                    return(object)                    return(object)
75                } else {                } else {
# Line 80  Line 85 
85                    close(con)                    close(con)
86                    doc <- xmlTreeParse(corpus, asText = TRUE)                    doc <- xmlTreeParse(corpus, asText = TRUE)
87                    class(doc) <- "list"                    class(doc) <- "list"
88                    Corpus(object) <- doc                    Content(object) <- doc
89                    Cached(object) <- TRUE                    Cached(object) <- TRUE
90                    return(object)                    return(object)
91                } else {                } else {
# Line 99  Line 104 
104                        if (mail[index] == "")                        if (mail[index] == "")
105                            break                            break
106                    }                    }
107                    Corpus(object) <- mail[(index + 1):length(mail)]                    Content(object) <- mail[(index + 1):length(mail)]
108                    return(object)                    return(object)
109                } else {                } else {
110                    return(object)                    return(object)
111                }                }
112            })            })
113    setMethod("loadDoc",
114              signature(object = "StructuredTextDocument"),
115              function(object, ...) {
116                  if (!Cached(object)) {
117                      warning("load on demand not (yet) supported for StructuredTextDocuments")
118                      return(object)
119                  } else
120                      return(object)
121              })
122    
123  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
124                                  origin,                                  origin,
125                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
126                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
127  # Update is only supported for directories  # Update is only supported for directories
128  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
129  setMethod("tmUpdate",  setMethod("tmUpdate",
130            signature(object = "TextDocCol", origin = "DirSource"),            signature(object = "Corpus", origin = "DirSource"),
131            function(object, origin,            function(object, origin,
132                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
133                     ...) {                     ...) {
134                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
135                      readerControl$reader <- origin@DefaultReader
136                  if (is(readerControl$reader, "FunctionGenerator"))
137                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
138                  if (is.null(readerControl$language))
139                      readerControl$language = "en_US"
140                  if (is.null(readerControl$load))
141                      readerControl$load = TRUE
142    
143                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))
144                new.files <- setdiff(origin@FileList, object.filelist)                new.files <- setdiff(origin@FileList, object.filelist)
145    
146                for (filename in new.files) {                for (filename in new.files) {
147                    elem <- list(content = readLines(filename),                    encoding <- origin@Encoding
148                                 uri = substitute(file(filename)))                    elem <- list(content = readLines(filename, encoding = encoding),
149                                   uri = substitute(file(filename, encoding = encoding)))
150                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))
151                }                }
152    
153                return(object)                return(object)
154            })            })
155    
156  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
157  setMethod("tmMap",  setMethod("tmMap",
158            signature(object = "TextDocCol", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
159            function(object, FUN, ...) {            function(object, FUN, ..., lazy = FALSE) {
160                result <- object                result <- object
161                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
162                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
163                      if (lazy)
164                          warning("lazy mapping is deactived when using database backend")
165                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
166                    i <- 1                    i <- 1
167                    for (id in unlist(object)) {                    for (id in unlist(object)) {
168                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
169                        i <- i + 1                        i <- i + 1
170                    }                    }
171                    dbDisconnect(db)                    # Suggested by Christian Buchta
172                      dbReorganize(db)
173                  }
174                  else {
175                      # Lazy mapping
176                      if (lazy) {
177                          lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
178                          if (is.null(lazyTmMap)) {
179                              meta(result, tag = "lazyTmMap", type = "corpus") <-
180                                  list(index = rep(TRUE, length(result)),
181                                       maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
182                          }
183                          else {
184                              lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
185                              meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
186                          }
187                }                }
188                else                else
189                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
190                  }
191                return(result)                return(result)
192            })            })
193    
194    # Materialize lazy mappings
195    # Improvements by Christian Buchta
196    materialize <- function(corpus, range = seq_along(corpus)) {
197        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
198        if (!is.null(lazyTmMap)) {
199           # Make valid and lazy index
200           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
201           if (any(idx)) {
202               res <- lapply(corpus@.Data[idx], loadDoc)
203               for (m in lazyTmMap$maps)
204                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
205               corpus@.Data[idx] <- res
206               lazyTmMap$index[idx] <- FALSE
207           }
208        }
209        # Clean up if everything is materialized
210        if (!any(lazyTmMap$index))
211            lazyTmMap <- NULL
212        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
213        return(corpus)
214    }
215    
216  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
217  setMethod("asPlain",  setMethod("asPlain",
218            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 159  Line 220 
220                return(object)                return(object)
221            })            })
222  setMethod("asPlain",  setMethod("asPlain",
223            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "XMLTextDocument"),
224            function(object, FUN, ...) {            function(object, FUN, ...) {
225                corpus <- Corpus(object)                corpus <- Content(object)
226    
227                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
228                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 231 
231                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
232            })            })
233  setMethod("asPlain",  setMethod("asPlain",
234            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
235            function(object, FUN, ...) {            function(object, FUN, ...) {
236                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
237                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Content(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
238    
239  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
240  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
241            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
242    
243  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
244            })            })
245    setMethod("asPlain",
246  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))            signature(object = "RCV1Document"),
247  setMethod("stemDoc",            function(object, FUN, ...) {
248            signature(object = "PlainTextDocument"),                return(convertRCV1Plain(object, ...))
           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)  
249            })            })
250    setMethod("asPlain",
251  setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))            signature(object = "NewsgroupDocument"),
252  setMethod("removePunctuation",            function(object, FUN, ...) {
253            signature(object = "PlainTextDocument"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
254            function(object, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
255                Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
256                return(object)                    LocalMetaData = LocalMetaData(object))
257            })            })
258    setMethod("asPlain",
259  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "StructuredTextDocument"),
260  setMethod("removeWords",            function(object, FUN, ...) {
261            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
262            function(object, stopwords, ...) {                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
263                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Description = Description(object), ID = ID(object), Origin = Origin(object),
264                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    Heading = Heading(object), Language = Language(object),
265                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")                    LocalMetaData = LocalMetaData(object))
               return(object)  
266            })            })
267    
268  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
269  setMethod("tmFilter",  setMethod("tmFilter",
270            signature(object = "TextDocCol"),            signature(object = "Corpus"),
271            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
272                  if (!is.null(attr(FUN, "doclevel")))
273                      doclevel <- attr(FUN, "doclevel")
274                if (doclevel)                if (doclevel)
275                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
276                else                else
277                    return(object[FUN(object, ...)])                    return(object[FUN(object, ...)])
278            })            })
279    
280  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
281  setMethod("tmIndex",  setMethod("tmIndex",
282            signature(object = "TextDocCol"),            signature(object = "Corpus"),
283            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
284                  if (!is.null(attr(FUN, "doclevel")))
285                      doclevel <- attr(FUN, "doclevel")
286                if (doclevel)                if (doclevel)
287                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
288                else                else
289                    return(FUN(object, ...))                    return(FUN(object, ...))
290            })            })
291    
 sFilter <- function(object, s, ...) {  
     con <- textConnection(s)  
     tokens <- scan(con, "character")  
     close(con)  
     localMetaNames <- unique(names(sapply(object, LocalMetaData)))  
     localMetaTokens <- localMetaNames[localMetaNames %in% tokens]  
     n <- names(DMetaData(object))  
     tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)  
     query.df <- DMetaData(prescindMeta(object, tags))  
     if (DBControl(object)[["useDb"]])  
         DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]  
     # Rename to avoid name conflicts  
     names(query.df)[names(query.df) == "Author"] <- "author"  
     names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"  
     names(query.df)[names(query.df) == "Description"] <- "description"  
     names(query.df)[names(query.df) == "ID"] <- "identifier"  
     names(query.df)[names(query.df) == "Origin"] <- "origin"  
     names(query.df)[names(query.df) == "Heading"] <- "heading"  
     names(query.df)[names(query.df) == "Language"] <- "language"  
     attach(query.df)  
     try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))  
     detach(query.df)  
     return(result)  
 }  
   
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
292  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
293  setMethod("appendElem",  setMethod("appendElem",
294            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
295            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
296                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
297                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
298                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
299                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
300                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
301                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
302                }                }
303                else                else
# Line 296  Line 308 
308    
309  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
310  setMethod("appendMeta",  setMethod("appendMeta",
311            signature(object = "TextDocCol"),            signature(object = "Corpus"),
312            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
313                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
314                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 319 
319    
320  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
321  setMethod("removeMeta",  setMethod("removeMeta",
322            signature(object = "TextDocCol"),            signature(object = "Corpus"),
323            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
324                if (!is.null(cname))                if (!is.null(cname))
325                    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 330 
330    
331  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
332  setMethod("prescindMeta",  setMethod("prescindMeta",
333            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
334            function(object, meta) {            function(object, meta) {
335                for (m in meta) {                for (m in meta) {
336                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
337                        local.m <- lapply(object, m)                        local.m <- lapply(object, m)
338                          local.m <- sapply(local.m, paste, collapse = " ")
339                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))                        local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))
340                        local.m <- unlist(local.m)                        local.m <- unlist(local.m)
341                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))                        DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))
# Line 344  Line 357 
357            })            })
358    
359  setMethod("[",  setMethod("[",
360            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
361            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
362                if(missing(i))                if(missing(i))
363                    return(x)                    return(x)
# Line 364  Line 377 
377            })            })
378    
379  setMethod("[<-",  setMethod("[<-",
380            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
381            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
382                object <- x                object <- x
383                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 378  Line 391 
391                        }                        }
392                        counter <- counter + 1                        counter <- counter + 1
393                    }                    }
                   dbDisconnect(db)  
394                }                }
395                else                else
396                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 386  Line 398 
398            })            })
399    
400  setMethod("[[",  setMethod("[[",
401            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
402            function(x, i, j, ...) {            function(x, i, j, ...) {
403                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
404                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
405                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
406                    return(loadDoc(result))                    return(loadDoc(result))
407                }                }
408                else                else {
409                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
410                      if (!is.null(lazyTmMap))
411                          .Call("copyCorpus", x, materialize(x, i))
412                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
413                  }
414            })            })
415    
416  setMethod("[[<-",  setMethod("[[<-",
417            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
418            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
419                object <- x                object <- x
420                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
421                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
422                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
423                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
424                }                }
425                else                else {
426                      # Mark new objects as not active for lazy mapping
427                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
428                      if (!is.null(lazyTmMap)) {
429                          lazyTmMap$index[i] <- FALSE
430                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
431                      }
432                      # Set the value
433                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
434                  }
435                return(object)                return(object)
436            })            })
437    
# Line 442  Line 464 
464  }  }
465    
466  setMethod("c",  setMethod("c",
467            signature(x = "TextDocCol"),            signature(x = "Corpus"),
468            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) {
469                args <- list(...)                args <- list(...)
470                if (length(args) == 0)                if (length(args) == 0)
471                    return(x)                    return(x)
472    
473                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
474                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
475                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
476                    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 484 
484    
485  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"))
486  setMethod("c2",  setMethod("c2",
487            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
488            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) {
489                object <- x                object <- x
490                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 551 
551                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
552                              children = list())                              children = list())
553    
554                return(new("TextDocCol",                return(new("Corpus",
555                           .Data = list(x, ...),                           .Data = list(x, ...),
556                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
557                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 559 
559            })            })
560    
561  setMethod("length",  setMethod("length",
562            signature(x = "TextDocCol"),            signature(x = "Corpus"),
563            function(x){            function(x){
564                return(length(as(x, "list")))                return(length(as(x, "list")))
565      })      })
566    
567  setMethod("show",  setMethod("show",
568            signature(object = "TextDocCol"),            signature(object = "Corpus"),
569            function(object){            function(object){
570                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
571                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 574 
574      })      })
575    
576  setMethod("summary",  setMethod("summary",
577            signature(object = "TextDocCol"),            signature(object = "Corpus"),
578            function(object){            function(object){
579                show(object)                show(object)
580                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 591 
591    
592  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
593  setMethod("inspect",  setMethod("inspect",
594            signature("TextDocCol"),            signature("Corpus"),
595            function(object) {            function(object) {
596                summary(object)                summary(object)
597                cat("\n")                cat("\n")
598                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
599                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
600                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
601                }                }
602                else                else
603                    show(object@.Data)                    print(noquote(lapply(object, identity)))
604            })            })
605    
606  # No metadata is checked  # No metadata is checked
607  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
608  setMethod("%IN%",  setMethod("%IN%",
609            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
610            function(x, y) {            function(x, y) {
611                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
612                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
613                    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)  
614                }                }
615                else                else
616                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 618 
618            })            })
619    
620  setMethod("lapply",  setMethod("lapply",
621            signature(X = "TextDocCol"),            signature(X = "Corpus"),
622            function(X, FUN, ...) {            function(X, FUN, ...) {
623                  print("lapply")
624                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
625                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
626                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
627                }                }
628                else                else {
629                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
630                      if (!is.null(lazyTmMap))
631                          .Call("copyCorpus", X, materialize(X))
632                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
633                  }
634                return(result)                return(result)
635            })            })
636    
637  setMethod("sapply",  setMethod("sapply",
638            signature(X = "TextDocCol"),            signature(X = "Corpus"),
639            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
640                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
641                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
642                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
643                }                }
644                else                else {
645                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
646                      if (!is.null(lazyTmMap))
647                          .Call("copyCorpus", X, materialize(X))
648                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
649                  }
650                return(result)                return(result)
651            })            })
652    
653    setAs("list", "Corpus", function(from) {
654        cmeta.node <- new("MetaDataNode",
655                          NodeID = 0,
656                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
657                          children = list())
658        data <- list()
659        counter <- 1
660        for (f in from) {
661            doc <- new("PlainTextDocument",
662                       .Data = f, URI = NULL, Cached = TRUE,
663                       Author = "", DateTimeStamp = Sys.time(),
664                       Description = "", ID = as.character(counter),
665                       Origin = "", Heading = "", Language = "en_US")
666            data <- c(data, list(doc))
667            counter <- counter + 1
668        }
669        return(new("Corpus", .Data = data,
670                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
671                   CMetaData = cmeta.node,
672                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
673    })
674    
675    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
676    setMethod("writeCorpus",
677              signature(object = "Corpus"),
678              function(object, path = ".", filenames = NULL) {
679                  filenames <- file.path(path,
680                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
681                                         else filenames)
682                  i <- 1
683                  for (o in object) {
684                      writeLines(asPlain(o), filenames[i])
685                      i <- i + 1
686                  }
687              })

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

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