SCM

SCM Repository

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

Diff of /pkg/R/corpus.R

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

trunk/R/textmin/R/textdoccol.R revision 54, Wed Sep 13 09:08:20 2006 UTC pkg/R/corpus.R revision 1333, Fri Apr 18 10:38:46 2014 UTC
# Line 1  Line 1 
1  # Author: Ingo Feinerer  # Author: Ingo Feinerer
2    
3  setGeneric("TextDocCol", function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) standardGeneric("TextDocCol"))  PCorpus <-
4  setMethod("TextDocCol",  function(x,
5            c("character"),           readerControl = list(reader = x$defaultreader, language = "en"),
6            function(object, inputType = "CSV", stripWhiteSpace = FALSE, toLower = FALSE) {           dbControl = list(dbName = "", dbType = "DB1"))
7                # Add a new type for each unique input source format  {
8                type <- match.arg(inputType,c("CSV", "RCV1", "REUT21578", "REUT21578_XML", "RIS"))      stopifnot(inherits(x, "Source"))
9                switch(type,  
10                       # Text in a special CSV format      readerControl <- prepareReader(readerControl, x$defaultreader)
11                       # For details on the file format see the R documentation file  
12                       # The first argument is a directory with .csv files      if (is.function(readerControl$init))
13                       "CSV" = {          readerControl$init()
14                           filelist <- dir(object, pattern = ".csv", full.names = TRUE)  
15                           tdl <- sapply(filelist,      if (is.function(readerControl$exit))
16                                         function(file) {          on.exit(readerControl$exit())
17                                             m <- as.matrix(read.csv(file, header = FALSE))  
18                                             l <- vector("list", dim(m)[1])      if (!filehash::dbCreate(dbControl$dbName, dbControl$dbType))
19                                             for (i in 1:dim(m)[1]) {          stop("error in creating database")
20                                                 author <- ""      db <- filehash::dbInit(dbControl$dbName, dbControl$dbType)
21                                                 datetimestamp <- date()  
22                                                 description <- ""      # Allocate memory in advance if length is known
23                                                 id <- as.integer(m[i,1])      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
24                                                 corpus <- as.character(m[i,2:dim(m)[2]])  
25                                                 if (stripWhiteSpace)      counter <- 1
26                                                     corpus <- gsub("[[:space:]]+", " ", corpus)      while (!eoi(x)) {
27                                                 if (toLower)          x <- stepNext(x)
28                                                     corpus <- tolower(corpus)          elem <- getElem(x)
29                                                 origin <- "CSV"          id <- if (is.null(x$names) || is.na(x$names))
30                                                 heading <- ""              as.character(counter)
31            else
32                                                 l[[i]] <- new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,              x$names[counter]
33                                                               Description = description, ID = id, Origin = origin, Heading = heading)          doc <- readerControl$reader(elem, readerControl$language, id)
34                                             }          filehash::dbInsert(db, meta(doc, "id"), doc)
35                                             l          if (x$length > 0) tdl[[counter]] <- meta(doc, "id")
36                                         })          else tdl <- c(tdl, meta(doc, "id"))
37                           if (length(filelist) > 1)          counter <- counter + 1
38                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))      }
39                           else      if (!is.null(x$names) && !is.na(x$names))
40                               tdcl <- new("TextDocCol", .Data = tdl)          names(tdl) <- x$names
41                       },  
42                       # Read in text documents in XML Reuters Corpus Volume 1 (RCV1) format      structure(list(content = tdl,
43                       # The first argument is a directory with the RCV1 XML files                     meta = CorpusMeta(),
44                       "RCV1" = {                     dmeta = data.frame(row.names = seq_along(tdl)),
45                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                     dbcontrol = dbControl),
46                           tdl <- sapply(filelist,                class = c("PCorpus", "Corpus"))
47                                         function(file) {  }
48                                             tree <- xmlTreeParse(file)  
49                                             xmlApply(xmlRoot(tree), parseNewsItemPlain, stripWhiteSpace, toLower)  VCorpus <-
50                                         })  function(x, readerControl = list(reader = x$defaultreader, language = "en"))
51                           if (length(filelist) > 1)  {
52                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))      stopifnot(inherits(x, "Source"))
53                           else  
54                               tdcl <- new("TextDocCol", .Data = tdl)      readerControl <- prepareReader(readerControl, x$defaultreader)
55                       },  
56                       # Read in text documents in Reuters-21578 XML (not SGML) format      if (is.function(readerControl$init))
57                       # Typically the first argument will be a directory where we can          readerControl$init()
58                       # find the files reut2-000.xml ... reut2-021.xml  
59                       "REUT21578" = {      if (is.function(readerControl$exit))
60                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)          on.exit(readerControl$exit())
61                           tdl <- sapply(filelist,  
62                                         function(file) {      # Allocate memory in advance if length is known
63                                             tree <- xmlTreeParse(file)      tdl <- if (x$length > 0) vector("list", as.integer(x$length)) else list()
64                                             xmlApply(xmlRoot(tree), parseReutersPlain, stripWhiteSpace, toLower)  
65                                         })      if (x$vectorized)
66                           if (length(filelist) > 1)          tdl <- mapply(function(elem, id)
67                               tdcl <- new("TextDocCol", .Data = unlist(tdl, recursive = FALSE))                            readerControl$reader(elem, readerControl$language, id),
68                           else                        pGetElem(x),
69                               tdcl <- new("TextDocCol", .Data = tdl)                        id = if (is.null(x$names) || is.na(x$names))
70                       },                            as.character(seq_len(x$length))
71                       "REUT21578_XML" = {                        else x$names,
72                           filelist <- dir(object, pattern = ".xml", full.names = TRUE)                        SIMPLIFY = FALSE)
73                           tdl <- sapply(filelist,      else {
74                                         function(file) {          counter <- 1
75                                             parseReutersXML(file)          while (!eoi(x)) {
76                                         })              x <- stepNext(x)
77                           tdcl <- new("TextDocCol", .Data = tdl)              elem <- getElem(x)
78                       },              id <- if (is.null(x$names) || is.na(x$names))
79                       # Read in HTML documents as used by http://ris.bka.gv.at/vwgh                  as.character(counter)
80                       "RIS" = {              else
81                           filelist <- dir(object, pattern = ".html", full.names = TRUE)                  x$names[counter]
82                           tdl <- sapply(filelist,              doc <- readerControl$reader(elem, readerControl$language, id)
83                                         function(file) {              if (x$length > 0)
84                                             # Ignore warnings from misformed HTML documents                  tdl[[counter]] <- doc
                                            suppressWarnings(RISDoc <- parseRISPlain(file, stripWhiteSpace, toLower))  
                                            if (!is.null(RISDoc)) {  
                                                l <- list()  
                                                l[[length(l) + 1]] <- RISDoc  
                                                l  
                                            }  
                                        })  
                          tdcl <- new("TextDocCol", .Data = tdl)  
                      })  
               tdcl  
           })  
   
 # Parse an Austrian RIS HTML document  
 parseRISPlain <- function(file, stripWhiteSpace = FALSE, toLower = FALSE) {  
     author <- ""  
     datetimestamp <- date()  
     description <- ""  
   
     tree <- htmlTreeParse(file)  
     htmlElem <- unlist(tree$children$html$children)  
   
     if (is.null(htmlElem))  
         stop(paste("Empty document", file, "cannot be processed."))  
   
     textElem <- htmlElem[which(regexpr("text.value", names(htmlElem)) > 0)]  
     names(textElem) <- NULL  
   
     corpus <- paste(textElem, collapse = " ")  
   
     year <- substring(corpus, regexpr("..../../", corpus), regexpr("..../../", corpus) + 3)  
     senat <- substring(corpus, regexpr("..../../", corpus) + 5, regexpr("..../../", corpus) + 6)  
     number <- substring(corpus, regexpr("..../../", corpus) + 8, regexpr("..../../", corpus) + 11)  
   
     id <- as.integer(paste(year, senat, number, sep = ""))  
   
     if (is.na(id))  
         stop(paste("Cannot extract 'Geschaeftszahl' out of malformed document", file))  
     origin <- ""  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     heading <- ""  
   
     new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
         Description = description, ID = id, Origin = origin, Heading = heading)  
 }  
   
 # Parse a <newsitem></newsitem> element from a well-formed RCV1 XML file  
 parseNewsItemPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  
     author <- "Not yet implemented"  
     datetimestamp <- xmlAttrs(node)[["date"]]  
     description <- "Not yet implemented"  
     id <- as.integer(xmlAttrs(node)[["itemid"]])  
     origin <- "Reuters Corpus Volume 1 XML"  
     corpus <- unlist(xmlApply(node[["text"]], xmlValue), use.names = FALSE)  
   
     if (stripWhiteSpace)  
         corpus <- gsub("[[:space:]]+", " ", corpus)  
     if (toLower)  
         corpus <- tolower(corpus)  
   
     heading <- xmlValue(node[["title"]])  
   
     new("PlainTextDocument", .Data = corpus, Author = author, DateTimeStamp = datetimestamp,  
         Description = description, ID = id, Origin = origin, Heading = heading)  
 }  
   
 # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  
 parseReutersPlain <- function(node, stripWhiteSpace = FALSE, toLower = FALSE) {  
     # The <AUTHOR></AUTHOR> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["AUTHOR"]]))  
         author <- xmlValue(node[["TEXT"]][["AUTHOR"]])  
85      else      else
86          author <- ""                  tdl <- c(tdl, list(doc))
87                counter <- counter + 1
88            }
89        }
90        if (!is.null(x$names) && !is.na(x$names))
91            names(tdl) <- x$names
92    
93      datetimestamp <- xmlValue(node[["DATE"]])      structure(list(content = tdl,
94      description <- ""                     meta = CorpusMeta(),
95      id <- as.integer(xmlAttrs(node)[["NEWID"]])                     dmeta = data.frame(row.names = seq_along(tdl))),
96                  class = c("VCorpus", "Corpus"))
97    }
98    
99      origin <- "Reuters-21578 XML"  `[.PCorpus` <-
100    function(x, i)
101    {
102        if (!missing(i)) {
103            x$content <- x$content[i]
104            x$dmeta <- x$dmeta[i, , drop = FALSE]
105        }
106        x
107    }
108    
109      # The <BODY></BODY> tag is unfortunately NOT obligatory!  `[.VCorpus` <-
110      if (!is.null(node[["TEXT"]][["BODY"]]))  function(x, i)
111          corpus <- xmlValue(node[["TEXT"]][["BODY"]])  {
112      else      if (!missing(i)) {
113          corpus <- ""          x$content <- x$content[i]
114            x$dmeta <- x$dmeta[i, , drop = FALSE]
115            if (!is.null(x$lazy))
116                x$lazy$index <- x$lazy$index[i]
117        }
118        x
119    }
120    
121      if (stripWhiteSpace)  .map_name_index <-
122          corpus <- gsub("[[:space:]]+", " ", corpus)  function(x, i)
123      if (toLower)  {
124          corpus <- tolower(corpus)      if (is.character(i))
125            match(i, if (is.null(names(x))) meta(x, "id", "local") else names(x))
     # The <TITLE></TITLE> tag is unfortunately NOT obligatory!  
     if (!is.null(node[["TEXT"]][["TITLE"]]))  
         heading <- xmlValue(node[["TEXT"]][["TITLE"]])  
126      else      else
127          heading <- ""          i
128    }
     topics <- unlist(xmlApply(node[["TOPICS"]], function(x) xmlValue(x)), use.names = FALSE)  
