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 799, Thu Nov 29 11:05:23 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                  if (is.null(readerControl$reader))
17                      readerControl$reader <- object@DefaultReader
18                  if (is.null(readerControl$language))
19                      readerControl$language = "en_US"
20                  if (is.null(readerControl$load))
21                      readerControl$load = FALSE
22    
23                if (dbControl$useDb) {                if (dbControl$useDb) {
24                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
# Line 43  Line 49 
49                if (dbControl$useDb) {                if (dbControl$useDb) {
50                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
51                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
52                }                }
53                else                else
54                    dmeta.df <- df                    dmeta.df <- df
# Line 105  Line 110 
110                    return(object)                    return(object)
111                }                }
112            })            })
113    setMethod("loadDoc",
114              signature(object = "StructuredTextDocument"),
115              function(object, ...) {
116                  if (!Cached(object)) {
117                      warning("load on demand not (yet) supported for StructuredTextDocuments")
118                      return(object)
119                  } else
120                      return(object)
121              })
122    
123  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
124                                  origin,                                  origin,
# Line 117  Line 131 
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 = FALSE),
133                     ...) {                     ...) {
134                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is(readerControl$reader, "FunctionGenerator"))
135                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
136    
137                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 159 
159                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
160                        i <- i + 1                        i <- i + 1
161                    }                    }
                   dbDisconnect(db)  
162                }                }
163                else                else
164                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
# Line 170  Line 183 
183                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
184            })            })
185  setMethod("asPlain",  setMethod("asPlain",
186            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
187            function(object, FUN, ...) {            function(object, FUN, ...) {
188                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                FUN <- convertReut21578XMLPlain
189                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),                corpus <- Corpus(object)
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
190    
191  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                # As XMLDocument is no native S4 class, restore valid information
192  setMethod("tmTolower",                class(corpus) <- "XMLDocument"
193            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
194    
195  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stripWhitespace",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
196            })            })
197    setMethod("asPlain",
198              signature(object = "RCV1Document"),
199              function(object, FUN, ...) {
200                  FUN <- convertRCV1Plain
201                  corpus <- Corpus(object)
202    
203  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))                # As XMLDocument is no native S4 class, restore valid information
204  setMethod("stemDoc",                class(corpus) <- "XMLDocument"
205            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, language = "english", ...) {  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- if (require("Rstem"))  
                   Rstem::wordStem(splittedCorpus, language)  
               else  
                   SnowballStemmer(splittedCorpus, Weka_control(S = language))  
               Corpus(object) <- paste(stemmedCorpus, collapse = " ")  
               return(object)  
           })  
206    
207  setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("removePunctuation",  
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
208            })            })
209    setMethod("asPlain",
210  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "NewsgroupDocument"),
211  setMethod("removeWords",            function(object, FUN, ...) {
212            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),
213            function(object, stopwords, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
214                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object))
215                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]            })
216                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")  setMethod("asPlain",
217                return(object)            signature(object = "StructuredTextDocument"),
218              function(object, FUN, ...) {
219                  new("PlainTextDocument", .Data = unlist(Corpus(object)), Cached = TRUE,
220                      URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
221                      Description = Description(object), ID = ID(object), Origin = Origin(object),
222                      Heading = Heading(object), Language = Language(object))
223            })            })
224    
225  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
# Line 246  Line 244 
244    
245  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
246      con <- textConnection(s)      con <- textConnection(s)
247      tokens <- scan(con, "character")      tokens <- scan(con, "character", quiet = TRUE)
248      close(con)      close(con)
249      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
250      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
# Line 269  Line 267 
267      return(result)      return(result)
268  }  }
269    
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
270  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
271  setMethod("appendElem",  setMethod("appendElem",
272            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "TextDocCol", data = "TextDocument"),
# Line 285  Line 276 
276                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
277                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
278                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
279                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
280                }                }
281                else                else
# Line 378  Line 368 
368                        }                        }
369                        counter <- counter + 1                        counter <- counter + 1
370                    }                    }
                   dbDisconnect(db)  
371                }                }
372                else                else
373                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 391  Line 380 
380                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]]) {
381                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
382                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
383                    return(loadDoc(result))                    return(loadDoc(result))
384                }                }
385                else                else
# Line 406  Line 394 
394                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
395                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
396                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
397                }                }
398                else                else
399                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
# Line 576  Line 563 
563                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
564                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
565                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
566                }                }
567                else                else
568                    show(object@.Data)                    show(object@.Data)
# Line 590  Line 576 
576                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]]) {
577                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
578                    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)  
579                }                }
580                else                else
581                    result <- x %in% y                    result <- x %in% y
# Line 603  Line 588 
588                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
589                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
590                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
591                }                }
592                else                else
593                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
# Line 616  Line 600 
600                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]]) {
601                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
602                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
603                }                }
604                else                else
605                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)

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

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