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 1366, Mon Apr 28 14:48:37 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 = reader(x), 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, reader(x))
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)      tdl <- vector("list", length(x))
23                           tdcl <- new("textdoccol", .Data = xmlApply(xmlRoot(tree), parseNewsItem, stripWhiteSpace, toLower))      counter <- 1
24                       },      while (!eoi(x)) {
25                       # Text in a special CSV format (as e.g. exported from an Excel sheet)          x <- stepNext(x)
26                       # For details on the file format see data/Umfrage.csv          elem <- getElem(x)
27                       # The first argument has to be a single file          id <- if (is.null(names(x)))
28                       "CSV" = {              as.character(counter)
                          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"]])  
29      else      else
30          corpus <- ""              names(x)[counter]
31            doc <- readerControl$reader(elem, readerControl$language, id)
32            filehash::dbInsert(db, meta(doc, "id"), doc)
33            tdl[[counter]] <- meta(doc, "id")
34            counter <- counter + 1
35        }
36        if (!is.null(names(x)))
37            names(tdl) <- names(x)
38    
39        structure(list(content = tdl,
40                       meta = CorpusMeta(),
41                       dmeta = data.frame(row.names = seq_along(tdl)),
42                       dbcontrol = dbControl),
43                  class = c("PCorpus", "Corpus"))
44    }
45    
46      if (stripWhiteSpace)  Corpus <-
47          corpus <- gsub("[[:space:]]+", " ", corpus)  VCorpus <-
48      if (toLower)  function(x, readerControl = list(reader = reader(x), language = "en"))
49          corpus <- tolower(corpus)  {
50        stopifnot(inherits(x, "Source"))
51      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
52      if (!is.null(node[["TEXT"]][["TITLE"]]))      readerControl <- prepareReader(readerControl, reader(x))
53          heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
54        if (is.function(readerControl$init))
55            readerControl$init()
56    
57        if (is.function(readerControl$exit))
58            on.exit(readerControl$exit())
59    
60        tdl <- vector("list", length(x))
61        # Check for parallel element access
62        if (is.function(getS3method("pGetElem", class(x), TRUE)))
63            tdl <- mapply(function(elem, id)
64                              readerControl$reader(elem, readerControl$language, id),
65                          pGetElem(x),
66                          id = if (is.null(names(x)))
67                              as.character(seq_len(length(x)))
68                          else names(x),
69                          SIMPLIFY = FALSE)
70        else {
71            counter <- 1
72            while (!eoi(x)) {
73                x <- stepNext(x)
74                elem <- getElem(x)
75                id <- if (is.null(names(x)))
76                    as.character(counter)
77      else      else
78          heading <- ""                  names(x)[counter]
79                doc <- readerControl$reader(elem, readerControl$language, id)
80                tdl[[counter]] <- doc
81                counter <- counter + 1
82            }
83        }
84        if (!is.null(names(x)))
85            names(tdl) <- names(x)
86    
87        structure(list(content = tdl,
88                       meta = CorpusMeta(),
89                       dmeta = data.frame(row.names = seq_along(tdl))),
90                  class = c("VCorpus", "Corpus"))
91    }
92    
93    `[.PCorpus` <-
94    function(x, i)
95    {
96        if (!missing(i)) {
97            x$content <- x$content[i]
98            x$dmeta <- x$dmeta[i, , drop = FALSE]
99        }
100        x
101    }
102    
103    `[.VCorpus` <-
104    function(x, i)
105    {
106        if (!missing(i)) {
107            x$content <- x$content[i]
108            x$dmeta <- x$dmeta[i, , drop = FALSE]
109            if (!is.null(x$lazy))
110                x$lazy$index <- x$lazy$index[i]
111        }
112        x
113    }
114    
115    .map_name_index <-
116    function(x, i)
117    {
118        if (is.character(i)) {
119            n <- names(x$content)
120            match(i, if (is.null(n)) meta(x, "id", "local") else n)
121        } else
122            i
123    }
124    
125    `[[.PCorpus` <-
126    function(x, i)
127    {
128        i <- .map_name_index(x, i)
129        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
130        filehash::dbFetch(db, x$content[[i]])
131    }
132    `[[.VCorpus` <-
133    function(x, i)
134    {
135        i <- .map_name_index(x, i)
136        if (!is.null(x$lazy))
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 inactive for lazy mapping
154        if (!is.null(x$lazy))
155            x$lazy$index[i] <- FALSE
156        x$content[[i]] <- value
157        x
158    }
159    
160    as.list.PCorpus <- as.list.VCorpus <-
161    function(x, ...)
162        content(x)
163    
164    as.VCorpus <-
165    function(x)
166        UseMethod("as.VCorpus")
167    as.VCorpus.VCorpus <- identity
168    
169    outer_union <-
170    function(x, y, ...)
171    {
172        if (nrow(x) > 0L)
173            x[, setdiff(names(y), names(x))] <- NA
174        if (nrow(y) > 0L)
175            y[, setdiff(names(x), names(y))] <- NA
176        res <- rbind(x, y)
177        if (ncol(res) == 0L)
178            res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
179        res
180    }
181    
182    c.VCorpus <-
183    function(..., recursive = FALSE)
184    {
185        args <- list(...)
186        x <- args[[1L]]
187    
188        if (length(args) == 1L)
189            return(x)
190    
191        if (!all(unlist(lapply(args, inherits, class(x)))))
192            stop("not all arguments are of the same corpus type")
193    
194        structure(list(content = do.call("c", lapply(args, content)),
195                       meta = CorpusMeta(meta = do.call("c",
196                         lapply(args, function(a) meta(a, type = "corpus")))),
197                       dmeta = Reduce(outer_union, lapply(args, meta))),
198                  class = c("VCorpus", "Corpus"))
199    }
200    
201    content.VCorpus <-
202    function(x)
203    {
204        if (!is.null(x$lazy))
205            .Call(copyCorpus, x, materialize(x))
206        x$content
207    }
208    
209    content.PCorpus <-
210    function(x)
211    {
212        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
213        filehash::dbMultiFetch(db, unlist(x$content))
214    }
215    
216    length.PCorpus <- length.VCorpus <-
217    function(x)
218        length(x$content)
219    
220    print.PCorpus <- print.VCorpus <-
221    function(x, ...)
222    {
223        writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
224                           class(x)[1],
225                           length(x),
226                           length(meta(x, type = "corpus")),
227                           ncol(meta(x, type = "indexed"))))
228        invisible(x)
229    }
230    
231    inspect <-
232    function(x)
233        UseMethod("inspect", x)
234    inspect.PCorpus <- inspect.VCorpus <-
235    function(x)
236    {
237        print(x)
238        cat("\n")
239        print(noquote(content(x)))
240        invisible(x)
241    }
242    
243    writeCorpus <-
244    function(x, path = ".", filenames = NULL)
245    {
246        filenames <- file.path(path,
247          if (is.null(filenames))
248              sprintf("%s.txt", as.character(meta(x, "id", "local")))
249          else filenames)
250    
251        stopifnot(length(x) == length(filenames))
252    
253        mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
254    
255      new("textdocument", .Data = corpus, author = author, timestamp = timestamp,      invisible(x)
         description = description, id = id, origin = origin, heading = heading)  
256  }  }

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

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