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 1313, Sun Mar 30 09:28:00 2014 UTC revision 1366, Mon Apr 28 14:48:37 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))          id <- if (is.null(names(x)))
28              as.character(counter)              as.character(counter)
29          else          else
30              x$names[counter]              names(x)[counter]
31          doc <- readerControl$reader(elem, readerControl$language, id)          doc <- readerControl$reader(elem, readerControl$language, id)
32          filehash::dbInsert(db, meta(doc, "id"), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
33          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")          tdl[[counter]] <- meta(doc, "id")
         else tdl <- c(tdl, meta(doc, "id"))  
34          counter <- counter + 1          counter <- counter + 1
35      }      }
36      if (!is.null(x$names) && !is.na(x$names))      if (!is.null(names(x)))
37          names(tdl) <- x$names          names(tdl) <- names(x)
38    
39      structure(list(content = tdl,      structure(list(content = tdl,
40                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 49  Line 43 
43                class = c("PCorpus", "Corpus"))                class = c("PCorpus", "Corpus"))
44  }  }
45    
46  VCorpus <- Corpus <-  Corpus <-
47  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  VCorpus <-
48    function(x, readerControl = list(reader = reader(x), language = "en"))
49  {  {
50      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
51    
52      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
53    
54      if (is.function(readerControl$init))      if (is.function(readerControl$init))
55          readerControl$init()          readerControl$init()
# Line 62  Line 57 
57      if (is.function(readerControl$exit))      if (is.function(readerControl$exit))
58          on.exit(readerControl$exit())          on.exit(readerControl$exit())
59    
60      # Allocate memory in advance if length is known      tdl <- vector("list", length(x))
61      tdl <- if (x$length > 0)      # Check for parallel element access
62          vector("list", as.integer(x$length))      if (is.function(getS3method("pGetElem", class(x), TRUE)))
     else  
         list()  
   
     if (x$vectorized)  
63          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
64                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
65                        pGetElem(x),                        pGetElem(x),
66                        id = if (is.null(x$names) || is.na(x$names))                        id = if (is.null(names(x)))
67                            as.character(seq_len(x$length))                            as.character(seq_len(length(x)))
68                        else x$names,                        else names(x),
69                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
70      else {      else {
71          counter <- 1          counter <- 1
72          while (!eoi(x)) {          while (!eoi(x)) {
73              x <- stepNext(x)              x <- stepNext(x)
74              elem <- getElem(x)              elem <- getElem(x)
75              id <- if (is.null(x$names) || is.na(x$names))              id <- if (is.null(names(x)))
76                  as.character(counter)                  as.character(counter)
77              else              else
78                  x$names[counter]                  names(x)[counter]
79              doc <- readerControl$reader(elem, readerControl$language, id)              doc <- readerControl$reader(elem, readerControl$language, id)
             if (x$length > 0)  
80                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
81              counter <- counter + 1              counter <- counter + 1
82          }          }
83      }      }
84      if (!is.null(x$names) && !is.na(x$names))      if (!is.null(names(x)))
85          names(tdl) <- x$names          names(tdl) <- names(x)
86    
87      structure(list(content = tdl,      structure(list(content = tdl,
88                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 102  Line 90 
90                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
91  }  }
92    
93  `[.PCorpus` <- `[.VCorpus` <-  `[.PCorpus` <-
94  function(x, i)  function(x, i)
95  {  {
96      if (!missing(i)) {      if (!missing(i)) {
# Line 112  Line 100 
100      x      x
101  }  }
102    
103    `[.VCorpus` <-
104    function(x, i)
105    {
106        if (!missing(i)) {
107            x$content <- x$content[i]
108            x$dmeta <- x$dmeta[i, , drop = FALSE]
109            if (!is.null(x$lazy))
110                x$lazy$index <- x$lazy$index[i]
111        }
112        x
113    }
114    
115  .map_name_index <-  .map_name_index <-
116  function(x, i)  function(x, i)
117  {  {
118      if (is.character(i))      if (is.character(i)) {
119          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          n <- names(x$content)
120      else          match(i, if (is.null(n)) meta(x, "id", "local") else n)
121        } else
122          i          i
123  }  }
124    
# Line 132  Line 133 
133  function(x, i)  function(x, i)
134  {  {
135      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
136      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
137      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
         .Call("copyCorpus", x, materialize(x, i))  
138      x$content[[i]]      x$content[[i]]
139  }  }
140    
# Line 150  Line 150 
150  function(x, i, value)  function(x, i, value)
151  {  {
152      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
153      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
154      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
155      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
         lazyTmMap$index[i] <- FALSE  
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
156      x$content[[i]] <- value      x$content[[i]] <- value
157      x      x
158  }  }
159    
160  # Update NodeIDs of a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
161  .update_id <-  function(x, ...)
162  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)  
 }  
163    
164  # Find indices to be updated for a CMetaData tree  as.VCorpus <-
 .find_indices <-  
165  function(x)  function(x)
166  {      UseMethod("as.VCorpus")
167      indices.mapping <- NULL  as.VCorpus.VCorpus <- identity
     for (m in levels(as.factor(CorpusDMeta(x)$MetaID))) {  
         indices <- (CorpusDMeta(x)$MetaID == m)  
         indices.mapping <- c(indices.mapping, list(m = indices))  
         names(indices.mapping)[length(indices.mapping)] <- m  
     }  
     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  
 #}  
168    
169  c.VCorpus <-  outer_union <-
170  function(..., recursive = FALSE)  function(x, y, ...)
171  {  {
172      args <- list(...)      if (nrow(x) > 0L)
173      x <- args[[1L]]          x[, setdiff(names(y), names(x))] <- NA
174        if (nrow(y) > 0L)
175      if (length(args) == 1L)          y[, setdiff(names(x), names(y))] <- NA
176          return(x)      res <- rbind(x, y)
177        if (ncol(res) == 0L)
178      if (!all(unlist(lapply(args, inherits, class(x)))))          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
179          stop("not all arguments are of the same corpus type")      res
   
     if (recursive)  
         Reduce(c2, args)  
     else {  
         args <- do.call("c", lapply(args, content))  
         structure(list(content = args,  
                        meta = CorpusMeta(),  
                        dmeta = data.frame(row.names = seq_along(args))),  
                   class = c("VCorpus", "Corpus"))  
     }  
180  }  }
181    
182  c.TextDocument <-  c.VCorpus <-
183  function(..., recursive = FALSE)  function(..., recursive = FALSE)
184  {  {
185      args <- list(...)      args <- list(...)
# Line 278  Line 189 
189          return(x)          return(x)
190    
191      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
192          stop("not all arguments are text documents")          stop("not all arguments are of the same corpus type")
193    
194      structure(list(content = args,      structure(list(content = do.call("c", lapply(args, content)),
195                     meta = CorpusMeta(),                     meta = CorpusMeta(meta = do.call("c",
196                     dmeta = data.frame(row.names = seq_along(args))),                       lapply(args, function(a) meta(a, type = "corpus")))),
197                       dmeta = Reduce(outer_union, lapply(args, meta))),
198                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
199  }  }
200    
 as.list.PCorpus <- as.list.VCorpus <-  
 function(x, ...)  
     content(x)  
   
201  content.VCorpus <-  content.VCorpus <-
202  function(x)  function(x)
203  {  {
204      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
205      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x))
         .Call("copyCorpus", x, materialize(x))  
206      x$content      x$content
207  }  }
208    
# Line 313  Line 220 
220  print.PCorpus <- print.VCorpus <-  print.PCorpus <- print.VCorpus <-
221  function(x, ...)  function(x, ...)
222  {  {
223      cat(sprintf(ngettext(length(x),      writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
224                           "A corpus with %d text document\n\n",                         class(x)[1],
225                           "A corpus with %d text documents\n\n"),                         length(x),
226                  length(x)))                         length(meta(x, type = "corpus")),
227                           ncol(meta(x, type = "indexed"))))
     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")  
   
228      invisible(x)      invisible(x)
229  }  }
230    

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

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