SCM Repository
Annotation of /pkg/R/corpus.R
Parent Directory
|
Revision Log
Revision 833 -
(view)
(download)
Original Path: trunk/tm/R/textdoccol.R
1 : | feinerer | 17 | # Author: Ingo Feinerer |
2 : | |||
3 : | feinerer | 722 | # The "..." are additional arguments for the FunctionGenerator reader |
4 : | feinerer | 816 | setGeneric("Corpus", function(object, |
5 : | feinerer | 817 | readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE), |
6 : | feinerer | 741 | dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"), |
7 : | feinerer | 816 | ...) standardGeneric("Corpus")) |
8 : | setMethod("Corpus", | ||
9 : | feinerer | 63 | signature(object = "Source"), |
10 : | feinerer | 717 | function(object, |
11 : | feinerer | 817 | readerControl = list(reader = object@DefaultReader, language = "en_US", load = TRUE), |
12 : | feinerer | 741 | dbControl = list(useDb = FALSE, dbName = "", dbType = "DB1"), |
13 : | feinerer | 733 | ...) { |
14 : | feinerer | 809 | if (is.null(readerControl$reader)) |
15 : | readerControl$reader <- object@DefaultReader | ||
16 : | feinerer | 777 | if (is(readerControl$reader, "FunctionGenerator")) |
17 : | feinerer | 722 | readerControl$reader <- readerControl$reader(...) |
18 : | feinerer | 799 | if (is.null(readerControl$language)) |
19 : | readerControl$language = "en_US" | ||
20 : | if (is.null(readerControl$load)) | ||
21 : | feinerer | 817 | readerControl$load = TRUE |
22 : | feinerer | 63 | |
23 : | feinerer | 712 | if (dbControl$useDb) { |
24 : | if (!dbCreate(dbControl$dbName, dbControl$dbType)) | ||
25 : | stop("error in creating database") | ||
26 : | db <- dbInit(dbControl$dbName, dbControl$dbType) | ||
27 : | } | ||
28 : | |||
29 : | feinerer | 63 | tdl <- list() |
30 : | counter <- 1 | ||
31 : | while (!eoi(object)) { | ||
32 : | feinerer | 698 | object <- stepNext(object) |
33 : | elem <- getElem(object) | ||
34 : | feinerer | 63 | # If there is no Load on Demand support |
35 : | # we need to load the corpus into memory at startup | ||
36 : | feinerer | 694 | if (!object@LoDSupport) |
37 : | feinerer | 722 | readerControl$load <- TRUE |
38 : | doc <- readerControl$reader(elem, readerControl$load, readerControl$language, as.character(counter)) | ||
39 : | feinerer | 712 | if (dbControl$useDb) { |
40 : | dbInsert(db, ID(doc), doc) | ||
41 : | tdl <- c(tdl, ID(doc)) | ||
42 : | } | ||
43 : | else | ||
44 : | tdl <- c(tdl, list(doc)) | ||
45 : | feinerer | 63 | counter <- counter + 1 |
46 : | } | ||
47 : | |||
48 : | feinerer | 712 | df <- data.frame(MetaID = rep(0, length(tdl)), stringsAsFactors = FALSE) |
49 : | if (dbControl$useDb) { | ||
50 : | dbInsert(db, "DMetaData", df) | ||
51 : | feinerer | 727 | dmeta.df <- data.frame(key = "DMetaData", subset = I(list(NA))) |
52 : | feinerer | 712 | } |
53 : | else | ||
54 : | dmeta.df <- df | ||
55 : | |||
56 : | feinerer | 698 | cmeta.node <- new("MetaDataNode", |
57 : | feinerer | 71 | NodeID = 0, |
58 : | feinerer | 689 | MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")), |
59 : | feinerer | 71 | children = list()) |
60 : | |||
61 : | feinerer | 816 | return(new("Corpus", .Data = tdl, DMetaData = dmeta.df, CMetaData = cmeta.node, DBControl = dbControl)) |
62 : | feinerer | 21 | }) |
63 : | |||
64 : | feinerer | 698 | setGeneric("loadDoc", function(object, ...) standardGeneric("loadDoc")) |
65 : | setMethod("loadDoc", | ||
66 : | feinerer | 62 | signature(object = "PlainTextDocument"), |
67 : | feinerer | 65 | function(object, ...) { |
68 : | feinerer | 61 | if (!Cached(object)) { |
69 : | feinerer | 67 | con <- eval(URI(object)) |
70 : | feinerer | 65 | corpus <- readLines(con) |
71 : | close(con) | ||
72 : | feinerer | 816 | Content(object) <- corpus |
73 : | feinerer | 60 | Cached(object) <- TRUE |
74 : | feinerer | 56 | return(object) |
75 : | } else { | ||
76 : | return(object) | ||
77 : | } | ||
78 : | }) | ||
79 : | feinerer | 698 | setMethod("loadDoc", |
80 : | feinerer | 62 | signature(object = "XMLTextDocument"), |
81 : | feinerer | 65 | function(object, ...) { |
82 : | feinerer | 61 | if (!Cached(object)) { |
83 : | feinerer | 67 | con <- eval(URI(object)) |
84 : | feinerer | 65 | corpus <- paste(readLines(con), "\n", collapse = "") |
85 : | close(con) | ||
86 : | doc <- xmlTreeParse(corpus, asText = TRUE) | ||
87 : | feinerer | 49 | class(doc) <- "list" |
88 : | feinerer | 816 | Content(object) <- doc |
89 : | feinerer | 60 | Cached(object) <- TRUE |
90 : | feinerer | 49 | return(object) |
91 : | } else { | ||
92 : | return(object) | ||
93 : | } | ||
94 : | }) | ||
95 : | feinerer | 698 | setMethod("loadDoc", |
96 : | feinerer | 62 | signature(object = "NewsgroupDocument"), |
97 : | feinerer | 65 | function(object, ...) { |
98 : | feinerer | 61 | if (!Cached(object)) { |
99 : | feinerer | 67 | con <- eval(URI(object)) |
100 : | feinerer | 65 | mail <- readLines(con) |
101 : | close(con) | ||
102 : | feinerer | 60 | Cached(object) <- TRUE |
103 : | feinerer | 744 | for (index in seq_along(mail)) { |
104 : | feinerer | 65 | if (mail[index] == "") |
105 : | break | ||
106 : | } | ||
107 : | feinerer | 816 | Content(object) <- mail[(index + 1):length(mail)] |
108 : | feinerer | 56 | return(object) |
109 : | } else { | ||
110 : | return(object) | ||
111 : | } | ||
112 : | }) | ||
113 : | feinerer | 767 | setMethod("loadDoc", |
114 : | signature(object = "StructuredTextDocument"), | ||
115 : | function(object, ...) { | ||
116 : | if (!Cached(object)) { | ||
117 : | warning("load on demand not (yet) supported for StructuredTextDocuments") | ||
118 : | return(object) | ||
119 : | } else | ||
120 : | return(object) | ||
121 : | }) | ||
122 : | feinerer | 49 | |
123 : | feinerer | 719 | setGeneric("tmUpdate", function(object, |
124 : | origin, | ||
125 : | feinerer | 817 | readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE), |
126 : | feinerer | 719 | ...) standardGeneric("tmUpdate")) |
127 : | feinerer | 72 | # Update is only supported for directories |
128 : | # At the moment no other LoD devices are available anyway | ||
129 : | feinerer | 698 | setMethod("tmUpdate", |
130 : | feinerer | 816 | signature(object = "Corpus", origin = "DirSource"), |
131 : | feinerer | 719 | function(object, origin, |
132 : | feinerer | 817 | readerControl = list(reader = origin@DefaultReader, language = "en_US", load = TRUE), |
133 : | feinerer | 719 | ...) { |
134 : | feinerer | 809 | if (is.null(readerControl$reader)) |
135 : | readerControl$reader <- origin@DefaultReader | ||
136 : | feinerer | 777 | if (is(readerControl$reader, "FunctionGenerator")) |
137 : | feinerer | 722 | readerControl$reader <- readerControl$reader(...) |
138 : | feinerer | 809 | if (is.null(readerControl$language)) |
139 : | readerControl$language = "en_US" | ||
140 : | if (is.null(readerControl$load)) | ||
141 : | feinerer | 817 | readerControl$load = TRUE |
142 : | feinerer | 72 | |
143 : | object.filelist <- unlist(lapply(object, function(x) {as.character(URI(x))[2]})) | ||
144 : | new.files <- setdiff(origin@FileList, object.filelist) | ||
145 : | |||
146 : | for (filename in new.files) { | ||
147 : | feinerer | 812 | encoding <- origin@Encoding |
148 : | elem <- list(content = readLines(filename, encoding = encoding), | ||
149 : | uri = substitute(file(filename, encoding = encoding))) | ||
150 : | feinerer | 722 | object <- appendElem(object, readerControl$reader(elem, readerControl$load, readerControl$language, filename)) |
151 : | feinerer | 72 | } |
152 : | |||
153 : | return(object) | ||
154 : | }) | ||
155 : | |||
156 : | feinerer | 830 | setGeneric("tmMap", function(object, FUN, ..., lazy = FALSE) standardGeneric("tmMap")) |
157 : | feinerer | 698 | setMethod("tmMap", |
158 : | feinerer | 816 | signature(object = "Corpus", FUN = "function"), |
159 : | feinerer | 830 | function(object, FUN, ..., lazy = FALSE) { |
160 : | feinerer | 73 | result <- object |
161 : | feinerer | 689 | # Note that text corpora are automatically loaded into memory via \code{[[} |
162 : | feinerer | 719 | if (DBControl(object)[["useDb"]]) { |
163 : | feinerer | 830 | if (lazy) |
164 : | warning("lazy mapping is deactived when using database backend") | ||
165 : | feinerer | 719 | db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]]) |
166 : | feinerer | 728 | i <- 1 |
167 : | for (id in unlist(object)) { | ||
168 : | db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object)) | ||
169 : | i <- i + 1 | ||
170 : | } | ||
171 : | feinerer | 833 | # Suggested by Christian Buchta |
172 : | dbReorganize(db) | ||
173 : | feinerer | 719 | } |
174 : | feinerer | 828 | else { |
175 : | feinerer | 830 | # Lazy mapping |
176 : | if (lazy) { | ||
177 : | lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus") | ||
178 : | if (is.null(lazyTmMap)) { | ||
179 : | meta(result, tag = "lazyTmMap", type = "corpus") <- | ||
180 : | list(index = rep(TRUE, length(result)), | ||
181 : | maps = list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData))) | ||
182 : | } | ||
183 : | else { | ||
184 : | lazyTmMap$maps <- c(lazyTmMap$maps, list(function(x, DMetaData) FUN(x, ..., DMetaData = DMetaData))) | ||
185 : | meta(result, tag = "lazyTmMap", type = "corpus") <- lazyTmMap | ||
186 : | } | ||
187 : | } | ||
188 : | feinerer | 828 | else |
189 : | result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object)) | ||
190 : | } | ||
191 : | feinerer | 56 | return(result) |
192 : | feinerer | 49 | }) |
193 : | |||
194 : | feinerer | 828 | # Materialize lazy mappings |
195 : | feinerer | 833 | # Improvements by Christian Buchta |
196 : | feinerer | 829 | materialize <- function(corpus, range = seq_along(corpus)) { |
197 : | feinerer | 828 | lazyTmMap <- meta(corpus, tag = "lazyTmMap", type = "corpus") |
198 : | feinerer | 829 | if (!is.null(lazyTmMap)) { |
199 : | feinerer | 833 | # Make valid and lazy index |
200 : | idx <- (seq_along(corpus) %in% range) & lazyTmMap$index | ||
201 : | if (any(idx)) { | ||
202 : | res <- lapply(corpus@.Data[idx], loadDoc) | ||
203 : | for (m in lazyTmMap$maps) | ||
204 : | res <- lapply(res, m, DMetaData = DMetaData(corpus)) | ||
205 : | corpus@.Data[idx] <- res | ||
206 : | lazyTmMap$index[idx] <- FALSE | ||
207 : | } | ||
208 : | feinerer | 829 | } |
209 : | feinerer | 830 | # Clean up if everything is materialized |
210 : | if (!any(lazyTmMap$index)) | ||
211 : | lazyTmMap <- NULL | ||
212 : | feinerer | 829 | meta(corpus, tag = "lazyTmMap", type = "corpus") <- lazyTmMap |
213 : | feinerer | 828 | return(corpus) |
214 : | } | ||
215 : | |||
216 : | feinerer | 698 | setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain")) |
217 : | setMethod("asPlain", | ||
218 : | feinerer | 62 | signature(object = "PlainTextDocument"), |
219 : | feinerer | 49 | function(object, FUN, ...) { |
220 : | return(object) | ||
221 : | }) | ||
222 : | feinerer | 698 | setMethod("asPlain", |
223 : | feinerer | 62 | signature(object = "XMLTextDocument", FUN = "function"), |
224 : | feinerer | 49 | function(object, FUN, ...) { |
225 : | feinerer | 816 | corpus <- Content(object) |
226 : | feinerer | 49 | |
227 : | # As XMLDocument is no native S4 class, restore valid information | ||
228 : | class(corpus) <- "XMLDocument" | ||
229 : | names(corpus) <- c("doc","dtd") | ||
230 : | |||
231 : | feinerer | 61 | return(FUN(xmlRoot(corpus), ...)) |
232 : | feinerer | 49 | }) |
233 : | feinerer | 725 | setMethod("asPlain", |
234 : | feinerer | 757 | signature(object = "Reuters21578Document"), |
235 : | function(object, FUN, ...) { | ||
236 : | FUN <- convertReut21578XMLPlain | ||
237 : | feinerer | 816 | corpus <- Content(object) |
238 : | feinerer | 757 | |
239 : | # As XMLDocument is no native S4 class, restore valid information | ||
240 : | class(corpus) <- "XMLDocument" | ||
241 : | names(corpus) <- c("doc","dtd") | ||
242 : | |||
243 : | return(FUN(xmlRoot(corpus), ...)) | ||
244 : | }) | ||
245 : | setMethod("asPlain", | ||
246 : | signature(object = "RCV1Document"), | ||
247 : | function(object, FUN, ...) { | ||
248 : | FUN <- convertRCV1Plain | ||
249 : | feinerer | 816 | corpus <- Content(object) |
250 : | feinerer | 757 | |
251 : | # As XMLDocument is no native S4 class, restore valid information | ||
252 : | class(corpus) <- "XMLDocument" | ||
253 : | names(corpus) <- c("doc","dtd") | ||
254 : | |||
255 : | return(FUN(xmlRoot(corpus), ...)) | ||
256 : | }) | ||
257 : | setMethod("asPlain", | ||
258 : | feinerer | 725 | signature(object = "NewsgroupDocument"), |
259 : | function(object, FUN, ...) { | ||
260 : | feinerer | 816 | new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object), |
261 : | feinerer | 725 | DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object), |
262 : | feinerer | 826 | Origin = Origin(object), Heading = Heading(object), Language = Language(object), |
263 : | LocalMetaData = LocalMetaData(object)) | ||
264 : | feinerer | 725 | }) |
265 : | feinerer | 775 | setMethod("asPlain", |
266 : | signature(object = "StructuredTextDocument"), | ||
267 : | function(object, FUN, ...) { | ||
268 : | feinerer | 816 | new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE, |
269 : | feinerer | 775 | URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object), |
270 : | Description = Description(object), ID = ID(object), Origin = Origin(object), | ||
271 : | feinerer | 826 | Heading = Heading(object), Language = Language(object), |
272 : | LocalMetaData = LocalMetaData(object)) | ||
273 : | feinerer | 775 | }) |
274 : | feinerer | 49 | |
275 : | feinerer | 698 | setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter")) |
276 : | setMethod("tmFilter", | ||
277 : | feinerer | 816 | signature(object = "Corpus"), |
278 : | feinerer | 698 | function(object, ..., FUN = sFilter, doclevel = FALSE) { |
279 : | feinerer | 73 | if (doclevel) |
280 : | return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))]) | ||
281 : | else | ||
282 : | feinerer | 724 | return(object[FUN(object, ...)]) |
283 : | feinerer | 61 | }) |
284 : | |||
285 : | feinerer | 698 | setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex")) |
286 : | setMethod("tmIndex", | ||
287 : | feinerer | 816 | signature(object = "Corpus"), |
288 : | feinerer | 698 | function(object, ..., FUN = sFilter, doclevel = FALSE) { |
289 : | feinerer | 73 | if (doclevel) |
290 : | return(sapply(object, FUN, ..., DMetaData = DMetaData(object))) | ||
291 : | else | ||
292 : | feinerer | 724 | return(FUN(object, ...)) |
293 : | feinerer | 49 | }) |
294 : | |||
295 : | feinerer | 698 | sFilter <- function(object, s, ...) { |
296 : | feinerer | 73 | con <- textConnection(s) |
297 : | feinerer | 772 | tokens <- scan(con, "character", quiet = TRUE) |
298 : | feinerer | 73 | close(con) |
299 : | feinerer | 721 | localMetaNames <- unique(names(sapply(object, LocalMetaData))) |
300 : | localMetaTokens <- localMetaNames[localMetaNames %in% tokens] | ||
301 : | feinerer | 729 | n <- names(DMetaData(object)) |
302 : | tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens) | ||
303 : | query.df <- DMetaData(prescindMeta(object, tags)) | ||
304 : | if (DBControl(object)[["useDb"]]) | ||
305 : | DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE] | ||
306 : | feinerer | 721 | # Rename to avoid name conflicts |
307 : | names(query.df)[names(query.df) == "Author"] <- "author" | ||
308 : | names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp" | ||
309 : | names(query.df)[names(query.df) == "Description"] <- "description" | ||
310 : | names(query.df)[names(query.df) == "ID"] <- "identifier" | ||
311 : | names(query.df)[names(query.df) == "Origin"] <- "origin" | ||
312 : | names(query.df)[names(query.df) == "Heading"] <- "heading" | ||
313 : | names(query.df)[names(query.df) == "Language"] <- "language" | ||
314 : | feinerer | 73 | attach(query.df) |
315 : | feinerer | 74 | try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ])) |
316 : | feinerer | 73 | detach(query.df) |
317 : | return(result) | ||
318 : | feinerer | 61 | } |
319 : | |||
320 : | feinerer | 698 | setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem")) |
321 : | setMethod("appendElem", | ||
322 : | feinerer | 816 | signature(object = "Corpus", data = "TextDocument"), |
323 : | feinerer | 72 | function(object, data, meta = NULL) { |
324 : | feinerer | 712 | if (DBControl(object)[["useDb"]]) { |
325 : | db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]]) | ||
326 : | if (dbExists(db, ID(data))) | ||
327 : | warning("document with identical ID already exists") | ||
328 : | dbInsert(db, ID(data), data) | ||
329 : | object@.Data[[length(object)+1]] <- ID(data) | ||
330 : | } | ||
331 : | else | ||
332 : | object@.Data[[length(object)+1]] <- data | ||
333 : | DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta)) | ||
334 : | feinerer | 52 | return(object) |
335 : | }) | ||
336 : | |||
337 : | feinerer | 698 | setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta")) |
338 : | setMethod("appendMeta", | ||
339 : | feinerer | 816 | signature(object = "Corpus"), |
340 : | feinerer | 698 | function(object, cmeta = NULL, dmeta = NULL) { |
341 : | feinerer | 712 | object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta) |
342 : | if (!is.null(dmeta)) { | ||
343 : | feinerer | 719 | DMetaData(object) <- cbind(DMetaData(object), eval(dmeta)) |
344 : | feinerer | 712 | } |
345 : | feinerer | 52 | return(object) |
346 : | }) | ||
347 : | feinerer | 53 | |
348 : | feinerer | 698 | setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta")) |
349 : | setMethod("removeMeta", | ||
350 : | feinerer | 816 | signature(object = "Corpus"), |
351 : | feinerer | 698 | function(object, cname = NULL, dname = NULL) { |
352 : | feinerer | 729 | if (!is.null(cname)) |
353 : | feinerer | 698 | object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname] |
354 : | feinerer | 729 | if (!is.null(dname)) |
355 : | DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE] | ||
356 : | feinerer | 77 | return(object) |
357 : | }) | ||
358 : | feinerer | 69 | |
359 : | feinerer | 698 | setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta")) |
360 : | setMethod("prescindMeta", | ||
361 : | feinerer | 816 | signature(object = "Corpus", meta = "character"), |
362 : | feinerer | 73 | function(object, meta) { |
363 : | for (m in meta) { | ||
364 : | feinerer | 719 | if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) { |
365 : | feinerer | 75 | local.m <- lapply(object, m) |
366 : | local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x)) | ||
367 : | feinerer | 73 | local.m <- unlist(local.m) |
368 : | feinerer | 721 | DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE)) |
369 : | names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m | ||
370 : | feinerer | 75 | } |
371 : | else { | ||
372 : | local.meta <- lapply(object, LocalMetaData) | ||
373 : | local.m <- lapply(local.meta, "[[", m) | ||
374 : | local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x)) | ||
375 : | if (length(local.m) == length(unlist(local.m))) | ||
376 : | local.m <- unlist(local.m) | ||
377 : | else | ||
378 : | local.m <- I(local.m) | ||
379 : | feinerer | 721 | DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE)) |
380 : | names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m | ||
381 : | feinerer | 75 | } |
382 : | feinerer | 73 | } |
383 : | return(object) | ||
384 : | }) | ||
385 : | |||
386 : | feinerer | 53 | setMethod("[", |
387 : | feinerer | 816 | signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"), |
388 : | feinerer | 53 | function(x, i, j, ... , drop) { |
389 : | if(missing(i)) | ||
390 : | return(x) | ||
391 : | |||
392 : | object <- x | ||
393 : | object@.Data <- x@.Data[i, ..., drop = FALSE] | ||
394 : | feinerer | 724 | if (DBControl(object)[["useDb"]]) { |
395 : | feinerer | 727 | index <- object@DMetaData[[1 , "subset"]] |
396 : | if (any(is.na(index))) | ||
397 : | object@DMetaData[[1 , "subset"]] <- i | ||
398 : | feinerer | 724 | else |
399 : | feinerer | 727 | object@DMetaData[[1 , "subset"]] <- index[i] |
400 : | feinerer | 724 | } |
401 : | feinerer | 729 | else |
402 : | DMetaData(object) <- DMetaData(x)[i, , drop = FALSE] | ||
403 : | feinerer | 53 | return(object) |
404 : | }) | ||
405 : | |||
406 : | feinerer | 63 | setMethod("[<-", |
407 : | feinerer | 816 | signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"), |
408 : | feinerer | 63 | function(x, i, j, ... , value) { |
409 : | object <- x | ||
410 : | feinerer | 724 | if (DBControl(object)[["useDb"]]) { |
411 : | db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]]) | ||
412 : | counter <- 1 | ||
413 : | for (id in object@.Data[i, ...]) { | ||
414 : | if (length(value) == 1) | ||
415 : | db[[id]] <- value | ||
416 : | else { | ||
417 : | db[[id]] <- value[[counter]] | ||
418 : | } | ||
419 : | counter <- counter + 1 | ||
420 : | } | ||
421 : | } | ||
422 : | else | ||
423 : | object@.Data[i, ...] <- value | ||
424 : | feinerer | 63 | return(object) |
425 : | }) | ||
426 : | |||
427 : | setMethod("[[", | ||
428 : | feinerer | 816 | signature(x = "Corpus", i = "ANY", j = "ANY"), |
429 : | feinerer | 63 | function(x, i, j, ...) { |
430 : | feinerer | 712 | if (DBControl(x)[["useDb"]]) { |
431 : | db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]]) | ||
432 : | result <- dbFetch(db, x@.Data[[i]]) | ||
433 : | return(loadDoc(result)) | ||
434 : | } | ||
435 : | feinerer | 829 | else { |
436 : | feinerer | 830 | lazyTmMap <- meta(x, tag = "lazyTmMap", type = "corpus") |
437 : | if (!is.null(lazyTmMap)) | ||
438 : | .Call("copyCorpus", x, materialize(x, i)) | ||
439 : | feinerer | 712 | return(loadDoc(x@.Data[[i]])) |
440 : | feinerer | 829 | } |
441 : | feinerer | 63 | }) |
442 : | |||
443 : | setMethod("[[<-", | ||
444 : | feinerer | 816 | signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"), |
445 : | feinerer | 63 | function(x, i, j, ..., value) { |
446 : | object <- x | ||
447 : | feinerer | 712 | if (DBControl(object)[["useDb"]]) { |
448 : | db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]]) | ||
449 : | index <- object@.Data[[i]] | ||
450 : | db[[index]] <- value | ||
451 : | } | ||
452 : | feinerer | 830 | else { |
453 : | # Mark new objects as not active for lazy mapping | ||
454 : | lazyTmMap <- meta(object, tag = "lazyTmMap", type = "corpus") | ||
455 : | feinerer | 831 | if (!is.null(lazyTmMap)) { |
456 : | feinerer | 830 | lazyTmMap$index[i] <- FALSE |
457 : | feinerer | 831 | meta(object, tag = "lazyTmMap", type = "corpus") <- lazyTmMap |
458 : | } | ||
459 : | feinerer | 830 | # Set the value |
460 : | feinerer | 712 | object@.Data[[i, ...]] <- value |
461 : | feinerer | 830 | } |
462 : | feinerer | 63 | return(object) |
463 : | }) | ||
464 : | |||
465 : | feinerer | 698 | # Update \code{NodeID}s of a CMetaData tree |
466 : | feinerer | 697 | update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) { |
467 : | feinerer | 698 | # Traversal of (binary) CMetaData tree with setup of \code{NodeID}s |
468 : | feinerer | 697 | set_id <- function(object) { |
469 : | object@NodeID <- id | ||
470 : | id <<- id + 1 | ||
471 : | level <<- level + 1 | ||
472 : | feinerer | 71 | |
473 : | feinerer | 697 | if (length(object@children) > 0) { |
474 : | mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id)) | ||
475 : | left <- set_id(object@children[[1]]) | ||
476 : | if (level == 1) { | ||
477 : | left.mapping <<- mapping | ||
478 : | mapping <<- NULL | ||
479 : | } | ||
480 : | mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id)) | ||
481 : | right <- set_id(object@children[[2]]) | ||
482 : | feinerer | 71 | |
483 : | feinerer | 697 | object@children <- list(left, right) |
484 : | feinerer | 71 | } |
485 : | feinerer | 697 | level <<- level - 1 |
486 : | feinerer | 71 | |
487 : | feinerer | 697 | return(object) |
488 : | feinerer | 71 | } |
489 : | |||
490 : | feinerer | 697 | return(list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping)) |
491 : | feinerer | 71 | } |
492 : | |||
493 : | feinerer | 53 | setMethod("c", |
494 : | feinerer | 816 | signature(x = "Corpus"), |
495 : | feinerer | 689 | function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) { |
496 : | args <- list(...) | ||
497 : | feinerer | 720 | if (length(args) == 0) |
498 : | feinerer | 689 | return(x) |
499 : | feinerer | 71 | |
500 : | feinerer | 816 | if (!all(sapply(args, inherits, "Corpus"))) |
501 : | feinerer | 720 | stop("not all arguments are text document collections") |
502 : | feinerer | 730 | if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ]))) |
503 : | feinerer | 720 | stop("concatenating text document collections with activated database is not supported") |
504 : | |||
505 : | feinerer | 689 | result <- x |
506 : | for (c in args) { | ||
507 : | result <- c2(result, c) | ||
508 : | } | ||
509 : | return(result) | ||
510 : | }) | ||
511 : | |||
512 : | setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2")) | ||
513 : | setMethod("c2", | ||
514 : | feinerer | 816 | signature(x = "Corpus", y = "Corpus"), |
515 : | feinerer | 689 | function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) { |
516 : | feinerer | 71 | object <- x |
517 : | # Concatenate data slots | ||
518 : | object@.Data <- c(as(x, "list"), as(y, "list")) | ||
519 : | |||
520 : | feinerer | 720 | # Set the DBControl slot |
521 : | feinerer | 741 | object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1") |
522 : | feinerer | 720 | |
523 : | feinerer | 698 | # Update the CMetaData tree |
524 : | cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y))) | ||
525 : | update.struct <- update_id(cmeta) | ||
526 : | object@CMetaData <- update.struct$root | ||
527 : | feinerer | 71 | |
528 : | # Find indices to be updated for the left tree | ||
529 : | indices.mapping <- NULL | ||
530 : | for (m in levels(as.factor(DMetaData(x)$MetaID))) { | ||
531 : | indices <- (DMetaData(x)$MetaID == m) | ||
532 : | indices.mapping <- c(indices.mapping, list(m = indices)) | ||
533 : | names(indices.mapping)[length(indices.mapping)] <- m | ||
534 : | } | ||
535 : | |||
536 : | # Update the DMetaData data frames for the left tree | ||
537 : | for (i in 1:ncol(update.struct$left.mapping)) { | ||
538 : | map <- update.struct$left.mapping[,i] | ||
539 : | x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2]) | ||
540 : | } | ||
541 : | |||
542 : | # Find indices to be updated for the right tree | ||
543 : | indices.mapping <- NULL | ||
544 : | for (m in levels(as.factor(DMetaData(y)$MetaID))) { | ||
545 : | indices <- (DMetaData(y)$MetaID == m) | ||
546 : | indices.mapping <- c(indices.mapping, list(m = indices)) | ||
547 : | names(indices.mapping)[length(indices.mapping)] <- m | ||
548 : | } | ||
549 : | |||
550 : | # Update the DMetaData data frames for the right tree | ||
551 : | for (i in 1:ncol(update.struct$right.mapping)) { | ||
552 : | map <- update.struct$right.mapping[,i] | ||
553 : | y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2]) | ||
554 : | } | ||
555 : | |||
556 : | # Merge the DMetaData data frames | ||
557 : | labels <- setdiff(names(DMetaData(y)), names(DMetaData(x))) | ||
558 : | na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels)) | ||
559 : | x.dmeta.aug <- cbind(DMetaData(x), na.matrix) | ||
560 : | labels <- setdiff(names(DMetaData(x)), names(DMetaData(y))) | ||
561 : | na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels)) | ||
562 : | y.dmeta.aug <- cbind(DMetaData(y), na.matrix) | ||
563 : | object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug) | ||
564 : | |||
565 : | return(object) | ||
566 : | feinerer | 72 | }) |
567 : | feinerer | 689 | |
568 : | feinerer | 72 | setMethod("c", |
569 : | signature(x = "TextDocument"), | ||
570 : | function(x, ..., recursive = TRUE){ | ||
571 : | args <- list(...) | ||
572 : | if(length(args) == 0) | ||
573 : | return(x) | ||
574 : | feinerer | 54 | |
575 : | feinerer | 73 | dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE) |
576 : | feinerer | 698 | cmeta.node <- new("MetaDataNode", |
577 : | feinerer | 72 | NodeID = 0, |
578 : | feinerer | 689 | MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")), |
579 : | feinerer | 72 | children = list()) |
580 : | |||
581 : | feinerer | 816 | return(new("Corpus", |
582 : | feinerer | 720 | .Data = list(x, ...), |
583 : | DMetaData = dmeta.df, | ||
584 : | CMetaData = cmeta.node, | ||
585 : | feinerer | 741 | DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1"))) |
586 : | feinerer | 72 | }) |
587 : | |||
588 : | feinerer | 54 | setMethod("length", |
589 : | feinerer | 816 | signature(x = "Corpus"), |
590 : | feinerer | 54 | function(x){ |
591 : | return(length(as(x, "list"))) | ||
592 : | }) | ||
593 : | |||
594 : | setMethod("show", | ||
595 : | feinerer | 816 | signature(object = "Corpus"), |
596 : | feinerer | 54 | function(object){ |
597 : | feinerer | 70 | cat(sprintf(ngettext(length(object), |
598 : | "A text document collection with %d text document\n", | ||
599 : | "A text document collection with %d text documents\n"), | ||
600 : | length(object))) | ||
601 : | feinerer | 54 | }) |
602 : | |||
603 : | setMethod("summary", | ||
604 : | feinerer | 816 | signature(object = "Corpus"), |
605 : | feinerer | 54 | function(object){ |
606 : | show(object) | ||
607 : | feinerer | 71 | if (length(DMetaData(object)) > 0) { |
608 : | feinerer | 698 | cat(sprintf(ngettext(length(CMetaData(object)@MetaData), |
609 : | feinerer | 77 | "\nThe metadata consists of %d tag-value pair and a data frame\n", |
610 : | "\nThe metadata consists of %d tag-value pairs and a data frame\n"), | ||
611 : | feinerer | 698 | length(CMetaData(object)@MetaData))) |
612 : | feinerer | 54 | cat("Available tags are:\n") |
613 : | feinerer | 722 | cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n") |
614 : | feinerer | 77 | cat("Available variables in the data frame are:\n") |
615 : | feinerer | 722 | cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n") |
616 : | feinerer | 54 | } |
617 : | }) | ||
618 : | feinerer | 55 | |
619 : | setGeneric("inspect", function(object) standardGeneric("inspect")) | ||
620 : | setMethod("inspect", | ||
621 : | feinerer | 816 | signature("Corpus"), |
622 : | feinerer | 55 | function(object) { |
623 : | summary(object) | ||
624 : | cat("\n") | ||
625 : | feinerer | 719 | if (DBControl(object)[["useDb"]]) { |
626 : | db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]]) | ||
627 : | show(dbMultiFetch(db, unlist(object))) | ||
628 : | } | ||
629 : | else | ||
630 : | feinerer | 830 | show(lapply(object, "[[", 1)) |
631 : | feinerer | 55 | }) |
632 : | feinerer | 65 | |
633 : | # No metadata is checked | ||
634 : | setGeneric("%IN%", function(x, y) standardGeneric("%IN%")) | ||
635 : | setMethod("%IN%", | ||
636 : | feinerer | 816 | signature(x = "TextDocument", y = "Corpus"), |
637 : | feinerer | 65 | function(x, y) { |
638 : | feinerer | 729 | if (DBControl(y)[["useDb"]]) { |
639 : | db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]]) | ||
640 : | feinerer | 816 | result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x)) |
641 : | feinerer | 729 | } |
642 : | else | ||
643 : | result <- x %in% y | ||
644 : | return(result) | ||
645 : | feinerer | 65 | }) |
646 : | feinerer | 719 | |
647 : | setMethod("lapply", | ||
648 : | feinerer | 816 | signature(X = "Corpus"), |
649 : | feinerer | 719 | function(X, FUN, ...) { |
650 : | feinerer | 830 | print("lapply") |
651 : | feinerer | 719 | if (DBControl(X)[["useDb"]]) { |
652 : | db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]]) | ||
653 : | result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...) | ||
654 : | } | ||
655 : | feinerer | 830 | else { |
656 : | lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus") | ||
657 : | if (!is.null(lazyTmMap)) | ||
658 : | .Call("copyCorpus", X, materialize(X)) | ||
659 : | feinerer | 719 | result <- base::lapply(X, FUN, ...) |
660 : | feinerer | 830 | } |
661 : | feinerer | 719 | return(result) |
662 : | }) | ||
663 : | |||
664 : | setMethod("sapply", | ||
665 : | feinerer | 816 | signature(X = "Corpus"), |
666 : | feinerer | 719 | function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) { |
667 : | if (DBControl(X)[["useDb"]]) { | ||
668 : | db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]]) | ||
669 : | result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...) | ||
670 : | } | ||
671 : | feinerer | 830 | else { |
672 : | lazyTmMap <- meta(X, tag = "lazyTmMap", type = "corpus") | ||
673 : | if (!is.null(lazyTmMap)) | ||
674 : | .Call("copyCorpus", X, materialize(X)) | ||
675 : | feinerer | 719 | result <- base::sapply(X, FUN, ...) |
676 : | feinerer | 830 | } |
677 : | feinerer | 719 | return(result) |
678 : | }) | ||
679 : | feinerer | 819 | |
680 : | setGeneric("writeCorpus", function(object, path = ".", filenames = NULL) standardGeneric("writeCorpus")) | ||
681 : | setMethod("writeCorpus", | ||
682 : | signature(object = "Corpus"), | ||
683 : | function(object, path = ".", filenames = NULL) { | ||
684 : | filenames <- file.path(path, | ||
685 : | if (is.null(filenames)) sapply(object, function(x) sprintf("%s.txt", ID(x))) | ||
686 : | else filenames) | ||
687 : | i <- 1 | ||
688 : | for (o in object) { | ||
689 : | writeLines(o, filenames[i]) | ||
690 : | i <- i + 1 | ||
691 : | } | ||
692 : | }) |
R-Forge@R-project.org | ViewVC Help |
Powered by ViewVC 1.0.0 |