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/R/textmin/R/textdoccol.R revision 49, Sun Aug 6 10:12:13 2006 UTC pkg/R/corpus.R revision 1114, Fri Nov 26 14:05:54 2010 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
4  setMethod("TextDocCol",      attr(x, "CMetaData") <- cmeta
5            c("character"),      attr(x, "DMetaData") <- dmeta
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {      attr(x, "DBControl") <- dbcontrol
7                # Add a new type for each unique input source format      class(x) <- c("PCorpus", "Corpus", "list")
8                type <- match.arg(inputType,c("CSV", "RCV1_PLAIN", "REUT21578_PLAIN", "REUT21578_XML", "RIS"))      x
9                switch(type,  }
10                       # Text in a special CSV format  DBControl <- function(x) attr(x, "DBControl")
11                       # For details on the file format see the R documentation file  
12                       # The first argument is a directory with .csv files  PCorpus <- function(x,
13                       "CSV" = {                      readerControl = list(reader = x$DefaultReader, language = "en"),
14                           filelist <- dir(object, pattern = ".csv", full.names = TRUE)                      dbControl = list(dbName = "", dbType = "DB1"),
15                           tdl <- sapply(filelist,                      ...) {
16                                         function(file) {      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
17                                             m <- as.matrix(read.csv(file, header = FALSE))  
18                                             l <- vector("list", dim(m)[1])      if (is.function(readerControl$init))
19                                             for (i in 1:dim(m)[1]) {          readerControl$init()
20                                                 author <- ""  
21                                                 datetimestamp <- date()      if (is.function(readerControl$exit))
22                                                 description <- ""          on.exit(readerControl$exit())
23                                                 id <- as.integer(m[i,1])  
24                                                 corpus <- as.character(m[i,2:dim(m)[2]])      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
25                                                 if (stripWhiteSpace)          stop("error in creating database")
26                                                     corpus <- gsub("[[:space:]]+", " ", corpus)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
27                                                 if (toLower)  
28                                                     corpus <- tolower(corpus)      # Allocate memory in advance if length is known
29                                                 origin <- "CSV"      tdl <- if (x$Length > 0)
30                                                 heading <- ""          vector("list", as.integer(x$Length))
   
                                                l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
                                                              Description = description, ID = id, Origin = origin, Heading = heading)  
                                            }  
                                            l  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format  
                      # The first argument is a directory with the RCV1 XML files  
                      "RCV1_PLAIN" = {  
                          filelist <- dir(object, pattern = ".xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in text documents in Reuters-21578 XML (not SGML) format  
                      # Typically the first argument will be a directory where we can  
                      # find the files reut2-000.xml ... reut2-021.xml  
                      "REUT21578_PLAIN" = {  
                          filelist <- dir(object, pattern = ".xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      "REUT21578_XML" = {  
                          filelist <- dir(object, pattern = ".xml", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            parseReutersXML(file)  
                                        })  
                          if (length(filelist) > 1)  
                              tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))  
                          else  
                              tdcl <- new("TextDocCol", .Data = tdl)  
                      },  
                      # Read in HTML documents as used by http://ris.bka.gv.at/vwgh  
                      "RIS" = {  
                          filelist <- dir(object, pattern = ".html", full.names = TRUE)  
                          tdl <- sapply(filelist,  
                                        function(file) {  
                                            # Ignore warnings from misformed HTML documents  
                                            suppressWarnings(RISDoc <- parseHTMLPlain(file, stripWhiteSpace, toLower))  
                                            if (!is.null(RISDoc)) {  
                                                l <- list()  
                                                l[[length(l) + 1]] <- RISDoc  
                                                l  
                                            }  
                                        })  
                          tdcl <- new("TextDocCol", .Data = tdl)  
                      })  
               tdcl  
           })  
   
 # Parse an Austrian RIS HTML document  
 parseHTMLPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {  
     author <- ""  
     datetimestamp <- date()  
     description <- ""  
   
     tree <- htmlTreeParse(file)  
     htmlElem <- unlist(tree$children$html$children)  
   
     if (is.null(htmlElem))  
         stop(paste("Empty document", file, "cannot be processed."))  
   
     textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]  
     names(textElem) <- NULL  
   
     corpus <- paste(textElem, collapse = " ")  
   
     year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)  
     senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)  
     number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)  
   
     id <- as.integer(paste(year, senat, number, sep = ""))  
   
     if (is.na(id))  
         stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))  
     origin <- ""  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     heading <- ""  
   
     new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
         Description = description, ID = id, Origin = origin, Heading = heading)  
 }  
   
 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  
 parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  
     author <- "Not yet implemented"  
     datetimestamp <- xmlAttrs(node)[["date"]]  
     description <- "Not yet implemented"  
     id <- as.integer(xmlAttrs(node)[["itemid"]])  
     origin <- "Reuters Corpus Volume 1 XML"  
     corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     heading <- xmlValue(node[["title"]])  
   
     new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
         Description = description, ID = id, Origin = origin, Heading = heading)  
 }  
   
 # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  
 parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  
     # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["AUTHOR"]]))  
         author <- xmlValue(node[["TEXT"]][["AUTHOR"]])  
