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 1274, Sun Jan 5 10:51:18 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, cmeta, dmeta, dbcontrol)  
 {  
     attr(x, "CMetaData") <- cmeta  
     attr(x, "DMetaData") <- dmeta  
     attr(x, "DBControl") <- dbcontrol  
     class(x) <- c("PCorpus", "Corpus", "list")  
     x  
 }  
   
 DBControl <-  
 function(x)  
     attr(x, "DBControl")  
   
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(is.Source(x))      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 33  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))
30                  x$Names[counter]          filehash::dbInsert(db, meta(doc, "id"), doc)
31          doc <- readerControl$reader(elem, readerControl$language, id)          tdl[[counter]] <- meta(doc, "id")
         filehash::dbInsert(db, ID(doc), doc)  
         if (x$Length > 0) tdl[[counter]] <- ID(doc)  
         else tdl <- c(tdl, ID(doc))  
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, "DMetaData", df)                     meta = CorpusMeta(),
37      dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))                     dmeta = data.frame(row.names = seq_along(tdl)),
38                       dbcontrol = dbControl),
39      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)                class = c("PCorpus", "Corpus"))
40  }  }
41    
 .VCorpus <-  
 function(x, cmeta, dmeta)  
 {  
     attr(x, "CMetaData") <- cmeta  
     attr(x, "DMetaData") <- dmeta  
     class(x) <- c("VCorpus", "Corpus", "list")  
     x  
 }  
   
 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(is.Source(x))      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 86  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)))
59      else          tdl <- mapply(function(elem, id)
60          list()                            readerControl$reader(elem, readerControl$language, id),
   
     if (x$Vectorized)  
         tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),  
61                        pGetElem(x),                        pGetElem(x),
62                        id = if (is.null(x$Names) || is.na(x$Names)) as.character(seq_len(x$Length)) else x$Names,                        id = as.character(seq_along(x)),
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, .MetaDataNode(), df)                     dmeta = data.frame(row.names = seq_along(tdl))),
80                  class = c("VCorpus", "Corpus"))
81  }  }
82    
83  `[.PCorpus` <-  `[.PCorpus` <-
84  function(x, i)  function(x, i)
85  {  {
86      if (missing(i)) return(x)      if (!missing(i)) {
87      index <- attr(x, "DMetaData")[[1 , "subset"]]          x$content <- x$content[i]
88      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i          x$dmeta <- x$dmeta[i, , drop = FALSE]
89      dmeta <- attr(x, "DMetaData")      }
90      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))      x
91  }  }
92    
93  `[.VCorpus` <-  `[.VCorpus` <-
94  function(x, i)  function(x, i)
95  {  {
96      if (missing(i)) return(x)      if (!missing(i)) {
97      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])          x$content <- x$content[i]
98  }          x$dmeta <- x$dmeta[i, , drop = FALSE]
99            if (!is.null(x$lazy))
100  `[<-.PCorpus` <-              x$lazy$index <- x$lazy$index[i]
 function(x, i, value)  
 {  
     db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
     counter <- 1  
     for (id in unclass(x)[i]) {  
         if (identical(length(value), 1L)) db[[id]] <- value  
         else db[[id]] <- value[[counter]]  
         counter <- counter + 1  
101      }      }
102      x      x
103  }  }
# Line 153  Line 105 
105  .map_name_index <-  .map_name_index <-
106  function(x, i)  function(x, i)
107  {  {
108      if (is.character(i)) {      if (is.character(i))
109          if (is.null(names(x)))          match(i, meta(x, "id", "local"))
             match(i, meta(x, "ID", type = "local"))  
110          else          else
             match(i, names(x))  
     }  
111      i      i
112  }  }
113    
# Line 166  Line 115 
115  function(x, i)  function(x, i)
116  {  {
117      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
118      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
119      filehash::dbFetch(db, NextMethod("[["))      filehash::dbFetch(db, x$content[[i]])
120  }  }
121  `[[.VCorpus` <-  `[[.VCorpus` <-
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))
127          .Call("copyCorpus", x, materialize(x, i))      x$content[[i]]
     NextMethod("[[")  
128  }  }
129    
130  `[[<-.PCorpus` <-  `[[<-.PCorpus` <-
131  function(x, i, value)  function(x, i, value)
132  {  {
133      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
134      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
135      index <- unclass(x)[[i]]      db[[x$content[[i]]]] <- value
     db[[index]] <- value  
136      x      x
137  }  }
138  `[[<-.VCorpus` <-  `[[<-.VCorpus` <-
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
145          lazyTmMap$index[i] <- FALSE      x$content[[i]] <- value
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
     # Set the value  
     cl <- class(x)  
     y <- NextMethod("[[<-")  
     class(y) <- cl  
     y  
 }  
   
 # Update NodeIDs of a CMetaData tree  
 .update_id <-  
 function(x, id = 0, mapping = NULL, left.mapping = NULL, level = 0)  
 {  
     # 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) > 0) {  
             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  
146          x          x
147      }      }
     list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)  
 }  
148    
149  # Find indices to be updated for a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
150  .find_indices <-  function(x, ...)
151        content(x)
152    
153    as.VCorpus <-
154  function(x)  function(x)
155  {      UseMethod("as.VCorpus")
156      indices.mapping <- NULL  as.VCorpus.VCorpus <- identity
     for (m in levels(as.factor(DMetaData(x)$MetaID))) {  
         indices <- (DMetaData(x)$MetaID == m)  
         indices.mapping <- c(indices.mapping, list(m = indices))  
         names(indices.mapping)[length(indices.mapping)] <- m  
     }  
     indices.mapping  
 }  
157    
158  c2 <-  outer_union <-
159  function(x, y, ...)  function(x, y, ...)
160  {  {
161      # Update the CMetaData tree      if (nrow(x) > 0L)
162      cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))          x[, setdiff(names(y), names(x))] <- NA
163      update.struct <- .update_id(cmeta)      if (nrow(y) > 0L)
164            y[, setdiff(names(x), names(y))] <- NA
165      new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)      res <- rbind(x, y)
166        if (ncol(res) == 0L)
167      # Find indices to be updated for the left tree          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
168      indices.mapping <- .find_indices(x)      res
   
     # Update the DMetaData 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])  
169      }      }
170    
171      # Find indices to be updated for the right tree  c.VCorpus <-
     indices.mapping <- .find_indices(y)  
   
     # Update the DMetaData 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 DMetaData 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  
 }  
   
 c.Corpus <-  
172  function(..., recursive = FALSE)  function(..., recursive = FALSE)
173  {  {
174      args <- list(...)      args <- list(...)
# Line 302  Line 180 
180      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
181          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
182    
183      if (inherits(x, "PCorpus"))      structure(list(content = do.call("c", lapply(args, content)),
184          stop("concatenation of corpora with underlying databases is not supported")                     meta = CorpusMeta(meta = do.call("c",
185                         lapply(args, function(a) meta(a, type = "corpus")))),
186      if (recursive)                     dmeta = Reduce(outer_union, lapply(args, meta))),
187          Reduce(c2, args)                class = c("VCorpus", "Corpus"))
     else {  
         args <- do.call("c", lapply(args, unclass))  
         .VCorpus(args,  
                  cmeta = .MetaDataNode(),  
                  dmeta = data.frame(MetaID = rep(0, length(args)),  
                                     stringsAsFactors = FALSE))  
     }  
 }  
   
 c.TextDocument <-  
 function(..., recursive = FALSE)  
 {  
     args <- list(...)  
     x <- args[[1L]]  
   
     if(length(args) == 1L)  
         return(x)  
   
     if (!all(unlist(lapply(args, inherits, class(x)))))  
         stop("not all arguments are text documents")  
   
     dmeta <- data.frame(MetaID = rep(0, length(args)),  
                         stringsAsFactors = FALSE)  
     .VCorpus(args, .MetaDataNode(), dmeta)  
188  }  }
189    
190  print.Corpus <-  content.VCorpus <-
191  function(x, ...)  function(x)
192  {  {
193      cat(sprintf(ngettext(length(x),      if (!is.null(x$lazy))
194                           "A corpus with %d text document\n",          .Call(copyCorpus, x, materialize(x))
195                           "A corpus with %d text documents\n"),      x$content
                 length(x)))  
     invisible(x)  
196  }  }
197    
198  summary.Corpus <-  content.PCorpus <-
199  function(object, ...)  function(x)
200  {  {
201      print(object)      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
202      if (length(DMetaData(object)) > 0) {      filehash::dbMultiFetch(db, unlist(x$content))
         cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),  
                              "\nThe metadata consists of %d tag-value pair and a data frame\n",  
                              "\nThe metadata consists of %d tag-value pairs and a data frame\n"),  
                     length(CMetaData(object)$MetaData)))  
         cat("Available tags are:\n")  
         cat(strwrap(paste(names(CMetaData(object)$MetaData), collapse = " "), indent = 2, exdent = 2), "\n")  
         cat("Available variables in the data frame are:\n")  
         cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")  
     }  
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      summary(x)      print(x)
212      cat("\n")      cat("\n")
213      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      print(noquote(content(x)))
214      show(filehash::dbMultiFetch(db, unlist(x)))      invisible(x)
215  }  }
216  inspect.VCorpus <-  
217    length.PCorpus <- length.VCorpus <-
218  function(x)  function(x)
219  {      length(x$content)
     summary(x)  
     cat("\n")  
     print(noquote(lapply(x, identity)))  
 }  
220    
221  lapply.PCorpus <-  names.PCorpus <- names.VCorpus <-
222  function(X, FUN, ...)  function(x)
223  {      as.character(meta(x, "id", "local"))
224      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
225      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)  print.PCorpus <- print.VCorpus <-
226  }  function(x, ...)
 lapply.VCorpus <-  
 function(X, FUN, ...)  
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      base::lapply(X, FUN, ...)                         length(meta(x, type = "corpus")),
232                           ncol(meta(x, type = "indexed"))))
233        invisible(x)
234  }  }
235    
236  writeCorpus <-  writeCorpus <-
237  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
238  {  {
239      filenames <- file.path(path,      filenames <- file.path(path,
240                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))        if (is.null(filenames))
241              sprintf("%s.txt", as.character(meta(x, "id", "local")))
242                             else filenames)                             else filenames)
243      i <- 1  
244      for (o in x) {      stopifnot(length(x) == length(filenames))
245          writeLines(as.PlainTextDocument(o), filenames[i])  
246          i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
247      }  
248        invisible(x)
249  }  }

Legend:
Removed from v.1274  
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