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 744, Mon Apr 23 00:35:10 2007 UTC pkg/R/textdoccol.R revision 886, Thu Jan 29 22:47:34 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # The "..." are additional arguments for the FunctionGenerator reader  # The "..." are additional arguments for the FunctionGenerator reader
4  setGeneric("TextDocCol", function(object,  setGeneric("Corpus", function(object,
5                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                                    readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
6                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                                    dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
7                                    ...) standardGeneric("TextDocCol"))                                    ...) standardGeneric("Corpus"))
8  setMethod("TextDocCol",  setMethod("Corpus",
9            signature(object = "Source"),            signature(object = "Source"),
10            function(object,            function(object,
11                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE),
12                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),                     dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"),
13                     ...) {                     ...) {
14                if (attr(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
15                      readerControl$reader <- object@DefaultReader
16                  if (is(readerControl$reader, "FunctionGenerator"))
17                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
18                  if (is.null(readerControl$language))
19                      readerControl$language = "en_US"
20                  if (is.null(readerControl$load))
21                      readerControl$load = TRUE
22    
23                if (dbControl$useDb) {                if (dbControl$useDb && require("filehash")) {
24                    if (!dbCreate(dbControl$dbName, dbControl$dbType))                    if (!dbCreate(dbControl$dbName, dbControl$dbType))
25                        stop("error in creating database")                        stop("error in creating database")
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 30  Line 41 
41                    if (!object@LoDSupport)                    if (!object@LoDSupport)
42                        readerControl$load <- TRUE                        readerControl$load <- TRUE
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 && require("filehash")) {
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    
60                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
61                if (dbControl$useDb) {                if (dbControl$useDb && require("filehash")) {
62                    dbInsert(db, "DMetaData", df)                    dbInsert(db, "DMetaData", df)
63                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                    dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
                   dbDisconnect(db)  
64                }                }
65                else                else
66                    dmeta.df <- df                    dmeta.df <- df
# Line 53  Line 70 
70                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
71                              children = list())                              children = list())
72    
73                return(new("TextDocCol", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))                return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl))
74            })            })
75    
76  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))  setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc"))
# Line 64  Line 81 
81                    con <- eval(URI(object))                    con <- eval(URI(object))
82                    corpus <- readLines(con)                    corpus <- readLines(con)
83                    close(con)                    close(con)
84                    Corpus(object) <- corpus                    Content(object) <- corpus
85                    Cached(object) <- TRUE                    Cached(object) <- TRUE
86                    return(object)                    return(object)
87                } else {                } else {
# Line 74  Line 91 
91  setMethod("loadDoc",  setMethod("loadDoc",
92            signature(object =  "XMLTextDocument"),            signature(object =  "XMLTextDocument"),
93            function(object, ...) {            function(object, ...) {
94                if (!Cached(object)) {                if (!Cached(object) && require("XML")) {
95                    con <- eval(URI(object))                    con <- eval(URI(object))
96                    corpus <- paste(readLines(con), "\n", collapse = "")                    corpus <- paste(readLines(con), "\n", collapse = "")
97                    close(con)                    close(con)
98                    doc <- xmlTreeParse(corpus, asText = TRUE)                    doc <- xmlTreeParse(corpus, asText = TRUE)
99                    class(doc) <- "list"                    class(doc) <- "list"
100                    Corpus(object) <- doc                    Content(object) <- doc
101                    Cached(object) <- TRUE                    Cached(object) <- TRUE
102                    return(object)                    return(object)
103                } else {                } else {
# Line 99  Line 116 
116                        if (mail[index] == "")                        if (mail[index] == "")
117                            break                            break
118                    }                    }
119                    Corpus(object) <- mail[(index + 1):length(mail)]                    Content(object) <- mail[(index + 1):length(mail)]
120                    return(object)                    return(object)
121                } else {                } else {
122                    return(object)                    return(object)
123                }                }
124            })            })
125    setMethod("loadDoc",
126              signature(object = "StructuredTextDocument"),
127              function(object, ...) {
128                  if (!Cached(object)) {
129                      warning("load on demand not (yet) supported for StructuredTextDocuments")
130                      return(object)
131                  } else
132                      return(object)
133              })
134    
135  setGeneric("tmUpdate", function(object,  setGeneric("tmUpdate", function(object,
136                                  origin,                                  origin,
137                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                                  readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
138                                  ...) standardGeneric("tmUpdate"))                                  ...) standardGeneric("tmUpdate"))
139  # Update is only supported for directories  # Update is only supported for directories
140  # At the moment no other LoD devices are available anyway  # At the moment no other LoD devices are available anyway
141  setMethod("tmUpdate",  setMethod("tmUpdate",
142            signature(object = "TextDocCol", origin = "DirSource"),            signature(object = "Corpus", origin = "DirSource"),
143            function(object, origin,            function(object, origin,
144                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),                     readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE),
145                     ...) {                     ...) {
146                if (inherits(readerControl$reader, "FunctionGenerator"))                if (is.null(readerControl$reader))
147                      readerControl$reader <- origin@DefaultReader
148                  if (is(readerControl$reader, "FunctionGenerator"))
149                    readerControl$reader <- readerControl$reader(...)                    readerControl$reader <- readerControl$reader(...)
150                  if (is.null(readerControl$language))
151                      readerControl$language = "en_US"
152                  if (is.null(readerControl$load))
153                      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) {
159                    elem <- list(content = readLines(filename),                    encoding <- origin@Encoding
160                                 uri = substitute(file(filename)))                    elem <- list(content = readLines(filename, encoding = encoding),
161                                   uri = substitute(file(filename, encoding = encoding)))
162                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))                    object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename))
163                }                }
164    
165                return(object)                return(object)
166            })            })
167    
168  setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))  setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap"))
169  setMethod("tmMap",  setMethod("tmMap",
170            signature(object = "TextDocCol", FUN = "function"),            signature(object = "Corpus", FUN = "function"),
171            function(object, FUN, ...) {            function(object, FUN, ..., lazy = FALSE) {
172                result <- object                result <- object
173                # Note that text corpora are automatically loaded into memory via \code{[[}                # Note that text corpora are automatically loaded into memory via \code{[[}
174                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
175                      if (lazy)
176                          warning("lazy mapping is deactived when using database backend")
177                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
178                    i <- 1                    i <- 1
179                    for (id in unlist(object)) {                    for (id in unlist(object)) {
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                    dbDisconnect(db)                    # Suggested by Christian Buchta
184                      dbReorganize(db)
185                  }
186                  else {
187                      # Lazy mapping
188                      if (lazy) {
189                          lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
190                          if (is.null(lazyTmMap)) {
191                              meta(result, tag = "lazyTmMap", type = "corpus") <-
192                                  list(index = rep(TRUE, length(result)),
193                                       maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
194                          }
195                          else {
196                              lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData)))
197                              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
211    # Improvements by Christian Buchta
212    materialize <- function(corpus, range = seq_along(corpus)) {
213        lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus")
214        if (!is.null(lazyTmMap)) {
215           # Make valid and lazy index
216           idx <- (seq_along(corpus) %in% range) & lazyTmMap$index
217           if (any(idx)) {
218               res <- lapply(corpus@.Data[idx], loadDoc)
219               for (m in lazyTmMap$maps)
220                   res <- lapply(res, m, DMetaData = DMetaData(corpus))
221               corpus@.Data[idx] <- res
222               lazyTmMap$index[idx] <- FALSE
223           }
224        }
225        # Clean up if everything is materialized
226        if (!any(lazyTmMap$index))
227            lazyTmMap <- NULL
228        meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
229        return(corpus)
230    }
231    
232  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))  setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
233  setMethod("asPlain",  setMethod("asPlain",
234            signature(object = "PlainTextDocument"),            signature(object = "PlainTextDocument"),
# Line 159  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 <- Corpus(object)                require("XML")
242    
243                  corpus <- Content(object)
244    
245                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
246                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 170  Line 249 
249                return(FUN(xmlRoot(corpus), ...))                return(FUN(xmlRoot(corpus), ...))
250            })            })
251  setMethod("asPlain",  setMethod("asPlain",
252            signature(object = "NewsgroupDocument"),            signature(object = "Reuters21578Document"),
253            function(object, FUN, ...) {            function(object, FUN, ...) {
254                new("PlainTextDocument", .Data = Corpus(object), Cached = TRUE, URI = "", Author = Author(object),                require("XML")
                   DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),  
                   Origin = Origin(object), Heading = Heading(object), Language = Language(object))  
           })  
255    
256  setGeneric("tmTolower", function(object, ...) standardGeneric("tmTolower"))                FUN <- convertReut21578XMLPlain
257  setMethod("tmTolower",                corpus <- Content(object)
           signature(object = "PlainTextDocument"),  
           function(object, ...) {  
               Corpus(object) <- tolower(object)  
               return(object)  
           })  
258    
259  setGeneric("stripWhitespace", function(object, ...) standardGeneric("stripWhitespace"))                # As XMLDocument is no native S4 class, restore valid information
260  setMethod("stripWhitespace",                class(corpus) <- "XMLDocument"
261            signature(object = "PlainTextDocument"),                names(corpus) <- c("doc","dtd")
           function(object, ...) {  
               Corpus(object) <- gsub("[[:space:]]+", " ", object)  
               return(object)  
           })  
262    
263  setGeneric("stemDoc", function(object, language = "english", ...) standardGeneric("stemDoc"))                return(FUN(xmlRoot(corpus), ...))
 setMethod("stemDoc",  
           signature(object = "PlainTextDocument"),  
           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)  
264            })            })
265    setMethod("asPlain",
266  setGeneric("removePunctuation", function(object, ...) standardGeneric("removePunctuation"))            signature(object = "RCV1Document"),
267  setMethod("removePunctuation",            function(object, FUN, ...) {
268            signature(object = "PlainTextDocument"),                return(convertRCV1Plain(object, ...))
           function(object, ...) {  
               Corpus(object) <- gsub("[[:punct:]]+", "", Corpus(object))  
               return(object)  
269            })            })
270    setMethod("asPlain",
271  setGeneric("removeWords", function(object, stopwords, ...) standardGeneric("removeWords"))            signature(object = "NewsgroupDocument"),
272  setMethod("removeWords",            function(object, FUN, ...) {
273            signature(object = "PlainTextDocument", stopwords = "character"),                new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = NULL, Author = Author(object),
274            function(object, stopwords, ...) {                    DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
275                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                    Origin = Origin(object), Heading = Heading(object), Language = Language(object),
276                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                    LocalMetaData = LocalMetaData(object))
277                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")            })
278                return(object)  setMethod("asPlain",
279              signature(object = "StructuredTextDocument"),
280              function(object, FUN, ...) {
281                  new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
282                      URI = NULL, Author = Author(object), DateTimeStamp = DateTimeStamp(object),
283                      Description = Description(object), ID = ID(object), Origin = Origin(object),
284                      Heading = Heading(object), Language = Language(object),
285                      LocalMetaData = LocalMetaData(object))
286            })            })
287    
288  setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))  setGeneric("tmFilter", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmFilter"))
289  setMethod("tmFilter",  setMethod("tmFilter",
290            signature(object = "TextDocCol"),            signature(object = "Corpus"),
291            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
292                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
293                      doclevel <- attr(FUN, "doclevel")
294                  if (doclevel) {
295                      if (clusterAvailable())
296                          return(object[snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object))])
297                      else
298                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])                    return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
299                  }
300                else                else
301                    return(object[FUN(object, ...)])                    return(object[FUN(object, ...)])
302            })            })
303    
304  setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))  setGeneric("tmIndex", function(object, ..., FUN = searchFullText, doclevel = TRUE) standardGeneric("tmIndex"))
305  setMethod("tmIndex",  setMethod("tmIndex",
306            signature(object = "TextDocCol"),            signature(object = "Corpus"),
307            function(object, ..., FUN = sFilter, doclevel = FALSE) {            function(object, ..., FUN = searchFullText, doclevel = TRUE) {
308                if (doclevel)                if (!is.null(attr(FUN, "doclevel")))
309                      doclevel <- attr(FUN, "doclevel")
310                  if (doclevel) {
311                      if (clusterAvailable())
312                          return(snow::parSapply(snow::getMPIcluster(), object, FUN, ..., DMetaData = DMetaData(object)))
313                      else
314                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))                    return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
315                  }
316                else                else
317                    return(FUN(object, ...))                    return(FUN(object, ...))
318            })            })
319    
 sFilter <- function(object, s, ...) {  
     con <- textConnection(s)  
     tokens <- scan(con, "character")  
     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)  
 }  
   
 setGeneric("searchFullText", function(object, pattern, ...) standardGeneric("searchFullText"))  
 setMethod("searchFullText",  
           signature(object = "PlainTextDocument", pattern = "character"),  
           function(object, pattern, ...) {  
               return(any(grep(pattern, Corpus(object))))  
           })  
   