129    
130      new("PlainTextDocument", .Data = corpus, Cached = 1, Author = author, DateTimeStamp = datetimestamp,  `[[.PCorpus` <-
131          Description = description, ID = id, Origin = origin, Heading = heading, LocalMetaData = list(Topics = topics))  function(x, i)
132    {
133        i <- .map_name_index(x, i)
134        db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
135        filehash::dbFetch(db, x$content[[i]])
136    }
137    `[[.VCorpus` <-
138    function(x, i)
139    {
140        i <- .map_name_index(x, i)
141        if (!is.null(x$lazy))
142            .Call(copyCorpus, x, materialize(x, i))
143        x$content[[i]]
144  }  }
145    
146  # Parse a <REUTERS></REUTERS> element from a well-formed Reuters-21578 XML file  `[[<-.PCorpus` <-
147  parseReutersXML<- function(file) {  function(x, i, value)
148      new("XMLTextDocument", FileName = file, Cached = 0, Author = "REUTERS", DateTimeStamp = date(),  {
149          Description = "Reuters21578 file containing several news articles", ID = as.integer(0),      i <- .map_name_index(x, i)
150          Origin = "Reuters-21578 XML", Heading = "Reuters21578 news articles")      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
151  }      db[[x$content[[i]]]] <- value
152        x
153  setGeneric("loadFileIntoMem", function(object) standardGeneric("loadFileIntoMem"))  }
154  setMethod("loadFileIntoMem",  `[[<-.VCorpus` <-
155            c("XMLTextDocument"),  function(x, i, value)
156            function(object) {  {
157                if (object@Cached == 0) {      i <- .map_name_index(x, i)
158                    file <- object@FileName      # Mark new objects as inactive for lazy mapping
159                    doc <- xmlTreeParse(file)      if (!is.null(x$lazy))
160                    class(doc) <- "list"          x$lazy$index[i] <- FALSE
161                    object@.Data <- doc      x$content[[i]] <- value
162                    object@Cached <- 1      x
163                    return(object)  }
               } else {  
                   return(object)  
               }  
           })  
   
 setGeneric("tm_transform", function(object, FUN, ...) standardGeneric("tm_transform"))  
 setMethod("tm_transform",  
           c("TextDocCol"),  
           function(object, FUN, ...) {  
               lapply(object, FUN, ...)  
           })  
   
 setGeneric("toPlainTextDocument", function(object, FUN, ...) standardGeneric("toPlainTextDocument"))  
 setMethod("toPlainTextDocument",  
           c("PlainTextDocument"),  
           function(object, FUN, ...) {  
               return(object)  
           })  
 setMethod("toPlainTextDocument",  
           c("XMLTextDocument"),  
           function(object, FUN, ...) {  
               if (object@Cached == 0)  
                   object <- loadFileIntoMem(object)  
   
               corpus <- object@.Data  
   
               # As XMLDocument is no native S4 class, restore valid information  
               class(corpus) <- "XMLDocument"  
               names(corpus) <- c("doc","dtd")  
   
               return(xmlApply(xmlRoot(corpus), FUN, ...))  
           })  
   
 setGeneric("stemTextDocument", function(object) standardGeneric("stemTextDocument"))  
 setMethod("stemTextDocument",  
           c("PlainTextDocument"),  
           function(object) {  
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               stemmedCorpus <- wordStem(splittedCorpus)  
               object@.Data <- paste(stemmedCorpus, collapse = " ")  
               return (object)  
           })  
   
 setGeneric("removeStopWords", function(object, stopwords) standardGeneric("removeStopWords"))  
 setMethod("removeStopWords",  
           c("PlainTextDocument", "character"),  
           function(object, stopwords) {  
               require(Rstem)  
               splittedCorpus <- unlist(strsplit(object, " ", fixed = TRUE))  
               noStopwordsCorpus <- splittedCorpus[!splittedCorpus %in% stopwords]  
               object@.Data <- paste(noStopwordsCorpus, collapse = " ")  
               return (object)  
           })  
   
 setGeneric("tm_filter", function(object, FUN, ...) standardGeneric("tm_filter"))  
 setMethod("tm_filter",  
           c("TextDocCol"),  
           function(object, FUN, ...) {  
               sapply(object, FUN, ...)  
           })  
   
 setGeneric("filterREUT21578Topics", function(object, topics, ...) standardGeneric("filterREUT21578Topics"))  
 setMethod("filterREUT21578Topics",  
           c("PlainTextDocument", "character"),  
           function(object, topics, ...) {  
               if (object@Cached == 0)  
                   object <- loadFileIntoMem(object)  
164    
165                if (any(object@LocalMetaData$Topics %in% topics))  outer_union <-
166                    return(TRUE)  function(x, y, ...)
167                else  {
168                    return(FALSE)      if (nrow(x) > 0L)
169            })          x[, setdiff(names(y), names(x))] <- NA
170        if (nrow(y) > 0L)
171            y[, setdiff(names(x), names(y))] <- NA
172        res <- rbind(x, y)
173        if (ncol(res) == 0L)
174            res <- data.frame(row.names = seq_len(nrow(x) + nrow(y)))
175        res
176    }
177    
178  setGeneric("filterIDs", function(object, IDs) standardGeneric("filterIDs"))  c.VCorpus <-
179  setMethod("filterIDs",  function(..., recursive = FALSE)
180            c("TextDocument", "numeric"),  {
181            function(object, IDs) {      args <- list(...)
182                if (object@ID %in% IDs)      x <- args[[1L]]
                   return(TRUE)  
               else  
                   return(FALSE)  
           })  
183    
184  setGeneric("attachData", function(object, data) standardGeneric("attachData"))      if (length(args) == 1L)
 setMethod("attachData",  
           c("TextDocCol","TextDocument"),  
           function(object, data) {  
               data <- as(list(data), "TextDocCol")  
               object@.Data <- as(c(object@.Data, data), "TextDocCol")  
               return(object)  
           })  
   
 setGeneric("attachMetaData", function(object, name, metadata) standardGeneric("attachMetaData"))  
 setMethod("attachMetaData",  
           c("TextDocCol"),  
           function(object, name, metadata) {  
               object@GlobalMetaData <- c(object@GlobalMetaData, new = list(metadata))  
               names(object@GlobalMetaData)[length(names(object@GlobalMetaData))] <- name  
               return(object)  
           })  
   
 setGeneric("setSubscriptable", function(object, name) standardGeneric("setSubscriptable"))  
 setMethod("setSubscriptable",  
           c("TextDocCol"),  
           function(object, name) {  
               if (!is.character(object@GlobalMetaData$subscriptable))  
                   object <- attachMetaData(object, "subscriptable", name)  
               else  
                   object@GlobalMetaData$subscriptable <- c(object@GlobalMetaData$subscriptable, name)  
               return(object)  
           })  
   
 setMethod("[",  
           signature(x = "TextDocCol", i = "ANY", j = "ANY", drop = "ANY"),  
           function(x, i, j, ... , drop) {  
               if(missing(i))  
185                    return(x)                    return(x)
186    
187                object <- x      if (!all(unlist(lapply(args, inherits, class(x)))))
188                object@.Data <- x@.Data[i, ..., drop = FALSE]          stop("not all arguments are of the same corpus type")
189                for (m in names(object@GlobalMetaData)) {  
190                    if (m %in% object@GlobalMetaData$subscriptable) {      structure(list(content = do.call("c", lapply(args, content)),
191                        object@GlobalMetaData[[m]] <- object@GlobalMetaData[[m]][i, ..., drop = FALSE]                     meta = structure(do.call("c",
192                         lapply(args, function(a) meta(a, type = "corpus"))),
193                                        class = "CorpusMeta"),
194                       dmeta = Reduce(outer_union, lapply(args, meta))),
195                  class = c("VCorpus", "Corpus"))
196                    }                    }
197    
198    as.list.PCorpus <- as.list.VCorpus <-
199    function(x, ...)
200        content(x)
201    
202    content.VCorpus <-
203    function(x)
204    {
205        if (!is.null(x$lazy))
206            .Call(copyCorpus, x, materialize(x))
207        x$content
208                }                }
               return(object)  
           })  
   
 setMethod("c",  
           signature(x = "TextDocCol"),  
           function(x, ..., recursive = TRUE){  
               args <- list(...)  
               if(length(args) == 0)  
                   return(x)  
               return(as(c(as(x, "list"), ...), "TextDocCol"))  
     })  
