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 721, Wed Mar 21 13:54:43 2007 UTC revision 744, Mon Apr 23 00:35:10 2007 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator parser  # The "..." are additional arguments for the FunctionGenerator reader
4  setGeneric("TextDocCol", function(object,  setGeneric("TextDocCol", function(object,
5                                    parserControl = list(parser = readPlain, language = "en_US", load = FALSE),                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
7                                    ...) standardGeneric("TextDocCol"))                                    ...) standardGeneric("TextDocCol"))
8  setMethod("TextDocCol",  setMethod("TextDocCol",
9            signature(object = "Source"),            signature(object = "Source"),
10            function(object,            function(object,
11                     parserControl = list(parser = readPlain, 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 (inherits(parserControl$parser, "FunctionGenerator"))                if (attr(readerControl$reader, "FunctionGenerator"))
15                    parserControl$parser <- parserControl$parser(...)                    readerControl$reader <- readerControl$reader(...)
16    
17                if (dbControl$useDb) {                if (dbControl$useDb) {
18                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
# Line 28  Line 28 
28                    # If there is no Load on Demand support                    # If there is no Load on Demand support
29                    # we need to load the corpus into memory at startup                    # we need to load the corpus into memory at startup
30                    if (!object@LoDSupport)                    if (!object@LoDSupport)
31                        parserControl$load <- TRUE                        readerControl$load <- TRUE
32                    doc <- parserControl$parser(elem, parserControl$load, parserControl$language, as.character(counter))                    doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter))
33                    if (dbControl$useDb) {                    if (dbControl$useDb) {
34                        dbInsert(db, ID(doc), doc)                        dbInsert(db, ID(doc), doc)
35                        tdl <- c(tdl, ID(doc))                        tdl <- c(tdl, ID(doc))
# Line 42  Line 42 
42                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
43                if (dbControl$useDb) {                if (dbControl$useDb) {
44                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
45                    dmeta.df <- data.frame(key = "DMetaData")                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
46                    dbDisconnect(db)                    dbDisconnect(db)
47                }                }
48                else                else
# Line 95  Line 95 
95                    mail <- readLines(con)                    mail <- readLines(con)
96                    close(con)                    close(con)
97                    Cached(object) <- TRUE                    Cached(object) <- TRUE
98                    for (index in seq(along = mail)) {                    for (index in seq_along(mail)) {
99                        if (mail[index] == "")                        if (mail[index] == "")
100                            break                            break
101                    }                    }
# Line 108  Line 108 
108    
109  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
110                                  origin,                                  origin,
111                                  parserControl = list(parser = readPlain, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),
112                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
113  # Update is only supported for directories  # Update is only supported for directories
114  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
115  setMethod("tmUpdate",  setMethod("tmUpdate",
116            signature(object = "TextDocCol", origin = "DirSource"),            signature(object = "TextDocCol", origin = "DirSource"),
117            function(object, origin,            function(object, origin,
118                     parserControl = list(parser = readPlain, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),
119                     ...) {                     ...) {
120                if (inherits(parserControl$parser, "FunctionGenerator"))                if (inherits(readerControl$reader, "FunctionGenerator"))
121                    parserControl$parser <- parserControl$parser(...)                    readerControl$reader <- readerControl$reader(...)
122    
123                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))                object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]}))
124                new.files <- setdiff(origin@FileList, object.filelist)                new.files <- setdiff(origin@FileList, object.filelist)
# Line 126  Line 126 
126                for (filename in new.files) {                for (filename in new.files) {
127                    elem <- list(content = readLines(filename),                    elem <- list(content = readLines(filename),
128                                 uri = substitute(file(filename)))                                 uri = substitute(file(filename)))
129                    object <- appendElem(object, parserControl$parser(elem, parserControl$load, parserControl$language, filename))                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))
130                }                }
131    
132                return(object)                return(object)
# Line 140  Line 140 
140                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
141                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]]) {
142                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
143                    new <- lapply(object, FUN, ..., DMetaData = DMetaData(object))                    i <- 1
144                    ids <- lapply(object, ID)                    for (id in unlist(object)) {
145                    # Avoidance of explicit loop is probably more efficient                        db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
146                    for (i in length(new)) {                        i <- i + 1
                       db[[ids[i]]] <- new[[i]]  
147                    }                    }
148                    dbDisconnect(db)                    dbDisconnect(db)
149                }                }
# Line 170  Line 169 
169    
170                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
171            })            })
172    setMethod("asPlain",
173              signature(object = "NewsgroupDocument"),
174              function(object, FUN, ...) {
175                  new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),
176                      DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
177                      Origin = Origin(object), Heading = Heading(object), Language = Language(object))
178              })
179    
180  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))
181  setMethod("tmTolower",  setMethod("tmTolower",
# Line 200  Line 206 
206                return(object)                return(object)
207            })            })
208    
209    setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))
210    setMethod("removePunctuation",
211              signature(object = "PlainTextDocument"),
212              function(object, ...) {
213                  Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))
214                  return(object)
215              })
216    
217  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))
218  setMethod("removeWords",  setMethod("removeWords",
219            signature(object = "PlainTextDocument", stopwords = "character"),            signature(object = "PlainTextDocument", stopwords = "character"),
# Line 217  Line 231 
231                if (doclevel)                if (doclevel)
232                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
233                else                else
234                    return(object[FUN(object, ...)]) # TODO: Check that FUN knows about the database                    return(object[FUN(object, ...)])
235            })            })
236    
237  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))
# Line 227  Line 241 
241                if (doclevel)                if (doclevel)
242                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
243                else                else
244                    return(FUN(object, ...)) # TODO: Check that FUN knows about the database                    return(FUN(object, ...))
245            })            })
246    
247  sFilter <- function(object, s, ...) {  sFilter <- function(object, s, ...) {
# Line 236  Line 250 
250      close(con)      close(con)
251      localMetaNames <- unique(names(sapply(object, LocalMetaData)))      localMetaNames <- unique(names(sapply(object, LocalMetaData)))
252      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]      localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
253      query.df <- DMetaData(prescindMeta(object,      n <- names(DMetaData(object))
254                                         c("Author", "DateTimeStamp", "Description", "ID",      tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)
255                                           "Origin", "Heading", "Language", localMetaTokens)))      query.df <- DMetaData(prescindMeta(object, tags))
256        if (DBControl(object)[["useDb"]])
257            DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]
258      # Rename to avoid name conflicts      # Rename to avoid name conflicts
259      names(query.df)[names(query.df) == "Author"] <- "author"      names(query.df)[names(query.df) == "Author"] <- "author"
260      names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"      names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"
# Line 293  Line 309 
309  setMethod("removeMeta",  setMethod("removeMeta",
310            signature(object = "TextDocCol"),            signature(object = "TextDocCol"),
311            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
312                if (!is.null(cname)) {                if (!is.null(cname))
313                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]
314                }                if (!is.null(dname))
315                if (!is.null(dname)) {                    DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE]
                   DMetaData(object) <- DMetaData(object)[names(DMetaData(object)) != dname]  
               }  
