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 32, Thu Dec 15 13:13:54 2005 UTC pkg/R/corpus.R revision 1312, Sat Mar 29 09:35:44 2014 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  # S4 class definition  PCorpus <-
4  # Text document collection  function(x,
5  setClass("textdoccol",           readerControl = list(reader = x$defaultreader, language = "en"),
6           contains = c("list"))           dbControl = list(dbName = "", dbType = "DB1"))
7    {
8  # Constructors      stopifnot(inherits(x, "Source"))
9    
10  setGeneric("textdoccol", function(object, ...) standardGeneric("textdoccol"))      readerControl <- prepareReader(readerControl, x$defaultreader)
11  setMethod("textdoccol",  
12            c("character", "character", "logical", "logical"),      if (is.function(readerControl$init))
13            function(object, inputType = "RCV1", stripWhiteSpace = FALSE, toLower = FALSE) {          readerControl$init()
14    
15                # Add a new type for each unique input source format      if (is.function(readerControl$exit))
16                type <- match.arg(inputType,c("RCV1","CSV","REUT21578"))          on.exit(readerControl$exit())
17                switch(type,  
18                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
19                       # For the moment the first argument is still a single file          stop("error in creating database")
20                       # This will be changed to a directory as soon as we have the full RCV1 data set      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
21                       "RCV1" = {  
22                           tree <- xmlTreeParse(object)      # Allocate memory in advance if length is known
23                           tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))      tdl <- if (x$length > 0)
24                       },          vector("list", as.integer(x$length))
                      # Text in a special CSV format (as e.g. exported from an Excel sheet)  
                      # For details on the file format see data/Umfrage.csv  
                      # The first argument has to be a single file  
                      "CSV" = {  
                          m <- as.matrix(read.csv(object))  
                          l <- vector("list", dim(m)[1])  
                          for (i in 1:dim(m)[1]) {  
                              author <- "Not yet implemented"  
                              timestamp <- date()  
                              description <- "Not yet implemented"  
                              id <- i  
                              corpus <- as.character(m[i,2:dim(m)[2]])  
                              if (stripWhiteSpace)  
                                  corpus <- gsub("[[:space:]]+", " ", corpus)  
                              if (toLower)  
                                  corpus <- tolower(corpus)  
                              origin <- "Not yet implemented"  
                              heading <- "Not yet implemented"  
   
                              l[[i]] <- new("textdocument", .Data = corpus, author = author, timestamp = timestamp,  
                                  description = description, id = id, origin = origin, heading = heading)  
                          }  
                          tdcl <- new("textdoccol", .Data = l)  
                      },  
                      # 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  
           })  
   
 # 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 <- "Not yet implemented"  
     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) {  
     author <- "Not yet implemented"  
     timestamp <- xmlValue(node[["DATE"]])  
     description <- "Not yet implemented"  
     id <- as.integer(xmlAttrs(node)[["NEWID"]])  
   
     origin <- "Not yet implemented"  
   
     # The <BODY></BODY> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["BODY"]]))  
         corpus <- xmlValue(node[["TEXT"]][["BODY"]])  
     else  
         corpus <- ""  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["TITLE"]]))  
         heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
