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 1445, Sun Oct 9 09:30:58 2016 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, "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))
             x$names[counter]  
         doc <- readerControl$reader(elem, readerControl$language, id)  
39          filehash::dbInsert(db, meta(doc, "id"), doc)          filehash::dbInsert(db, meta(doc, "id"), doc)
40          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")          tdl[[counter]] <- meta(doc, "id")
         else tdl <- c(tdl, meta(doc, "id"))  
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  
44    
45      structure(list(content = tdl,      p <- list(content = tdl,
46                     meta = CorpusMeta(),                     meta = CorpusMeta(),
47                     dmeta = data.frame(row.names = seq_along(tdl)),                     dmeta = data.frame(row.names = seq_along(tdl)),
48                     dbcontrol = dbControl),                dbcontrol = dbControl)
49                class = c("PCorpus", "Corpus"))      class(p) <- c("PCorpus", "Corpus")
50        p
51  }  }
52    
53  VCorpus <- Corpus <-  SimpleCorpus <-
54  function(x, readerControl = list(reader = x$defaultreader, language = "en"))  function(x, control = list(language = "en"))
55  {  {
56      stopifnot(inherits(x, "Source"))      stopifnot(inherits(x, "Source"))
57    
58      readerControl <- prepareReader(readerControl, x$defaultreader)      if (!is.null(control$reader) && !identical(control$reader, readPlain))
59            warning("custom reader is ignored")
60    
61      if (is.function(readerControl$init))      content <- if (inherits(x, "VectorSource"))
62          readerControl$init()          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      if (is.function(readerControl$exit))  VCorpus <-
80          on.exit(readerControl$exit())  function(x, readerControl = list(reader = reader(x), language = "en"))
81    {
82        stopifnot(inherits(x, "Source"))
83    
84      # Allocate memory in advance if length is known      readerControl <- prepareReader(readerControl, reader(x))
     tdl <- if (x$length > 0)  
         vector("list", as.integer(x$length))  
     else  
         list()  
85    
86      if (x$vectorized)      x <- open(x)
87        tdl <- vector("list", length(x))
88        # Check for parallel element access
89        if (is.function(getS3method("pGetElem", class(x), TRUE)))
90          tdl <- mapply(function(elem, id)          tdl <- mapply(function(elem, id)
91                            readerControl$reader(elem, readerControl$language, id),                            readerControl$reader(elem, readerControl$language, id),
92                        pGetElem(x),                        pGetElem(x),
93                        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,  
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)
         names(tdl) <- x$names  
108    
109      structure(list(content = tdl,      as.VCorpus(tdl)
                    meta = CorpusMeta(),  
                    dmeta = data.frame(row.names = seq_along(tdl))),  
               class = c("VCorpus", "Corpus"))  
110  }  }
111    
112  `[.PCorpus` <- `[.VCorpus` <-  `[.PCorpus` <-
113    `[.SimpleCorpus` <-
114    function(x, i)
115    {
116        if (!missing(i)) {
117            x$content <- x$content[i]
118            x$dmeta <- x$dmeta[i, , drop = FALSE]
119        }
120        x
121    }
122    `[.VCorpus` <-
123  function(x, i)  function(x, i)
124  {  {
125      if (!missing(i)) {      if (!missing(i)) {
126          x$content <- x$content[i]          x$content <- x$content[i]
127          x$dmeta <- x$dmeta[i, , drop = FALSE]          x$dmeta <- x$dmeta[i, , drop = FALSE]
128            if (!is.null(x$lazy))
129                x$lazy$index <- x$lazy$index[i]
130      }      }
131      x      x
132  }  }
# Line 116  Line 135 
135  function(x, i)  function(x, i)
136  {  {
137      if (is.character(i))      if (is.character(i))
138          match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))          match(i, meta(x, "id", "local"))
139      else      else
140          i          i
141  }  }
# Line 128  Line 147 
147      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
148      filehash::dbFetch(db, x$content[[i]])      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))
         .Call("copyCorpus", x, materialize(x, i))  
165      x$content[[i]]      x$content[[i]]
166  }  }
167    
# Line 150  Line 177 
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
         lazyTmMap$index[i] <- FALSE  
         meta(x, tag = "lazyTmMap", type = "corpus") <- lazyTmMap  
     }  
