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 1377, Wed May 21 17:15:56 2014 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))
11    
12      if (is.function(readerControl$init))      if (is.function(readerControl$init))
13          readerControl$init()          readerControl$init()
# Line 25  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      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      structure(list(content = tdl,
36      filehash::dbInsert(db, "CorpusDMeta", df)                     meta = CorpusMeta(),
37      dmeta.df <- data.frame(key = "CorpusDMeta", subset = I(list(NA)))                     dmeta = data.frame(row.names = seq_along(tdl)),
38                       dbcontrol = dbControl),
39      .PCorpus(tdl, CorpusMeta(), dmeta.df, dbControl)                class = c("PCorpus", "Corpus"))
40  }  }
41    
 .VCorpus <-  
 function(x, meta, dmeta)  
     structure(list(content = as.list(x), meta = meta, dmeta = dmeta),  
               class = c("VCorpus", "Corpus"))  
   
 VCorpus <-  
42  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 74  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      }      }
76      if (!is.null(x$names) && !is.na(x$names))  
77          names(tdl) <- x$names      structure(list(content = tdl,
78      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)                     meta = CorpusMeta(),
79      .VCorpus(tdl, CorpusMeta(), df)                     dmeta = data.frame(row.names = seq_along(tdl))),
80                  class = c("VCorpus", "Corpus"))
81  }  }
82    
83  `[.PCorpus` <-  `[.PCorpus` <-
# Line 116  Line 85 
85  {  {
86      if (!missing(i)) {      if (!missing(i)) {
87          x$content <- x$content[i]          x$content <- x$content[i]
88          index <- x$dmeta[[1 , "subset"]]          x$dmeta <- x$dmeta[i, , drop = FALSE]
         x$dmeta[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i  
89      }      }
90      x      x
91  }  }
# Line 128  Line 96 
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              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  
101      }      }
102      x      x
103  }  }
# Line 151  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 167  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 185  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.Corpus <-  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 (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))  
     }  
169  }  }
170    
171  c.TextDocument <-  c.VCorpus <-
172  function(..., recursive = FALSE)  function(..., recursive = FALSE)
173  {  {
174      args <- list(...)      args <- list(...)
# Line 316  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      dmeta <- data.frame(MetaID = rep(0, length(args)),      structure(list(content = do.call("c", lapply(args, content)),
184                          stringsAsFactors = FALSE)                     meta = CorpusMeta(meta = do.call("c",
185      .VCorpus(args, CorpusMeta(), dmeta)                       lapply(args, function(a) meta(a, type = "corpus")))),
186                       dmeta = Reduce(outer_union, lapply(args, meta))),
187                  class = c("VCorpus", "Corpus"))
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      db <- filehash::dbInit(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])  
221      lapply(filehash::dbMultiFetch(db, unlist(content(X))), FUN, ...)  names.PCorpus <- names.VCorpus <-
222  }  function(x)
223  lapply.VCorpus <-      as.character(meta(x, "id", "local"))
224  function(X, FUN, ...)  
225    print.PCorpus <- print.VCorpus <-
226    function(x, ...)
227  {  {
228      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")      writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
229      if (!is.null(lazyTmMap))                         class(x)[1],
230          .Call("copyCorpus", X, materialize(X))                         length(x),
231      lapply(content(X), FUN, ...)                         length(meta(x, type = "corpus")),
232                           ncol(meta(x, type = "indexed"))))
233        invisible(x)
234  }  }
235    
236  writeCorpus <-  writeCorpus <-

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

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