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 1460, Mon Jan 9 17:01:04 2017 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  .PCorpus <-  Corpus <-
4  function(x, cmeta, dmeta, dbcontrol)  function(x, readerControl = list(reader = reader(x), language = "en"))
5  {  {
6      attr(x, "CMetaData") <- cmeta      stopifnot(inherits(x, "Source"))
     attr(x, "DMetaData") <- dmeta  
     attr(x, "DBControl") <- dbcontrol  
     class(x) <- c("PCorpus", "Corpus", "list")  
     x  
 }  
7    
8  DBControl <-      readerControl <- prepareReader(readerControl, reader(x))
9  function(x)  
10      attr(x, "DBControl")      if ((inherits(x, "DirSource") || inherits(x, "VectorSource")) &&
11            identical(readerControl$reader, readPlain))
12            SimpleCorpus(x, readerControl)
13        else
14            VCorpus(x, readerControl)
15    }
16    
17  PCorpus <-  PCorpus <-
18  function(x,  function(x,
19           readerControl = list(reader = x$DefaultReader, language = "en"),           readerControl = list(reader = reader(x), language = "en"),
20           dbControl = list(dbName = "", dbType = "DB1"))           dbControl = list(dbName = "", dbType = "DB1"))
21  {  {
22      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
23    
24      readerControl <- prepareReader(readerControl, x$DefaultReader)      readerControl <- prepareReader(readerControl, reader(x))
   
     if (is.function(readerControl$init))  
         readerControl$init()  
   
     if (is.function(readerControl$exit))  
         on.exit(readerControl$exit())  
25    
26      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
27          stop("error in creating database")          stop("error in creating database")
28      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
29    
30      # Allocate memory in advance if length is known      x <- open(x)
31      tdl <- if (x$Length > 0)      tdl <- vector("list", length(x))
         vector("list", as.integer(x$Length))  
     else  
         list()  
   
32      counter <- 1      counter <- 1
33      while (!eoi(x)) {      while (!eoi(x)) {
34          x <- stepNext(x)          x <- stepNext(x)
35          elem <- getElem(x)          elem <- getElem(x)
36          id <- if (is.null(x$Names) || is.na(x$Names))          doc <- readerControl$reader(elem,
37                  as.character(counter)                                      readerControl$language,
38              else                                      as.character(counter))
39                  x$Names[counter]          filehash::dbInsert(db, meta(doc, "id"), doc)
40          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))  
41          counter <- counter + 1          counter <- counter + 1
42      }      }
43      if (!is.null(x$Names) && !is.na(x$Names))      x <- close(x)
         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)))  
44    
45      .PCorpus(tdl, .MetaDataNode(), dmeta.df, dbControl)      p <- list(content = tdl,
46                  meta = CorpusMeta(),
47                  dmeta = data.frame(row.names = seq_along(tdl)),
48                  dbcontrol = dbControl)
49        class(p) <- c("PCorpus", "Corpus")
50        p
51  }  }
52    
53  .VCorpus <-  SimpleCorpus <-
54  function(x, cmeta, dmeta)  function(x, control = list(language = "en"))
55  {  {
56      attr(x, "CMetaData") <- cmeta      stopifnot(inherits(x, "Source"))
57      attr(x, "DMetaData") <- dmeta  
58      class(x) <- c("VCorpus", "Corpus", "list")      if (!is.null(control$reader) && !identical(control$reader, readPlain))
59      x          warning("custom reader is ignored")
60    
61        content <- if (inherits(x, "VectorSource")) {
62            if (is.character(x$content)) x$content else as.character(x$content)
63        } else if (inherits(x, "DirSource")) {
64            setNames(as.character(
65                       lapply(x$filelist,
66                              function(f) paste(readContent(f, x$encoding, "text"),
67                                                collapse = "\n"))
68                       ),
69                     basename(x$filelist))
70        } else
71            stop("unsupported source type")
72        s <- list(content = content,
73                  meta = CorpusMeta(language = control$language),
74                  dmeta = data.frame(row.names = seq_along(x)))
75        class(s) <- c("SimpleCorpus", "Corpus")
76        s
77  }  }
78    
79  VCorpus <-  VCorpus <-
80  Corpus <-  function(x, readerControl = list(reader = reader(x), language = "en"))
 function(x, readerControl = list(reader = x$DefaultReader, language = "en"))  
