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 1357, Thu Apr 24 06:33:35 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)  VCorpus <-
47          corpus <- gsub("[[:space:]]+", " ", corpus)  function(x, readerControl = list(reader = reader(x), language = "en"))
48      if (toLower)  {
49          corpus <- tolower(corpus)      stopifnot(inherits(x, "Source"))
50    
51      # The <TITLE></TITLE> tag is unfortunately NOT obligatory!      readerControl <- prepareReader(readerControl, reader(x))
52      if (!is.null(node[["TEXT"]][["TITLE"]]))  
53          heading <- xmlValue(node[["TEXT"]][["TITLE"]])      if (is.function(readerControl$init))
54            readerControl$init()
55    
56        if (is.function(readerControl$exit))
57            on.exit(readerControl$exit())
58    
59        tdl <- vector("list", length(x))
60        # Check for parallel element access
61        if (is.function(getS3method("pGetElem", class(x), TRUE)))
62            tdl <- mapply(function(elem, id)
63                              readerControl$reader(elem, readerControl$language, id),
64                          pGetElem(x),
65                          id = if (is.null(names(x)))
66                              as.character(seq_len(length(x)))
67                          else names(x),
68                          SIMPLIFY = FALSE)
69        else {
70            counter <- 1
71            while (!eoi(x)) {
72                x <- stepNext(x)
73                elem <- getElem(x)
74                id <- if (is.null(names(x)))
75                    as.character(counter)
76      else      else
77          heading <- ""                  names(x)[counter]
78                doc <- readerControl$reader(elem, readerControl$language, id)
79                tdl[[counter]] <- doc
80                counter <- counter + 1
81            }
82        }
83        if (!is.null(names(x)))
84            names(tdl) <- names(x)
85    
86        structure(list(content = tdl,
87                       meta = CorpusMeta(),
88                       dmeta = data.frame(row.names = seq_along(tdl))),
89                  class = c("VCorpus", "Corpus"))
90    }
91    
92    `[.PCorpus` <-
93    function(x, i)
94    {
95        if (!missing(i)) {
96            x$content <- x$content[i]
97            x$dmeta <- x$dmeta[i, , drop = FALSE]
98        }
99        x
100    }
101    
102    `[.VCorpus` <-
103    function(x, i)
104    {
105        if (!missing(i)) {
106            x$content <- x$content[i]
107            x$dmeta <- x$dmeta[i, , drop = FALSE]
108            if (!is.null(x$lazy))
109                x$lazy$index <- x$lazy$index[i]
110        }
111        x
112    }
113    
114    .map_name_index <-
115    function(x, i)
116    {
117        if (is.character(i)) {
118            n <- names(x$content)
119            match(i, if (is.null(n)) meta(x, "id", "local") else n)
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        if (!is.null(x$lazy))
136            .Call(copyCorpus, x, materialize(x, i))
137        x$content[[i]]
138    }
139    
140    `[[<-.PCorpus` <-
141    function(x, i, value)
142    {
143        i <- .map_name_index(x, i)
144        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
145        db[[x$content[[i]]]] <- value
146        x
147    }
148    `[[<-.VCorpus` <-
149    function(x, i, value)
150    {
151        i <- .map_name_index(x, i)
152        # Mark new objects as inactive for lazy mapping
153        if (!is.null(x$lazy))
154            x$lazy$index[i] <- FALSE
155        x$content[[i]] <- value
156        x
157    }
158    
159    as.list.PCorpus <- as.list.VCorpus <-
160    function(x, ...)
161        content(x)
162    
163    as.VCorpus <-
164    function(x)
165        UseMethod("as.VCorpus")
166    as.VCorpus.VCorpus <- identity
167    
168    outer_union <-
169    function(x, y, ...)
170    {
171        if (nrow(x) > 0L)
172            x[, setdiff(names(y), names(x))] <- NA
173        if (nrow(y) > 0L)
174            y[, setdiff(names(x), names(y))] <- NA
175        res <- rbind(x, y)
176        if (ncol(res) == 0L)
177            res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
178        res
179    }
180    
181    c.VCorpus <-
182    function(..., recursive = FALSE)
183    {
184        args <- list(...)
185        x <- args[[1L]]
186    
187        if (length(args) == 1L)
188            return(x)
189    
190        if (!all(unlist(lapply(args, inherits, class(x)))))
191            stop("not all arguments are of the same corpus type")
192    
193        structure(list(content = do.call("c", lapply(args, content)),
194                       meta = structure(do.call("c",
195                         lapply(args, function(a) meta(a, type = "corpus"))),
196                                        class = "CorpusMeta"),
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.1357

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