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 836, Sat Apr 19 17:08:07 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 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                corpus <- Content(object)                corpus <- Content(object)
242    
# Line 245  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 266  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 363  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 627  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 647  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 708  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.836  
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