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 :			})

---

root@r-forge.r-project.org	ViewVC Help
Powered by ViewVC 1.0.0