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