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

trunk/tm/R/textdoccol.R revision 744, Mon Apr 23 00:35:10 2007 UTC pkg/tm/R/textdoccol.R revision 884, Wed Jan 28 10:24:27 2009 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 20  Line 26 
26                    db <- dbInit(dbControl$dbName, dbControl$dbType)                    db <- dbInit(dbControl$dbName, dbControl$dbType)
27                }                }
28    
29                tdl <- list()                # Allocate memory in advance if length is known
30                  tdl <- if (object@Length > 0)
31                      vector("list", as.integer(object@Length))
32                  else
33                      list()
34    
35                counter <- 1                counter <- 1
36                while (!eoi(object)) {                while (!eoi(object)) {
37                    object <- stepNext(object)                    object <- stepNext(object)
# Line 32  Line 43 
43                    doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))                    doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))
44                    if (dbControl$useDb) {                    if (dbControl$useDb) {
45                        dbInsert(db, ID(doc), doc)                        dbInsert(db, ID(doc), doc)
46                          if (object@Length > 0)
47                              tdl[[counter]] <- ID(doc)
48                          else
49                        tdl <- c(tdl, ID(doc))                        tdl <- c(tdl, ID(doc))
50                    }                    }
51                      else {
52                          if (object@Length > 0)
53                              tdl[[counter]] <- doc
54                    else                    else
55                        tdl <- c(tdl, list(doc))                        tdl <- c(tdl, list(doc))
56                      }
57                    counter <- counter + 1                    counter <- counter + 1
58                }                }
59    
# Line 43  Line 61 
61                if (dbControl$useDb) {                if (dbControl$useDb) {
62                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
63                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
64                }                }
65                else                else
66                    dmeta.df <- df                    dmeta.df <- df
# Line 53  Line 70 
70                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
71                              children = list())                              children = list())
72    
73                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))
74            })            })
75    
76  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))
# Line 64  Line 81 
81                    con <- eval(URI(object))                    con <- eval(URI(object))
82                    corpus <- readLines(con)                    corpus <- readLines(con)
83                    close(con)                    close(con)
84                    Corpus(object) <- corpus                    Content(object) <- corpus
85                    Cached(object) <- TRUE                    Cached(object) <- TRUE
86                    return(object)                    return(object)
87                } else {                } else {
# Line 80  Line 97 
97                    close(con)                    close(con)
98                    doc <- xmlTreeParse(corpus, asText = TRUE)                    doc <- xmlTreeParse(corpus, asText = TRUE)
99                    class(doc) <- "list"                    class(doc) <- "list"
100                    Corpus(object) <- doc                    Content(object) <- doc
101                    Cached(object) <- TRUE                    Cached(object) <- TRUE
102                    return(object)                    return(object)
103                } else {                } else {
# Line 99  Line 116 
116                        if (mail[index] == "")                        if (mail[index] == "")
117                            break                            break
118                    }                    }
119                    Corpus(object) <- mail[(index + 1):length(mail)]                    Content(object) <- mail[(index + 1):length(mail)]
120                    return(object)                    return(object)
121                } else {                } else {
122                    return(object)                    return(object)
123                }                }
124            })            })
125    setMethod("loadDoc",
126              signature(object = "StructuredTextDocument"),
127              function(object, ...) {
128                  if (!Cached(object)) {
129                      warning("load on demand not (yet) supported for StructuredTextDocuments")
130                      return(object)
131                  } else
132                      return(object)
133              })
134    
135  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
136                                  origin,                                  origin,
137                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
138                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
139  # Update is only supported for directories  # Update is only supported for directories
140  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
141  setMethod("tmUpdate",  setMethod("tmUpdate",
142            signature(object = "TextDocCol", origin = "DirSource"),            signature(object = "Corpus", origin = "DirSource"),
143            function(object, origin,            function(object, origin,
144                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
145                     ...) {                     ...) {
146                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
147                      readerControl$reader <- origin@DefaultReader
148                  if (is(readerControl$reader, "FunctionGenerator"))
149                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
150                  if (is.null(readerControl$language))
151                      readerControl$language = "en_US"
152                  if (is.null(readerControl$load))
153                      readerControl$load = TRUE
154    
155                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {summary(eval(URI(x)))$description}))
156                new.files <- setdiff(origin@FileList, object.filelist)                new.files <- setdiff(origin@FileList, object.filelist)
157    
158                for (filename in new.files) {                for (filename in new.files) {
159                    elem <- list(content = readLines(filename),                    encoding <- origin@Encoding
160                                 uri = substitute(file(filename)))                    elem <- list(content = readLines(filename, encoding = encoding),
161                                   uri = substitute(file(filename, encoding = encoding)))
162                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))
163                }                }
164    
165                return(object)                return(object)
166            })            })
167    
168  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
169  setMethod("tmMap",  setMethod("tmMap",
170            signature(object = "TextDocCol", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
171            function(object, FUN, ...) {            function(object, FUN, ..., lazy = FALSE) {
172                result <- object                result <- object
173                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
174                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
175                      if (lazy)
176                          warning("lazy mapping is deactived when using database backend")
177                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
178                    i <- 1                    i <- 1
179                    for (id in unlist(object)) {                    for (id in unlist(object)) {
180                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
181                        i <- i + 1                        i <- i + 1
182                    }                    }
183                    dbDisconnect(db)                    # Suggested by Christian Buchta
184                      dbReorganize(db)
185                }                }
186                  else {
187                      # Lazy mapping
188                      if (lazy) {
189                          lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
190                          if (is.null(lazyTmMap)) {
191                              meta(result, tag = "lazyTmMap", type = "corpus") <-
192                                  list(index = rep(TRUE, length(result)),
193                                       maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
194                          }
195                          else {
196                              lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
197                              meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
198                          }
199                      }
200                      else {
201                          result@.Data <- if (clusterAvailable())
202                              snow::parLapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))
203                else                else
204                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                            lapply(object, FUN, ..., DMetaData = DMetaData(object))
205                      }
206                  }
207                return(result)                return(result)
208            })            })
209    
210    # Materialize lazy mappings
211    # Improvements by Christian Buchta
212    materialize <- function(corpus, range = seq_along(corpus)) {
213        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
214        if (!is.null(lazyTmMap)) {
215           # Make valid and lazy index
216           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
217           if (any(idx)) {
218               res <- lapply(corpus@.Data[idx], loadDoc)
219               for (m in lazyTmMap$maps)
220                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
221               corpus@.Data[idx] <- res
222               lazyTmMap$index[idx] <- FALSE
223           }
224        }
225        # Clean up if everything is materialized
226        if (!any(lazyTmMap$index))
227            lazyTmMap <- NULL
228        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
229        return(corpus)
230    }
231    
232  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
233  setMethod("asPlain",  setMethod("asPlain",
234            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 159  Line 236 
236                return(object)                return(object)
237            })            })
238  setMethod("asPlain",  setMethod("asPlain",
239            signature(object = "XMLTextDocument", FUN = "function"),            signature(object = "XMLTextDocument"),
240            function(object, FUN, ...) {            function(object, FUN, ...) {
241                corpus <- Corpus(object)                corpus <- Content(object)
242    
243                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
244                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 247 
247                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
248            })            })
249  setMethod("asPlain",  setMethod("asPlain",
250            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
251            function(object, FUN, ...) {            function(object, FUN, ...) {
252                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
253                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Content(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
254    
255  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
256  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
257            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
258    
259  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
260            })            })
261    setMethod("asPlain",
262  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))            signature(object = "RCV1Document"),
263  setMethod("stemDoc",            function(object, FUN, ...) {
264            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)  
265            })            })
266    setMethod("asPlain",
267  setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))            signature(object = "NewsgroupDocument"),
268  setMethod("removePunctuation",            function(object, FUN, ...) {
269            signature(object = "PlainTextDocument"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),
270            function(object, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
271                Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
272                return(object)                    LocalMetaData = LocalMetaData(object))
273            })            })
274    setMethod("asPlain",
275  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "StructuredTextDocument"),
276  setMethod("removeWords",            function(object, FUN, ...) {
277            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
278            function(object, stopwords, ...) {                    URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),
279                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Description = Description(object), ID = ID(object), Origin = Origin(object),
280                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    Heading = Heading(object), Language = Language(object),
281                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")                    LocalMetaData = LocalMetaData(object))
               return(object)  
282            })            })
283    
284  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
285  setMethod("tmFilter",  setMethod("tmFilter",
286            signature(object = "TextDocCol"),            signature(object = "Corpus"),
287            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
288                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
289                      doclevel <- attr(FUN, "doclevel")
290                  if (doclevel) {
291                      if (clusterAvailable())
292                          return(object[snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))])
293                      else
294                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
295                  }
296                else                else
297                    return(object[FUN(object, ...)])                    return(object[FUN(object, ...)])
298            })            })
299    
300  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
301  setMethod("tmIndex",  setMethod("tmIndex",
302            signature(object = "TextDocCol"),            signature(object = "Corpus"),
303            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
304                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
305                      doclevel <- attr(FUN, "doclevel")
306                  if (doclevel) {
307                      if (clusterAvailable())
308                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
309                      else
310                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
311                  }
312                else                else
313                    return(FUN(object, ...))                    return(FUN(object, ...))
314            })            })
315    
 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))))  
           })  
   
