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/trunk/R/textdoccol.R revision 37, Wed Jan 11 17:49:17 2006 UTC pkg/R/corpus.R revision 987, Wed Sep 2 17:54:45 2009 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))  prepareReader <- function(readerControl, defaultReader = NULL, ...) {
4  setMethod("textdoccol",      if (is.null(readerControl$reader))
5            c("character", "character", "logical", "logical"),          readerControl$reader <- defaultReader
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {      if (inherits(readerControl$reader, "FunctionGenerator"))
7                # Add a new type for each unique input source format          readerControl$reader <- readerControl$reader(...)
8                type <- match.arg(inputType,c("CSV","RCV1","REUT21578"))      if (is.null(readerControl$language))
9                switch(type,          readerControl$language <- "eng"
10                       # Text in a special CSV format      readerControl
11                       # For details on the file format see the R documentation file  }
12                       # The first argument is a directory with .csv files  
13                       "CSV" = {  # Node ID, actual meta data, and possibly other nodes as children
14                           tdl <- sapply(dir(object,  .MetaDataNode <- function(nodeid = 0, meta = list(create_date = as.POSIXlt(Sys.time(), tz = "GMT"), creator = Sys.getenv("LOGNAME")), children = NULL) {
15                                             pattern = ".csv",      structure(list(NodeID = nodeid, MetaData = meta, Children = children),
16                                             full.names = TRUE),                class = "MetaDataNode")
17                                         function(file) {  }
18                                             m <- as.matrix(read.csv(file, header = FALSE))  
19                                             l <- vector("list", dim(m)[1])  print.MetaDataNode <- function(x, ...)
20                                             for (i in 1:dim(m)[1]) {      print(x$MetaData)
21                                                 author <- ""  
22                                                 timestamp <- date()  .PCorpus <- function(x, cmeta, dmeta, dbcontrol) {
23                                                 description <- ""      attr(x, "CMetaData") <- cmeta
24                                                 id <- as.integer(m[i,1])      attr(x, "DMetaData") <- dmeta
25                                                 corpus <- as.character(m[i,2:dim(m)[2]])      attr(x, "DBControl") <- dbcontrol
26                                                 if (stripWhiteSpace)      class(x) <- c("PCorpus", "Corpus", "list")
27                                                     corpus <- gsub("[[:space:]]+", " ", corpus)      x
28                                                 if (toLower)  }
29                                                     corpus <- tolower(corpus)  
30                                                 origin <- "CSV"  PCorpus <- function(x,
31                                                 heading <- ""                      readerControl = list(reader = x$DefaultReader, language = "eng"),
32                        dbControl = list(dbName = "", dbType = "DB1"),
33                                                 l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,                      ...) {
34                                                               description = description, id = id, origin = origin, heading = heading)      readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
35                                             }  
36                                             l      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
37                                         })          stop("error in creating database")
38                           tdcl <- new("textdoccol", .Data = tdl)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
39                       },  
40                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format      # Allocate memory in advance if length is known
41                       # The first argument is a directory with the RCV1 XML files      tdl <- if (x$Length > 0)
42                       "RCV1" = {          vector("list", as.integer(x$Length))
                          tdl <- sapply(dir(object,  
                                            pattern = ".xml",  
                                            full.names = TRUE),  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower)  
                                        })  
                          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" = {  
                          tdl <- sapply(dir(object,  
                                            pattern = ".xml",  
                                            full.names = TRUE),  
                                        function(file) {  
                                            tree <- xmlTreeParse(file)  
                                            xmlApply(xmlRoot(tree), parseReuters, stripWhiteSpace, toLower)  
                                        })  
                          tdcl <- new("textdoccol", .Data = tdl)  
                      })  
               tdcl  
           })  
   
 # TODO: Implement lacking fields as soon I have access to the original RCV1  
 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  
 parseNewsItem <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  
     author <- "Not yet implemented"  
     timestamp <- 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("textdocument", .Data = corpus, author = author, timestamp = timestamp,  
         description = description, id = id, origin = origin, heading = heading)  
 }  
   
 # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  
 parseReuters <- 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"]])  
