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

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

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