SCM

SCM Repository

[tm] Diff of /pkg/R/corpus.R
ViewVC logotype

Diff of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 816, Thu Jan 24 14:36:41 2008 UTC revision 837, Wed Apr 23 09:16:25 2008 UTC
# Line 2  Line 2 
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  # The "..." are additional arguments for the FunctionGenerator reader
4  setGeneric("Corpus", 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("Corpus"))                                    ...) standardGeneric("Corpus"))
8  setMethod("Corpus",  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 (is.null(readerControl$reader))                if (is.null(readerControl$reader))
# Line 18  Line 18 
18                if (is.null(readerControl$language))                if (is.null(readerControl$language))
19                    readerControl$language = "en_US"                    readerControl$language = "en_US"
20                if (is.null(readerControl$load))                if (is.null(readerControl$load))
21                    readerControl$load = FALSE                    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 122  Line 122 
122    
123  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
124                                  origin,                                  origin,
125                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
126                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
127  # Update is only supported for directories  # Update is only supported for directories
128  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
129  setMethod("tmUpdate",  setMethod("tmUpdate",
130            signature(object = "Corpus", origin = "DirSource"),            signature(object = "Corpus", origin = "DirSource"),
131            function(object, origin,            function(object, origin,
132                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
133                     ...) {                     ...) {
134                if (is.null(readerControl$reader))                if (is.null(readerControl$reader))
135                    readerControl$reader <- origin@DefaultReader                    readerControl$reader <- origin@DefaultReader
# Line 138  Line 138 
138                if (is.null(readerControl$language))                if (is.null(readerControl$language))
139                    readerControl$language = "en_US"                    readerControl$language = "en_US"
140                if (is.null(readerControl$load))                if (is.null(readerControl$load))
141                    readerControl$load = FALSE                    readerControl$load = TRUE
142    
143                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))
144                new.files <- setdiff(origin@FileList, object.filelist)                new.files <- setdiff(origin@FileList, object.filelist)
# Line 153  Line 153 
153                return(object)                return(object)
154            })            })
155    
156  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
157  setMethod("tmMap",  setMethod("tmMap",
158            signature(object = "Corpus", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
159            function(object, FUN, ...) {            function(object, FUN, ..., lazy = FALSE) {
160                result <- object                result <- object
161                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
162                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
163                      if (lazy)
164                          warning("lazy mapping is deactived when using database backend")
165                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
166                    i <- 1                    i <- 1
167                    for (id in unlist(object)) {                    for (id in unlist(object)) {
168                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
169                        i <- i + 1                        i <- i + 1
170                    }                    }
171                      # Suggested by Christian Buchta
172                      dbReorganize(db)
173                  }
174                  else {
175                      # Lazy mapping
176                      if (lazy) {
177                          lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
178                          if (is.null(lazyTmMap)) {
179                              meta(result, tag = "lazyTmMap", type = "corpus") <-
180                                  list(index = rep(TRUE, length(result)),
181                                       maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
182                          }
183                          else {
184                              lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
185                              meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
186                          }
187                }                }
188                else                else
189                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
190                  }
191                return(result)                return(result)
192            })            })
193    
194    # Materialize lazy mappings
195    # Improvements by Christian Buchta
196    materialize <- function(corpus, range = seq_along(corpus)) {
197        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
198        if (!is.null(lazyTmMap)) {
199           # Make valid and lazy index
200           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
201           if (any(idx)) {
202               res <- lapply(corpus@.Data[idx], loadDoc)
203               for (m in lazyTmMap$maps)
204                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
205               corpus@.Data[idx] <- res
206               lazyTmMap$index[idx] <- FALSE
207           }
208        }
209        # Clean up if everything is materialized
210        if (!any(lazyTmMap$index))
211            lazyTmMap <- NULL
212        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
213        return(corpus)
214    }
215    
216  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
217  setMethod("asPlain",  setMethod("asPlain",
218            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 218  Line 259 
259            function(object, FUN, ...) {            function(object, FUN, ...) {
260                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
261                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
262                    Origin = Origin(object), Heading = Heading(object), Language = Language(object))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
263                      LocalMetaData = LocalMetaData(object))
264            })            })
265  setMethod("asPlain",  setMethod("asPlain",
266            signature(object = "StructuredTextDocument"),            signature(object = "StructuredTextDocument"),
# Line 226  Line 268 
268                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
269                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
270                    Description = Description(object), ID = ID(object), Origin = Origin(object),                    Description = Description(object), ID = ID(object), Origin = Origin(object),
271                    Heading = Heading(object), Language = Language(object))                    Heading = Heading(object), Language = Language(object),
272                      LocalMetaData = LocalMetaData(object))
273            })            })
274    
275  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
# Line 389  Line 432 
432                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
433                    return(loadDoc(result))                    return(loadDoc(result))
434                }                }
435                else                else {
436                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
437                      if (!is.null(lazyTmMap))
438                          .Call("copyCorpus", x, materialize(x, i))
439                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
440                  }
441            })            })
442    
443  setMethod("[[<-",  setMethod("[[<-",
# Line 402  Line 449 
449                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
450                    db[[index]] <- value                    db[[index]] <- value
451                }                }
452                else                else {
453                      # Mark new objects as not active for lazy mapping
454                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
455                      if (!is.null(lazyTmMap)) {
456                          lazyTmMap$index[i] <- FALSE
457                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
458                      }
459                      # Set the value
460                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
461                  }
462                return(object)                return(object)
463            })            })
464    
# Line 572  Line 627 
627                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
628                }                }
629                else                else
630                    show(object@.Data)                    print(noquote(lapply(object, identity)))
631            })            })
632    
633  # No metadata is checked  # No metadata is checked
# Line 592  Line 647 
647  setMethod("lapply",  setMethod("lapply",
648            signature(X = "Corpus"),            signature(X = "Corpus"),
649            function(X, FUN, ...) {            function(X, FUN, ...) {
650                  print("lapply")
651                if (DBControl(X)[["useDb"]]) {                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                }                }
655                else                else {
656                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
657                      if (!is.null(lazyTmMap))
658                          .Call("copyCorpus", X, materialize(X))
659                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
660                  }
661                return(result)                return(result)
662            })            })
663    
# Line 608  Line 668 
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                }                }
671                else                else {
672                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
673                      if (!is.null(lazyTmMap))
674                          .Call("copyCorpus", X, materialize(X))
675                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
676                  }
677                return(result)                return(result)
678            })            })
679    
680    setAs("list", "Corpus", function(from) {
681        cmeta.node <- new("MetaDataNode",
682                          NodeID = 0,
683                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
684                          children = list())
685        data <- list()
686        counter <- 1
687        for (f in from) {
688            doc <- new("PlainTextDocument",
689                       .Data = f, URI = NULL, Cached = TRUE,
690                       Author = "", DateTimeStamp = Sys.time(),
691                       Description = "", ID = as.character(counter),
692                       Origin = "", Heading = "", Language = "en_US")
693            data <- c(data, list(doc))
694            counter <- counter + 1
695        }
696        return(new("Corpus", .Data = data,
697                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
698                   CMetaData = cmeta.node,
699                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
700    })
701    
702    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
703    setMethod("writeCorpus",
704              signature(object = "Corpus"),
705              function(object, path = ".", filenames = NULL) {
706                  filenames <- file.path(path,
707                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
708                                         else filenames)
709                  i <- 1
710                  for (o in object) {
711                      writeLines(o, filenames[i])
712                      i <- i + 1
713                  }
714              })

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

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