81  {  {
82      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
83    
84      readerControl <- prepareReader(readerControl, x$DefaultReader)      readerControl <- prepareReader(readerControl, reader(x))
   
     if (is.function(readerControl$init))  
         readerControl$init()  
   
     if (is.function(readerControl$exit))  
         on.exit(readerControl$exit())  
85    
86      # Allocate memory in advance if length is known      x <- open(x)
87      tdl <- if (x$Length > 0)      tdl <- vector("list", length(x))
88          vector("list", as.integer(x$Length))      # Check for parallel element access
89      else      if (is.function(getS3method("pGetElem", class(x), TRUE)))
90          list()          tdl <- mapply(function(elem, id)
91                            readerControl$reader(elem, readerControl$language, id),
     if (x$Vectorized)  
         tdl <- mapply(function(x, id) readerControl$reader(x, readerControl$language, id),  
92                        pGetElem(x),                        pGetElem(x),
93                        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)),
94                        SIMPLIFY = FALSE)                        SIMPLIFY = FALSE)
95      else {      else {
96          counter <- 1          counter <- 1
97          while (!eoi(x)) {          while (!eoi(x)) {
98              x <- stepNext(x)              x <- stepNext(x)
99              elem <- getElem(x)              elem <- getElem(x)
100              id <- if (is.null(x$Names) || is.na(x$Names))              doc <- readerControl$reader(elem,
101                  as.character(counter)                                          readerControl$language,
102              else                                          as.character(counter))
                 x$Names[counter]  
             doc <- readerControl$reader(elem, readerControl$language, id)  
             if (x$Length > 0)  
103                  tdl[[counter]] <- doc                  tdl[[counter]] <- doc
             else  
                 tdl <- c(tdl, list(doc))  
104              counter <- counter + 1              counter <- counter + 1
105          }          }
106      }      }
107      if (!is.null(x$Names) && !is.na(x$Names))      x <- close(x)
108          names(tdl) <- x$Names  
109      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      as.VCorpus(tdl)
     .VCorpus(tdl, .MetaDataNode(), df)  
