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 1312, Sat Mar 29 09:35:44 2014 UTC revision 1419, Sat May 2 17:23:47 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)      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  
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  VCorpus <- 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))
   
     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)
71                     meta = CorpusMeta(),  }
72                     dmeta = data.frame(row.names = seq_along(tdl))),  
73                class = c("VCorpus", "Corpus"))  `[.PCorpus` <-
74    function(x, i)
75    {
76        if (!missing(i)) {
77            x$content <- x$content[i]
78            x$dmeta <- x$dmeta[i, , drop = FALSE]
79        }
80        x
81  }  }
82    
83  `[.PCorpus` <- `[.VCorpus` <-  `[.VCorpus` <-
84  function(x, i)  function(x, i)
85  {  {
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$lazy$index <- x$lazy$index[i]
91      }      }
92      x      x
93  }  }
# Line 116  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 132  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 150  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)      setNames(content(x), as.character(lapply(content(x), meta, "id")))
 {  
     # 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, content))  
         .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 281  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      .VCorpus(args,      v <- list(content = do.call("c", lapply(args, content)),
183               CorpusMeta(),                meta = CorpusMeta(meta = do.call("c",
184               data.frame(MetaID = rep(0, length(args)),                  lapply(args, function(a) meta(a, type = "corpus")))),
185                          stringsAsFactors = FALSE))                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")  
     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 <-
209  function(x)  function(x)
210  {  {
211      print(x)      print(x)
212      cat("\n")      cat("\n")
213      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])      print(noquote(content(x)))
     show(filehash::dbMultiFetch(db, unlist(content(x))))  
214      invisible(x)      invisible(x)
215  }  }
216  inspect.VCorpus <-  
217    length.PCorpus <- length.VCorpus <-
218  function(x)  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      print(x)      meta(x, "id", "local") <- as.character(value)
229      cat("\n")      x
     print(noquote(content(x)))  
     invisible(x)  
230  }  }
231    
232  # TODO: lapply() is not generic but as.list() is  format.PCorpus <- format.VCorpus <-
233  #  function(x, ...)
234  #lapply.PCorpus <-  {
235  #function(X, FUN, ...)      c(sprintf("<<%s>>", class(x)[1L]),
236  #{        sprintf("Metadata:  corpus specific: %d, document level (indexed): %d",
237  #    db <- filehash::dbInit(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])                length(meta(x, type = "corpus")),
238  #    lapply(filehash::dbMultiFetch(db, unlist(content(X))), FUN, ...)                ncol(meta(x, type = "indexed"))),
239  #}        sprintf("Content:  documents: %d", length(x)))
240  #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, ...)  
 #}  
241    
242  writeCorpus <-  writeCorpus <-
243  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)

Legend:
Removed from v.1312  
changed lines
  Added in v.1419

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