SCM

SCM Repository

[tm] Annotation of /pkg/R/corpus.R
ViewVC logotype

Annotation of /pkg/R/corpus.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 55 - (view) (download)
Original Path: trunk/R/textmin/R/textdoccol.R

1 : feinerer 17 # Author: Ingo Feinerer
2 :    
3 : feinerer 49 setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))
4 :     setMethod("TextDocCol",
5 : feinerer 42 c("character"),
6 : feinerer 37 function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {
7 : feinerer 22 # Add a new type for each unique input source format
8 : feinerer 51 type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "REUT21578_XML", "RIS"))
9 : feinerer 22 switch(type,
10 : feinerer 37 # Text in a special CSV format
11 :     # For details on the file format see the R documentation file
12 :     # The first argument is a directory with .csv files
13 :     "CSV" = {
14 : feinerer 41 filelist <- dir(object, pattern = ".csv", full.names = TRUE)
15 : feinerer 39 tdl <- sapply(filelist,
16 : feinerer 37 function(file) {
17 :     m <- as.matrix(read.csv(file, header = FALSE))
18 :     l <- vector("list", dim(m)[1])
19 :     for (i in 1:dim(m)[1]) {
20 :     author <- ""
21 : feinerer 42 datetimestamp <- date()
22 : feinerer 37 description <- ""
23 :     id <- as.integer(m[i,1])
24 :     corpus <- as.character(m[i,2:dim(m)[2]])
25 :     if (stripWhiteSpace)
26 :     corpus <- gsub("[[:space:]]+", " ", corpus)
27 :     if (toLower)
28 :     corpus <- tolower(corpus)
29 :     origin <- "CSV"
30 :     heading <- ""
31 :    
32 : feinerer 49 l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
33 :     Description = description, ID = id, Origin = origin, Heading = heading)
34 : feinerer 37 }
35 :     l
36 :     })
37 : feinerer 39 if (length(filelist) > 1)
38 : feinerer 49 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
39 : feinerer 39 else
40 : feinerer 49 tdcl <- new("TextDocCol", .Data = tdl)
41 : feinerer 37 },
42 : feinerer 22 # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
43 : feinerer 37 # The first argument is a directory with the RCV1 XML files
44 : feinerer 51 "RCV1" = {
45 : feinerer 40 filelist <- dir(object, pattern = ".xml", full.names = TRUE)
46 : feinerer 39 tdl <- sapply(filelist,
47 : feinerer 37 function(file) {
48 :     tree <- xmlTreeParse(file)
49 : feinerer 49 xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)
50 : feinerer 37 })
51 : feinerer 39 if (length(filelist) > 1)
52 : feinerer 49 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
53 : feinerer 39 else
54 : feinerer 49 tdcl <- new("TextDocCol", .Data = tdl)
55 : feinerer 22 },
56 : feinerer 23 # Read in text documents in Reuters-21578 XML (not SGML) format
57 :     # Typically the first argument will be a directory where we can
58 :     # find the files reut2-000.xml ... reut2-021.xml
59 : feinerer 51 "REUT21578" = {
60 : feinerer 40 filelist <- dir(object, pattern = ".xml", full.names = TRUE)
61 : feinerer 39 tdl <- sapply(filelist,
62 : feinerer 24 function(file) {
63 :     tree <- xmlTreeParse(file)
64 : feinerer 49 xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)
65 : feinerer 24 })
66 : feinerer 39 if (length(filelist) > 1)
67 : feinerer 49 tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))
68 : feinerer 39 else
69 : feinerer 49 tdcl <- new("TextDocCol", .Data = tdl)
70 : feinerer 40 },
71 : feinerer 49 "REUT21578_XML" = {
72 :     filelist <- dir(object, pattern = ".xml", full.names = TRUE)
73 :     tdl <- sapply(filelist,
74 :     function(file) {
75 :     parseReutersXML(file)
76 :     })
77 : feinerer 51 tdcl <- new("TextDocCol", .Data = tdl)
78 : feinerer 49 },
79 : feinerer 40 # Read in HTML documents as used by http://ris.bka.gv.at/vwgh
80 :     "RIS" = {
81 :     filelist <- dir(object, pattern = ".html", full.names = TRUE)
82 :     tdl <- sapply(filelist,
83 :     function(file) {
84 : feinerer 41 # Ignore warnings from misformed HTML documents
85 : feinerer 51 suppressWarnings(RISDoc <- parseRISPlain(file, stripWhiteSpace, toLower))
86 : feinerer 41 if (!is.null(RISDoc)) {
87 :     l <- list()
88 :     l[[length(l) + 1]] <- RISDoc
89 :     l
90 :     }
91 : feinerer 40 })
92 : feinerer 49 tdcl <- new("TextDocCol", .Data = tdl)
93 : feinerer 24 })
94 : feinerer 21 tdcl
95 :     })
96 :    
97 : feinerer 42 # Parse an Austrian RIS HTML document
98 : feinerer 51 parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {
99 : feinerer 40 author <- ""
100 : feinerer 42 datetimestamp <- date()
101 : feinerer 40 description <- ""
102 :    
103 :     tree <- htmlTreeParse(file)
104 :     htmlElem <- unlist(tree$children$html$children)
105 : feinerer 41
106 :     if (is.null(htmlElem))
107 :     stop(paste("Empty document", file, "cannot be processed."))
108 :    
109 : feinerer 40 textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]
110 :     names(textElem) <- NULL
111 :    
112 :     corpus <- paste(textElem, collapse = " ")
113 : feinerer 41
114 :     year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)
115 :     senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)
116 :     number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)
117 :    
118 :     id <- as.integer(paste(year, senat, number, sep = ""))
119 :    
120 :     if (is.na(id))
121 :     stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))
122 : feinerer 40 origin <- ""
123 :    
124 :     if (stripWhiteSpace)
125 :     corpus <- gsub("[[:space:]]+", " ", corpus)
126 :     if (toLower)
127 :     corpus <- tolower(corpus)
128 :    
129 :     heading <- ""
130 :    
131 : feinerer 49 new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
132 :     Description = description, ID = id, Origin = origin, Heading = heading)
133 : feinerer 40 }
134 :    
135 : feinerer 23 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file
136 : feinerer 49 parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
137 : feinerer 17 author <- "Not yet implemented"
138 : feinerer 42 datetimestamp <- xmlAttrs(node)[["date"]]
139 : feinerer 17 description <- "Not yet implemented"
140 :     id <- as.integer(xmlAttrs(node)[["itemid"]])
141 : feinerer 36 origin <- "Reuters Corpus Volume 1 XML"
142 : feinerer 18 corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)
143 : feinerer 21
144 :     if (stripWhiteSpace)
145 :     corpus <- gsub("[[:space:]]+", " ", corpus)
146 :     if (toLower)
147 :     corpus <- tolower(corpus)
148 :    
149 : feinerer 18 heading <- xmlValue(node[["title"]])
150 : feinerer 17
151 : feinerer 49 new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,
152 :     Description = description, ID = id, Origin = origin, Heading = heading)
153 : feinerer 19 }
154 : feinerer 23
155 :     # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
156 : feinerer 49 parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {
157 : feinerer 36 # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!
158 :     if (!is.null(node[["TEXT"]][["AUTHOR"]]))
159 :     author <- xmlValue(node[["TEXT"]][["AUTHOR"]])
160 :     else
161 :     author <- ""
162 :    
163 : feinerer 42 datetimestamp <- xmlValue(node[["DATE"]])
164 : feinerer 36 description <- ""
165 : feinerer 23 id <- as.integer(xmlAttrs(node)[["NEWID"]])
166 :    
167 : feinerer 36 origin <- "Reuters-21578 XML"
168 : feinerer 23
169 :     # The <BODY></BODY> tag is unfortunately NOT obligatory!
170 :     if (!is.null(node[["TEXT"]][["BODY"]]))
171 :     corpus <- xmlValue(node[["TEXT"]][["BODY"]])
172 :     else
173 :     corpus <- ""
174 :    
175 :     if (stripWhiteSpace)
176 :     corpus <- gsub("[[:space:]]+", " ", corpus)
177 :     if (toLower)
178 :     corpus <- tolower(corpus)
179 :    
180 :     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!
181 :     if (!is.null(node[["TEXT"]][["TITLE"]]))
182 :     heading <- xmlValue(node[["TEXT"]][["TITLE"]])
183 :     else
184 :     heading <- ""
185 :    
186 : feinerer 49 topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)
187 :    
188 :     new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,
189 :     Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
190 : feinerer 23 }
191 : feinerer 49
192 :     # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file
193 :     parseReutersXML<- function(file) {
194 :     new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),
195 :     Description = "Reuters21578 file containing several news articles", ID = as.integer(0),
196 :     Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")
197 :     }
198 :    
199 :     setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))
200 :     setMethod("loadFileIntoMem",
201 :     c("XMLTextDocument"),
202 :     function(object) {
203 :     if (object@Cached == 0) {
204 :     file <- object@FileName
205 :     doc <- xmlTreeParse(file)
206 :     class(doc) <- "list"
207 :     object@.Data <- doc
208 :     object@Cached <- 1
209 :     return(object)
210 :     } else {
211 :     return(object)
212 :     }
213 :     })
214 :    
215 : feinerer 54 setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))
216 :     setMethod("tm_transform",
217 : feinerer 49 c("TextDocCol"),
218 :     function(object, FUN, ...) {
219 : feinerer 55 lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
220 : feinerer 49 })
221 :    
222 :     setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
223 :     setMethod("toPlainTextDocument",
224 :     c("PlainTextDocument"),
225 :     function(object, FUN, ...) {
226 :     return(object)
227 :     })
228 :     setMethod("toPlainTextDocument",
229 :     c("XMLTextDocument"),
230 :     function(object, FUN, ...) {
231 :     if (object@Cached == 0)
232 :     object <- loadFileIntoMem(object)
233 :    
234 :     corpus <- object@.Data
235 :    
236 :     # As XMLDocument is no native S4 class, restore valid information
237 :     class(corpus) <- "XMLDocument"
238 :     names(corpus) <- c("doc","dtd")
239 :    
240 :     return(xmlApply(xmlRoot(corpus), FUN, ...))
241 :     })
242 :    
243 : feinerer 55 setGeneric("stemTextDocument", function(object, ...) standardGeneric("stemTextDocument"))
244 : feinerer 49 setMethod("stemTextDocument",
245 :     c("PlainTextDocument"),
246 :     function(object) {
247 :     require(Rstem)
248 :     splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
249 :     stemmedCorpus <- wordStem(splittedCorpus)
250 :     object@.Data <- paste(stemmedCorpus, collapse = " ")
251 :     return (object)
252 :     })
253 :    
254 : feinerer 55 setGeneric("removeStopWords", function(object, stopwords, ...) standardGeneric("removeStopWords"))
255 : feinerer 53 setMethod("removeStopWords",
256 : feinerer 49 c("PlainTextDocument", "character"),
257 :     function(object, stopwords) {
258 :     require(Rstem)
259 :     splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
260 :     noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
261 :     object@.Data <- paste(noStopwordsCorpus, collapse = " ")
262 :     return (object)
263 :     })
264 :    
265 : feinerer 54 setGeneric("tm_filter", function(object, FUN, ...) standardGeneric("tm_filter"))
266 :     setMethod("tm_filter",
267 : feinerer 49 c("TextDocCol"),
268 :     function(object, FUN, ...) {
269 : feinerer 55 sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))
270 : feinerer 49 })
271 :    
272 :     setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))
273 :     setMethod("filterREUT21578Topics",
274 :     c("PlainTextDocument", "character"),
275 : feinerer 55 function(object, topics) {
276 : feinerer 49 if (object@Cached == 0)
277 :     object <- loadFileIntoMem(object)
278 :    
279 :     if (any(object@LocalMetaData$Topics %in% topics))
280 :     return(TRUE)
281 :     else
282 :     return(FALSE)
283 :     })
284 : feinerer 52
285 : feinerer 55 setGeneric("filterIDs", function(object, IDs, ...) standardGeneric("filterIDs"))
286 : feinerer 53 setMethod("filterIDs",
287 :     c("TextDocument", "numeric"),
288 :     function(object, IDs) {
289 :     if (object@ID %in% IDs)
290 :     return(TRUE)
291 :     else
292 :     return(FALSE)
293 :     })
294 :    
295 : feinerer 52 setGeneric("attachData", function(object, data) standardGeneric("attachData"))
296 :     setMethod("attachData",
297 :     c("TextDocCol","TextDocument"),
298 :     function(object, data) {
299 :     data <- as(list(data), "TextDocCol")
300 :     object@.Data <- as(c(object@.Data, data), "TextDocCol")
301 :     return(object)
302 :     })
303 :    
304 :     setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))
305 :     setMethod("attachMetaData",
306 :     c("TextDocCol"),
307 :     function(object, name, metadata) {
308 :     object@GlobalMetaData <- c(object@GlobalMetaData, new = list(metadata))
309 :     names(object@GlobalMetaData)[length(names(object@GlobalMetaData))] <- name
310 :     return(object)
311 :     })
312 : feinerer 53
313 :     setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))
314 :     setMethod("setSubscriptable",
315 :     c("TextDocCol"),
316 :     function(object, name) {
317 :     if (!is.character(object@GlobalMetaData$subscriptable))
318 :     object <- attachMetaData(object, "subscriptable", name)
319 :     else
320 :     object@GlobalMetaData$subscriptable <- c(object@GlobalMetaData$subscriptable, name)
321 :     return(object)
322 :     })
323 :    
324 :     setMethod("[",
325 :     signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),
326 :     function(x, i, j, ... , drop) {
327 :     if(missing(i))
328 :     return(x)
329 :    
330 :     object <- x
331 :     object@.Data <- x@.Data[i, ..., drop = FALSE]
332 :     for (m in names(object@GlobalMetaData)) {
333 :     if (m %in% object@GlobalMetaData$subscriptable) {
334 :     object@GlobalMetaData[[m]] <- object@GlobalMetaData[[m]][i, ..., drop = FALSE]
335 :     }
336 :     }
337 :     return(object)
338 :     })
339 :    
340 :     setMethod("c",
341 :     signature(x = "TextDocCol"),
342 :     function(x, ..., recursive = TRUE){
343 :     args <- list(...)
344 :     if(length(args) == 0)
345 :     return(x)
346 :     return(as(c(as(x, "list"), ...), "TextDocCol"))
347 :     })
348 : feinerer 54
349 :     setMethod("length",
350 :     signature(x = "TextDocCol"),
351 :     function(x){
352 :     return(length(as(x, "list")))
353 :     })
354 :    
355 :     setMethod("show",
356 :     signature(object = "TextDocCol"),
357 :     function(object){
358 :     cat("A text document collection with", length(object), "text document")
359 :     if (length(object) == 1)
360 :     cat("\n")
361 :     else
362 :     cat("s\n")
363 :     })
364 :    
365 :     setMethod("summary",
366 :     signature(object = "TextDocCol"),
367 :     function(object){
368 :     show(object)
369 :     if (length(GlobalMetaData(object)) > 0) {
370 :     cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")
371 :     if (length(GlobalMetaData(object)) == 1)
372 :     cat(".\n")
373 :     else
374 :     cat("s.\n")
375 :     cat("Available tags are:\n")
376 :     cat(names(GlobalMetaData(object)), "\n")
377 :     }
378 :     })
379 : feinerer 55
380 :     setGeneric("inspect", function(object) standardGeneric("inspect"))
381 :     setMethod("inspect",
382 :     c("TextDocCol"),
383 :     function(object) {
384 :     summary(object)
385 :     cat("\n")
386 :     show(as(object, "list"))
387 :     })

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge