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 1307, Tue Mar 25 12:15:51 2014 UTC revision 1409, Fri Feb 27 16:10:18 2015 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 = 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)      tdl <- vector("list", length(x))
         vector("list", as.integer(x$length))  
     else  
         list()  
   
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  
   
     df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)  
     filehash::dbInsert(db, "CorpusDMeta", df)  
     dmeta.df <- data.frame(key = "CorpusDMeta", subset = I(list(NA)))  
30    
31      .PCorpus(tdl, CorpusMeta(), dmeta.df, dbControl)      p <- list(content = tdl,
32                  meta = CorpusMeta(),
33                  dmeta = data.frame(row.names = seq_along(tdl)),
34                  dbcontrol = dbControl)
35        class(p) <- c("PCorpus", "Corpus")
36        p
37  }  }
38    
 .VCorpus <-  
 function(x, meta, dmeta)  
     structure(list(content = as.list(x), meta = meta, dmeta = dmeta),  
               class = c("VCorpus", "Corpus"))  
   
 VCorpus <-  
39  Corpus <-  Corpus <-
40  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  VCorpus <-
41    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))
46    
47      if (is.function(readerControl$init))      x <- open(x)
48          readerControl$init()      tdl <- vector("list", length(x))
49        # Check for parallel element access
50      if (is.function(readerControl$exit))      if (is.function(getS3method("pGetElem", class(x), TRUE)))
         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()  
   
     if (x$vectorized)  
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)
69          names(tdl) <- x$names  
70      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      as.VCorpus(tdl)
     .VCorpus(tdl, CorpusMeta(), df)  