43      else      else
44          author <- ""          list()
45    
46        counter <- 1
47        while (!eoi(x)) {
48            x <- stepNext(x)
49            elem <- getElem(x)
50            doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
51            filehash::dbInsert(db, ID(doc), doc)
52            if (x$Length > 0) tdl[[counter]] <- ID(doc)
53            else tdl <- c(tdl, ID(doc))
54            counter <- counter + 1
55        }
56    
57      timestamp <- xmlValue(node[["DATE"]])      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
58      description <- ""      filehash::dbInsert(db, "DMetaData", df)
59      id <- as.integer(xmlAttrs(node)[["NEWID"]])      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))
60    
61      origin <- "Reuters-21578 XML"      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)
62    }
63    
64    .VCorpus <- function(x, cmeta, dmeta) {
65        attr(x, "CMetaData") <- cmeta
66        attr(x, "DMetaData") <- dmeta
67        class(x) <- c("VCorpus", "Corpus", "list")
68        x
69    }
70    
71      # The <BODY></BODY> tag is unfortunately NOT obligatory!  # The "..." are additional arguments for the FunctionGenerator reader
72      if (!is.null(node[["TEXT"]][["BODY"]]))  VCorpus <- Corpus <- function(x,
73          corpus <- xmlValue(node[["TEXT"]][["BODY"]])                      readerControl = list(reader = x$DefaultReader, language = "eng"),
74                        ...) {
75        readerControl <- prepareReader(readerControl, x$DefaultReader, ...)
76    
77        # Allocate memory in advance if length is known
78        tdl <- if (x$Length > 0)
79            vector("list", as.integer(x$Length))
80      else      else
81          corpus <- ""          list()
82    
83      if (stripWhiteSpace)      if (x$Vectorized)
84          corpus <- gsub("[[:space:]]+", " ", corpus)          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),
85      if (toLower)                        pGetElem(x),
86          corpus <- tolower(corpus)                        id = as.character(seq_len(x$Length)),
87                          SIMPLIFY = FALSE)
88      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      else {
89      if (!is.null(node[["TEXT"]][["TITLE"]]))          counter <- 1
90          heading <- xmlValue(node[["TEXT"]][["TITLE"]])          while (!eoi(x)) {
91                x <- stepNext(x)
92                elem <- getElem(x)
93                doc <- readerControl$reader(elem, readerControl$language, as.character(counter))
94                if (x$Length > 0)
95                    tdl[[counter]] <- doc
96      else      else
97          heading <- ""                  tdl <- c(tdl, list(doc))
98                counter <- counter + 1
99            }
100        }
101    
102        df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)
103        .VCorpus(tdl, .MetaDataNode(), df)
104    }
105    
106    `[.PCorpus` <- function(x, i) {
107        if (missing(i)) return(x)
108        cmeta <- CMetaData(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        dbcontrol <- DBControl(x)
113        class(x) <- "list"
114        .PCorpus(x[i, drop = FALSE], cmeta, dmeta, dbcontrol)
115    }
116    
117      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,  `[.VCorpus` <- function(x, i) {
118          description = description, id = id, origin = origin, heading = heading)      if (missing(i)) return(x)
119        cmeta <- CMetaData(x)
120        dmeta <- DMetaData(x)[i, , drop = FALSE]
121        class(x) <- "list"
122        .VCorpus(x[i, drop = FALSE], cmeta, dmeta)
123    }
124    
125    `[<-.PCorpus` <- function(x, i, value) {
126        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
127        counter <- 1
128        for (id in unclass(x)[i]) {
129            if (identical(length(value), 1)) db[[id]] <- value
130            else db[[id]] <- value[[counter]]
131            counter <- counter + 1
132        }
133        x
134    }
135    
136    `[[.PCorpus` <-  function(x, i) {
137        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
138        class(x) <- "list"
139        filehash::dbFetch(db, x[[i]])
140    }
141    `[[.VCorpus` <-  function(x, i) {
142        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
143        if (!is.null(lazyTmMap))
144            .Call("copyCorpus", x, materialize(x, i))
145        class(x) <- "list"
146        x[[i]]
147    }
148    
149    `[[<-.PCorpus` <-  function(x, i, value) {
150        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
151        index <- unclass(x)[[i]]
152        db[[index]] <- value
153        x
154    }
155    `[[<-.VCorpus` <-  function(x, i, value) {
156        # Mark new objects as not active for lazy mapping
157        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
158        if (!is.null(lazyTmMap)) {
159            lazyTmMap$index[i] <- FALSE
160            meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
161        }
162        # Set the value
163        cl <- class(x)
164        class(x) <- "list"
165        x[[i]] <- value
166        class(x) <- cl
167        x
168    }
169    
170    # Update \code{NodeID}s of a CMetaData tree
171    update_id <- function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
172        # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
173        set_id <- function(x) {
174            attrs <- attributes(x)
175            x <- id
176            attributes(x) <- attrs
177            id <<- id + 1
178            level <<- level + 1
179            if (length(attr(x, "Children")) > 0) {
180                mapping <<- cbind(mapping, c(as.numeric(attr(x, "Children")[[1]]), id))
181                left <- set_id(attr(x, "Children")[[1]])
182                if (level == 1) {
183                    left.mapping <<- mapping
184                    mapping <<- NULL
185                }
186                mapping <<- cbind(mapping, c(as.numeric(attr(x, "Children")[[2]]), id))
187                right <- set_id(attr(x, "Children")[[2]])
188    
189                attr(x, "Children") <- list(left, right)
190            }
191            level <<- level - 1
192            x
193        }
194    
195        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
196    }
197    
198    c2 <- function(x, y, ...) {
199        # Update the CMetaData tree
200        cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
201        update.struct <- update_id(cmeta)
202    
203        new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
204    
205        # Find indices to be updated for the left tree
206        indices.mapping <- NULL
207        for (m in levels(as.factor(DMetaData(x)$MetaID))) {
208            indices <- (DMetaData(x)$MetaID == m)
209            indices.mapping <- c(indices.mapping, list(m = indices))
210            names(indices.mapping)[length(indices.mapping)] <- m
211        }
212    
213        # Update the DMetaData data frames for the left tree
214        for (i in 1:ncol(update.struct$left.mapping)) {
215            map <- update.struct$left.mapping[,i]
216            DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
217        }
218    
219        # Find indices to be updated for the right tree
220        indices.mapping <- NULL
221        for (m in levels(as.factor(DMetaData(y)$MetaID))) {
222            indices <- (DMetaData(y)$MetaID == m)
223            indices.mapping <- c(indices.mapping, list(m = indices))
224            names(indices.mapping)[length(indices.mapping)] <- m
225        }
226    
227        # Update the DMetaData data frames for the right tree
228        for (i in 1:ncol(update.struct$right.mapping)) {
229            map <- update.struct$right.mapping[,i]
230            DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
231        }
232    
233        # Merge the DMetaData data frames
234        labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
235        na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
236        x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
237        labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
238        na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
239        y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
240        DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
241    
242        new
243    }
244    
245    c.Corpus <-
246    function(x, ..., recursive = FALSE)
247    {
248        args <- list(...)
249    
250        if (identical(length(args), 0))
251            return(x)
252    
253        if (!all(unlist(lapply(args, inherits, class(x)))))
254            stop("not all arguments are of the same corpus type")
255    
256        if (inherits(x, "PCorpus"))
257            stop("concatenation of corpora with underlying databases is not supported")
258    
259        Reduce(c2, base::c(list(x), args))
260    }
261    
262    c.TextDocument <- function(x, ..., recursive = FALSE) {
263        args <- list(...)
264    
265        if (identical(length(args), 0))
266            return(x)
267    
268        if (!all(unlist(lapply(args, inherits, class(x)))))
269            stop("not all arguments are text documents")
270    
271        dmeta <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
272        .VCorpus(list(x, ...), .MetaDataNode(), dmeta)
273    }
274    
275    print.Corpus <- function(x, ...) {
276        cat(sprintf(ngettext(length(x),
277                             "A corpus with %d text document\n",
278                             "A corpus with %d text documents\n"),
279                    length(x)))
280        invisible(x)
281    }
282    
283    summary.Corpus <- function(x, ...) {
284        print(x)
285        if (length(DMetaData(x)) > 0) {
286            cat(sprintf(ngettext(length(attr(CMetaData(x), "MetaData")),
287                                 "\nThe metadata consists of %d tag-value pair and a data frame\n",
288                                 "\nThe metadata consists of %d tag-value pairs and a data frame\n"),
289                        length(attr(CMetaData(x), "MetaData"))))
290            cat("Available tags are:\n")
291            cat(strwrap(paste(names(attr(CMetaData(x), "MetaData")), collapse = " "), indent = 2, exdent = 2), "\n")
292            cat("Available variables in the data frame are:\n")
293            cat(strwrap(paste(names(DMetaData(x)), collapse = " "), indent = 2, exdent = 2), "\n")
294        }
295    }
296    
297    inspect <- function(x) UseMethod("inspect", x)
298    inspect.PCorpus <- function(x) {
299        summary(x)
300        cat("\n")
301        db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
302        show(filehash::dbMultiFetch(db, unlist(x)))
303    }
304    inspect.VCorpus <- function(x) {
305        summary(x)
306        cat("\n")
307        print(noquote(lapply(x, identity)))
308    }
309    
310    lapply.PCorpus <- function(X, FUN, ...) {
311        db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
312        lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)
313    }
314    lapply.VCorpus <- function(X, FUN, ...) {
315        lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
316        if (!is.null(lazyTmMap))
317            .Call("copyCorpus", X, materialize(X))
318        base::lapply(X, FUN, ...)
319    }
320    
321    writeCorpus <-  function(x, path = ".", filenames = NULL) {
322        filenames <- file.path(path,
323                               if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))
324                               else filenames)
325        i <- 1
326        for (o in x) {
327            writeLines(as.PlainTextDocument(o), filenames[i])
328            i <- i + 1
329        }
330  }  }

Legend:
Removed from v.37  
changed lines
  Added in v.987

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