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 856, Fri Jun 6 11:45:39 2008 UTC pkg/R/textdoccol.R revision 905, Sat Mar 21 10:13:08 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 55  Line 67 
67    
68                cmeta.node <- new("MetaDataNode",                cmeta.node <- new("MetaDataNode",
69                              NodeID = 0,                              NodeID = 0,
70                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
71                              children = list())                              children = list())
72    
73                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))
# 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 222  Line 238 
238  setMethod("asPlain",  setMethod("asPlain",
239            signature(object = "XMLTextDocument"),            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 250  Line 270 
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 259  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))
# Line 271  Line 291 
291            function(object, ..., FUN = searchFullText, doclevel = TRUE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
292                if (!is.null(attr(FUN, "doclevel")))                if (!is.null(attr(FUN, "doclevel")))
293                    doclevel <- attr(FUN, "doclevel")                    doclevel <- attr(FUN, "doclevel")
294                if (doclevel)                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            })            })
# Line 283  Line 307 
307            function(object, ..., FUN = searchFullText, doclevel = TRUE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
308                if (!is.null(attr(FUN, "doclevel")))                if (!is.null(attr(FUN, "doclevel")))
309                    doclevel <- attr(FUN, "doclevel")                    doclevel <- attr(FUN, "doclevel")
310                if (doclevel)                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            })            })
# Line 293  Line 321 
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 364  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 380  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 400  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 417  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 465  Line 493 
493    
494  setMethod("c",  setMethod("c",
495            signature(x = "Corpus"),            signature(x = "Corpus"),
496            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, ..., meta = list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
497                args <- list(...)                args <- list(...)
498                if (length(args) == 0)                if (length(args) == 0)
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                Reduce(c2, base::c(list(x), args))
               for (c in args) {  
                   result <- c2(result, c)  
               }  
               return(result)  
507            })            })
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 = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))
510  setMethod("c2",  setMethod("c2",
511            signature(x = "Corpus", y = "Corpus"),            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 = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
513                object <- x                object <- x
514                # Concatenate data slots                # Concatenate data slots
515                object@.Data <- c(as(x, "list"), as(y, "list"))                object@.Data <- c(as(x, "list"), as(y, "list"))
# Line 548  Line 572 
572                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)                dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
573                cmeta.node <- new("MetaDataNode",                cmeta.node <- new("MetaDataNode",
574                              NodeID = 0,                              NodeID = 0,
575                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
576                              children = list())                              children = list())
577    
578                return(new("Corpus",                return(new("Corpus",
# Line 568  Line 592 
592            signature(object = "Corpus"),            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 corpus with %d text document\n",
596                                     "A text document collection with %d text documents\n"),                                     "A corpus with %d text documents\n"),
597                            length(object)))                            length(object)))
598      })      })
599    
# Line 595  Line 619 
619            function(object) {            function(object) {
620                summary(object)                summary(object)
621                cat("\n")                cat("\n")
622                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
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)))
625                }                }
# Line 608  Line 632 
632  setMethod("%IN%",  setMethod("%IN%",
633            signature(x = "TextDocument", y = "Corpus"),            signature(x = "TextDocument", y = "Corpus"),
634            function(x, y) {            function(x, y) {
635                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]] && require("filehash")) {
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% Content(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
638                }                }
# Line 620  Line 644 
644  setMethod("lapply",  setMethod("lapply",
645            signature(X = "Corpus"),            signature(X = "Corpus"),
646            function(X, FUN, ...) {            function(X, FUN, ...) {
647                print("lapply")                if (DBControl(X)[["useDb"]] && require("filehash")) {
               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, ...)
650                }                }
# Line 637  Line 660 
660  setMethod("sapply",  setMethod("sapply",
661            signature(X = "Corpus"),            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"]] && require("filehash")) {
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, ...)
666                }                }
# Line 653  Line 676 
676  setAs("list", "Corpus", function(from) {  setAs("list", "Corpus", function(from) {
677      cmeta.node <- new("MetaDataNode",      cmeta.node <- new("MetaDataNode",
678                        NodeID = 0,                        NodeID = 0,
679                        MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                        MetaData = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")),
680                        children = list())                        children = list())
681      data <- list()      data <- list()
682      counter <- 1      counter <- 1
683      for (f in from) {      for (f in from) {
684          doc <- new("PlainTextDocument",          doc <- new("PlainTextDocument",
685                     .Data = f, URI = NULL, Cached = TRUE,                     .Data = f, URI = NULL, Cached = TRUE,
686                     Author = "", DateTimeStamp = Sys.time(),                     Author = "", DateTimeStamp = as.POSIXlt(Sys.time(), tz = "GMT"),
687                     Description = "", ID = as.character(counter),                     Description = "", ID = as.character(counter),
688                     Origin = "", Heading = "", Language = "en_US")                     Origin = "", Heading = "", Language = "en_US")
689          data <- c(data, list(doc))          data <- c(data, list(doc))
# Line 681  Line 704 
704                                       else filenames)                                       else filenames)
705                i <- 1                i <- 1
706                for (o in object) {                for (o in object) {
707                    writeLines(o, filenames[i])                    writeLines(asPlain(o), filenames[i])
708                    i <- i + 1                    i <- i + 1
709                }                }
710            })            })

Legend:
Removed from v.856  
changed lines
  Added in v.905

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