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 1357, Thu Apr 24 06:33:35 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 <-  VCorpus <-
47  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  function(x, readerControl = list(reader = reader(x), language = "en"))
48  {  {
49      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
50    
51      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
52    
53      if (is.function(readerControl$init))      if (is.function(readerControl$init))
54          readerControl$init()          readerControl$init()
# Line 62  Line 56 
56      if (is.function(readerControl$exit))      if (is.function(readerControl$exit))
57          on.exit(readerControl$exit())          on.exit(readerControl$exit())
58    
59      # Allocate memory in advance if length is known      tdl <- vector("list", length(x))
60      tdl <- if (x$length > 0)      # Check for parallel element access
61          vector("list", as.integer(x$length))      if (is.function(getS3method("pGetElem", class(x), TRUE)))
     else  
         list()  
   
     if (x$vectorized)  
62          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
63                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
64                        pGetElem(x),                        pGetElem(x),
65                        id = if (is.null(x$names) || is.na(x$names))                        id = if (is.null(names(x)))
66                            as.character(seq_len(x$length))                            as.character(seq_len(length(x)))
67                        else x$names,                        else names(x),
68                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
69      else {      else {
70          counter <- 1          counter <- 1
71          while (!eoi(x)) {          while (!eoi(x)) {
72              x <- stepNext(x)              x <- stepNext(x)
73              elem <- getElem(x)              elem <- getElem(x)
74              id <- if (is.null(x$names) || is.na(x$names))              id <- if (is.null(names(x)))
75                  as.character(counter)                  as.character(counter)
76              else              else
77                  x$names[counter]                  names(x)[counter]
78              doc <- readerControl$reader(elem, readerControl$language, id)              doc <- readerControl$reader(elem, readerControl$language, id)
             if (x$length > 0)  
79                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
80              counter <- counter + 1              counter <- counter + 1
81          }          }
82      }      }
83      if (!is.null(x$names) && !is.na(x$names))      if (!is.null(names(x)))
84          names(tdl) <- x$names          names(tdl) <- names(x)
85    
86      structure(list(content = tdl,      structure(list(content = tdl,
87                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 102  Line 89 
89                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
90  }  }
91    
92  `[.PCorpus` <- `[.VCorpus` <-  `[.PCorpus` <-
93  function(x, i)  function(x, i)
94  {  {
95      if (!missing(i)) {      if (!missing(i)) {
# Line 112  Line 99 
99      x      x
100  }  }
101    
102    `[.VCorpus` <-
103    function(x, i)
104    {
105        if (!missing(i)) {
106            x$content <- x$content[i]
107            x$dmeta <- x$dmeta[i, , drop = FALSE]
108            if (!is.null(x$lazy))
109                x$lazy$index <- x$lazy$index[i]
110        }
111        x
112    }
113    
114  .map_name_index <-  .map_name_index <-
115  function(x, i)  function(x, i)
116  {  {
117      if (is.character(i))      if (is.character(i)) {
118          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          n <- names(x$content)
119      else          match(i, if (is.null(n)) meta(x, "id", "local") else n)
120        } else
121          i          i
122  }  }
123    
# Line 132  Line 132 
132  function(x, i)  function(x, i)
133  {  {
134      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
135      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
136      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
         .Call("copyCorpus", x, materialize(x, i))  
137      x$content[[i]]      x$content[[i]]
138  }  }
139    
# Line 150  Line 149 
149  function(x, i, value)  function(x, i, value)
150  {  {
151      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
152      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
153      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
154      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
         lazyTmMap$index[i] <- FALSE  
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
155      x$content[[i]] <- value      x$content[[i]] <- value
156      x      x
157  }  }
158    
159  # Update NodeIDs of a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
160  .update_id <-  function(x, ...)
161  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)  
 }  
162    
163  # Find indices to be updated for a CMetaData tree  as.VCorpus <-
 .find_indices <-  
164  function(x)  function(x)
165  {      UseMethod("as.VCorpus")
166      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  
 #}  
167    
168  c.VCorpus <-  outer_union <-
169  function(..., recursive = FALSE)  function(x, y, ...)
170  {  {
171      args <- list(...)      if (nrow(x) > 0L)
172      x <- args[[1L]]          x[, setdiff(names(y), names(x))] <- NA
173        if (nrow(y) > 0L)
174      if (length(args) == 1L)          y[, setdiff(names(x), names(y))] <- NA
175          return(x)      res <- rbind(x, y)
176        if (ncol(res) == 0L)
177      if (!all(unlist(lapply(args, inherits, class(x)))))          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
178          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"))  
     }  
179  }  }
180    
181  c.TextDocument <-  c.VCorpus <-
182  function(..., recursive = FALSE)  function(..., recursive = FALSE)
183  {  {
184      args <- list(...)      args <- list(...)
# Line 278  Line 188 
188          return(x)          return(x)
189    
190      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
191          stop("not all arguments are text documents")          stop("not all arguments are of the same corpus type")
192    
193      structure(list(content = args,      structure(list(content = do.call("c", lapply(args, content)),
194                     meta = CorpusMeta(),                     meta = structure(do.call("c",
195                     dmeta = data.frame(row.names = seq_along(args))),                       lapply(args, function(a) meta(a, type = "corpus"))),
196                                        class = "CorpusMeta"),
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.1357

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