183      x$content[[i]] <- value      x$content[[i]] <- value
184      x      x
185  }  }
186    
187  # Update NodeIDs of a CMetaData tree  as.list.PCorpus <- as.list.VCorpus <-
188  .update_id <-  function(x, ...)
189  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]])  
190    
191              x$Children <- list(left, right)  as.list.SimpleCorpus <-
192          }  function(x, ...)
193          level <<- level - 1      as.list(content(x))
         x  
     }  
     list(root = set_id(x), left.mapping = left.mapping, right.mapping = mapping)  
 }  
194    
195  # Find indices to be updated for a CMetaData tree  as.VCorpus <-
196  .find_indices <-  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,
     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,  
203                         meta = CorpusMeta(),                         meta = CorpusMeta(),
204                         dmeta = data.frame(row.names = seq_along(args))),                dmeta = data.frame(row.names = seq_along(x)))
205                    class = c("VCorpus", "Corpus"))      class(v) <- c("VCorpus", "Corpus")
206      }      v
207    }
208    
209    outer_union <-
210    function(x, y, ...)
211    {
212        if (nrow(x) > 0L)
213            x[, setdiff(names(y), names(x))] <- NA
214        if (nrow(y) > 0L)
215            y[, setdiff(names(x), names(y))] <- NA
216        res <- rbind(x, y)
217        if (ncol(res) == 0L)
218            res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
219        res
220  }  }
221    
222  c.TextDocument <-  c.VCorpus <-
223  function(..., recursive = FALSE)  function(..., recursive = FALSE)
224  {  {
225      args <- list(...)      args <- list(...)
# Line 278  Line 229 
229          return(x)          return(x)
230    
231      if (!all(unlist(lapply(args, inherits, class(x)))))      if (!all(unlist(lapply(args, inherits, class(x)))))
232          stop("not all arguments are text documents")          stop("not all arguments are of the same corpus type")
233    
234      structure(list(content = args,      v <- list(content = do.call("c", lapply(args, content)),
235                     meta = CorpusMeta(),                meta = CorpusMeta(meta = do.call("c",
236                     dmeta = data.frame(row.names = seq_along(args))),                  lapply(args, function(a) meta(a, type = "corpus")))),
237                class = c("VCorpus", "Corpus"))                dmeta = Reduce(outer_union, lapply(args, meta)))
238        class(v) <- c("VCorpus", "Corpus")
239        v
240  }  }
241    
 as.list.PCorpus <- as.list.VCorpus <-  
 function(x, ...)  
     content(x)  
   
242  content.VCorpus <-  content.VCorpus <-
243  function(x)  function(x)
244  {  {
245      lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus")      if (!is.null(x$lazy))
246      if (!is.null(lazyTmMap))          .Call(copyCorpus, x, materialize(x))
         .Call("copyCorpus", x, materialize(x))  
247      x$content      x$content
248  }  }
249    
250    content.SimpleCorpus <-
251    function(x)
252        x$content
253    
254  content.PCorpus <-  content.PCorpus <-
255  function(x)  function(x)
256  {  {
# Line 306  Line 258 
258      filehash::dbMultiFetch(db, unlist(x$content))      filehash::dbMultiFetch(db, unlist(x$content))
259  }  }
260    
 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)  
 }  
   
261  inspect <-  inspect <-
262  function(x)  function(x)
263      UseMethod("inspect", x)      UseMethod("inspect", x)
264  inspect.PCorpus <- inspect.VCorpus <-  inspect.PCorpus <-
265    inspect.SimpleCorpus <-
266    inspect.VCorpus <-
267  function(x)  function(x)
268  {  {
269      print(x)      print(x)
# Line 341  Line 272 
272      invisible(x)      invisible(x)
273  }  }
274    
275    length.PCorpus <-
276    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        meta(x, "id", "local") <- as.character(value)
291        x
292    }
293    
294    format.PCorpus <-
295    format.SimpleCorpus <-
296    format.VCorpus <-
297    function(x, ...)
298    {
299        c(sprintf("<<%s>>", class(x)[1L]),
300          sprintf("Metadata:  corpus specific: %d, document level (indexed): %d",
301                  length(meta(x, type = "corpus")),
302                  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  {  {

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

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