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 837, Wed Apr 23 09:16:25 2008 UTC pkg/R/textdoccol.R revision 894, Tue Mar 3 15:33:22 2009 UTC
# Line 20  Line 20 
20                if (is.null(readerControl$load))                if (is.null(readerControl$load))
21                    readerControl$load = TRUE                    readerControl$load = TRUE
22    
23                if (dbControl$useDb) {                if (dbControl$useDb && require("filehash")) {
24                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
25                        stop("error in creating database")                        stop("error in creating database")
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 36  Line 41 
41                    if (!object@LoDSupport)                    if (!object@LoDSupport)
42                        readerControl$load <- TRUE                        readerControl$load <- TRUE
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 && require("filehash")) {
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    
60                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
61                if (dbControl$useDb) {                if (dbControl$useDb && require("filehash")) {
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)))
64                }                }
# Line 79  Line 91 
91  setMethod("loadDoc",  setMethod("loadDoc",
92            signature(object =  "XMLTextDocument"),            signature(object =  "XMLTextDocument"),
93            function(object, ...) {            function(object, ...) {
94                if (!Cached(object)) {                if (!Cached(object) && require("XML")) {
95                    con <- eval(URI(object))                    con <- eval(URI(object))
96                    corpus <- paste(readLines(con), "\n", collapse = "")                    corpus <- paste(readLines(con), "\n", collapse = "")
97                    close(con)                    close(con)
# Line 140  Line 152 
152                if (is.null(readerControl$load))                if (is.null(readerControl$load))
153                    readerControl$load = TRUE                    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) {
# Line 159  Line 171 
171            function(object, FUN, ..., lazy = FALSE) {            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"]] && require("filehash")) {
175                    if (lazy)                    if (lazy)
176                        warning("lazy mapping is deactived when using database backend")                        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"]])
# Line 185  Line 197 
197                            meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap                            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            })            })
# Line 220  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                  require("XML")
242    
243                corpus <- Content(object)                corpus <- Content(object)
244    
245                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
# Line 233  Line 251 
251  setMethod("asPlain",  setMethod("asPlain",
252            signature(object = "Reuters21578Document"),            signature(object = "Reuters21578Document"),
253            function(object, FUN, ...) {            function(object, FUN, ...) {
254                  require("XML")
255    
256                FUN <- convertReut21578XMLPlain                FUN <- convertReut21578XMLPlain
257                corpus <- Content(object)                corpus <- Content(object)
258    
# Line 245  Line 265 
265  setMethod("asPlain",  setMethod("asPlain",
266            signature(object = "RCV1Document"),            signature(object = "RCV1Document"),
267            function(object, FUN, ...) {            function(object, FUN, ...) {
268                FUN <- convertRCV1Plain                return(convertRCV1Plain(object, ...))
               corpus <- Content(object)  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(FUN(xmlRoot(corpus), ...))  
269            })            })
270  setMethod("asPlain",  setMethod("asPlain",
271            signature(object = "NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
272            function(object, FUN, ...) {            function(object, FUN, ...) {
273                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),
274                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
275                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
276                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(object))
# Line 266  Line 279 
279            signature(object = "StructuredTextDocument"),            signature(object = "StructuredTextDocument"),
280            function(object, FUN, ...) {            function(object, FUN, ...) {
281                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
282                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),                    URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),
283                    Description = Description(object), ID = ID(object), Origin = Origin(object),                    Description = Description(object), ID = ID(object), Origin = Origin(object),
284                    Heading = Heading(object), Language = Language(object),                    Heading = Heading(object), Language = Language(object),
285                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(object))
286            })            })
287    
288  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
289  setMethod("tmFilter",  setMethod("tmFilter",
290            signature(object = "Corpus"),            signature(object = "Corpus"),
291            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
292                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
293                      doclevel <- attr(FUN, "doclevel")
294                  if (doclevel) {
295                      if (clusterAvailable())
296                          return(object[snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))])
297                      else
298                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
299                  }
300                else                else
301                    return(object[FUN(object, ...)])                    return(object[FUN(object, ...)])
302            })            })
303    
304  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
305  setMethod("tmIndex",  setMethod("tmIndex",
306            signature(object = "Corpus"),            signature(object = "Corpus"),
307            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
308                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
309                      doclevel <- attr(FUN, "doclevel")
310                  if (doclevel) {
311                      if (clusterAvailable())
312                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
313                      else
314                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
315                  }
316                else                else
317                    return(FUN(object, ...))                    return(FUN(object, ...))
318            })            })
319    
 sFilter <- function(object, s, ...) {  
     con <- textConnection(s)  
     tokens <- scan(con, "character", quiet = TRUE)  
     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)  
 }  
   