320  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))  setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
321  setMethod("appendElem",  setMethod("appendElem",
322            signature(object = "TextDocCol", data = "TextDocument"),            signature(object = "Corpus", data = "TextDocument"),
323            function(object, data, meta = NULL) {            function(object, data, meta = NULL) {
324                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
325                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
326                    if (dbExists(db, ID(data)))                    if (dbExists(db, ID(data)))
327                        warning("document with identical ID already exists")                        warning("document with identical ID already exists")
328                    dbInsert(db, ID(data), data)                    dbInsert(db, ID(data), data)
                   dbDisconnect(db)  
329                    object@.Data[[length(object)+1]] <- ID(data)                    object@.Data[[length(object)+1]] <- ID(data)
330                }                }
331                else                else
# Line 296  Line 336 
336    
337  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))  setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
338  setMethod("appendMeta",  setMethod("appendMeta",
339            signature(object = "TextDocCol"),            signature(object = "Corpus"),
340            function(object, cmeta = NULL, dmeta = NULL) {            function(object, cmeta = NULL, dmeta = NULL) {
341                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)                object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
342                if (!is.null(dmeta)) {                if (!is.null(dmeta)) {
# Line 307  Line 347 
347    
348  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))  setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
349  setMethod("removeMeta",  setMethod("removeMeta",
350            signature(object = "TextDocCol"),            signature(object = "Corpus"),
351            function(object, cname = NULL, dname = NULL) {            function(object, cname = NULL, dname = NULL) {
352                if (!is.null(cname))                if (!is.null(cname))
353                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]                    object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]
# Line 318  Line 358 
358    
359  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))  setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
360  setMethod("prescindMeta",  setMethod("prescindMeta",
361            signature(object = "TextDocCol", meta = "character"),            signature(object = "Corpus", meta = "character"),
362            function(object, meta) {            function(object, meta) {
363                for (m in meta) {                for (m in meta) {
364                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {                    if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
365                        local.m <- lapply(object, m)                        local.m <- lapply(object, m)
366                          local.m <- sapply(local.m, paste, collapse = " ")
367                        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))
368                        local.m <- unlist(local.m)                        local.m <- unlist(local.m)
369                        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 344  Line 385 
385            })            })
386    
387  setMethod("[",  setMethod("[",
388            signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
389            function(x, i, j, ... , drop) {            function(x, i, j, ... , drop) {
390                if(missing(i))                if(missing(i))
391                    return(x)                    return(x)
392    
393                object <- x                object <- x
394                object@.Data <- x@.Data[i, ..., drop = FALSE]                object@.Data <- x@.Data[i, ..., drop = FALSE]
395                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
396                    index <- object@DMetaData[[1 , "subset"]]                    index <- object@DMetaData[[1 , "subset"]]
397                    if (any(is.na(index)))                    if (any(is.na(index)))
398                        object@DMetaData[[1 , "subset"]] <- i                        object@DMetaData[[1 , "subset"]] <- i
# Line 364  Line 405 
405            })            })
406    
407  setMethod("[<-",  setMethod("[<-",
408            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
409            function(x, i, j, ... , value) {            function(x, i, j, ... , value) {
410                object <- x                object <- x
411                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
412                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
413                    counter <- 1                    counter <- 1
414                    for (id in object@.Data[i, ...]) {                    for (id in object@.Data[i, ...]) {
# Line 378  Line 419 
419                        }                        }
420                        counter <- counter + 1                        counter <- counter + 1
421                    }                    }
                   dbDisconnect(db)  
422                }                }
423                else                else
424                    object@.Data[i, ...] <- value                    object@.Data[i, ...] <- value
# Line 386  Line 426 
426            })            })
427    
428  setMethod("[[",  setMethod("[[",
429            signature(x = "TextDocCol", i = "ANY", j = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY"),
430            function(x, i, j, ...) {            function(x, i, j, ...) {
431                if (DBControl(x)[["useDb"]]) {                if (DBControl(x)[["useDb"]] && require("filehash")) {
432                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])                    db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
433                    result <- dbFetch(db, x@.Data[[i]])                    result <- dbFetch(db, x@.Data[[i]])
                   dbDisconnect(db)  
434                    return(loadDoc(result))                    return(loadDoc(result))
435                }                }
436                else                else {
437                      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
438                      if (!is.null(lazyTmMap))
439                          .Call("copyCorpus", x, materialize(x, i))
440                    return(loadDoc(x@.Data[[i]]))                    return(loadDoc(x@.Data[[i]]))
441                  }
442            })            })
443    
444  setMethod("[[<-",  setMethod("[[<-",
445            signature(x = "TextDocCol", i = "ANY", j = "ANY", value = "ANY"),            signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
446            function(x, i, j, ..., value) {            function(x, i, j, ..., value) {
447                object <- x                object <- x
448                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
449                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
450                    index <- object@.Data[[i]]                    index <- object@.Data[[i]]
451                    db[[index]] <- value                    db[[index]] <- value
                   dbDisconnect(db)  
452                }                }
453                else                else {
454                      # Mark new objects as not active for lazy mapping
455                      lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus")
456                      if (!is.null(lazyTmMap)) {
457                          lazyTmMap$index[i] <- FALSE
458                          meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
459                      }
460                      # Set the value
461                    object@.Data[[i, ...]] <- value                    object@.Data[[i, ...]] <- value
462                  }
463                return(object)                return(object)
464            })            })
465    
# Line 442  Line 492 
492  }  }
493    
494  setMethod("c",  setMethod("c",
495            signature(x = "TextDocCol"),            signature(x = "Corpus"),
496            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
497                args <- list(...)                args <- list(...)
498                if (length(args) == 0)                if (length(args) == 0)
499                    return(x)                    return(x)
500    
501                if (!all(sapply(args, inherits, "TextDocCol")))                if (!all(sapply(args, inherits, "Corpus")))
502                    stop("not all arguments are text document collections")                    stop("not all arguments are text document collections")
503                if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))                if (DBControl(x)[["useDb"]] || any(unlist(sapply(args, DBControl)["useDb", ])))
504                    stop("concatenating text document collections with activated database is not supported")                    stop("concatenating text document collections with activated database is not supported")
505    
506                result <- x                result <- x
# Line 462  Line 512 
512    
513  setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))  setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))
514  setMethod("c2",  setMethod("c2",
515            signature(x = "TextDocCol", y = "TextDocCol"),            signature(x = "Corpus", y = "Corpus"),
516            function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {            function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
517                object <- x                object <- x
518                # Concatenate data slots                # Concatenate data slots
# Line 529  Line 579 
579                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),                              MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
580                              children = list())                              children = list())
581    
582                return(new("TextDocCol",                return(new("Corpus",
583                           .Data = list(x, ...),                           .Data = list(x, ...),
584                           DMetaData = dmeta.df,                           DMetaData = dmeta.df,
585                           CMetaData = cmeta.node,                           CMetaData = cmeta.node,
# Line 537  Line 587 
587            })            })
588    
589  setMethod("length",  setMethod("length",
590            signature(x = "TextDocCol"),            signature(x = "Corpus"),
591            function(x){            function(x){
592                return(length(as(x, "list")))                return(length(as(x, "list")))
593      })      })
594    
595  setMethod("show",  setMethod("show",
596            signature(object = "TextDocCol"),            signature(object = "Corpus"),
597            function(object){            function(object){
598                cat(sprintf(ngettext(length(object),                cat(sprintf(ngettext(length(object),
599                                     "A text document collection with %d text document\n",                                     "A text document collection with %d text document\n",
# Line 552  Line 602 
602      })      })
603    
604  setMethod("summary",  setMethod("summary",
605            signature(object = "TextDocCol"),            signature(object = "Corpus"),
606            function(object){            function(object){
607                show(object)                show(object)
608                if (length(DMetaData(object)) > 0) {                if (length(DMetaData(object)) > 0) {
# Line 569  Line 619 
619    
620  setGeneric("inspect", function(object) standardGeneric("inspect"))  setGeneric("inspect", function(object) standardGeneric("inspect"))
621  setMethod("inspect",  setMethod("inspect",
622            signature("TextDocCol"),            signature("Corpus"),
623            function(object) {            function(object) {
624                summary(object)                summary(object)
625                cat("\n")                cat("\n")
626                if (DBControl(object)[["useDb"]]) {                if (DBControl(object)[["useDb"]] && require("filehash")) {
627                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])                    db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
628                    show(dbMultiFetch(db, unlist(object)))                    show(dbMultiFetch(db, unlist(object)))
                   dbDisconnect(db)  
629                }                }
630                else                else
631                    show(object@.Data)                    print(noquote(lapply(object, identity)))
632            })            })
633    
634  # No metadata is checked  # No metadata is checked
635  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))  setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
636  setMethod("%IN%",  setMethod("%IN%",
637            signature(x = "TextDocument", y = "TextDocCol"),            signature(x = "TextDocument", y = "Corpus"),
638            function(x, y) {            function(x, y) {
639                if (DBControl(y)[["useDb"]]) {                if (DBControl(y)[["useDb"]] && require("filehash")) {
640                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])                    db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
641                    result <- any(sapply(y, function(x, z) {x %in% Corpus(z)}, x))                    result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
                   dbDisconnect(db)  
642                }                }
643                else                else
644                    result <- x %in% y                    result <- x %in% y
# Line 598  Line 646 
646            })            })
647    
648  setMethod("lapply",  setMethod("lapply",
649            signature(X = "TextDocCol"),            signature(X = "Corpus"),
650            function(X, FUN, ...) {            function(X, FUN, ...) {
651                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]] && require("filehash")) {
652                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
653                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
654                }                }
655                else                else {
656                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
657                      if (!is.null(lazyTmMap))
658                          .Call("copyCorpus", X, materialize(X))
659                    result <- base::lapply(X, FUN, ...)                    result <- base::lapply(X, FUN, ...)
660                  }
661                return(result)                return(result)
662            })            })
663    
664  setMethod("sapply",  setMethod("sapply",
665            signature(X = "TextDocCol"),            signature(X = "Corpus"),
666            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {            function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
667                if (DBControl(X)[["useDb"]]) {                if (DBControl(X)[["useDb"]] && require("filehash")) {
668                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])                    db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
669                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)                    result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
                   dbDisconnect(db)  
670                }                }
671                else                else {
672                      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
673                      if (!is.null(lazyTmMap))
674                          .Call("copyCorpus", X, materialize(X))
675                    result <- base::sapply(X, FUN, ...)                    result <- base::sapply(X, FUN, ...)
676                  }
677                return(result)                return(result)
678            })            })
679    
680    setAs("list", "Corpus", function(from) {
681        cmeta.node <- new("MetaDataNode",
682                          NodeID = 0,
683                          MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
684                          children = list())
685        data <- list()
686        counter <- 1
687        for (f in from) {
688            doc <- new("PlainTextDocument",
689                       .Data = f, URI = NULL, Cached = TRUE,
690                       Author = "", DateTimeStamp = Sys.time(),
691                       Description = "", ID = as.character(counter),
692                       Origin = "", Heading = "", Language = "en_US")
693            data <- c(data, list(doc))
694            counter <- counter + 1
695        }
696        return(new("Corpus", .Data = data,
697                   DMetaData = data.frame(MetaID = rep(0, length(from)), stringsAsFactors = FALSE),
698                   CMetaData = cmeta.node,
699                   DBControl = dbControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")))
700    })
701    
702    setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus"))
703    setMethod("writeCorpus",
704              signature(object = "Corpus"),
705              function(object, path = ".", filenames = NULL) {
706                  filenames <- file.path(path,
707                                         if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x)))
708                                         else filenames)
709                  i <- 1
710                  for (o in object) {
711                      writeLines(asPlain(o), filenames[i])
712                      i <- i + 1
713                  }
714              })

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

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