31      else      else
32          author <- ""          list()
33    
34        counter <- 1
35        while (!eoi(x)) {
36            x <- stepNext(x)
37            elem <- getElem(x)
38            doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
39            filehash::dbInsert(db, ID(doc), doc)
40            if (x$Length > 0) tdl[[counter]] <- ID(doc)
41            else tdl <- c(tdl, ID(doc))
42            counter <- counter + 1
43        }
44        names(tdl) <- x$Names
45    
46      datetimestamp <- xmlValue(node[["DATE"]])      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
47      description <- ""      filehash::dbInsert(db, "DMetaData", df)
48      id <- as.integer(xmlAttrs(node)[["NEWID"]])      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
49    
50      origin <- "Reuters-21578 XML"      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
51    }
52    
53      # The <BODY></BODY> tag is unfortunately NOT obligatory!  .VCorpus <- function(x, cmeta, dmeta) {
54      if (!is.null(node[["TEXT"]][["BODY"]]))      attr(x, "CMetaData") <- cmeta
55          corpus <- xmlValue(node[["TEXT"]][["BODY"]])      attr(x, "DMetaData") <- dmeta
56        class(x) <- c("VCorpus", "Corpus", "list")
57        x
58    }
59    
60    # Register S3 corpus classes to be recognized by S4 methods. This is
61    # mainly a fix to be compatible with packages which were originally
62    # developed to cooperate with corresponding S4 tm classes. Necessary
63    # since tm's class architecture was changed to S3 since tm version 0.5.
64    setOldClass(c("VCorpus", "Corpus", "list"))
65    
66    # The "..." are additional arguments for the FunctionGenerator reader
67    VCorpus <- Corpus <- function(x,
68                                  readerControl = list(reader = x$DefaultReader, language = "en"),
69                                  ...) {
70        readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
71    
72        if (is.function(readerControl$init))
73            readerControl$init()
74    
75        if (is.function(readerControl$exit))
76            on.exit(readerControl$exit())
77    
78        # Allocate memory in advance if length is known
79        tdl <- if (x$Length > 0)
80            vector("list", as.integer(x$Length))
81      else      else
82          corpus <- ""          list()
83    
84      if (stripWhiteSpace)      if (x$Vectorized)
85          corpus <- gsub("[[:space:]]+", " ", corpus)          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
86      if (toLower)                        pGetElem(x),
87          corpus <- tolower(corpus)                        id = if (is.null(x$Names)) as.character(seq_len(x$Length)) else x$Names,
88                          SIMPLIFY = FALSE)
89      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      else {
90      if (!is.null(node[["TEXT"]][["TITLE"]]))          counter <- 1
91          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          while (!eoi(x)) {
92                x <- stepNext(x)
93                elem <- getElem(x)
94                doc <- readerControl$reader(elem, readerControl$language, if (is.null(x$Names)) as.character(counter) else x$Names[counter])
95                if (x$Length > 0)
96                    tdl[[counter]] <- doc
97      else      else
98          heading <- ""                  tdl <- c(tdl, list(doc))
99                counter <- counter + 1
100            }
101        }
102        names(tdl) <- x$Names
103        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
104        .VCorpus(tdl, .MetaDataNode(), df)
105    }
106    
107      # TODO: Check whether <TOPICS></TOPICS> tags are obligatory  `[.PCorpus` <- function(x, i) {
108      topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)      if (missing(i)) return(x)
109        index <- attr(x, "DMetaData")[[1 , "subset"]]
110        attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i
111        dmeta <- attr(x, "DMetaData")
112        .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))
113    }
114    
115      new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,  `[.VCorpus` <- function(x, i) {
116          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))      if (missing(i)) return(x)
117        .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])
118  }  }
119    
120  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  `[<-.PCorpus` <- function(x, i, value) {
121  parseReutersXML<- function(file) {      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
122      new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),      counter <- 1
123          Description = "Reuters21578 file containing several news articles", ID = as.integer(0),      for (id in unclass(x)[i]) {
124          Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")          if (identical(length(value), 1L)) db[[id]] <- value
125  }          else db[[id]] <- value[[counter]]
126            counter <- counter + 1
127  setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))      }
128  setMethod("loadFileIntoMem",      x
129            c("XMLTextDocument"),  }
           function(object) {  
               if (object@Cached == 0) {  
                   file <- object@FileName  
                   doc <- xmlTreeParse(file)  
                   class(doc) <- "list"  
                   object@.Data <- doc  
                   object@Cached <- 1  
                   return(object)  
               } else {  
                   return(object)  
               }  
           })  
   
 setGeneric("transformTextDocCol", function(object, FUN, ...) standardGeneric("transformTextDocCol"))  
 setMethod("transformTextDocCol",  
           c("TextDocCol"),  
           function(object, FUN, ...) {  
               lapply(object, FUN, ...)  
           })  
   
 setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))  
 setMethod("toPlainTextDocument",  
           c("PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("toPlainTextDocument",  
           c("XMLTextDocument"),  
           function(object, FUN, ...) {  
               if (object@Cached == 0)  
                   object <- loadFileIntoMem(object)  
   
               corpus <- object@.Data  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(xmlApply(xmlRoot(corpus), FUN, ...))  
           })  
   
 setGeneric("stemTextDocument", function(object) standardGeneric("stemTextDocument"))  
 setMethod("stemTextDocument",  
           c("PlainTextDocument"),  
           function(object) {  
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- wordStem(splittedCorpus)  
               object@.Data <- paste(stemmedCorpus, collapse = " ")  
               return (object)  
           })  
   
 setGeneric("removeStopWordsInTextDocument", function(object, stopwords) standardGeneric("removeStopWordsInTextDocument"))  
 setMethod("removeStopWordsInTextDocument",  
           c("PlainTextDocument", "character"),  
           function(object, stopwords) {  
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               object@.Data <- paste(noStopwordsCorpus, collapse = " ")  
               return (object)  
           })  
   
 setGeneric("filterTextDocCol", function(object, FUN, ...) standardGeneric("filterTextDocCol"))  
 setMethod("filterTextDocCol",  
           c("TextDocCol"),  
           function(object, FUN, ...) {  
               sapply(object, FUN, ...)  
           })  
   
 setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))  
 setMethod("filterREUT21578Topics",  
           c("PlainTextDocument", "character"),  
           function(object, topics, ...) {  
               if (object@Cached == 0)  
                   object <- loadFileIntoMem(object)  
130    
131                if (any(object@LocalMetaData$Topics %in% topics))  .map_name_index <- function(x, i) {
132                    return(TRUE)      if (is.character(i)) {
133            if (is.null(names(x)))
134                match(i, meta(x, "ID", type = "local"))
135                else                else
136                    return(FALSE)              match(i, names(x))
137            })      }
138        i
139    }
140    
141    `[[.PCorpus` <-  function(x, i) {
142        i <- .map_name_index(x, i)
143        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
144        filehash::dbFetch(db, NextMethod("[["))
145    }
146    `[[.VCorpus` <-  function(x, i) {
147        i <- .map_name_index(x, i)
148        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
149        if (!is.null(lazyTmMap))
150            .Call("copyCorpus", x, materialize(x, i))
151        NextMethod("[[")
152    }
153    
154    `[[<-.PCorpus` <-  function(x, i, value) {
155        i <- .map_name_index(x, i)
156        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
157        index <- unclass(x)[[i]]
158        db[[index]] <- value
159        x
160    }
161    `[[<-.VCorpus` <-  function(x, i, value) {
162        i <- .map_name_index(x, i)
163        # Mark new objects as not active for lazy mapping
164        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
165        if (!is.null(lazyTmMap)) {
166            lazyTmMap$index[i] <- FALSE
167            meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
168        }
169        # Set the value
170        cl <- class(x)
171        y <- NextMethod("[[<-")
172        class(y) <- cl
173        y
174    }
175    
176    # Update NodeIDs of a CMetaData tree
177    .update_id <- function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
178        # Traversal of (binary) CMetaData tree with setup of NodeIDs
179        set_id <- function(x) {
180            x$NodeID <- id
181            id <<- id + 1
182            level <<- level + 1
183            if (length(x$Children) > 0) {
184                mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
185                left <- set_id(x$Children[[1]])
186                if (level == 1) {
187                    left.mapping <<- mapping
188                    mapping <<- NULL
189                }
190                mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
191                right <- set_id(x$Children[[2]])
192    
193                x$Children <- list(left, right)
194            }
195            level <<- level - 1
196            x
197        }
198        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
199    }
200    
201    # Find indices to be updated for a CMetaData tree
202    .find_indices <- function(x) {
203        indices.mapping <- NULL
204        for (m in levels(as.factor(DMetaData(x)$MetaID))) {
205            indices <- (DMetaData(x)$MetaID == m)
206            indices.mapping <- c(indices.mapping, list(m = indices))
207            names(indices.mapping)[length(indices.mapping)] <- m
208        }
209        indices.mapping
210    }
211    
212    c2 <- function(x, y, ...) {
213        # Update the CMetaData tree
214        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
215        update.struct <- .update_id(cmeta)
216    
217        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
218    
219        # Find indices to be updated for the left tree
220        indices.mapping <- .find_indices(x)
221    
222        # Update the DMetaData data frames for the left tree
223        for (i in 1:ncol(update.struct$left.mapping)) {
224            map <- update.struct$left.mapping[,i]
225            DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
226        }
227    
228        # Find indices to be updated for the right tree
229        indices.mapping <- .find_indices(y)
230    
231        # Update the DMetaData data frames for the right tree
232        for (i in 1:ncol(update.struct$right.mapping)) {
233            map <- update.struct$right.mapping[,i]
234            DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
235        }
236    
237        # Merge the DMetaData data frames
238        labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
239        na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
240        x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
241        labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
242        na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
243        y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
244        DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
245    
246        new
247    }
248    
249    c.Corpus <-
250    function(x, ..., recursive = FALSE)
251    {
252        args <- list(...)
253    
254        if (identical(length(args), 0L))
255            return(x)
256    
257        if (!all(unlist(lapply(args, inherits, class(x)))))
258            stop("not all arguments are of the same corpus type")
259    
260        if (inherits(x, "PCorpus"))
261            stop("concatenation of corpora with underlying databases is not supported")
262    
263        l <- base::c(list(x), args)
264        if (recursive)
265            Reduce(c2, l)
266        else {
267            l <- do.call("c", lapply(l, unclass))
268            .VCorpus(l,
269                     cmeta = .MetaDataNode(),
270                     dmeta = data.frame(MetaID = rep(0, length(l)), stringsAsFactors = FALSE))
271        }
272    }
273    
274    c.TextDocument <- function(x, ..., recursive = FALSE) {
275        args <- list(...)
276    
277        if (identical(length(args), 0L))
278            return(x)
279    
280        if (!all(unlist(lapply(args, inherits, class(x)))))
281            stop("not all arguments are text documents")
282    
283        dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
284        .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
285    }
286    
287    print.Corpus <- function(x, ...) {
288        cat(sprintf(ngettext(length(x),
289                             "A corpus with %d text document\n",
290                             "A corpus with %d text documents\n"),
291                    length(x)))
292        invisible(x)
293    }
294    
295    summary.Corpus <- function(object, ...) {
296        print(object)
297        if (length(DMetaData(object)) > 0) {
298            cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),
299                                 "\nThe metadata consists of %d tag-value pair and a data frame\n",
300                                 "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
301                        length(CMetaData(object)$MetaData)))
302            cat("Available tags are:\n")
303            cat(strwrap(paste(names(CMetaData(object)$MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
304            cat("Available variables in the data frame are:\n")
305            cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
306        }
307    }
308    
309    inspect <- function(x) UseMethod("inspect", x)
310    inspect.PCorpus <- function(x) {
311        summary(x)
312        cat("\n")
313        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
314        show(filehash::dbMultiFetch(db, unlist(x)))
315    }
316    inspect.VCorpus <- function(x) {
317        summary(x)
318        cat("\n")
319        print(noquote(lapply(x, identity)))
320    }
321    
322    lapply.PCorpus <- function(X, FUN, ...) {
323        db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
324        lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
325    }
326    lapply.VCorpus <- function(X, FUN, ...) {
327        lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
328        if (!is.null(lazyTmMap))
329            .Call("copyCorpus", X, materialize(X))
330        base::lapply(X, FUN, ...)
331    }
332    
333    writeCorpus <-  function(x, path = ".", filenames = NULL) {
334        filenames <- file.path(path,
335                               if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
336                               else filenames)
337        i <- 1
338        for (o in x) {
339            writeLines(as.PlainTextDocument(o), filenames[i])
340            i <- i + 1
341        }
342    }

Legend:
Removed from v.49  
changed lines
  Added in v.1114

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