320  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
321  setMethod("appendElem",  setMethod("appendElem",
322            signature(object = "Corpus", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
323            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
324                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
325                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
326                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
327                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
# Line 363  Line 363 
363                for (m in meta) {                for (m in meta) {
364                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
365                        local.m <- lapply(object, m)                        local.m <- lapply(object, m)
366                          local.m <- sapply(local.m, paste, collapse = " ")
367                        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))
368                        local.m <- unlist(local.m)                        local.m <- unlist(local.m)
369                        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 391  Line 392 
392    
393                object <- x                object <- x
394                object@.Data <- x@.Data[i, ..., drop = FALSE]                object@.Data <- x@.Data[i, ..., drop = FALSE]
395                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
396                    index <- object@DMetaData[[1 , "subset"]]                    index <- object@DMetaData[[1 , "subset"]]
397                    if (any(is.na(index)))                    if (any(is.na(index)))
398                        object@DMetaData[[1 , "subset"]] <- i                        object@DMetaData[[1 , "subset"]] <- i
# Line 407  Line 408 
408            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
409            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
410                object <- x                object <- x
411                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
412                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
413                    counter <- 1                    counter <- 1
414                    for (id in object@.Data[i, ...]) {                    for (id in object@.Data[i, ...]) {
# Line 427  Line 428 
428  setMethod("[[",  setMethod("[[",
429            signature(x = "Corpus", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
430            function(x, i, j, ...) {            function(x, i, j, ...) {
431                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]] && require("filehash")) {
432                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
433                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
434                    return(loadDoc(result))                    return(loadDoc(result))
# Line 444  Line 445 
445            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
446            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
447                object <- x                object <- x
448                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
449                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
450                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
451                    db[[index]] <- value                    db[[index]] <- value
# Line 498  Line 499 
499                    return(x)                    return(x)
500    
501                if (!all(sapply(args, inherits, "Corpus")))                if (!all(sapply(args, inherits, "Corpus")))
502                    stop("not all arguments are text document collections")                    stop("not all arguments are corpora")
503                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] || any(unlist(sapply(args, DBControl)["useDb", ])))
504                    stop("concatenating text document collections with activated database is not supported")                    stop("concatenating corpora with activated database is not supported")
505    
506                result <- x                result <- x
507                for (c in args) {                for (c in args) {
# Line 595  Line 596 
596            signature(object = "Corpus"),            signature(object = "Corpus"),
597            function(object){            function(object){
598                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
599                                     "A text document collection with %d text document\n",                                     "A corpus with %d text document\n",
600                                     "A text document collection with %d text documents\n"),                                     "A corpus with %d text documents\n"),
601                            length(object)))                            length(object)))
602      })      })
603    
# Line 622  Line 623 
623            function(object) {            function(object) {
624                summary(object)                summary(object)
625                cat("\n")                cat("\n")
626                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
627                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
628                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
629                }                }
# Line 635  Line 636 
636  setMethod("%IN%",  setMethod("%IN%",
637            signature(x = "TextDocument", y = "Corpus"),            signature(x = "TextDocument", y = "Corpus"),
638            function(x, y) {            function(x, y) {
639                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]] && require("filehash")) {
640                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
641                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
642                }                }
# Line 647  Line 648 
648  setMethod("lapply",  setMethod("lapply",
649            signature(X = "Corpus"),            signature(X = "Corpus"),
650            function(X, FUN, ...) {            function(X, FUN, ...) {
651                print("lapply")                if (DBControl(X)[["useDb"]] && require("filehash")) {
               if (DBControl(X)[["useDb"]]) {  
652                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
653                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
654                }                }
# Line 664  Line 664 
664  setMethod("sapply",  setMethod("sapply",
665            signature(X = "Corpus"),            signature(X = "Corpus"),
666            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
667                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]] && require("filehash")) {
668                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
669                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
670                }                }
# Line 708  Line 708 
708                                       else filenames)                                       else filenames)
709                i <- 1                i <- 1
710                for (o in object) {                for (o in object) {
711                    writeLines(o, filenames[i])                    writeLines(asPlain(o), filenames[i])
712                    i <- i + 1                    i <- i + 1
713                }                }
714            })            })

Legend:
Removed from v.837  
changed lines
  Added in v.894

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