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 744, Mon Apr 23 00:35:10 2007 UTC revision 777, Tue Aug 28 07:19:12 2007 UTC
# Line 11  Line 11 
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
13                     ...) {                     ...) {
14                if (attr(readerControl$reader, "FunctionGenerator"))                if (is(readerControl$reader, "FunctionGenerator"))
15                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
16    
17                if (dbControl$useDb) {                if (dbControl$useDb) {
# Line 43  Line 43 
43                if (dbControl$useDb) {                if (dbControl$useDb) {
44                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
45                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
46                }                }
47                else                else
48                    dmeta.df <- df                    dmeta.df <- df
# Line 105  Line 104 
104                    return(object)                    return(object)
105                }                }
106            })            })
107    setMethod("loadDoc",
108              signature(object = "StructuredTextDocument"),
109              function(object, ...) {
110                  if (!Cached(object)) {
111                      warning("load on demand not (yet) supported for StructuredTextDocuments")
112                      return(object)
113                  } else
114                      return(object)
115              })
116    
117  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
118                                  origin,                                  origin,
# Line 117  Line 125 
125            function(object, origin,            function(object, origin,
126                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),
127                     ...) {                     ...) {
128                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is(readerControl$reader, "FunctionGenerator"))
129                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
130    
131                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))
# Line 145  Line 153 
153                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
154                        i <- i + 1                        i <- i + 1
155                    }                    }
                   dbDisconnect(db)  
156                }                }
157                else                else
158                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
# Line 170  Line 177 
177                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
178            })            })
179  setMethod("asPlain",  setMethod("asPlain",
180              signature(object = "Reuters21578Document"),
181              function(object, FUN, ...) {
182                  FUN <- convertReut21578XMLPlain
183                  corpus <- Corpus(object)
184    
185                  # As XMLDocument is no native S4 class, restore valid information
186                  class(corpus) <- "XMLDocument"
187                  names(corpus) <- c("doc","dtd")
188    
189                  return(FUN(xmlRoot(corpus), ...))
190              })
191    setMethod("asPlain",
192              signature(object = "RCV1Document"),
193              function(object, FUN, ...) {
194                  FUN <- convertRCV1Plain
195                  corpus <- Corpus(object)
196    
197                  # As XMLDocument is no native S4 class, restore valid information
198                  class(corpus) <- "XMLDocument"
199                  names(corpus) <- c("doc","dtd")
200    
201                  return(FUN(xmlRoot(corpus), ...))
202              })
203    setMethod("asPlain",
204            signature(object = "NewsgroupDocument"),            signature(object = "NewsgroupDocument"),
205            function(object, FUN, ...) {            function(object, FUN, ...) {
206                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),
207                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
208                    Origin = Origin(object), Heading = Heading(object), Language = Language(object))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object))
209            })            })
210    setMethod("asPlain",
211              signature(object = "StructuredTextDocument"),
212              function(object, FUN, ...) {
213                  new("PlainTextDocument", .Data = unlist(Corpus(object)), Cached = TRUE,
214                      URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
215                      Description = Description(object), ID = ID(object), Origin = Origin(object),
216                      Heading = Heading(object), Language = Language(object))
217              })
218    
219  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))
220  setMethod("tmTolower",  setMethod("tmTolower",
# Line 198  Line 237 
237            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
238            function(object, language = "english", ...) {            function(object, language = "english", ...) {
239                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
240                stemmedCorpus <- if (require("Rstem"))                stemmedCorpus <- if (require("Rstem", quietly = TRUE))
241                    Rstem::wordStem(splittedCorpus, language)                    Rstem::wordStem(splittedCorpus, language)
242                else                else
243                    SnowballStemmer(splittedCorpus, Weka_control(S = language))                    SnowballStemmer(splittedCorpus, Weka_control(S = language))
# Line 224  Line 263 
263                return(object)                return(object)
264            })            })
265    
266    setGeneric("replaceWords", function(object, words, by, ...) standardGeneric("replaceWords"))
267    setMethod("replaceWords",
268              signature(object = "PlainTextDocument", words = "character", by = "character"),
269              function(object, words, by, ...) {
270                  pattern <- paste(words, collapse = "|")
271                  Corpus(object) <- gsub(pattern, by, Corpus(object))
272                  return(object)
273              })
274    
275  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
276  setMethod("tmFilter",  setMethod("tmFilter",
277            signature(object = "TextDocCol"),            signature(object = "TextDocCol"),
# Line 246  Line 294 
294    
295  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
296      con <- textConnection(s)      con <- textConnection(s)
297      tokens <- scan(con, "character")      tokens <- scan(con, "character", quiet = TRUE)
298      close(con)      close(con)
299      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
300      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
# Line 285  Line 333 
333                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
334                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
335                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
336                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
337                }                }
338                else                else
# Line 378  Line 425 
425                        }                        }
426                        counter <- counter + 1                        counter <- counter + 1
427                    }                    }
                   dbDisconnect(db)  
428                }                }
429                else                else
430                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 391  Line 437 
437                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
438                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
439                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
440                    return(loadDoc(result))                    return(loadDoc(result))
441                }                }
442                else                else
# Line 406  Line 451 
451                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
452                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
453                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
454                }                }
455                else                else
456                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
# Line 576  Line 620 
620                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
621                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
622                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
623                }                }
624                else                else
625                    show(object@.Data)                    show(object@.Data)
# Line 590  Line 633 
633                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
634                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
635                    result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))
                   dbDisconnect(db)  
636                }                }
637                else                else
638                    result <- x %in% y                    result <- x %in% y
# Line 603  Line 645 
645                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
646                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
647                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
648                }                }
649                else                else
650                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
# Line 616  Line 657 
657                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
658                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
659                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
660                }                }
661                else                else
662                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)

Legend:
Removed from v.744  
changed lines
  Added in v.777

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