71  }  }
72    
73  `[.PCorpus` <-  `[.PCorpus` <-
# Line 116  Line 75 
75  {  {
76      if (!missing(i)) {      if (!missing(i)) {
77          x$content <- x$content[i]          x$content <- x$content[i]
78          index <- x$dmeta[[1 , "subset"]]          x$dmeta <- x$dmeta[i, , drop = FALSE]
         x$dmeta[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i  
79      }      }
80      x      x
81  }  }
# Line 128  Line 86 
86      if (!missing(i)) {      if (!missing(i)) {
87          x$content <- x$content[i]          x$content <- x$content[i]
88          x$dmeta <- x$dmeta[i, , drop = FALSE]          x$dmeta <- x$dmeta[i, , drop = FALSE]
89      }          if (!is.null(x$lazy))
90      x              x$lazy$index <- x$lazy$index[i]
 }  
   
 `[<-.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  
91      }      }
92      x      x
93  }  }
# Line 151  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 167  Line 112 
112  function(x, i)  function(x, i)
113  {  {
114      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
115      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
116      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
         .Call("copyCorpus", x, materialize(x, i))  
117      x$content[[i]]      x$content[[i]]
118  }  }
119    
# Line 185  Line 129 
129  function(x, i, value)  function(x, i, value)
130  {  {
131      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
132      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
133      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
134      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
         lazyTmMap$index[i] <- FALSE  
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
135      x$content[[i]] <- value      x$content[[i]] <- value
136      x      x
137  }  }
138    
139  # Update NodeIDs of a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
140  .update_id <-  function(x, ...)
141  function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)      content(x)
 {  
     # Traversal of (binary) CMetaData tree with setup of NodeIDs  
     set_id <- function(x) {  
         x$NodeID <- id  
         id <<- id + 1  
         level <<- level + 1  
         if (length(x$Children)) {  
             mapping <<- cbind(mapping, c(x$Children[[1]]$NodeID, id))  
             left <- set_id(x$Children[[1]])  
             if (level == 1) {  
                 left.mapping <<- mapping  
                 mapping <<- NULL  
             }  
             mapping <<- cbind(mapping, c(x$Children[[2]]$NodeID, id))  
             right <- set_id(x$Children[[2]])  
   
             x$Children <- list(left, right)  
         }  
         level <<- level - 1  
         x  
     }  
     list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)  
 }  
142    
143  # Find indices to be updated for a CMetaData tree  as.VCorpus <-
144  .find_indices <-  function(x)
145        UseMethod("as.VCorpus")
146    as.VCorpus.VCorpus <- identity
147    as.VCorpus.list <-
148  function(x)  function(x)
149  {  {
150      indices.mapping <- NULL      v <- list(content = x,
151      for (m in levels(as.factor(CorpusDMeta(x)$MetaID))) {                meta = CorpusMeta(),
152          indices <- (CorpusDMeta(x)$MetaID == m)                dmeta = data.frame(row.names = seq_along(x)))
153          indices.mapping <- c(indices.mapping, list(m = indices))      class(v) <- c("VCorpus", "Corpus")
154          names(indices.mapping)[length(indices.mapping)] <- m      v
155      }  }
     indices.mapping  
 }  
   
 #c2 <-  
 #function(x, y, ...)  
 #{  
 #    # Update the CMetaData tree  
 #    cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))  
 #    update.struct <- .update_id(cmeta)  
 #  
 #    new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)  
 #  
 #    # Find indices to be updated for the left tree  
 #    indices.mapping <- .find_indices(x)  
 #  
 #    # Update the CorpusDMeta data frames for the left tree  
 #    for (i in 1:ncol(update.struct$left.mapping)) {  
 #        map <- update.struct$left.mapping[,i]  
 #        DMetaData(x)$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])  
 #    }  
 #  
 #    # Find indices to be updated for the right tree  
 #    indices.mapping <- .find_indices(y)  
 #  
 #    # Update the CorpusDMeta data frames for the right tree  
 #    for (i in 1:ncol(update.struct$right.mapping)) {  
 #        map <- update.struct$right.mapping[,i]  
 #        DMetaData(y)$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])  
 #    }  
 #  
 #    # Merge the CorpusDMeta data frames  
 #    labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))  
 #    na.matrix <- matrix(NA,  
 #                        nrow = nrow(DMetaData(x)),  
 #                        ncol = length(labels),  
 #                        dimnames = list(row.names(DMetaData(x)), labels))  
 #    x.dmeta.aug <- cbind(DMetaData(x), na.matrix)  
 #    labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))  
 #    na.matrix <- matrix(NA,  
 #                        nrow = nrow(DMetaData(y)),  
 #                        ncol = length(labels),  
 #                        dimnames = list(row.names(DMetaData(y)), labels))  
 #    y.dmeta.aug <- cbind(DMetaData(y), na.matrix)  
 #    DMetaData(new) <- rbind(x.dmeta.aug, y.dmeta.aug)  
 #  
 #    new  
 #}  
156    
157  c.Corpus <-  outer_union <-
158  function(..., recursive = FALSE)  function(x, y, ...)
159  {  {
160      args <- list(...)      if (nrow(x) > 0L)
161      x <- args[[1L]]          x[, setdiff(names(y), names(x))] <- NA
162        if (nrow(y) > 0L)
163      if(length(args) == 1L)          y[, setdiff(names(x), names(y))] <- NA
164          return(x)      res <- rbind(x, y)
165        if (ncol(res) == 0L)
166      if (!all(unlist(lapply(args, inherits, class(x)))))          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
167          stop("not all arguments are of the same corpus type")      res
   
     if (inherits(x, "PCorpus"))  
         stop("concatenation of corpora with underlying databases is not supported")  
   
     if (recursive)  
         Reduce(c2, args)  
     else {  
         args <- do.call("c", lapply(args, unclass))  
         .VCorpus(args,  
                  CorpusMeta(),  
                  data.frame(MetaID = rep(0, length(args)),  
                             stringsAsFactors = FALSE))  
     }  
168  }  }
169    
170  c.TextDocument <-  c.VCorpus <-
171  function(..., recursive = FALSE)  function(..., recursive = FALSE)
172  {  {
173      args <- list(...)      args <- list(...)
# Line 316  Line 177 
177          return(x)          return(x)
178    
179      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
180          stop("not all arguments are text documents")          stop("not all arguments are of the same corpus type")
181    
182      dmeta <- data.frame(MetaID = rep(0, length(args)),      v <- list(content = do.call("c", lapply(args, content)),
183                          stringsAsFactors = FALSE)                meta = CorpusMeta(meta = do.call("c",
184      .VCorpus(args, CorpusMeta(), dmeta)                  lapply(args, function(a) meta(a, type = "corpus")))),
185                  dmeta = Reduce(outer_union, lapply(args, meta)))
186        class(v) <- c("VCorpus", "Corpus")
187        v
188  }  }
189    
190  content.Corpus <-  content.VCorpus <-
191  function(x)  function(x)
     x$content  
   
 `content<-.Corpus` <-  
 function(x, value)  
192  {  {
193      x$content <- value      if (!is.null(x$lazy))
194      x          .Call(copyCorpus, x, materialize(x))
195        x$content
196  }  }
197    
198  length.Corpus <-  content.PCorpus <-
199  function(x)  function(x)
     length(content(x))  
   
 print.Corpus <-  
 function(x, ...)  
200  {  {
201      cat(sprintf(ngettext(length(x),      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
202                           "A corpus with %d text document\n\n",      filehash::dbMultiFetch(db, unlist(x$content))
                          "A corpus with %d text documents\n\n"),  
                 length(x)))  
   
     meta <- meta(x, type = "corpus")$value  
     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)  
203  }  }
204    
205  inspect <-  inspect <-
206  function(x)  function(x)
207      UseMethod("inspect", x)      UseMethod("inspect", x)
208  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 <-  
209  function(x)  function(x)
210  {  {
211      print(x)      print(x)
# Line 378  Line 214 
214      invisible(x)      invisible(x)
215  }  }
216    
217  lapply.PCorpus <-  length.PCorpus <- length.VCorpus <-
218  function(X, FUN, ...)  function(x)
219        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      db <- filehash::dbInit(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])      meta(x, "id", "local") <- as.character(value)
229      lapply(filehash::dbMultiFetch(db, unlist(content(X))), FUN, ...)      x
230  }  }
231  lapply.VCorpus <-  
232  function(X, FUN, ...)  print.PCorpus <- print.VCorpus <-
233    function(x, ...)
234  {  {
235      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")      writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
236      if (!is.null(lazyTmMap))                         class(x)[1],
237          .Call("copyCorpus", X, materialize(X))                         length(x),
238      lapply(content(X), FUN, ...)                         length(meta(x, type = "corpus")),
239                           ncol(meta(x, type = "indexed"))))
240        invisible(x)
241  }  }
242    
243  writeCorpus <-  writeCorpus <-

Legend:
Removed from v.1307  
changed lines
  Added in v.1409

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