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 831, Wed Mar 12 09:10:46 2008 UTC pkg/tm/R/textdoccol.R revision 884, Wed Jan 28 10:24:27 2009 UTC
# Line 26  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 38  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 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 168  Line 180 
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                      # Suggested by Christian Buchta
184                      dbReorganize(db)
185                }                }
186                else {                else {
187                    # Lazy mapping                    # Lazy mapping
# Line 183  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            })            })
209    
210  # Materialize lazy mappings  # Materialize lazy mappings
211    # Improvements by Christian Buchta
212  materialize <- function(corpus, range = seq_along(corpus)) {  materialize <- function(corpus, range = seq_along(corpus)) {
213      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")      lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
214      if (!is.null(lazyTmMap)) {      if (!is.null(lazyTmMap)) {
215          for (i in range)         # Make valid and lazy index
216              if (lazyTmMap$index[i]) {         idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
217                  res <- loadDoc(corpus@.Data[[i]])         if (any(idx)) {
218               res <- lapply(corpus@.Data[idx], loadDoc)
219                  for (m in lazyTmMap$maps)                  for (m in lazyTmMap$maps)
220                      res <- m(res, DMetaData = DMetaData(corpus))                 res <- lapply(res, m, DMetaData = DMetaData(corpus))
221                  corpus@.Data[[i]] <- res             corpus@.Data[idx] <- res
222                  lazyTmMap$index[i] <- FALSE             lazyTmMap$index[idx] <- FALSE
223              }              }
224      }      }
225      # Clean up if everything is materialized      # Clean up if everything is materialized
# Line 216  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 <- Content(object)                corpus <- Content(object)
242    
# Line 241  Line 261 
261  setMethod("asPlain",  setMethod("asPlain",
262            signature(object = "RCV1Document"),            signature(object = "RCV1Document"),
263            function(object, FUN, ...) {            function(object, FUN, ...) {
264                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), ...))  
265            })            })
266  setMethod("asPlain",  setMethod("asPlain",
267            signature(object = "NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
268            function(object, FUN, ...) {            function(object, FUN, ...) {
269                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),
270                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
271                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
272                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(object))
# Line 262  Line 275 
275            signature(object = "StructuredTextDocument"),            signature(object = "StructuredTextDocument"),
276            function(object, FUN, ...) {            function(object, FUN, ...) {
277                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,                new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
278                    URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),                    URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),
279                    Description = Description(object), ID = ID(object), Origin = Origin(object),                    Description = Description(object), ID = ID(object), Origin = Origin(object),
280                    Heading = Heading(object), Language = Language(object),                    Heading = Heading(object), Language = Language(object),
281                    LocalMetaData = LocalMetaData(object))                    LocalMetaData = LocalMetaData(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 = "Corpus"),            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 = "Corpus"),            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", 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)  
 }  
   
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 = "Corpus", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
# Line 359  Line 359 
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 623  Line 624 
624                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
625                }                }
626                else                else
627                    show(lapply(object, "[[", 1))                    print(noquote(lapply(object, identity)))
628            })            })
629    
630  # No metadata is checked  # No metadata is checked
# Line 643  Line 644 
644  setMethod("lapply",  setMethod("lapply",
645            signature(X = "Corpus"),            signature(X = "Corpus"),
646            function(X, FUN, ...) {            function(X, FUN, ...) {
               print("lapply")  
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, ...)
# Line 673  Line 673 
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"))  setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
699  setMethod("writeCorpus",  setMethod("writeCorpus",
700            signature(object = "Corpus"),            signature(object = "Corpus"),
# Line 682  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.831  
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