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 1376, Wed May 21 14:36: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))          doc <- readerControl$reader(elem,
28              as.character(counter)                                      readerControl$language,
29          else                                      as.character(counter))
             x$names[counter]  
         doc <- readerControl$reader(elem, readerControl$language, id)  
30          filehash::dbInsert(db, meta(doc, "id"), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
31          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")          tdl[[counter]] <- meta(doc, "id")
         else tdl <- c(tdl, meta(doc, "id"))  
32          counter <- counter + 1          counter <- counter + 1
33      }      }
     if (!is.null(x$names) && !is.na(x$names))  
         names(tdl) <- x$names  
34    
35      structure(list(content = tdl,      structure(list(content = tdl,
36                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 49  Line 39 
39                class = c("PCorpus", "Corpus"))                class = c("PCorpus", "Corpus"))
40  }  }
41    
42  VCorpus <- Corpus <-  Corpus <-
43  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  VCorpus <-
44    function(x, readerControl = list(reader = reader(x), language = "en"))
45  {  {
46      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
47    
48      readerControl <- prepareReader(readerControl, x$defaultreader)      readerControl <- prepareReader(readerControl, reader(x))
49    
50      if (is.function(readerControl$init))      if (is.function(readerControl$init))
51          readerControl$init()          readerControl$init()
# Line 62  Line 53 
53      if (is.function(readerControl$exit))      if (is.function(readerControl$exit))
54          on.exit(readerControl$exit())          on.exit(readerControl$exit())
55    
56      # Allocate memory in advance if length is known      tdl <- vector("list", length(x))
57      tdl <- if (x$length > 0)      # Check for parallel element access
58          vector("list", as.integer(x$length))      if (is.function(getS3method("pGetElem", class(x), TRUE)))
     else  
         list()  
   
     if (x$vectorized)  
59          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
60                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
61                        pGetElem(x),                        pGetElem(x),
62                        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,  
63                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
64      else {      else {
65          counter <- 1          counter <- 1
66          while (!eoi(x)) {          while (!eoi(x)) {
67              x <- stepNext(x)              x <- stepNext(x)
68              elem <- getElem(x)              elem <- getElem(x)
69              id <- if (is.null(x$names) || is.na(x$names))              doc <- readerControl$reader(elem,
70                  as.character(counter)                                          readerControl$language,
71              else                                          as.character(counter))
                 x$names[counter]  
             doc <- readerControl$reader(elem, readerControl$language, id)  
             if (x$length > 0)  
72                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
73              counter <- counter + 1              counter <- counter + 1
74          }          }
75      }      }
     if (!is.null(x$names) && !is.na(x$names))  
         names(tdl) <- x$names  
76    
77      structure(list(content = tdl,      structure(list(content = tdl,
78                     meta = CorpusMeta(),                     meta = CorpusMeta(),
# Line 102  Line 80 
80                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
81  }  }
82    
83  `[.PCorpus` <- `[.VCorpus` <-  `[.PCorpus` <-
84    function(x, i)
85    {
86        if (!missing(i)) {
87            x$content <- x$content[i]
88            x$dmeta <- x$dmeta[i, , drop = FALSE]
89        }
90        x
91    }
92    
93    `[.VCorpus` <-
94  function(x, i)  function(x, i)
95  {  {
96      if (!missing(i)) {      if (!missing(i)) {
97          x$content <- x$content[i]          x$content <- x$content[i]
98          x$dmeta <- x$dmeta[i, , drop = FALSE]          x$dmeta <- x$dmeta[i, , drop = FALSE]
99            if (!is.null(x$lazy))
100                x$lazy$index <- x$lazy$index[i]
101      }      }
102      x      x
103  }  }
# Line 116  Line 106 
106  function(x, i)  function(x, i)
107  {  {
108      if (is.character(i))      if (is.character(i))
109          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          match(i, meta(x, "id", "local"))
110      else      else
111          i          i
112  }  }
# Line 132  Line 122 
122  function(x, i)  function(x, i)
123  {  {
124      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
125      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
126      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
         .Call("copyCorpus", x, materialize(x, i))  
127      x$content[[i]]      x$content[[i]]
128  }  }
129    
# Line 150  Line 139 
139  function(x, i, value)  function(x, i, value)
140  {  {
141      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
142      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
143      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
144      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
         lazyTmMap$index[i] <- FALSE  
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
145      x$content[[i]] <- value      x$content[[i]] <- value
146      x      x
147  }  }
148    
149  # Update NodeIDs of a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
150  .update_id <-  function(x, ...)
151  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)  
 }  
152    
153  # Find indices to be updated for a CMetaData tree  as.VCorpus <-
 .find_indices <-  
154  function(x)  function(x)
155  {      UseMethod("as.VCorpus")
156      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  
 #}  
157    
158  c.VCorpus <-  outer_union <-
159  function(..., recursive = FALSE)  function(x, y, ...)
160  {  {
161      args <- list(...)      if (nrow(x) > 0L)
162      x <- args[[1L]]          x[, setdiff(names(y), names(x))] <- NA
163        if (nrow(y) > 0L)
164      if (length(args) == 1L)          y[, setdiff(names(x), names(y))] <- NA
165          return(x)      res <- rbind(x, y)
166        if (ncol(res) == 0L)
167      if (!all(unlist(lapply(args, inherits, class(x)))))          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
168          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"))  
     }  
169  }  }
170    
171  c.TextDocument <-  c.VCorpus <-
172  function(..., recursive = FALSE)  function(..., recursive = FALSE)
173  {  {
174      args <- list(...)      args <- list(...)
# Line 278  Line 178 
178          return(x)          return(x)
179    
180      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
181          stop("not all arguments are text documents")          stop("not all arguments are of the same corpus type")
182    
183      structure(list(content = args,      structure(list(content = do.call("c", lapply(args, content)),
184                     meta = CorpusMeta(),                     meta = CorpusMeta(meta = do.call("c",
185                     dmeta = data.frame(row.names = seq_along(args))),                       lapply(args, function(a) meta(a, type = "corpus")))),
186                       dmeta = Reduce(outer_union, lapply(args, meta))),
187                class = c("VCorpus", "Corpus"))                class = c("VCorpus", "Corpus"))
188  }  }
189    
 as.list.PCorpus <- as.list.VCorpus <-  
 function(x, ...)  
     content(x)  
   
190  content.VCorpus <-  content.VCorpus <-
191  function(x)  function(x)
192  {  {
193      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
194      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x))
         .Call("copyCorpus", x, materialize(x))  
195      x$content      x$content
196  }  }
197    
# Line 310  Line 206 
206  function(x)  function(x)
207      length(x$content)      length(x$content)
208    
 print.PCorpus <- print.VCorpus <-  
 function(x, ...)  
 {  
     cat(sprintf(ngettext(length(x),  
                          "A corpus with %d text document\n\n",  
                          "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)  
 }  
   
209  inspect <-  inspect <-
210  function(x)  function(x)
211      UseMethod("inspect", x)      UseMethod("inspect", x)
# Line 341  Line 218 
218      invisible(x)      invisible(x)
219  }  }
220    
221    print.PCorpus <- print.VCorpus <-
222    function(x, ...)
223    {
224        writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
225                           class(x)[1],
226                           length(x),
227                           length(meta(x, type = "corpus")),
228                           ncol(meta(x, type = "indexed"))))
229        invisible(x)
230    }
231    
232  writeCorpus <-  writeCorpus <-
233  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
234  {  {

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

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