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

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

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