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 1307, Tue Mar 25 12:15:51 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, meta, dmeta, dbcontrol)  function(x, readerControl = list(reader = reader(x), language = "en"))
5      structure(list(content = as.list(x), meta = meta, dmeta = dmeta,  {
6                     dbcontrol = dbcontrol),      stopifnot(inherits(x, "Source"))
7                class = c("PCorpus", "Corpus"))  
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      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      p <- list(content = tdl,
46      filehash::dbInsert(db, "CorpusDMeta", df)                meta = CorpusMeta(),
47      dmeta.df <- data.frame(key = "CorpusDMeta", subset = I(list(NA)))                dmeta = data.frame(row.names = seq_along(tdl)),
48                  dbcontrol = dbControl)
49      .PCorpus(tdl, CorpusMeta(), dmeta.df, dbControl)      class(p) <- c("PCorpus", "Corpus")
50        p
51  }  }
52    
53  .VCorpus <-  SimpleCorpus <-
54  function(x, meta, dmeta)  function(x, control = list(language = "en"))
     structure(list(content = as.list(x), meta = meta, dmeta = dmeta),  
               class = c("VCorpus", "Corpus"))  
   
 VCorpus <-  
 Corpus <-  
 function(x, readerControl = list(reader = x$defaultreader, 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()          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      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)
108          names(tdl) <- x$names  
109      df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE)      as.VCorpus(tdl)
     .VCorpus(tdl, CorpusMeta(), df)  
110  }  }
111    
112  `[.PCorpus` <-  `[.PCorpus` <-
113    `[.SimpleCorpus` <-
114  function(x, i)  function(x, i)
115  {  {
116      if (!missing(i)) {      if (!missing(i)) {
117          x$content <- x$content[i]          x$content <- x$content[i]
118          index <- x$dmeta[[1 , "subset"]]          x$dmeta <- x$dmeta[i, , drop = FALSE]
         x$dmeta[[1 , "subset"]] <- if (is.numeric(index)) index[i] else i  
119      }      }
120      x      x
121  }  }
   
122  `[.VCorpus` <-  `[.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              x$lazy$index <- x$lazy$index[i]
 }  
   
 `[<-.PCorpus` <-  
 function(x, i, value)  
 {  
     db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])  
     counter <- 1  
     for (id in x$content[i]) {  
         db[[id]] <- if (identical(length(value), 1L))  
             value  
         else  
             value[[counter]]  
         counter <- counter + 1  
130      }      }
131      x      x
132  }  }
# Line 151  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 163  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 185  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,
203      for (m in levels(as.factor(CorpusDMeta(x)$MetaID))) {                meta = CorpusMeta(),
204          indices <- (CorpusDMeta(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
207      }  }
208      indices.mapping  
209  }  outer_union <-
210    function(x, y, ...)
211  #c2 <-  {
212  #function(x, y, ...)      if (nrow(x) > 0L)
213  #{          x[, setdiff(names(y), names(x))] <- NA
214  #    # Update the CMetaData tree      if (nrow(y) > 0L)
215  #    cmeta <- .MetaDataNode(0, list(merge_date = as.POSIXlt(Sys.time(), tz = "GMT"), merger = Sys.getenv("LOGNAME")), list(CMetaData(x), CMetaData(y)))          y[, setdiff(names(x), names(y))] <- NA
216  #    update.struct <- .update_id(cmeta)      res <- rbind(x, y)
217  #      if (ncol(res) == 0L)
218  #    new <- .VCorpus(c(unclass(x), unclass(y)), update.struct$root, NULL)          res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
219  #      res
220  #    # 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  
 #}  
221    
222  c.Corpus <-  c.VCorpus <-
223  function(..., recursive = FALSE)  function(..., recursive = FALSE)
224  {  {
225      args <- list(...)      args <- list(...)
# Line 292  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,  
                  CorpusMeta(),  
                  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, CorpusMeta(), dmeta)  
248  }  }
249    
250  content.Corpus <-  content.SimpleCorpus <-
251  function(x)  function(x)
252      x$content      x$content
253    
254  `content<-.Corpus` <-  content.PCorpus <-
 function(x, value)  
 {  
     x$content <- value  
     x  
 }  
   
 length.Corpus <-  
255  function(x)  function(x)
     length(content(x))  
   
 print.Corpus <-  
 function(x, ...)  
256  {  {
257      cat(sprintf(ngettext(length(x),      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
258                           "A corpus with %d text document\n\n",      filehash::dbMultiFetch(db, unlist(x$content))
                          "A corpus with %d text documents\n\n"),  
                 length(x)))  
   
     meta <- meta(x, type = "corpus")$value  
     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)  
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 <-
 {  
     print(x)  
     cat("\n")  
     db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])  
     show(filehash::dbMultiFetch(db, unlist(x)))  
     invisible(x)  
 }  
266  inspect.VCorpus <-  inspect.VCorpus <-
267  function(x)  function(x)
268  {  {
# Line 378  Line 272 
272      invisible(x)      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(X$dbcontrol[["dbName"]], X$dbcontrol[["dbType"]])      meta(x, "id", "local") <- as.character(value)
291      lapply(filehash::dbMultiFetch(db, unlist(content(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      lapply(content(X), FUN, ...)                ncol(meta(x, type = "indexed"))),
303          sprintf("Content:  documents: %d", length(x)))
304  }  }
305    
306  writeCorpus <-  writeCorpus <-

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