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

revision 1327, Mon Apr 14 15:35:38 2014 UTC revision 1377, Wed May 21 17:15:56 2014 UTC
# Line 2  Line 2 
2    
3  PCorpus <-  PCorpus <-
4  function(x,  function(x,
5           readerControl = list(reader = x$defaultreader, language = "en"),           readerControl = list(reader = reader(x), language = "en"),
6           dbControl = list(dbName = "", dbType = "DB1"))           dbControl = list(dbName = "", dbType = "DB1"))
7  {  {
8      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
9    
10      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
11    
12      if (is.function(readerControl$init))      if (is.function(readerControl$init))
13          readerControl$init()          readerControl$init()
# Line 19  Line 19 
19          stop("error in creating database")          stop("error in creating database")
20      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
21    
22      # Allocate memory in advance if length is known      tdl <- vector("list", length(x))
     tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()  
   
23      counter <- 1      counter <- 1
24      while (!eoi(x)) {      while (!eoi(x)) {
25          x <- stepNext(x)          x <- stepNext(x)
26          elem <- getElem(x)          elem <- getElem(x)
27          id <- if (is.null(x$names) || is.na(x$names))          doc <- readerControl$reader(elem,
28              as.character(counter)                                      readerControl$language,
29          else                                      as.character(counter))
             x$names[counter]  
         doc <- readerControl$reader(elem, readerControl$language, id)  
30          filehash::dbInsert(db, meta(doc, "id"), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
31          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")          tdl[[counter]] <- meta(doc, "id")
         else tdl <- c(tdl, meta(doc, "id"))  
32          counter <- counter + 1          counter <- counter + 1
33      }      }
     if (!is.null(x$names) && !is.na(x$names))  
         names(tdl) <- x$names  
34    
35      structure(list(content = tdl,      structure(list(content = tdl,
36                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 46  Line 39 
39                class = c("PCorpus", "Corpus"))                class = c("PCorpus", "Corpus"))
40  }  }
41    
42  VCorpus <- Corpus <-  Corpus <-
43  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  VCorpus <-
44    function(x, readerControl = list(reader = reader(x), language = "en"))
45  {  {
46      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
47    
48      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
49    
50      if (is.function(readerControl$init))      if (is.function(readerControl$init))
51          readerControl$init()          readerControl$init()
# Line 59  Line 53 
53      if (is.function(readerControl$exit))      if (is.function(readerControl$exit))
54          on.exit(readerControl$exit())          on.exit(readerControl$exit())
55    
56      # Allocate memory in advance if length is known      tdl <- vector("list", length(x))
57      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()      # Check for parallel element access
58        if (is.function(getS3method("pGetElem", class(x), TRUE)))
     if (x$vectorized)  
59          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
60                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
61                        pGetElem(x),                        pGetElem(x),
62                        id = if (is.null(x$names) || is.na(x$names))                        id = as.character(seq_along(x)),
                           as.character(seq_len(x$length))  
                       else x$names,  
63                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
64      else {      else {
65          counter <- 1          counter <- 1
66          while (!eoi(x)) {          while (!eoi(x)) {
67              x <- stepNext(x)              x <- stepNext(x)
68              elem <- getElem(x)              elem <- getElem(x)
69              id <- if (is.null(x$names) || is.na(x$names))              doc <- readerControl$reader(elem,
70                  as.character(counter)                                          readerControl$language,
71              else                                          as.character(counter))
                 x$names[counter]  
             doc <- readerControl$reader(elem, readerControl$language, id)  
             if (x$length > 0)  
72                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
73              counter <- counter + 1              counter <- counter + 1
74          }          }
75      }      }
     if (!is.null(x$names) && !is.na(x$names))  
         names(tdl) <- x$names  
76    
77      structure(list(content = tdl,      structure(list(content = tdl,
78                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 122  Line 106 
106  function(x, i)  function(x, i)
107  {  {
108      if (is.character(i))      if (is.character(i))
109          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          match(i, meta(x, "id", "local"))
110      else      else
111          i          i
112  }  }
# Line 162  Line 146 
146      x      x
147  }  }
148    
149    as.list.PCorpus <- as.list.VCorpus <-
150    function(x, ...)
151        content(x)
152    
153    as.VCorpus <-
154    function(x)
155        UseMethod("as.VCorpus")
156    as.VCorpus.VCorpus <- identity
157    
158  outer_union <-  outer_union <-
159  function(x, y, ...)  function(x, y, ...)
160  {  {
# Line 188  Line 181 
181          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
182    
183      structure(list(content = do.call("c", lapply(args, content)),      structure(list(content = do.call("c", lapply(args, content)),
184                     meta = structure(do.call("c",                     meta = CorpusMeta(meta = do.call("c",
185                       lapply(args, function(a) meta(a, type = "corpus"))),                       lapply(args, function(a) meta(a, type = "corpus")))),
                                     class = "CorpusMeta"),  
186                     dmeta = Reduce(outer_union, lapply(args, meta))),                     dmeta = Reduce(outer_union, lapply(args, meta))),
187                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
188  }  }
189    
 c.TextDocument <-  
 function(..., recursive = FALSE)  
 {  
     args <- list(...)  
     x <- args[[1L]]  
   
     if (length(args) == 1L)  
         return(x)  
   
     if (!all(unlist(lapply(args, inherits, class(x)))))  
         stop("not all arguments are text documents")  
   
     structure(list(content = args,  
                    meta = CorpusMeta(),  
                    dmeta = data.frame(row.names = seq_along(args))),  
               class = c("VCorpus", "Corpus"))  
 }  
   
 as.list.PCorpus <- as.list.VCorpus <-  
 function(x, ...)  
     content(x)  
   
190  content.VCorpus <-  content.VCorpus <-
191  function(x)  function(x)
192  {  {
# Line 232  Line 202 
202      filehash::dbMultiFetch(db, unlist(x$content))      filehash::dbMultiFetch(db, unlist(x$content))
203  }  }
204    
 length.PCorpus <- length.VCorpus <-  
 function(x)  
     length(x$content)  
   
 print.PCorpus <- print.VCorpus <-  
 function(x, ...)  
 {  
     cat(sprintf(ngettext(length(x),  
                          "A corpus with %d text document\n\n",  
                          "A corpus with %d text documents\n\n"),  
                 length(x)))  
   
     meta <- meta(x, type = "corpus")  
     dmeta <- meta(x, type = "indexed")  
   
     cat("Metadata:\n")  
     cat(sprintf("  Tag-value pairs. Tags: %s\n",  
                 paste(names(meta), collapse = " ")))  
     cat("  Data frame. Variables:", colnames(dmeta), "\n")  
   
     invisible(x)  
 }  
   
205  inspect <-  inspect <-
206  function(x)  function(x)
207      UseMethod("inspect", x)      UseMethod("inspect", x)
# Line 267  Line 214 
214      invisible(x)      invisible(x)
215  }  }
216    
217    length.PCorpus <- length.VCorpus <-
218    function(x)
219        length(x$content)
220    
221    names.PCorpus <- names.VCorpus <-
222    function(x)
223        as.character(meta(x, "id", "local"))
224    
225    print.PCorpus <- print.VCorpus <-
226    function(x, ...)
227    {
228        writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
229                           class(x)[1],
230                           length(x),
231                           length(meta(x, type = "corpus")),
232                           ncol(meta(x, type = "indexed"))))
233        invisible(x)
234    }
235    
236  writeCorpus <-  writeCorpus <-
237  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
238  {  {

Legend:
Removed from v.1327  
changed lines
  Added in v.1377

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