Annotation of /pkg/R/corpus.R

Parent Directory | Revision Log

---

Revision 816 - (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	733	readerControl = list(reader = object@DefaultReader, language = "en_US", load = FALSE),
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	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	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 :			readerControl$load = FALSE
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	723	readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),
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	723	readerControl = list(reader = origin@DefaultReader, language = "en_US", load = FALSE),
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 :			readerControl$load = FALSE
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	698	setGeneric("tmMap", function(object, FUN, ...) standardGeneric("tmMap"))
157 :			setMethod("tmMap",
158 :	feinerer	816	signature(object = "Corpus", FUN = "function"),
159 :	feinerer	49	function(object, FUN, ...) {
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 :			db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
164 :	feinerer	728	i <- 1
165 :			for (id in unlist(object)) {
166 :			db[[id]] <- FUN(object[[i]], ..., DMetaData = DMetaData(object))
167 :			i <- i + 1
168 :			}
169 :	feinerer	719	}
170 :			else
171 :			result@.Data <- lapply(object, FUN, ..., DMetaData = DMetaData(object))
172 :	feinerer	56	return(result)
173 :	feinerer	49	})
174 :
175 :	feinerer	698	setGeneric("asPlain", function(object, FUN, ...) standardGeneric("asPlain"))
176 :			setMethod("asPlain",
177 :	feinerer	62	signature(object = "PlainTextDocument"),
178 :	feinerer	49	function(object, FUN, ...) {
179 :			return(object)
180 :			})
181 :	feinerer	698	setMethod("asPlain",
182 :	feinerer	62	signature(object = "XMLTextDocument", FUN = "function"),
183 :	feinerer	49	function(object, FUN, ...) {
184 :	feinerer	816	corpus <- Content(object)
185 :	feinerer	49
186 :			# As XMLDocument is no native S4 class, restore valid information
187 :			class(corpus) <- "XMLDocument"
188 :			names(corpus) <- c("doc","dtd")
189 :
190 :	feinerer	61	return(FUN(xmlRoot(corpus), ...))
191 :	feinerer	49	})
192 :	feinerer	725	setMethod("asPlain",
193 :	feinerer	757	signature(object = "Reuters21578Document"),
194 :			function(object, FUN, ...) {
195 :			FUN <- convertReut21578XMLPlain
196 :	feinerer	816	corpus <- Content(object)
197 :	feinerer	757
198 :			# As XMLDocument is no native S4 class, restore valid information
199 :			class(corpus) <- "XMLDocument"
200 :			names(corpus) <- c("doc","dtd")
201 :
202 :			return(FUN(xmlRoot(corpus), ...))
203 :			})
204 :			setMethod("asPlain",
205 :			signature(object = "RCV1Document"),
206 :			function(object, FUN, ...) {
207 :			FUN <- convertRCV1Plain
208 :	feinerer	816	corpus <- Content(object)
209 :	feinerer	757
210 :			# As XMLDocument is no native S4 class, restore valid information
211 :			class(corpus) <- "XMLDocument"
212 :			names(corpus) <- c("doc","dtd")
213 :
214 :			return(FUN(xmlRoot(corpus), ...))
215 :			})
216 :			setMethod("asPlain",
217 :	feinerer	725	signature(object = "NewsgroupDocument"),
218 :			function(object, FUN, ...) {
219 :	feinerer	816	new("PlainTextDocument", .Data = Content(object), Cached = TRUE, URI = "", Author = Author(object),
220 :	feinerer	725	DateTimeStamp = DateTimeStamp(object), Description = Description(object), ID = ID(object),
221 :			Origin = Origin(object), Heading = Heading(object), Language = Language(object))
222 :			})
223 :	feinerer	775	setMethod("asPlain",
224 :			signature(object = "StructuredTextDocument"),
225 :			function(object, FUN, ...) {
226 :	feinerer	816	new("PlainTextDocument", .Data = unlist(Content(object)), Cached = TRUE,
227 :	feinerer	775	URI = "", Author = Author(object), DateTimeStamp = DateTimeStamp(object),
228 :			Description = Description(object), ID = ID(object), Origin = Origin(object),
229 :			Heading = Heading(object), Language = Language(object))
230 :			})
231 :	feinerer	49
232 :	feinerer	698	setGeneric("tmFilter", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmFilter"))
233 :			setMethod("tmFilter",
234 :	feinerer	816	signature(object = "Corpus"),
235 :	feinerer	698	function(object, ..., FUN = sFilter, doclevel = FALSE) {
236 :	feinerer	73	if (doclevel)
237 :			return(object[sapply(object, FUN, ..., DMetaData = DMetaData(object))])
238 :			else
239 :	feinerer	724	return(object[FUN(object, ...)])
240 :	feinerer	61	})
241 :
242 :	feinerer	698	setGeneric("tmIndex", function(object, ..., FUN = sFilter, doclevel = FALSE) standardGeneric("tmIndex"))
243 :			setMethod("tmIndex",
244 :	feinerer	816	signature(object = "Corpus"),
245 :	feinerer	698	function(object, ..., FUN = sFilter, doclevel = FALSE) {
246 :	feinerer	73	if (doclevel)
247 :			return(sapply(object, FUN, ..., DMetaData = DMetaData(object)))
248 :			else
249 :	feinerer	724	return(FUN(object, ...))
250 :	feinerer	49	})
251 :
252 :	feinerer	698	sFilter <- function(object, s, ...) {
253 :	feinerer	73	con <- textConnection(s)
254 :	feinerer	772	tokens <- scan(con, "character", quiet = TRUE)
255 :	feinerer	73	close(con)
256 :	feinerer	721	localMetaNames <- unique(names(sapply(object, LocalMetaData)))
257 :			localMetaTokens <- localMetaNames[localMetaNames %in% tokens]
258 :	feinerer	729	n <- names(DMetaData(object))
259 :			tags <- c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language", localMetaTokens)
260 :			query.df <- DMetaData(prescindMeta(object, tags))
261 :			if (DBControl(object)[["useDb"]])
262 :			DMetaData(object) <- DMetaData(object)[, setdiff(n, tags), drop = FALSE]
263 :	feinerer	721	# Rename to avoid name conflicts
264 :			names(query.df)[names(query.df) == "Author"] <- "author"
265 :			names(query.df)[names(query.df) == "DateTimeStamp"] <- "datetimestamp"
266 :			names(query.df)[names(query.df) == "Description"] <- "description"
267 :			names(query.df)[names(query.df) == "ID"] <- "identifier"
268 :			names(query.df)[names(query.df) == "Origin"] <- "origin"
269 :			names(query.df)[names(query.df) == "Heading"] <- "heading"
270 :			names(query.df)[names(query.df) == "Language"] <- "language"
271 :	feinerer	73	attach(query.df)
272 :	feinerer	74	try(result <- rownames(query.df) %in% row.names(query.df[eval(parse(text = s)), ]))
273 :	feinerer	73	detach(query.df)
274 :			return(result)
275 :	feinerer	61	}
276 :
277 :	feinerer	698	setGeneric("appendElem", function(object, data, meta = NULL) standardGeneric("appendElem"))
278 :			setMethod("appendElem",
279 :	feinerer	816	signature(object = "Corpus", data = "TextDocument"),
280 :	feinerer	72	function(object, data, meta = NULL) {
281 :	feinerer	712	if (DBControl(object)[["useDb"]]) {
282 :			db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
283 :			if (dbExists(db, ID(data)))
284 :			warning("document with identical ID already exists")
285 :			dbInsert(db, ID(data), data)
286 :			object@.Data[[length(object)+1]] <- ID(data)
287 :			}
288 :			else
289 :			object@.Data[[length(object)+1]] <- data
290 :			DMetaData(object) <- rbind(DMetaData(object), c(MetaID = CMetaData(object)@NodeID, meta))
291 :	feinerer	52	return(object)
292 :			})
293 :
294 :	feinerer	698	setGeneric("appendMeta", function(object, cmeta = NULL, dmeta = NULL) standardGeneric("appendMeta"))
295 :			setMethod("appendMeta",
296 :	feinerer	816	signature(object = "Corpus"),
297 :	feinerer	698	function(object, cmeta = NULL, dmeta = NULL) {
298 :	feinerer	712	object@CMetaData@MetaData <- c(CMetaData(object)@MetaData, cmeta)
299 :			if (!is.null(dmeta)) {
300 :	feinerer	719	DMetaData(object) <- cbind(DMetaData(object), eval(dmeta))
301 :	feinerer	712	}
302 :	feinerer	52	return(object)
303 :			})
304 :	feinerer	53
305 :	feinerer	698	setGeneric("removeMeta", function(object, cname = NULL, dname = NULL) standardGeneric("removeMeta"))
306 :			setMethod("removeMeta",
307 :	feinerer	816	signature(object = "Corpus"),
308 :	feinerer	698	function(object, cname = NULL, dname = NULL) {
309 :	feinerer	729	if (!is.null(cname))
310 :	feinerer	698	object@CMetaData@MetaData <- CMetaData(object)@MetaData[names(CMetaData(object)@MetaData) != cname]
311 :	feinerer	729	if (!is.null(dname))
312 :			DMetaData(object) <- DMetaData(object)[, names(DMetaData(object)) != dname, drop = FALSE]
313 :	feinerer	77	return(object)
314 :			})
315 :	feinerer	69
316 :	feinerer	698	setGeneric("prescindMeta", function(object, meta) standardGeneric("prescindMeta"))
317 :			setMethod("prescindMeta",
318 :	feinerer	816	signature(object = "Corpus", meta = "character"),
319 :	feinerer	73	function(object, meta) {
320 :			for (m in meta) {
321 :	feinerer	719	if (m %in% c("Author", "DateTimeStamp", "Description", "ID", "Origin", "Heading", "Language")) {
322 :	feinerer	75	local.m <- lapply(object, m)
323 :			local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))
324 :	feinerer	73	local.m <- unlist(local.m)
325 :	feinerer	721	DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))
326 :			names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m
327 :	feinerer	75	}
328 :			else {
329 :			local.meta <- lapply(object, LocalMetaData)
330 :			local.m <- lapply(local.meta, "[[", m)
331 :			local.m <- lapply(local.m, function(x) if (is.null(x)) return(NA) else return(x))
332 :			if (length(local.m) == length(unlist(local.m)))
333 :			local.m <- unlist(local.m)
334 :			else
335 :			local.m <- I(local.m)
336 :	feinerer	721	DMetaData(object) <- cbind(DMetaData(object), data.frame(m = local.m, stringsAsFactors = FALSE))
337 :			names(DMetaData(object))[which(names(DMetaData(object)) == "m")] <- m
338 :	feinerer	75	}
339 :	feinerer	73	}
340 :			return(object)
341 :			})
342 :
343 :	feinerer	53	setMethod("[",
344 :	feinerer	816	signature(x = "Corpus", i = "ANY", j = "ANY", drop = "ANY"),
345 :	feinerer	53	function(x, i, j, ... , drop) {
346 :			if(missing(i))
347 :			return(x)
348 :
349 :			object <- x
350 :			object@.Data <- x@.Data[i, ..., drop = FALSE]
351 :	feinerer	724	if (DBControl(object)[["useDb"]]) {
352 :	feinerer	727	index <- object@DMetaData[[1 , "subset"]]
353 :			if (any(is.na(index)))
354 :			object@DMetaData[[1 , "subset"]] <- i
355 :	feinerer	724	else
356 :	feinerer	727	object@DMetaData[[1 , "subset"]] <- index[i]
357 :	feinerer	724	}
358 :	feinerer	729	else
359 :			DMetaData(object) <- DMetaData(x)[i, , drop = FALSE]
360 :	feinerer	53	return(object)
361 :			})
362 :
363 :	feinerer	63	setMethod("[<-",
364 :	feinerer	816	signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
365 :	feinerer	63	function(x, i, j, ... , value) {
366 :			object <- x
367 :	feinerer	724	if (DBControl(object)[["useDb"]]) {
368 :			db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
369 :			counter <- 1
370 :			for (id in object@.Data[i, ...]) {
371 :			if (length(value) == 1)
372 :			db[[id]] <- value
373 :			else {
374 :			db[[id]] <- value[[counter]]
375 :			}
376 :			counter <- counter + 1
377 :			}
378 :			}
379 :			else
380 :			object@.Data[i, ...] <- value
381 :	feinerer	63	return(object)
382 :			})
383 :
384 :			setMethod("[[",
385 :	feinerer	816	signature(x = "Corpus", i = "ANY", j = "ANY"),
386 :	feinerer	63	function(x, i, j, ...) {
387 :	feinerer	712	if (DBControl(x)[["useDb"]]) {
388 :			db <- dbInit(DBControl(x)[["dbName"]], DBControl(x)[["dbType"]])
389 :			result <- dbFetch(db, x@.Data[[i]])
390 :			return(loadDoc(result))
391 :			}
392 :			else
393 :			return(loadDoc(x@.Data[[i]]))
394 :	feinerer	63	})
395 :
396 :			setMethod("[[<-",
397 :	feinerer	816	signature(x = "Corpus", i = "ANY", j = "ANY", value = "ANY"),
398 :	feinerer	63	function(x, i, j, ..., value) {
399 :			object <- x
400 :	feinerer	712	if (DBControl(object)[["useDb"]]) {
401 :			db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
402 :			index <- object@.Data[[i]]
403 :			db[[index]] <- value
404 :			}
405 :			else
406 :			object@.Data[[i, ...]] <- value
407 :	feinerer	63	return(object)
408 :			})
409 :
410 :	feinerer	698	# Update \code{NodeID}s of a CMetaData tree
411 :	feinerer	697	update_id <- function(object, id = 0, mapping = NULL, left.mapping = NULL, level = 0) {
412 :	feinerer	698	# Traversal of (binary) CMetaData tree with setup of \code{NodeID}s
413 :	feinerer	697	set_id <- function(object) {
414 :			object@NodeID <- id
415 :			id <<- id + 1
416 :			level <<- level + 1
417 :	feinerer	71
418 :	feinerer	697	if (length(object@children) > 0) {
419 :			mapping <<- cbind(mapping, c(object@children[[1]]@NodeID, id))
420 :			left <- set_id(object@children[[1]])
421 :			if (level == 1) {
422 :			left.mapping <<- mapping
423 :			mapping <<- NULL
424 :			}
425 :			mapping <<- cbind(mapping, c(object@children[[2]]@NodeID, id))
426 :			right <- set_id(object@children[[2]])
427 :	feinerer	71
428 :	feinerer	697	object@children <- list(left, right)
429 :	feinerer	71	}
430 :	feinerer	697	level <<- level - 1
431 :	feinerer	71
432 :	feinerer	697	return(object)
433 :	feinerer	71	}
434 :
435 :	feinerer	697	return(list(root = set_id(object), left.mapping = left.mapping, right.mapping = mapping))
436 :	feinerer	71	}
437 :
438 :	feinerer	53	setMethod("c",
439 :	feinerer	816	signature(x = "Corpus"),
440 :	feinerer	689	function(x, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
441 :			args <- list(...)
442 :	feinerer	720	if (length(args) == 0)
443 :	feinerer	689	return(x)
444 :	feinerer	71
445 :	feinerer	816	if (!all(sapply(args, inherits, "Corpus")))
446 :	feinerer	720	stop("not all arguments are text document collections")
447 :	feinerer	730	if (DBControl(x)[["useDb"]] == TRUE || any(unlist(sapply(args, DBControl)["useDb", ])))
448 :	feinerer	720	stop("concatenating text document collections with activated database is not supported")
449 :
450 :	feinerer	689	result <- x
451 :			for (c in args) {
452 :			result <- c2(result, c)
453 :			}
454 :			return(result)
455 :			})
456 :
457 :			setGeneric("c2", function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) standardGeneric("c2"))
458 :			setMethod("c2",
459 :	feinerer	816	signature(x = "Corpus", y = "Corpus"),
460 :	feinerer	689	function(x, y, ..., meta = list(merge_date = Sys.time(), merger = Sys.getenv("LOGNAME")), recursive = TRUE) {
461 :	feinerer	71	object <- x
462 :			# Concatenate data slots
463 :			object@.Data <- c(as(x, "list"), as(y, "list"))
464 :
465 :	feinerer	720	# Set the DBControl slot
466 :	feinerer	741	object@DBControl <- list(useDb = FALSE, dbName = "", dbType = "DB1")
467 :	feinerer	720
468 :	feinerer	698	# Update the CMetaData tree
469 :			cmeta <- new("MetaDataNode", NodeID = 0, MetaData = meta, children = list(CMetaData(x), CMetaData(y)))
470 :			update.struct <- update_id(cmeta)
471 :			object@CMetaData <- update.struct$root
472 :	feinerer	71
473 :			# Find indices to be updated for the left tree
474 :			indices.mapping <- NULL
475 :			for (m in levels(as.factor(DMetaData(x)$MetaID))) {
476 :			indices <- (DMetaData(x)$MetaID == m)
477 :			indices.mapping <- c(indices.mapping, list(m = indices))
478 :			names(indices.mapping)[length(indices.mapping)] <- m
479 :			}
480 :
481 :			# Update the DMetaData data frames for the left tree
482 :			for (i in 1:ncol(update.struct$left.mapping)) {
483 :			map <- update.struct$left.mapping[,i]
484 :			x@DMetaData$MetaID <- replace(DMetaData(x)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
485 :			}
486 :
487 :			# Find indices to be updated for the right tree
488 :			indices.mapping <- NULL
489 :			for (m in levels(as.factor(DMetaData(y)$MetaID))) {
490 :			indices <- (DMetaData(y)$MetaID == m)
491 :			indices.mapping <- c(indices.mapping, list(m = indices))
492 :			names(indices.mapping)[length(indices.mapping)] <- m
493 :			}
494 :
495 :			# Update the DMetaData data frames for the right tree
496 :			for (i in 1:ncol(update.struct$right.mapping)) {
497 :			map <- update.struct$right.mapping[,i]
498 :			y@DMetaData$MetaID <- replace(DMetaData(y)$MetaID, indices.mapping[[as.character(map[1])]], map[2])
499 :			}
500 :
501 :			# Merge the DMetaData data frames
502 :			labels <- setdiff(names(DMetaData(y)), names(DMetaData(x)))
503 :			na.matrix <- matrix(NA, nrow = nrow(DMetaData(x)), ncol = length(labels), dimnames = list(row.names(DMetaData(x)), labels))
504 :			x.dmeta.aug <- cbind(DMetaData(x), na.matrix)
505 :			labels <- setdiff(names(DMetaData(x)), names(DMetaData(y)))
506 :			na.matrix <- matrix(NA, nrow = nrow(DMetaData(y)), ncol = length(labels), dimnames = list(row.names(DMetaData(y)), labels))
507 :			y.dmeta.aug <- cbind(DMetaData(y), na.matrix)
508 :			object@DMetaData <- rbind(x.dmeta.aug, y.dmeta.aug)
509 :
510 :			return(object)
511 :	feinerer	72	})
512 :	feinerer	689
513 :	feinerer	72	setMethod("c",
514 :			signature(x = "TextDocument"),
515 :			function(x, ..., recursive = TRUE){
516 :			args <- list(...)
517 :			if(length(args) == 0)
518 :			return(x)
519 :	feinerer	54
520 :	feinerer	73	dmeta.df <- data.frame(MetaID = rep(0, length(list(x, ...))), stringsAsFactors = FALSE)
521 :	feinerer	698	cmeta.node <- new("MetaDataNode",
522 :	feinerer	72	NodeID = 0,
523 :	feinerer	689	MetaData = list(create_date = Sys.time(), creator = Sys.getenv("LOGNAME")),
524 :	feinerer	72	children = list())
525 :
526 :	feinerer	816	return(new("Corpus",
527 :	feinerer	720	.Data = list(x, ...),
528 :			DMetaData = dmeta.df,
529 :			CMetaData = cmeta.node,
530 :	feinerer	741	DBControl = list(useDb = FALSE, dbName = "", dbType = "DB1")))
531 :	feinerer	72	})
532 :
533 :	feinerer	54	setMethod("length",
534 :	feinerer	816	signature(x = "Corpus"),
535 :	feinerer	54	function(x){
536 :			return(length(as(x, "list")))
537 :			})
538 :
539 :			setMethod("show",
540 :	feinerer	816	signature(object = "Corpus"),
541 :	feinerer	54	function(object){
542 :	feinerer	70	cat(sprintf(ngettext(length(object),
543 :			"A text document collection with %d text document\n",
544 :			"A text document collection with %d text documents\n"),
545 :			length(object)))
546 :	feinerer	54	})
547 :
548 :			setMethod("summary",
549 :	feinerer	816	signature(object = "Corpus"),
550 :	feinerer	54	function(object){
551 :			show(object)
552 :	feinerer	71	if (length(DMetaData(object)) > 0) {
553 :	feinerer	698	cat(sprintf(ngettext(length(CMetaData(object)@MetaData),
554 :	feinerer	77	"\nThe metadata consists of %d tag-value pair and a data frame\n",
555 :			"\nThe metadata consists of %d tag-value pairs and a data frame\n"),
556 :	feinerer	698	length(CMetaData(object)@MetaData)))
557 :	feinerer	54	cat("Available tags are:\n")
558 :	feinerer	722	cat(strwrap(paste(names(CMetaData(object)@MetaData), collapse = " "), indent = 2, exdent = 2), "\n")
559 :	feinerer	77	cat("Available variables in the data frame are:\n")
560 :	feinerer	722	cat(strwrap(paste(names(DMetaData(object)), collapse = " "), indent = 2, exdent = 2), "\n")
561 :	feinerer	54	}
562 :			})
563 :	feinerer	55
564 :			setGeneric("inspect", function(object) standardGeneric("inspect"))
565 :			setMethod("inspect",
566 :	feinerer	816	signature("Corpus"),
567 :	feinerer	55	function(object) {
568 :			summary(object)
569 :			cat("\n")
570 :	feinerer	719	if (DBControl(object)[["useDb"]]) {
571 :			db <- dbInit(DBControl(object)[["dbName"]], DBControl(object)[["dbType"]])
572 :			show(dbMultiFetch(db, unlist(object)))
573 :			}
574 :			else
575 :			show(object@.Data)
576 :	feinerer	55	})
577 :	feinerer	65
578 :			# No metadata is checked
579 :			setGeneric("%IN%", function(x, y) standardGeneric("%IN%"))
580 :			setMethod("%IN%",
581 :	feinerer	816	signature(x = "TextDocument", y = "Corpus"),
582 :	feinerer	65	function(x, y) {
583 :	feinerer	729	if (DBControl(y)[["useDb"]]) {
584 :			db <- dbInit(DBControl(y)[["dbName"]], DBControl(y)[["dbType"]])
585 :	feinerer	816	result <- any(sapply(y, function(x, z) {x %in% Content(z)}, x))
586 :	feinerer	729	}
587 :			else
588 :			result <- x %in% y
589 :			return(result)
590 :	feinerer	65	})
591 :	feinerer	719
592 :			setMethod("lapply",
593 :	feinerer	816	signature(X = "Corpus"),
594 :	feinerer	719	function(X, FUN, ...) {
595 :			if (DBControl(X)[["useDb"]]) {
596 :			db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
597 :			result <- lapply(dbMultiFetch(db, unlist(X)), FUN, ...)
598 :			}
599 :			else
600 :			result <- base::lapply(X, FUN, ...)
601 :			return(result)
602 :			})
603 :
604 :			setMethod("sapply",
605 :	feinerer	816	signature(X = "Corpus"),
606 :	feinerer	719	function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
607 :			if (DBControl(X)[["useDb"]]) {
608 :			db <- dbInit(DBControl(X)[["dbName"]], DBControl(X)[["dbType"]])
609 :			result <- sapply(dbMultiFetch(db, unlist(X)), FUN, ...)
610 :			}
611 :			else
612 :			result <- base::sapply(X, FUN, ...)
613 :			return(result)
614 :			})

---

R-Forge@R-project.org	ViewVC Help
Powered by ViewVC 1.0.0