316                return(object)                return(object)
317            })            })
318    
 # WARNING: If dbUse the augmented dataframe is stored (watch out since sFilter calls this method)  
319  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
320  setMethod("prescindMeta",  setMethod("prescindMeta",
321            signature(object = "TextDocCol", meta = "character"),            signature(object = "TextDocCol", meta = "character"),
# Line 330  Line 343 
343                return(object)                return(object)
344            })            })
345    
 # WARNING: DMetaData is changed (since both use the same database)  
346  setMethod("[",  setMethod("[",
347            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
348            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
# Line 339  Line 351 
351    
352                object <- x                object <- x
353                object@.Data <- x@.Data[i, ..., drop = FALSE]                object@.Data <- x@.Data[i, ..., drop = FALSE]
354                df <- as.data.frame(DMetaData(x)[i, ])                if (DBControl(object)[["useDb"]]) {
355                names(df) <- names(DMetaData(x))                    index <- object@DMetaData[[1 , "subset"]]
356                DMetaData(object) <- df                    if (any(is.na(index)))
357                          object@DMetaData[[1 , "subset"]] <- i
358                      else
359                          object@DMetaData[[1 , "subset"]] <- index[i]
360                  }
361                  else
362                      DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]
363                return(object)                return(object)
364            })            })
365    
 # TODO  
366  setMethod("[<-",  setMethod("[<-",
367            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),
368            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
369                object <- x                object <- x
370                  if (DBControl(object)[["useDb"]]) {
371                      db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
372                      counter <- 1
373                      for (id in object@.Data[i, ...]) {
374                          if (length(value) == 1)
375                              db[[id]] <- value
376                          else {
377                              db[[id]] <- value[[counter]]
378                          }
379                          counter <- counter + 1
380                      }
381                      dbDisconnect(db)
382                  }
383                  else
384                object@.Data[i, ...] <- value                object@.Data[i, ...] <- value
385                return(object)                return(object)
386            })            })
# Line 419  Line 450 
450    
451                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "TextDocCol")))
452                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
453                if (DBControl(x)$useDb == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
454                    stop("concatenating text document collections with activated database is not supported")                    stop("concatenating text document collections with activated database is not supported")
455    
456                result <- x                result <- x
# Line 530  Line 561 
561                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),                                                "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
562                                         length(CMetaData(object)@MetaData)))                                         length(CMetaData(object)@MetaData)))
563                    cat("Available tags are:\n")                    cat("Available tags are:\n")
564                    cat(names(CMetaData(object)@MetaData), "\n")                    cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
565                    cat("Available variables in the data frame are:\n")                    cat("Available variables in the data frame are:\n")
566                    cat(names(DMetaData(object)), "\n")                    cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
567                }                }
568      })      })
569    
# Line 556  Line 587 
587  setMethod("%IN%",  setMethod("%IN%",
588            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "TextDocCol"),
589            function(x, y) {            function(x, y) {
590                x %in% y                if (DBControl(y)[["useDb"]]) {
591                      db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
592                      result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))
593                      dbDisconnect(db)
594                  }
595                  else
596                      result <- x %in% y
597                  return(result)
598            })            })
599    
600  setMethod("lapply",  setMethod("lapply",

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

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