316  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
317  setMethod("appendElem",  setMethod("appendElem",
318            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
319            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
320                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
321                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
322                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
323                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
324                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
325                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
326                }                }
327                else                else
# Line 296  Line 332 
332    
333  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
334  setMethod("appendMeta",  setMethod("appendMeta",
335            signature(object = "TextDocCol"),            signature(object = "Corpus"),
336            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
337                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
338                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 343 
343    
344  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
345  setMethod("removeMeta",  setMethod("removeMeta",
346            signature(object = "TextDocCol"),            signature(object = "Corpus"),
347            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
348                if (!is.null(cname))                if (!is.null(cname))
349                    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 354 
354    
355  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
356  setMethod("prescindMeta",  setMethod("prescindMeta",
357            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
358            function(object, meta) {            function(object, meta) {
359                for (m in meta) {                for (m in meta) {
360                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
361                        local.m <- lapply(object, m)                        local.m <- lapply(object, m)
362                          local.m <- sapply(local.m, paste, collapse = " ")
363                        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))
364                        local.m <- unlist(local.m)                        local.m <- unlist(local.m)
365                        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 381 
381            })            })
382    
383  setMethod("[",  setMethod("[",
384            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
385            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
386                if(missing(i))                if(missing(i))
387                    return(x)                    return(x)
# Line 364  Line 401 
401            })            })
402    
403  setMethod("[<-",  setMethod("[<-",
404            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
405            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
406                object <- x                object <- x
407                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
# Line 378  Line 415 
415                        }                        }
416                        counter <- counter + 1                        counter <- counter + 1
417                    }                    }
                   dbDisconnect(db)  
