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 1333, Fri Apr 18 10:38:46 2014 UTC revision 1411, Sat Feb 28 18:16:54 2015 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))
   
     if (is.function(readerControl$init))  
         readerControl$init()  
   
     if (is.function(readerControl$exit))  
         on.exit(readerControl$exit())  
11    
12      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
13          stop("error in creating database")          stop("error in creating database")
14      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
15    
16      # Allocate memory in advance if length is known      x <- open(x)
17      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()      tdl <- vector("list", length(x))
   
18      counter <- 1      counter <- 1
19      while (!eoi(x)) {      while (!eoi(x)) {
20          x <- stepNext(x)          x <- stepNext(x)
21          elem <- getElem(x)          elem <- getElem(x)
22          id <- if (is.null(x$names) || is.na(x$names))          doc <- readerControl$reader(elem,
23              as.character(counter)                                      readerControl$language,
24          else                                      as.character(counter))
             x$names[counter]  
         doc <- readerControl$reader(elem, readerControl$language, id)  
25          filehash::dbInsert(db, meta(doc, "id"), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
26          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")          tdl[[counter]] <- meta(doc, "id")
         else tdl <- c(tdl, meta(doc, "id"))  
27          counter <- counter + 1          counter <- counter + 1
28      }      }
29      if (!is.null(x$names) && !is.na(x$names))      x <- close(x)
         names(tdl) <- x$names  
30    
31      structure(list(content = tdl,      p <- list(content = tdl,
32                     meta = CorpusMeta(),                     meta = CorpusMeta(),
33                     dmeta = data.frame(row.names = seq_along(tdl)),                     dmeta = data.frame(row.names = seq_along(tdl)),
34                     dbcontrol = dbControl),                dbcontrol = dbControl)
35                class = c("PCorpus", "Corpus"))      class(p) <- c("PCorpus", "Corpus")
36        p
37  }  }
38    
39    Corpus <-
40  VCorpus <-  VCorpus <-
41  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  function(x, readerControl = list(reader = reader(x), language = "en"))
42  {  {
43      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
44    
45      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
   
     if (is.function(readerControl$init))  
         readerControl$init()  
   
     if (is.function(readerControl$exit))  
         on.exit(readerControl$exit())  
   
     # Allocate memory in advance if length is known  
     tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()  
46    
47      if (x$vectorized)      x <- open(x)
48        tdl <- vector("list", length(x))
49        # Check for parallel element access
50        if (is.function(getS3method("pGetElem", class(x), TRUE)))
51          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
52                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
53                        pGetElem(x),                        pGetElem(x),
54                        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,  
55                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
56      else {      else {
57          counter <- 1          counter <- 1
58          while (!eoi(x)) {          while (!eoi(x)) {
59              x <- stepNext(x)              x <- stepNext(x)
60              elem <- getElem(x)              elem <- getElem(x)
61              id <- if (is.null(x$names) || is.na(x$names))              doc <- readerControl$reader(elem,
62                  as.character(counter)                                          readerControl$language,
63              else                                          as.character(counter))
                 x$names[counter]  
             doc <- readerControl$reader(elem, readerControl$language, id)  
             if (x$length > 0)  
64                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
65              counter <- counter + 1              counter <- counter + 1
66          }          }
67      }      }
68      if (!is.null(x$names) && !is.na(x$names))      x <- close(x)
         names(tdl) <- x$names  
69    
70      structure(list(content = tdl,      as.VCorpus(tdl)
                    meta = CorpusMeta(),  
                    dmeta = data.frame(row.names = seq_along(tdl))),  
               class = c("VCorpus", "Corpus"))  
71  }  }
72    
73  `[.PCorpus` <-  `[.PCorpus` <-
# Line 122  Line 96 
96  function(x, i)  function(x, i)
97  {  {
98      if (is.character(i))      if (is.character(i))
99          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          match(i, meta(x, "id", "local"))
100      else      else
101          i          i
102  }  }
# Line 162  Line 136 
136      x      x
137  }  }
138    
139    as.list.PCorpus <- as.list.VCorpus <-
140    function(x, ...)
141        setNames(content(x), as.character(lapply(content(x), meta, "id")))
142    
143    as.VCorpus <-
144    function(x)
145        UseMethod("as.VCorpus")
146    as.VCorpus.VCorpus <- identity
147    as.VCorpus.list <-
148    function(x)
149    {
150        v <- list(content = x,
151                  meta = CorpusMeta(),
152                  dmeta = data.frame(row.names = seq_along(x)))
153        class(v) <- c("VCorpus", "Corpus")
154        v
155    }
156    
157  outer_union <-  outer_union <-
158  function(x, y, ...)  function(x, y, ...)
159  {  {
# Line 187  Line 179 
179      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
180          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
181    
182      structure(list(content = do.call("c", lapply(args, content)),      v <- list(content = do.call("c", lapply(args, content)),
183                     meta = structure(do.call("c",                meta = CorpusMeta(meta = do.call("c",
184                       lapply(args, function(a) meta(a, type = "corpus"))),                  lapply(args, function(a) meta(a, type = "corpus")))),
185                                      class = "CorpusMeta"),                dmeta = Reduce(outer_union, lapply(args, meta)))
186                     dmeta = Reduce(outer_union, lapply(args, meta))),      class(v) <- c("VCorpus", "Corpus")
187                class = c("VCorpus", "Corpus"))      v
188  }  }
189    
 as.list.PCorpus <- as.list.VCorpus <-  
 function(x, ...)  
     content(x)  
   
190  content.VCorpus <-  content.VCorpus <-
191  function(x)  function(x)
192  {  {
# Line 214  Line 202 
202      filehash::dbMultiFetch(db, unlist(x$content))      filehash::dbMultiFetch(db, unlist(x$content))
203  }  }
204    
205    inspect <-
206    function(x)
207        UseMethod("inspect", x)
208    inspect.PCorpus <- inspect.VCorpus <-
209    function(x)
210    {
211        print(x)
212        cat("\n")
213        print(noquote(content(x)))
214        invisible(x)
215    }
216    
217  length.PCorpus <- length.VCorpus <-  length.PCorpus <- length.VCorpus <-
218  function(x)  function(x)
219      length(x$content)      length(x$content)
220    
221    names.PCorpus <- names.VCorpus <-
222    function(x)
223        as.character(meta(x, "id", "local"))
224    
225    `names<-.PCorpus` <- `names<-.VCorpus` <-
226    function(x, value)
227    {
228        meta(x, "id", "local") <- as.character(value)
229        x
230    }
231    
232  print.PCorpus <- print.VCorpus <-  print.PCorpus <- print.VCorpus <-
233  function(x, ...)  function(x, ...)
234  {  {
# Line 229  Line 240 
240      invisible(x)      invisible(x)
241  }  }
242    
 inspect <-  
 function(x)  
     UseMethod("inspect", x)  
 inspect.PCorpus <- inspect.VCorpus <-  
 function(x)  
 {  
     print(x)  
     cat("\n")  
     print(noquote(content(x)))  
     invisible(x)  
 }  
   
243  writeCorpus <-  writeCorpus <-
244  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
245  {  {

Legend:
Removed from v.1333  
changed lines
  Added in v.1411

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