209    
210  setMethod("length",  content.PCorpus <-
211            signature(x = "TextDocCol"),  function(x)
212            function(x){  {
213                return(length(as(x, "list")))      db <- filehash::dbInit(x$dbcontrol[["dbName"]], x$dbcontrol[["dbType"]])
214      })      filehash::dbMultiFetch(db, unlist(x$content))
215    }
216  setMethod("show",  
217            signature(object = "TextDocCol"),  length.PCorpus <- length.VCorpus <-
218            function(object){  function(x)
219                cat("A text document collection with", length(object), "text document")      length(x$content)
220                if (length(object) == 1)  
221    print.PCorpus <- print.VCorpus <-
222    function(x, ...)
223    {
224        writeLines(sprintf("<<%s (documents: %d, metadata (corpus/indexed): %d/%d)>>",
225                           class(x)[1],
226                           length(x),
227                           length(meta(x, type = "corpus")),
228                           ncol(meta(x, type = "indexed"))))
229        invisible(x)
230    }
231    
232    inspect <-
233    function(x)
234        UseMethod("inspect", x)
235    inspect.PCorpus <- inspect.VCorpus <-
236    function(x)
237    {
238        print(x)
239                    cat("\n")                    cat("\n")
240                else      print(noquote(content(x)))
241                    cat("s\n")      invisible(x)
242      })  }
243    
244  setMethod("summary",  writeCorpus <-
245            signature(object = "TextDocCol"),  function(x, path = ".", filenames = NULL)
246            function(object){  {
247                show(object)      filenames <- file.path(path,
248                if (length(GlobalMetaData(object)) > 0) {        if (is.null(filenames))
249                    cat("\nThe global metadata consists of", length(GlobalMetaData(object)), "tag-value pair")            sprintf("%s.txt", as.character(meta(x, "id", "local")))
250                    if (length(GlobalMetaData(object)) == 1)        else filenames)
251                        cat(".\n")  
252                    else      stopifnot(length(x) == length(filenames))
253                        cat("s.\n")  
254                    cat("Available tags are:\n")      mapply(function(doc, f) writeLines(as.character(doc), f), x, filenames)
255                    cat(names(GlobalMetaData(object)), "\n")  
256        invisible(x)
257                }                }
     })  

Legend:
Removed from v.54  
changed lines
  Added in v.1333

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