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 1273, Sun Jan 5 08:42:02 2014 UTC revision 1333, Fri Apr 18 10:38:46 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 = x$defaultreader, 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, x$defaultreader)
11    
12      if (is.function(readerControl$init))      if (is.function(readerControl$init))
13          readerControl$init()          readerControl$init()
# Line 34  Line 20 
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      # Allocate memory in advance if length is known
23      tdl <- if (x$Length > 0)      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
         vector("list", as.integer(x$Length))  
     else  
         list()  
24    
25      counter <- 1      counter <- 1
26      while (!eoi(x)) {      while (!eoi(x)) {
27          x <- stepNext(x)          x <- stepNext(x)
28          elem <- getElem(x)          elem <- getElem(x)
29          id <- if (is.null(x$Names) || is.na(x$Names))          id <- if (is.null(x$names) || is.na(x$names))
30                  as.character(counter)                  as.character(counter)
31              else              else
32                  x$Names[counter]              x$names[counter]
33          doc <- readerControl$reader(elem, readerControl$language, id)          doc <- readerControl$reader(elem, readerControl$language, id)
34          filehash::dbInsert(db, ID(doc), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
35          if (x$Length > 0) tdl[[counter]] <- ID(doc)          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
36          else tdl <- c(tdl, ID(doc))          else tdl <- c(tdl, meta(doc, "id"))
37          counter <- counter + 1          counter <- counter + 1
38      }      }
39      if (!is.null(x$Names) && !is.na(x$Names))      if (!is.null(x$names) && !is.na(x$names))
40          names(tdl) <- x$Names          names(tdl) <- x$names
   
     df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)  
     filehash::dbInsert(db, "DMetaData", df)  
     dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA)))  
   
     .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)  
 }  
41    
42  .VCorpus <-      structure(list(content = tdl,
43  function(x, cmeta, dmeta)                     meta = CorpusMeta(),
44  {                     dmeta = data.frame(row.names = seq_along(tdl)),
45      attr(x, "CMetaData") <- cmeta                     dbcontrol = dbControl),
46      attr(x, "DMetaData") <- dmeta                class = c("PCorpus", "Corpus"))
     class(x) <- c("VCorpus", "Corpus", "list")  
     x  
47  }  }
48    
49  VCorpus <-  VCorpus <-
50  Corpus <-  function(x, readerControl = list(reader = x$defaultreader, language = "en"))
 function(x, readerControl = list(reader = x$DefaultReader, language = "en"))  
51  {  {
52      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
53    
54      readerControl <- prepareReader(readerControl, x$DefaultReader)      readerControl <- prepareReader(readerControl, x$defaultreader)
55    
56      if (is.function(readerControl$init))      if (is.function(readerControl$init))
57          readerControl$init()          readerControl$init()
# Line 87  Line 60 
60          on.exit(readerControl$exit())          on.exit(readerControl$exit())
61    
62      # Allocate memory in advance if length is known      # Allocate memory in advance if length is known
63      tdl <- if (x$Length > 0)      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
         vector("list", as.integer(x$Length))  
     else  
         list()  
64    
65      if (x$Vectorized)      if (x$vectorized)
66          tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),          tdl <- mapply(function(elem, id)
67                              readerControl$reader(elem, readerControl$language, id),
68                        pGetElem(x),                        pGetElem(x),
69                        id = if (is.null(x$Names) || is.na(x$Names)) as.character(seq_len(x$Length)) else x$Names,                        id = if (is.null(x$names) || is.na(x$names))
70                              as.character(seq_len(x$length))
71                          else x$names,
72                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
73      else {      else {
74          counter <- 1          counter <- 1
75          while (!eoi(x)) {          while (!eoi(x)) {
76              x <- stepNext(x)              x <- stepNext(x)
77              elem <- getElem(x)              elem <- getElem(x)
78              id <- if (is.null(x$Names) || is.na(x$Names))              id <- if (is.null(x$names) || is.na(x$names))
79                  as.character(counter)                  as.character(counter)
80              else              else
81                  x$Names[counter]                  x$names[counter]
82              doc <- readerControl$reader(elem, readerControl$language, id)              doc <- readerControl$reader(elem, readerControl$language, id)
83              if (x$Length > 0)              if (x$length > 0)
84                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
85              else              else
86                  tdl <- c(tdl, list(doc))                  tdl <- c(tdl, list(doc))
87              counter <- counter + 1              counter <- counter + 1
88          }          }
89      }      }
90      if (!is.null(x$Names) && !is.na(x$Names))      if (!is.null(x$names) && !is.na(x$names))
91          names(tdl) <- x$Names          names(tdl) <- x$names
92      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)  
93      .VCorpus(tdl, .MetaDataNode(), df)      structure(list(content = tdl,
94                       meta = CorpusMeta(),
95                       dmeta = data.frame(row.names = seq_along(tdl))),
96                  class = c("VCorpus", "Corpus"))
97  }  }
98    
99  `[.PCorpus` <-  `[.PCorpus` <-
100  function(x, i)  function(x, i)
101  {  {
102      if (missing(i)) return(x)      if (!missing(i)) {
103      index <- attr(x, "DMetaData")[[1 , "subset"]]          x$content <- x$content[i]
104      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i          x$dmeta <- x$dmeta[i, , drop = FALSE]
105      dmeta <- attr(x, "DMetaData")      }
106      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))      x
107  }  }
108    
109  `[.VCorpus` <-  `[.VCorpus` <-
110  function(x, i)  function(x, i)
111  {  {
112      if (missing(i)) return(x)      if (!missing(i)) {
113      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])          x$content <- x$content[i]
114  }          x$dmeta <- x$dmeta[i, , drop = FALSE]
115            if (!is.null(x$lazy))
116  `[<-.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  
117      }      }
118      x      x
119  }  }
# Line 153  Line 121 
121  .map_name_index <-  .map_name_index <-
122  function(x, i)  function(x, i)
123  {  {
124      if (is.character(i)) {      if (is.character(i))
125          if (is.null(names(x)))          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))
             match(i, meta(x, "ID", type = "local"))  
126          else          else
             match(i, names(x))  
     }  
127      i      i
128  }  }
129    
# Line 166  Line 131 
131  function(x, i)  function(x, i)
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      filehash::dbFetch(db, NextMethod("[["))      filehash::dbFetch(db, x$content[[i]])
136  }  }
137  `[[.VCorpus` <-  `[[.VCorpus` <-
138  function(x, i)  function(x, i)
139  {  {
140      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
141      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
142      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
143          .Call("copyCorpus", x, materialize(x, i))      x$content[[i]]
     NextMethod("[[")  
144  }  }
145    
146  `[[<-.PCorpus` <-  `[[<-.PCorpus` <-
147  function(x, i, value)  function(x, i, value)
148  {  {
149      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
150      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
151      index <- unclass(x)[[i]]      db[[x$content[[i]]]] <- value
     db[[index]] <- value  
152      x      x
153  }  }
154  `[[<-.VCorpus` <-  `[[<-.VCorpus` <-
155  function(x, i, value)  function(x, i, value)
156  {  {
157      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
158      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
159      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
160      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
161          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  
162          x          x
163      }      }
     list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)  
 }  
   
 # Find indices to be updated for a CMetaData tree  
 .find_indices <-  
 function(x)  
 {  
     indices.mapping <- NULL  
     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  
 }  
164    
165  c2 <-  outer_union <-
166  function(x, y, ...)  function(x, y, ...)
167  {  {
168      # Update the CMetaData tree      if (nrow(x) > 0L)
169      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
170      update.struct <- .update_id(cmeta)      if (nrow(y) > 0L)
171            y[, setdiff(names(x), names(y))] <- NA
172      new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)      res <- rbind(x, y)
173        if (ncol(res) == 0L)
174      # Find indices to be updated for the left tree          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
175      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])  
176      }      }
177    
178      # 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 <-  
179  function(..., recursive = FALSE)  function(..., recursive = FALSE)
180  {  {
181      args <- list(...)      args <- list(...)
# Line 302  Line 187 
187      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
188          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
189    
190      if (inherits(x, "PCorpus"))      structure(list(content = do.call("c", lapply(args, content)),
191          stop("concatenation of corpora with underlying databases is not supported")                     meta = structure(do.call("c",
192                         lapply(args, function(a) meta(a, type = "corpus"))),
193      if (recursive)                                      class = "CorpusMeta"),
194          Reduce(c2, args)                     dmeta = Reduce(outer_union, lapply(args, meta))),
195      else {                class = c("VCorpus", "Corpus"))
         args <- do.call("c", lapply(args, unclass))  
         .VCorpus(args,  
                  cmeta = .MetaDataNode(),  
                  dmeta = data.frame(MetaID = rep(0, length(args)),  
                                     stringsAsFactors = FALSE))  
196      }      }
 }  
   
 c.TextDocument <-  
 function(..., recursive = FALSE)  
 {  
     args <- list(...)  
     x <- args[[1L]]  
   
     if(length(args) == 1L)  
         return(x)  
197    
198      if (!all(unlist(lapply(args, inherits, class(x)))))  as.list.PCorpus <- as.list.VCorpus <-
199          stop("not all arguments are text documents")  function(x, ...)
200        content(x)
201    
202      dmeta <- data.frame(MetaID = rep(0, length(args)),  content.VCorpus <-
203                          stringsAsFactors = FALSE)  function(x)
204      .VCorpus(args, .MetaDataNode(), dmeta)  {
205        if (!is.null(x$lazy))
206            .Call(copyCorpus, x, materialize(x))
207        x$content
208  }  }
209    
210  print.Corpus <-  content.PCorpus <-
211  function(x, ...)  function(x)
212  {  {
213      cat(sprintf(ngettext(length(x),      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
214                           "A corpus with %d text document\n",      filehash::dbMultiFetch(db, unlist(x$content))
                          "A corpus with %d text documents\n"),  
                 length(x)))  
     invisible(x)  
215  }  }
216    
217  summary.Corpus <-  length.PCorpus <- length.VCorpus <-
218  function(object, ...)  function(x)
219        length(x$content)
220    
221    print.PCorpus <- print.VCorpus <-
222    function(x, ...)
223  {  {
224      print(object)      writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
225      if (length(DMetaData(object)) > 0) {                         class(x)[1],
226          cat(sprintf(ngettext(length(attr(CMetaData(object), "MetaData")),                         length(x),
227                               "\nThe metadata consists of %d tag-value pair and a data frame\n",                         length(meta(x, type = "corpus")),
228                               "\nThe metadata consists of %d tag-value pairs and a data frame\n"),                         ncol(meta(x, type = "indexed"))))
229                      length(CMetaData(object)$MetaData)))      invisible(x)
         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")  
     }  
230  }  }
231    
232  inspect <-  inspect <-
233  function(x)  function(x)
234      UseMethod("inspect", x)      UseMethod("inspect", x)
235  inspect.PCorpus <-  inspect.PCorpus <- inspect.VCorpus <-
 function(x)  
 {  
     summary(x)  
     cat("\n")  
     db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
     show(filehash::dbMultiFetch(db, unlist(x)))  
 }  
 inspect.VCorpus <-  
236  function(x)  function(x)
237  {  {
238      summary(x)      print(x)
239      cat("\n")      cat("\n")
240      print(noquote(lapply(x, identity)))      print(noquote(content(x)))
241  }      invisible(x)
   
 lapply.PCorpus <-  
 function(X, FUN, ...)  
 {  
     db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])  
     lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)  
 }  
 lapply.VCorpus <-  
 function(X, FUN, ...)  
 {  
     lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")  
     if (!is.null(lazyTmMap))  
         .Call("copyCorpus", X, materialize(X))  
     base::lapply(X, FUN, ...)  
242  }  }
243    
244  writeCorpus <-  writeCorpus <-
245  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
246  {  {
247      filenames <- file.path(path,      filenames <- file.path(path,
248                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))        if (is.null(filenames))
249              sprintf("%s.txt", as.character(meta(x, "id", "local")))
250                             else filenames)                             else filenames)
251      i <- 1  
252      for (o in x) {      stopifnot(length(x) == length(filenames))
253          writeLines(as.PlainTextDocument(o), filenames[i])  
254          i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
255      }  
256        invisible(x)
257  }  }

Legend:
Removed from v.1273  
changed lines
  Added in v.1333

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