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 1308, Tue Mar 25 15:02:15 2014 UTC revision 1313, Sun Mar 30 09:28:00 2014 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
 .PCorpus <-  
 function(x, meta, dmeta, dbcontrol)  
     structure(list(content = as.list(x), meta = meta, dmeta = dmeta,  
                    dbcontrol = dbcontrol),  
               class = c("PCorpus", "Corpus"))  
   
3  PCorpus <-  PCorpus <-
4  function(x,  function(x,
5           readerControl = list(reader = x$defaultreader, language = "en"),           readerControl = list(reader = x$defaultreader, language = "en"),
# Line 48  Line 42 
42      if (!is.null(x$names) && !is.na(x$names))      if (!is.null(x$names) && !is.na(x$names))
43          names(tdl) <- x$names          names(tdl) <- x$names
44    
45      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      structure(list(content = tdl,
46      filehash::dbInsert(db, "CorpusDMeta", df)                     meta = CorpusMeta(),
47      dmeta.df <- data.frame(key = "CorpusDMeta", subset = I(list(NA)))                     dmeta = data.frame(row.names = seq_along(tdl)),
48                       dbcontrol = dbControl),
49      .PCorpus(tdl, CorpusMeta(), dmeta.df, dbControl)                class = c("PCorpus", "Corpus"))
50  }  }
51    
52  .VCorpus <-  VCorpus <- Corpus <-
 function(x, meta, dmeta)  
     structure(list(content = as.list(x), meta = meta, dmeta = dmeta),  
               class = c("VCorpus", "Corpus"))  
   
 VCorpus <-  
 Corpus <-  
53  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  function(x, readerControl = list(reader = x$defaultreader, language = "en"))
54  {  {
55      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
# Line 107  Line 95 
95      }      }
96      if (!is.null(x$names) && !is.na(x$names))      if (!is.null(x$names) && !is.na(x$names))
97          names(tdl) <- x$names          names(tdl) <- x$names
     df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)  
     .VCorpus(tdl, CorpusMeta(), df)  
 }  
98    
99  `[.PCorpus` <-      structure(list(content = tdl,
100  function(x, i)                     meta = CorpusMeta(),
101  {                     dmeta = data.frame(row.names = seq_along(tdl))),
102      if (!missing(i)) {                class = c("VCorpus", "Corpus"))
         x$content <- x$content[i]  
         index <- x$dmeta[[1 , "subset"]]  
         x$dmeta[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i  
     }  
     x  
103  }  }
104    
105  `[.VCorpus` <-  `[.PCorpus` <- `[.VCorpus` <-
106  function(x, i)  function(x, i)
107  {  {
108      if (!missing(i)) {      if (!missing(i)) {
# Line 132  Line 112 
112      x      x
113  }  }
114    
 `[<-.PCorpus` <-  
 function(x, i, value)  
 {  
     db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])  
     counter <- 1  
     for (id in x$content[i]) {  
         db[[id]] <- if (identical(length(value), 1L))  
             value  
         else  
             value[[counter]]  
         counter <- counter + 1  
     }  
     x  
 }  
   
115  .map_name_index <-  .map_name_index <-
116  function(x, i)  function(x, i)
117  {  {
# Line 280  Line 245 
245  #    new  #    new
246  #}  #}
247    
248  c.Corpus <-  c.VCorpus <-
249  function(..., recursive = FALSE)  function(..., recursive = FALSE)
250  {  {
251      args <- list(...)      args <- list(...)
# Line 292  Line 257 
257      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
258          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
259    
     if (inherits(x, "PCorpus"))  
         stop("concatenation of corpora with underlying databases is not supported")  
   
260      if (recursive)      if (recursive)
261          Reduce(c2, args)          Reduce(c2, args)
262      else {      else {
263          args <- do.call("c", lapply(args, content))          args <- do.call("c", lapply(args, content))
264          .VCorpus(args,          structure(list(content = args,
265                   CorpusMeta(),                         meta = CorpusMeta(),
266                   data.frame(MetaID = rep(0, length(args)),                         dmeta = data.frame(row.names = seq_along(args))),
267                              stringsAsFactors = FALSE))                    class = c("VCorpus", "Corpus"))
268      }      }
269  }  }
270    
# Line 318  Line 280 
280      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
281          stop("not all arguments are text documents")          stop("not all arguments are text documents")
282    
283      .VCorpus(args,      structure(list(content = args,
284               CorpusMeta(),                     meta = CorpusMeta(),
285               data.frame(MetaID = rep(0, length(args)),                     dmeta = data.frame(row.names = seq_along(args))),
286                          stringsAsFactors = FALSE))                class = c("VCorpus", "Corpus"))
287  }  }
288    
289  content.Corpus <-  as.list.PCorpus <- as.list.VCorpus <-
290    function(x, ...)
291        content(x)
292    
293    content.VCorpus <-
294  function(x)  function(x)
295    {
296        lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")
297        if (!is.null(lazyTmMap))
298            .Call("copyCorpus", x, materialize(x))
299      x$content      x$content
300    }
301    
302  `content<-.Corpus` <-  content.PCorpus <-
303  function(x, value)  function(x)
304  {  {
305      x$content <- value      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
306      x      filehash::dbMultiFetch(db, unlist(x$content))
307  }  }
308    
309  length.Corpus <-  length.PCorpus <- length.VCorpus <-
310  function(x)  function(x)
311      length(content(x))      length(x$content)
312    
313  print.Corpus <-  print.PCorpus <- print.VCorpus <-
314  function(x, ...)  function(x, ...)
315  {  {
316      cat(sprintf(ngettext(length(x),      cat(sprintf(ngettext(length(x),
# Line 347  Line 318 
318                           "A corpus with %d text documents\n\n"),                           "A corpus with %d text documents\n\n"),
319                  length(x)))                  length(x)))
320    
321      meta <- meta(x, type = "corpus")$value      meta <- meta(x, type = "corpus")
322      dmeta <- meta(x, type = "indexed")      dmeta <- meta(x, type = "indexed")
323    
324      cat("Metadata:\n")      cat("Metadata:\n")
# Line 361  Line 332 
332  inspect <-  inspect <-
333  function(x)  function(x)
334      UseMethod("inspect", x)      UseMethod("inspect", x)
335  inspect.PCorpus <-  inspect.PCorpus <- inspect.VCorpus <-
 function(x)  
 {  
     print(x)  
     cat("\n")  
     db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])  
     show(filehash::dbMultiFetch(db, unlist(x)))  
     invisible(x)  
 }  
 inspect.VCorpus <-  
336  function(x)  function(x)
337  {  {
338      print(x)      print(x)
# Line 379  Line 341 
341      invisible(x)      invisible(x)
342  }  }
343    
 lapply.PCorpus <-  
 function(X, FUN, ...)  
 {  
     db <- filehash::dbInit(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])  
     lapply(filehash::dbMultiFetch(db, unlist(content(X))), FUN, ...)  
 }  
 lapply.VCorpus <-  
 function(X, FUN, ...)  
 {  
     lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  
     if (!is.null(lazyTmMap))  
         .Call("copyCorpus", X, materialize(X))  
     lapply(content(X), FUN, ...)  
 }  
   
344  writeCorpus <-  writeCorpus <-
345  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
346  {  {

Legend:
Removed from v.1308  
changed lines
  Added in v.1313

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