110  }  }
111    
112  `[.PCorpus` <-  `[.PCorpus` <-
113    `[.SimpleCorpus` <-
114  function(x, i)  function(x, i)
115  {  {
116      if (missing(i)) return(x)      if (!missing(i)) {
117      index <- attr(x, "DMetaData")[[1 , "subset"]]          x$content <- x$content[i]
118      attr(x, "DMetaData")[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i          x$dmeta <- x$dmeta[i, , drop = FALSE]
119      dmeta <- attr(x, "DMetaData")      }
120      .PCorpus(NextMethod("["), CMetaData(x), dmeta, DBControl(x))      x
121  }  }
   
122  `[.VCorpus` <-  `[.VCorpus` <-
123  function(x, i)  function(x, i)
124  {  {
125      if (missing(i)) return(x)      if (!missing(i)) {
126      .VCorpus(NextMethod("["), CMetaData(x), DMetaData(x)[i, , drop = FALSE])          x$content <- x$content[i]
127  }          x$dmeta <- x$dmeta[i, , drop = FALSE]
128            if (!is.null(x$lazy))
129  `[<-.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  
130      }      }
131      x      x
132  }  }
# Line 153  Line 134 
134  .map_name_index <-  .map_name_index <-
135  function(x, i)  function(x, i)
136  {  {
137      if (is.character(i)) {      if (is.character(i))
138          if (is.null(names(x)))          match(i, meta(x, "id", "local"))
             match(i, meta(x, "ID", type = "local"))  
139          else          else
             match(i, names(x))  
     }  
140      i      i
141  }  }
142    
# Line 166  Line 144 
144  function(x, i)  function(x, i)
145  {  {
146      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
147      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
148      filehash::dbFetch(db, NextMethod("[["))      filehash::dbFetch(db, x$content[[i]])
149    }
150    `[[.SimpleCorpus` <-
151    function(x, i)
152    {
153        i <- .map_name_index(x, i)
154        n <- names(x$content)
155        PlainTextDocument(x$content[[i]],
156                          id = if (is.null(n)) i else n[i],
157                          language = meta(x, "language"))
158  }  }
159  `[[.VCorpus` <-  `[[.VCorpus` <-
160  function(x, i)  function(x, i)
161  {  {
162      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
163      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
164      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x, i))
165          .Call("copyCorpus", x, materialize(x, i))      x$content[[i]]
     NextMethod("[[")  
166  }  }
167    
168  `[[<-.PCorpus` <-  `[[<-.PCorpus` <-
169  function(x, i, value)  function(x, i, value)
170  {  {
171      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
172      db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
173      index <- unclass(x)[[i]]      db[[x$content[[i]]]] <- value
     db[[index]] <- value  
174      x      x
175  }  }
176  `[[<-.VCorpus` <-  `[[<-.VCorpus` <-
177  function(x, i, value)  function(x, i, value)
178  {  {
179      i <- .map_name_index(x, i)      i <- .map_name_index(x, i)
180      # Mark new objects as not active for lazy mapping      # Mark new objects as inactive for lazy mapping
181      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
182      if (!is.null(lazyTmMap)) {          x$lazy$index[i] <- FALSE
183          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  
184          x          x
185      }      }
     list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)  
 }  
186    
187  # Find indices to be updated for a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
188  .find_indices <-  function(x, ...)
189        setNames(content(x), as.character(lapply(content(x), meta, "id")))
190    
191    as.list.SimpleCorpus <-
192    function(x, ...)
193        as.list(content(x))
194    
195    as.VCorpus <-
196    function(x)
197        UseMethod("as.VCorpus")
198    as.VCorpus.VCorpus <- identity
199    as.VCorpus.list <-
200  function(x)  function(x)
201  {  {
202      indices.mapping <- NULL      v <- list(content = x,
203      for (m in levels(as.factor(DMetaData(x)$MetaID))) {                meta = CorpusMeta(),
204          indices <- (DMetaData(x)$MetaID == m)                dmeta = data.frame(row.names = seq_along(x)))
205          indices.mapping <- c(indices.mapping, list(m = indices))      class(v) <- c("VCorpus", "Corpus")
206          names(indices.mapping)[length(indices.mapping)] <- m      v
     }  
     indices.mapping  
207  }  }
208    
209  c2 <-  outer_union <-
210  function(x, y, ...)  function(x, y, ...)
211  {  {
212      # Update the CMetaData tree      if (nrow(x) > 0L)
213      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
214      update.struct <- .update_id(cmeta)      if (nrow(y) > 0L)
215            y[, setdiff(names(x), names(y))] <- NA
216      new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)      res <- rbind(x, y)
217        if (ncol(res) == 0L)
218      # Find indices to be updated for the left tree          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
219      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])  
     }  
   
     # Find indices to be updated for the right tree  
     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  
220  }  }
221    
222  c.Corpus <-  c.VCorpus <-
223  function(..., recursive = FALSE)  function(..., recursive = FALSE)
224  {  {
225      args <- list(...)      args <- list(...)
# Line 302  Line 231 
231      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
232          stop("not all arguments are of the same corpus type")          stop("not all arguments are of the same corpus type")
233    
234      if (inherits(x, "PCorpus"))      v <- list(content = do.call("c", lapply(args, content)),
235          stop("concatenation of corpora with underlying databases is not supported")                meta = CorpusMeta(meta = do.call("c",
236                    lapply(args, function(a) meta(a, type = "corpus")))),
237      if (recursive)                dmeta = Reduce(outer_union, lapply(args, meta)))
238          Reduce(c2, args)      class(v) <- c("VCorpus", "Corpus")
239      else {      v
         args <- do.call("c", lapply(args, unclass))  
         .VCorpus(args,  
                  cmeta = .MetaDataNode(),  
                  dmeta = data.frame(MetaID = rep(0, length(args)),  
                                     stringsAsFactors = FALSE))  
     }  
240  }  }
241    
242  c.TextDocument <-  content.VCorpus <-
243  function(..., recursive = FALSE)  function(x)
244  {  {
245      args <- list(...)      if (!is.null(x$lazy))
246      x <- args[[1L]]          .Call(copyCorpus, x, materialize(x))
247        x$content
     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)  
248  }  }
249    
250  print.Corpus <-  content.SimpleCorpus <-
251  function(x, ...)  function(x)
252  {      x$content
     cat(sprintf(ngettext(length(x),  
                          "A corpus with %d text document\n",  
                          "A corpus with %d text documents\n"),  
                 length(x)))  
     invisible(x)  
 }  
253    
254  summary.Corpus <-  content.PCorpus <-
255  function(object, ...)  function(x)
256  {  {
257      print(object)      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
258      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")  
     }  
259  }  }
260    
261  inspect <-  inspect <-
262  function(x)  function(x)
263      UseMethod("inspect", x)      UseMethod("inspect", x)
264  inspect.PCorpus <-  inspect.PCorpus <-
265  function(x)  inspect.SimpleCorpus <-
 {  
     summary(x)  
     cat("\n")  
     db <- filehash::dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])  
     show(filehash::dbMultiFetch(db, unlist(x)))  
 }  
266  inspect.VCorpus <-  inspect.VCorpus <-
267  function(x)  function(x)
268  {  {
269      summary(x)      print(x)
270      cat("\n")      cat("\n")
271      print(noquote(lapply(x, identity)))      print(noquote(content(x)))
272        invisible(x)
273  }  }
274    
275  lapply.PCorpus <-  length.PCorpus <-
276  function(X, FUN, ...)  length.SimpleCorpus <-
277    length.VCorpus <-
278    function(x)
279        length(x$content)
280    
281    names.PCorpus <-
282    names.SimpleCorpus <-
283    names.VCorpus <-
284    function(x)
285        as.character(meta(x, "id", "local"))
286    
287    `names<-.PCorpus` <- `names<-.VCorpus` <-
288    function(x, value)
289  {  {
290      db <- filehash::dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])      meta(x, "id", "local") <- as.character(value)
291      lapply(filehash::dbMultiFetch(db, unlist(X)), FUN, ...)      x
292  }  }
293  lapply.VCorpus <-  
294  function(X, FUN, ...)  format.PCorpus <-
295    format.SimpleCorpus <-
296    format.VCorpus <-
297    function(x, ...)
298  {  {
299      lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus")      c(sprintf("<<%s>>", class(x)[1L]),
300      if (!is.null(lazyTmMap))        sprintf("Metadata:  corpus specific: %d, document level (indexed): %d",
301          .Call("copyCorpus", X, materialize(X))                length(meta(x, type = "corpus")),
302      base::lapply(X, FUN, ...)                ncol(meta(x, type = "indexed"))),
303          sprintf("Content:  documents: %d", length(x)))
304  }  }
305    
306  writeCorpus <-  writeCorpus <-
307  function(x, path = ".", filenames = NULL)  function(x, path = ".", filenames = NULL)
308  {  {
309      filenames <- file.path(path,      filenames <- file.path(path,
310                             if (is.null(filenames)) unlist(lapply(x, function(x) sprintf("%s.txt", ID(x))))        if (is.null(filenames))
311              sprintf("%s.txt", as.character(meta(x, "id", "local")))
312                             else filenames)                             else filenames)
313      i <- 1  
314      for (o in x) {      stopifnot(length(x) == length(filenames))
315          writeLines(as.PlainTextDocument(o), filenames[i])  
316          i <- i + 1      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
317      }  
318        invisible(x)
319  }  }

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

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