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

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

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