418                }                }
419                else                else
420                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 386  Line 422 
422            })            })
423    
424  setMethod("[[",  setMethod("[[",
425            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
426            function(x, i, j, ...) {            function(x, i, j, ...) {
427                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
428                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
429                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
430                    return(loadDoc(result))                    return(loadDoc(result))
431                }                }
432                else                else {
433                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
434                      if (!is.null(lazyTmMap))
435                          .Call("copyCorpus", x, materialize(x, i))
436                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
437                  }
438            })            })
439    
440  setMethod("[[<-",  setMethod("[[<-",
441            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
442            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
443                object <- x                object <- x
444                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
445                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
446                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
447                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
448                }                }
449                else                else {
450                      # Mark new objects as not active for lazy mapping
451                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
452                      if (!is.null(lazyTmMap)) {
453                          lazyTmMap$index[i] <- FALSE
454                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
455                      }
456                      # Set the value
457                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
458                  }
459                return(object)                return(object)
460            })            })
461    
# Line 442  Line 488 
488  }  }
489    
490  setMethod("c",  setMethod("c",
491            signature(x = "TextDocCol"),            signature(x = "Corpus"),
492            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) {
493                args <- list(...)                args <- list(...)
494                if (length(args) == 0)                if (length(args) == 0)
495                    return(x)                    return(x)
496    
497                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
498                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
499                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
500                    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 508 
508    
509  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"))
510  setMethod("c2",  setMethod("c2",
511            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
512            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) {
513                object <- x                object <- x
514                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 575 
575                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
576                              children = list())                              children = list())
577    
578                return(new("TextDocCol",                return(new("Corpus",
579                           .Data = list(x, ...),                           .Data = list(x, ...),
580                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
581                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 583 
583            })            })
584    
585  setMethod("length",  setMethod("length",
586            signature(x = "TextDocCol"),            signature(x = "Corpus"),
587            function(x){            function(x){
588                return(length(as(x, "list")))                return(length(as(x, "list")))
589      })      })
590    
591  setMethod("show",  setMethod("show",
592            signature(object = "TextDocCol"),            signature(object = "Corpus"),
593            function(object){            function(object){
594                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
595                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 598 
598      })      })
599    
600  setMethod("summary",  setMethod("summary",
601            signature(object = "TextDocCol"),            signature(object = "Corpus"),
602            function(object){            function(object){
603                show(object)                show(object)
604                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 615 
615    
616  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
617  setMethod("inspect",  setMethod("inspect",
618            signature("TextDocCol"),            signature("Corpus"),
619            function(object) {            function(object) {
620                summary(object)                summary(object)
621                cat("\n")                cat("\n")
622                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
623                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
624                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
625                }                }
626                else                else
627                    show(object@.Data)                    print(noquote(lapply(object, identity)))
628            })            })
629    
630  # No metadata is checked  # No metadata is checked
631  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
632  setMethod("%IN%",  setMethod("%IN%",
633            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
634            function(x, y) {            function(x, y) {
635                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
636                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
637                    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)  
638                }                }
639                else                else
640                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 642 
642            })            })
643    
644  setMethod("lapply",  setMethod("lapply",
645            signature(X = "TextDocCol"),            signature(X = "Corpus"),
646            function(X, FUN, ...) {            function(X, FUN, ...) {
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 <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(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::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
656                  }
657                return(result)                return(result)
658            })            })
659    
660  setMethod("sapply",  setMethod("sapply",
661            signature(X = "TextDocCol"),            signature(X = "Corpus"),
662            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
663                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
664                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
665                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
666                }                }
667                else                else {
668                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
669                      if (!is.null(lazyTmMap))
670                          .Call("copyCorpus", X, materialize(X))
671                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
672                  }
673                return(result)                return(result)
674            })            })
675    
676    setAs("list", "Corpus", function(from) {
677        cmeta.node <- new("MetaDataNode",
678                          NodeID = 0,
679                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
680                          children = list())
681        data <- list()
682        counter <- 1
683        for (f in from) {
684            doc <- new("PlainTextDocument",
685                       .Data = f, URI = NULL, Cached = TRUE,
686                       Author = "", DateTimeStamp = Sys.time(),
687                       Description = "", ID = as.character(counter),
688                       Origin = "", Heading = "", Language = "en_US")
689            data <- c(data, list(doc))
690            counter <- counter + 1
691        }
692        return(new("Corpus", .Data = data,
693                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
694                   CMetaData = cmeta.node,
695                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
696    })
697    
698    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
699    setMethod("writeCorpus",
700              signature(object = "Corpus"),
701              function(object, path = ".", filenames = NULL) {
702                  filenames <- file.path(path,
703                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
704                                         else filenames)
705                  i <- 1
706                  for (o in object) {
707                      writeLines(asPlain(o), filenames[i])
708                      i <- i + 1
709                  }
710              })

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

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