25      else      else
26          heading <- ""          list()
27    
28      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      counter <- 1
29          description = description, id = id, origin = origin, heading = heading)      while (!eoi(x)) {
30            x <- stepNext(x)
31            elem <- getElem(x)
32            id <- if (is.null(x$names) || is.na(x$names))
33                as.character(counter)
34            else
35                x$names[counter]
36            doc <- readerControl$reader(elem, readerControl$language, id)
37            filehash::dbInsert(db, meta(doc, "id"), doc)
38            if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
39            else tdl <- c(tdl, meta(doc, "id"))
40            counter <- counter + 1
41        }
42        if (!is.null(x$names) && !is.na(x$names))
43            names(tdl) <- x$names
44    
45        structure(list(content = tdl,
46                       meta = CorpusMeta(),
47                       dmeta = data.frame(row.names = seq_along(tdl)),
48                       dbcontrol = dbControl),
49                  class = c("PCorpus", "Corpus"))
50    }
51    
52    VCorpus <- Corpus <-
53    function(x, readerControl = list(reader = x$defaultreader, language = "en"))
54    {
55        stopifnot(inherits(x, "Source"))
56    
57        readerControl <- prepareReader(readerControl, x$defaultreader)
58    
59        if (is.function(readerControl$init))
60            readerControl$init()
61    
62        if (is.function(readerControl$exit))
63            on.exit(readerControl$exit())
64    
65        # Allocate memory in advance if length is known
66        tdl <- if (x$length > 0)
67            vector("list", as.integer(x$length))
68        else
69            list()
70    
71        if (x$vectorized)
72            tdl <- mapply(function(elem, id)
73                              readerControl$reader(elem, readerControl$language, id),
74                          pGetElem(x),
75                          id = if (is.null(x$names) || is.na(x$names))
76                              as.character(seq_len(x$length))
77                          else x$names,
78                          SIMPLIFY = FALSE)
79        else {
80            counter <- 1
81            while (!eoi(x)) {
82                x <- stepNext(x)
83                elem <- getElem(x)
84                id <- if (is.null(x$names) || is.na(x$names))
85                    as.character(counter)
86                else
87                    x$names[counter]
88                doc <- readerControl$reader(elem, readerControl$language, id)
89                if (x$length > 0)
90                    tdl[[counter]] <- doc
91                else
92                    tdl <- c(tdl, list(doc))
93                counter <- counter + 1
94            }
95        }
96        if (!is.null(x$names) && !is.na(x$names))
97            names(tdl) <- x$names
98    
99        structure(list(content = tdl,
100                       meta = CorpusMeta(),
101                       dmeta = data.frame(row.names = seq_along(tdl))),
102                  class = c("VCorpus", "Corpus"))
103    }
104    
105    `[.PCorpus` <- `[.VCorpus` <-
106    function(x, i)
107    {
108        if (!missing(i)) {
109            x$content <- x$content[i]
110            x$dmeta <- x$dmeta[i, , drop = FALSE]
111        }
112        x
113    }
114    
115    .map_name_index <-
116    function(x, i)
117    {
118        if (is.character(i))
119            match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))
120        else
121            i
122    }
123    
124    `[[.PCorpus` <-
125    function(x, i)
126    {
127        i <- .map_name_index(x, i)
128        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
129        filehash::dbFetch(db, x$content[[i]])
130    }
131    `[[.VCorpus` <-
132    function(x, i)
133    {
134        i <- .map_name_index(x, i)
135        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
136        if (!is.null(lazyTmMap))
137            .Call("copyCorpus", x, materialize(x, i))
138        x$content[[i]]
139    }
140    
141    `[[<-.PCorpus` <-
142    function(x, i, value)
143    {
144        i <- .map_name_index(x, i)
145        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
146        db[[x$content[[i]]]] <- value
147        x
148    }
149    `[[<-.VCorpus` <-
150    function(x, i, value)
151    {
152        i <- .map_name_index(x, i)
153        # Mark new objects as not active for lazy mapping
154        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
155        if (!is.null(lazyTmMap)) {
156            lazyTmMap$index[i] <- FALSE
157            meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap
158        }
159        x$content[[i]] <- value
160        x
161    }
162    
163    # Update NodeIDs of a CMetaData tree
164    .update_id <-
165    function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)
166    {
167        # Traversal of (binary) CMetaData tree with setup of NodeIDs
168        set_id <- function(x) {
169            x$NodeID <- id
170            id <<- id + 1
171            level <<- level + 1
172            if (length(x$Children)) {
173                mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))
174                left <- set_id(x$Children[[1]])
175                if (level == 1) {
176                    left.mapping <<- mapping
177                    mapping <<- NULL
178                }
179                mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))
180                right <- set_id(x$Children[[2]])
181    
182                x$Children <- list(left, right)
183            }
184            level <<- level - 1
185            x
186        }
187        list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)
188    }
189    
190    # Find indices to be updated for a CMetaData tree
191    .find_indices <-
192    function(x)
193    {
194        indices.mapping <- NULL
195        for (m in levels(as.factor(CorpusDMeta(x)$MetaID))) {
196            indices <- (CorpusDMeta(x)$MetaID == m)
197            indices.mapping <- c(indices.mapping, list(m = indices))
198            names(indices.mapping)[length(indices.mapping)] <- m
199        }
200        indices.mapping
201    }
202    
203    #c2 <-
204    #function(x, y, ...)
205    #{
206    #    # Update the CMetaData tree
207    #    cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))
208    #    update.struct <- .update_id(cmeta)
209    #
210    #    new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)
211    #
212    #    # Find indices to be updated for the left tree
213    #    indices.mapping <- .find_indices(x)
214    #
215    #    # Update the CorpusDMeta data frames for the left tree
216    #    for (i in 1:ncol(update.struct$left.mapping)) {
217    #        map <- update.struct$left.mapping[,i]
218    #        DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
219    #    }
220    #
221    #    # Find indices to be updated for the right tree
222    #    indices.mapping <- .find_indices(y)
223    #
224    #    # Update the CorpusDMeta data frames for the right tree
225    #    for (i in 1:ncol(update.struct$right.mapping)) {
226    #        map <- update.struct$right.mapping[,i]
227    #        DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
228    #    }
229    #
230    #    # Merge the CorpusDMeta data frames
231    #    labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
232    #    na.matrix <- matrix(NA,
233    #                        nrow = nrow(DMetaData(x)),
234    #                        ncol = length(labels),
235    #                        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,
239    #                        nrow = nrow(DMetaData(y)),
240    #                        ncol = length(labels),
241    #                        dimnames = list(row.names(DMetaData(y)), labels))
242    #    y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
243    #    DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)
244    #
245    #    new
246    #}
247    
248    c.Corpus <-
249    function(..., recursive = FALSE)
250    {
251        args <- list(...)
252        x <- args[[1L]]
253    
254        if(length(args) == 1L)
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        if (recursive)
264            Reduce(c2, args)
265        else {
266            args <- do.call("c", lapply(args, content))
267            .VCorpus(args,
268                     CorpusMeta(),
269                     data.frame(MetaID = rep(0, length(args)),
270                                stringsAsFactors = FALSE))
271        }
272    }
273    
274    c.TextDocument <-
275    function(..., recursive = FALSE)
276    {
277        args <- list(...)
278        x <- args[[1L]]
279    
280        if(length(args) == 1L)
281            return(x)
282    
283        if (!all(unlist(lapply(args, inherits, class(x)))))
284            stop("not all arguments are text documents")
285    
286        .VCorpus(args,
287                 CorpusMeta(),
288                 data.frame(MetaID = rep(0, length(args)),
289                            stringsAsFactors = FALSE))
290    }
291    
292    content.Corpus <-
293    function(x)
294        x$content
295    
296    `content<-.Corpus` <-
297    function(x, value)
298    {
299        x$content <- value
300        x
301    }
302    
303    length.Corpus <-
304    function(x)
305        length(content(x))
306    
307    print.Corpus <-
308    function(x, ...)
309    {
310        cat(sprintf(ngettext(length(x),
311                             "A corpus with %d text document\n\n",
312                             "A corpus with %d text documents\n\n"),
313                    length(x)))
314    
315        meta <- meta(x, type = "corpus")
316        dmeta <- meta(x, type = "indexed")
317    
318        cat("Metadata:\n")
319        cat(sprintf("  Tag-value pairs. Tags: %s\n",
320                    paste(names(meta), collapse = " ")))
321        cat("  Data frame. Variables:", colnames(dmeta), "\n")
322    
323        invisible(x)
324    }
325    
326    inspect <-
327    function(x)
328        UseMethod("inspect", x)
329    inspect.PCorpus <-
330    function(x)
331    {
332        print(x)
333        cat("\n")
334        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
335        show(filehash::dbMultiFetch(db, unlist(content(x))))
336        invisible(x)
337    }
338    inspect.VCorpus <-
339    function(x)
340    {
341        print(x)
342        cat("\n")
343        print(noquote(content(x)))
344        invisible(x)
345    }
346    
347    # TODO: lapply() is not generic but as.list() is
348    #
349    #lapply.PCorpus <-
350    #function(X, FUN, ...)
351    #{
352    #    db <- filehash::dbInit(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])
353    #    lapply(filehash::dbMultiFetch(db, unlist(content(X))), FUN, ...)
354    #}
355    #lapply.VCorpus <-
356    #function(X, FUN, ...)
357    #{
358    #    lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")
359    #    if (!is.null(lazyTmMap))
360    #        .Call("copyCorpus", X, materialize(X))
361    #    lapply(content(X), FUN, ...)
362    #}
363    
364    writeCorpus <-
365    function(x, path = ".", filenames = NULL)
366    {
367        filenames <- file.path(path,
368          if (is.null(filenames))
369              sprintf("%s.txt", as.character(meta(x, "id", "local")))
370          else filenames)
371    
372        stopifnot(length(x) == length(filenames))
373    
374        mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
375    
376        invisible(x)
377  }  }

Legend:
Removed from v.32  
changed lines
  Added in v.1312

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