SCM

SCM Repository

[tm] Diff of /trunk/R/textmin/R/textdoccol.R
ViewVC logotype

Diff of /trunk/R/textmin/R/textdoccol.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 55, Thu Sep 14 12:31:07 2006 UTC revision 56, Sun Sep 24 14:12:28 2006 UTC
# Line 3  Line 3 
3  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))
4  setMethod("TextDocCol",  setMethod("TextDocCol",
5            c("character"),            c("character"),
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {            function(object, inputType = "PLAIN", stripWhiteSpace = FALSE, toLower = FALSE) {
7                # Add a new type for each unique input source format                # Add a new type for each unique input source format
8                type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "REUT21578_XML", "RIS"))                type <- match.arg(inputType,c("PLAIN", "CSV", "RCV1", "REUT21578", "REUT21578_XML", "NEWSGROUP", "RIS"))
9                switch(type,                switch(type,
10                         # Plain text
11                         "PLAIN" = {
12                             filelist <- dir(object, full.names = TRUE)
13                             filenameIDs <- list(FileNames = filelist, IDs = 1:length(filelist))
14                             tdl <- sapply(filelist,
15                                           function(file, FileNameIDs = filenameIDs) {
16                                               id <- FileNameIDs$IDs[grep(file, FileNameIDs$FileNames)]
17                                               origin <- dirname(file)
18                                               new("PlainTextDocument", FileName = file, Cached = 0, Author = "Unknown", DateTimeStamp = date(),
19                                                   Description = "", ID = id, Origin = origin, Heading = "")
20                                           })
21                             tdcl <- new("TextDocCol", .Data = tdl)
22                         },
23                       # Text in a special CSV format                       # Text in a special CSV format
24                       # For details on the file format see the R documentation file                       # For details on the file format see the R documentation file
25                       # The first argument is a directory with .csv files                       # The first argument is a directory with .csv files
26                       "CSV" = {                       "CSV" = {
27                           filelist <- dir(object, pattern = ".csv", full.names = TRUE)                           filelist <- dir(object, pattern = "\\.csv", full.names = TRUE)
28                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
29                                         function(file) {                                         function(file) {
30                                             m <- as.matrix(read.csv(file, header = FALSE))                                             m <- as.matrix(read.csv(file, header = FALSE))
# Line 42  Line 55 
55                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format
56                       # The first argument is a directory with the RCV1 XML files                       # The first argument is a directory with the RCV1 XML files
57                       "RCV1" = {                       "RCV1" = {
58                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                           filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
59                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
60                                         function(file) {                                         function(file) {
61                                             tree <- xmlTreeParse(file)                                             tree <- xmlTreeParse(file)
# Line 57  Line 70 
70                       # Typically the first argument will be a directory where we can                       # Typically the first argument will be a directory where we can
71                       # find the files reut2-000.xml ... reut2-021.xml                       # find the files reut2-000.xml ... reut2-021.xml
72                       "REUT21578" = {                       "REUT21578" = {
73                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                           filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
74                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
75                                         function(file) {                                         function(file) {
76                                             tree <- xmlTreeParse(file)                                             tree <- xmlTreeParse(file)
# Line 69  Line 82 
82                               tdcl <- new("TextDocCol", .Data = tdl)                               tdcl <- new("TextDocCol", .Data = tdl)
83                       },                       },
84                       "REUT21578_XML" = {                       "REUT21578_XML" = {
85                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                           filelist <- dir(object, pattern = "\\..xml", full.names = TRUE)
86                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
87                                         function(file) {                                         function(file) {
88                                             parseReutersXML(file)                                             parseReutersXML(file)
89                                         })                                         })
90                           tdcl <- new("TextDocCol", .Data = tdl)                           tdcl <- new("TextDocCol", .Data = tdl)
91                       },                       },
92                         "NEWSGROUP" = {
93                             filelist <- dir(object, full.names = TRUE)
94                             tdl <- sapply(filelist,
95                                           function(file) {
96                                               parseMail(file)
97                                           })
98                             new("TextDocCol", .Data = tdl)
99                         },
100                       # Read in HTML documents as used by http://ris.bka.gv.at/vwgh                       # Read in HTML documents as used by http://ris.bka.gv.at/vwgh
101                       "RIS" = {                       "RIS" = {
102                           filelist <- dir(object, pattern = ".html", full.names = TRUE)                           filelist <- dir(object, pattern = "\\..html", full.names = TRUE)
103                           tdl <- sapply(filelist,                           tdl <- sapply(filelist,
104                                         function(file) {                                         function(file) {
105                                             # Ignore warnings from misformed HTML documents                                             # Ignore warnings from misformed HTML documents
# Line 189  Line 210 
210          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))
211  }  }
212    
213  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  # Set up metadata for a well-formed Reuters-21578 XML file
214  parseReutersXML<- function(file) {  parseReutersXML<- function(file) {
215      new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),      new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),
216          Description = "Reuters21578 file containing several news articles", ID = as.integer(0),          Description = "Reuters21578 file containing several news articles", ID = as.integer(0),
217          Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")          Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")
218  }  }
219    
220  setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))  parseMail <- function(file) {
221        mail <- readLines(file)
222        author <- gsub("From: ", "", grep("^From:", mail, value = TRUE))
223        datetimestamp <- gsub("Date: ", "", grep("^Date:", mail, value = TRUE))
224        id <- as.integer(file)
225        origin <- gsub("Path: ", "", grep("^Path:", mail, value = TRUE))
226        heading <- gsub("Subject: ", "", grep("^Subject:", mail, value = TRUE))
227        newsgroup <- gsub("Newsgroups: ", "", grep("^Newsgroups:", mail, value = TRUE))
228    
229        new("NewsgroupDocument", FileName = file, Cached = 0, Author = author, DateTimeStamp = datetimestamp,
230            Description = "", ID = id, Origin = origin, Heading = heading, Newsgroup = newsgroup)
231    }
232    
233    setGeneric("loadFileIntoMem", function(object, ...) standardGeneric("loadFileIntoMem"))
234    setMethod("loadFileIntoMem",
235              c("PlainTextDocument"),
236              function(object, ...) {
237                  if (Cached(object) == 0) {
238                      corpus <- readLines(FileName(object))
239                      Corpus(object) <- corpus
240                      Cached(object) <- 1
241                      return(object)
242                  } else {
243                      return(object)
244                  }
245              })
246  setMethod("loadFileIntoMem",  setMethod("loadFileIntoMem",
247            c("XMLTextDocument"),            c("XMLTextDocument"),
248            function(object) {            function(object, ...) {
249                if (object@Cached == 0) {                if (Cached(object) == 0) {
250                    file <- object@FileName                    file <- FileName(object)
251                    doc <- xmlTreeParse(file)                    doc <- xmlTreeParse(file)
252                    class(doc) <- "list"                    class(doc) <- "list"
253                    object@.Data <- doc                    Corpus(object) <- doc
254                    object@Cached <- 1                    Cached(object) <- 1
255                      return(object)
256                  } else {
257                      return(object)
258                  }
259              })
260    setMethod("loadFileIntoMem",
261              c("NewsgroupDocument"),
262              function(object, ...) {
263                  if (Cached(object) == 0) {
264                      mail <- readLines(FileName(object))
265                      Cached(object) <- 1
266                      index <- grep("^Lines:", mail)
267                      Corpus(object) <- mail[(index + 1):length(mail)]
268                    return(object)                    return(object)
269                } else {                } else {
270                    return(object)                    return(object)
# Line 216  Line 275 
275  setMethod("tm_transform",  setMethod("tm_transform",
276            c("TextDocCol"),            c("TextDocCol"),
277            function(object, FUN, ...) {            function(object, FUN, ...) {
278                lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))                result <- as(lapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
279                  result@GlobalMetaData <- GlobalMetaData(object)
280                  return(result)
281            })            })
282    
283  setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))  setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))
# Line 228  Line 289 
289  setMethod("toPlainTextDocument",  setMethod("toPlainTextDocument",
290            c("XMLTextDocument"),            c("XMLTextDocument"),
291            function(object, FUN, ...) {            function(object, FUN, ...) {
292                if (object@Cached == 0)                if (Cached(object) == 0)
293                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
294    
295                corpus <- object@.Data                corpus <- Corpus(object)
296    
297                # As XMLDocument is no native S4 class, restore valid information                # As XMLDocument is no native S4 class, restore valid information
298                class(corpus) <- "XMLDocument"                class(corpus) <- "XMLDocument"
# Line 244  Line 305 
305  setMethod("stemTextDocument",  setMethod("stemTextDocument",
306            c("PlainTextDocument"),            c("PlainTextDocument"),
307            function(object) {            function(object) {
308                  if (Cached(object) == 0)
309                      object <- loadFileIntoMem(object)
310    
311                require(Rstem)                require(Rstem)
312                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
313                stemmedCorpus <- wordStem(splittedCorpus)                stemmedCorpus <- wordStem(splittedCorpus)
314                object@.Data <- paste(stemmedCorpus, collapse = " ")                Corpus(object) <- paste(stemmedCorpus, collapse = " ")
315                return (object)                return (object)
316            })            })
317    
# Line 255  Line 319 
319  setMethod("removeStopWords",  setMethod("removeStopWords",
320            c("PlainTextDocument", "character"),            c("PlainTextDocument", "character"),
321            function(object, stopwords) {            function(object, stopwords) {
322                  if (Cached(object) == 0)
323                      object <- loadFileIntoMem(object)
324    
325                require(Rstem)                require(Rstem)
326                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))                splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))
327                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]                noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]
328                object@.Data <- paste(noStopwordsCorpus, collapse = " ")                Corpus(object) <- paste(noStopwordsCorpus, collapse = " ")
329                return (object)                return (object)
330            })            })
331    
# Line 266  Line 333 
333  setMethod("tm_filter",  setMethod("tm_filter",
334            c("TextDocCol"),            c("TextDocCol"),
335            function(object, FUN, ...) {            function(object, FUN, ...) {
336                sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object))                result <- as(sapply(object, FUN, ..., GlobalMetaData = GlobalMetaData(object)), "TextDocCol")
337                  result@GlobalMetaData <- GlobalMetaData(object)
338                  return(result)
339            })            })
340    
341  setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))  setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))
342  setMethod("filterREUT21578Topics",  setMethod("filterREUT21578Topics",
343            c("PlainTextDocument", "character"),            c("PlainTextDocument", "character"),
344            function(object, topics) {            function(object, topics) {
345                if (object@Cached == 0)                if (Cached(object) == 0)
346                    object <- loadFileIntoMem(object)                    object <- loadFileIntoMem(object)
347    
348                if (any(object@LocalMetaData$Topics %in% topics))                if (any(LocalMetaData(object)$Topics %in% topics))
349                    return(TRUE)                    return(TRUE)
350                else                else
351                    return(FALSE)                    return(FALSE)
# Line 286  Line 355 
355  setMethod("filterIDs",  setMethod("filterIDs",
356            c("TextDocument", "numeric"),            c("TextDocument", "numeric"),
357            function(object, IDs) {            function(object, IDs) {
358                if (object@ID %in% IDs)                if (ID(object) %in% IDs)
359                    return(TRUE)                    return(TRUE)
360                else                else
361                    return(FALSE)                    return(FALSE)
# Line 305  Line 374 
374  setMethod("attachMetaData",  setMethod("attachMetaData",
375            c("TextDocCol"),            c("TextDocCol"),
376            function(object, name, metadata) {            function(object, name, metadata) {
377                object@GlobalMetaData <- c(object@GlobalMetaData, new = list(metadata))                object@GlobalMetaData <- c(GlobalMetaData(object), new = list(metadata))
378                names(object@GlobalMetaData)[length(names(object@GlobalMetaData))] <- name                names(object@GlobalMetaData)[length(names(GlobalMetaData(object)))] <- name
379                return(object)                return(object)
380            })            })
381    
# Line 314  Line 383 
383  setMethod("setSubscriptable",  setMethod("setSubscriptable",
384            c("TextDocCol"),            c("TextDocCol"),
385            function(object, name) {            function(object, name) {
386                if (!is.character(object@GlobalMetaData$subscriptable))                if (!is.character(GlobalMetaData(object)$subscriptable))
387                    object <- attachMetaData(object, "subscriptable", name)                    object <- attachMetaData(object, "subscriptable", name)
388                else                else
389                    object@GlobalMetaData$subscriptable <- c(object@GlobalMetaData$subscriptable, name)                    object@GlobalMetaData$subscriptable <- c(GlobalMetaData(object)$subscriptable, name)
390                return(object)                return(object)
391            })            })
392    
# Line 329  Line 398 
398    
399                object <- x                object <- x
400                object@.Data <- x@.Data[i, ..., drop = FALSE]                object@.Data <- x@.Data[i, ..., drop = FALSE]
401                for (m in names(object@GlobalMetaData)) {                for (m in names(GlobalMetaData(object))) {
402                    if (m %in% object@GlobalMetaData$subscriptable) {                    if (m %in% GlobalMetaData(object)$subscriptable) {
403                        object@GlobalMetaData[[m]] <- object@GlobalMetaData[[m]][i, ..., drop = FALSE]                        object@GlobalMetaData[[m]] <- GlobalMetaData(object)[[m]][i, ..., drop = FALSE]
404                    }                    }
405                }                }
406                return(object)                return(object)

Legend:
Removed from v.55  
changed lines
  Added in v.56

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge