SCM

SCM Repository

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

Annotation of /pkg/R/matrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1404 - (view) (download)

1 : feinerer 1131 ## Authors: Ingo Feinerer, Kurt Hornik
2 : feinerer 16
3 : khornik 1128 TermDocumentMatrix_classes <-
4 :     c("TermDocumentMatrix", "simple_triplet_matrix")
5 :     DocumentTermMatrix_classes <-
6 :     c("DocumentTermMatrix", "simple_triplet_matrix")
7 :    
8 : feinerer 1018 .TermDocumentMatrix <-
9 : khornik 1128 function(x, weighting)
10 : feinerer 1018 {
11 : khornik 1128 x <- as.simple_triplet_matrix(x)
12 : khornik 1133 if(!is.null(dimnames(x)))
13 :     names(dimnames(x)) <- c("Terms", "Docs")
14 : khornik 1128 class(x) <- TermDocumentMatrix_classes
15 : feinerer 1129 ## <NOTE>
16 : khornik 1128 ## Note that if weighting is a weight function, it already needs to
17 :     ## know whether we have a term-document or document-term matrix.
18 : feinerer 1129 ##
19 : khornik 1128 ## Ideally we would require weighting to be a WeightFunction object
20 :     ## or a character string of length 2. But then
21 :     ## dtm <- DocumentTermMatrix(crude,
22 :     ## control = list(weighting =
23 :     ## function(x)
24 :     ## weightTfIdf(x, normalize =
25 :     ## FALSE),
26 :     ## stopwords = TRUE))
27 :     ## in example("DocumentTermMatrix") fails [because weightTfIdf() is
28 :     ## a weight function and not a weight function generator ...]
29 :     ## Hence, for now, instead of
30 :     ## if(inherits(weighting, "WeightFunction"))
31 :     ## x <- weighting(x)
32 :     ## use
33 :     if(is.function(weighting))
34 :     x <- weighting(x)
35 :     ## and hope for the best ...
36 : feinerer 1129 ## </NOTE>
37 : khornik 1128 else if(is.character(weighting) && (length(weighting) == 2L))
38 : feinerer 1306 attr(x, "weighting") <- weighting
39 : khornik 1128 else
40 :     stop("invalid weighting")
41 :     x
42 : feinerer 925 }
43 : feinerer 790
44 : khornik 1128 TermDocumentMatrix <-
45 :     function(x, control = list())
46 :     UseMethod("TermDocumentMatrix", x)
47 : feinerer 918
48 : khornik 1128 TermDocumentMatrix.PCorpus <-
49 :     TermDocumentMatrix.VCorpus <-
50 :     function(x, control = list())
51 :     {
52 : feinerer 1275 stopifnot(is.list(control))
53 :    
54 : feinerer 1310 tflist <- mclapply(unname(content(x)), termFreq, control)
55 : feinerer 987 tflist <- lapply(tflist, function(y) y[y > 0])
56 : feinerer 918
57 : feinerer 941 v <- unlist(tflist)
58 :     i <- names(v)
59 : feinerer 1384 allTerms <- sort(unique(as.character(if (is.null(control$dictionary)) i
60 :     else control$dictionary)))
61 : feinerer 938 i <- match(i, allTerms)
62 : feinerer 987 j <- rep(seq_along(x), sapply(tflist, length))
63 : feinerer 1306 docs <- as.character(meta(x, "id", "local"))
64 : feinerer 1223 if (length(docs) != length(x)) {
65 :     warning("invalid document identifiers")
66 :     docs <- NULL
67 :     }
68 : feinerer 918
69 : khornik 1128 m <- simple_triplet_matrix(i = i, j = j, v = as.numeric(v),
70 :     nrow = length(allTerms),
71 :     ncol = length(x),
72 :     dimnames =
73 : feinerer 1200 list(Terms = allTerms,
74 : feinerer 1223 Docs = docs))
75 : feinerer 1129
76 : feinerer 1151 bg <- control$bounds$global
77 :     if (length(bg) == 2L && is.numeric(bg)) {
78 :     rs <- row_sums(m > 0)
79 :     m <- m[(rs >= bg[1]) & (rs <= bg[2]), ]
80 :     }
81 :    
82 :     weighting <- control$weighting
83 :     if (is.null(weighting))
84 :     weighting <- weightTf
85 :    
86 : khornik 1128 .TermDocumentMatrix(m, weighting)
87 : feinerer 938 }
88 : feinerer 918
89 : khornik 1128 DocumentTermMatrix <-
90 :     function(x, control = list())
91 : feinerer 987 t(TermDocumentMatrix(x, control))
92 : feinerer 941
93 : khornik 1128 as.TermDocumentMatrix <-
94 :     function(x, ...)
95 :     UseMethod("as.TermDocumentMatrix")
96 :     as.TermDocumentMatrix.TermDocumentMatrix <-
97 :     function(x, ...)
98 :     x
99 :     as.TermDocumentMatrix.DocumentTermMatrix <-
100 :     function(x, ...)
101 :     t(x)
102 : feinerer 1145 as.TermDocumentMatrix.term_frequency <-
103 : feinerer 1278 as.TermDocumentMatrix.textcnt <-
104 : khornik 1206 function(x, ...)
105 :     {
106 : feinerer 1145 m <- simple_triplet_matrix(i = seq_along(x),
107 :     j = rep(1, length(x)),
108 :     v = as.numeric(x),
109 :     nrow = length(x),
110 :     ncol = 1,
111 :     dimnames =
112 :     list(Terms = names(x),
113 : khornik 1206 Docs = NA_character_))
114 : feinerer 1145
115 :     .TermDocumentMatrix(m, weightTf)
116 :     }
117 : khornik 1128 as.TermDocumentMatrix.default <-
118 :     function(x, weighting, ...)
119 :     .TermDocumentMatrix(x, weighting)
120 :    
121 :     as.DocumentTermMatrix <-
122 :     function(x, ...)
123 :     UseMethod("as.DocumentTermMatrix")
124 :     as.DocumentTermMatrix.DocumentTermMatrix <-
125 :     function(x, ...)
126 :     x
127 :     as.DocumentTermMatrix.TermDocumentMatrix <-
128 :     function(x, ...)
129 :     t(x)
130 : khornik 1207 as.DocumentTermMatrix.term_frequency <-
131 : feinerer 1278 as.DocumentTermMatrix.textcnt <-
132 : khornik 1207 function(x, ...)
133 :     t(as.TermDocumentMatrix(x))
134 : khornik 1128 as.DocumentTermMatrix.default <-
135 :     function(x, weighting, ...)
136 :     {
137 :     x <- as.simple_triplet_matrix(x)
138 :     t(.TermDocumentMatrix(t(x), weighting))
139 :     }
140 :    
141 :     t.TermDocumentMatrix <-
142 :     t.DocumentTermMatrix <-
143 :     function(x)
144 :     {
145 : khornik 1246 m <- NextMethod("t")
146 : feinerer 1306 attr(m, "weighting") <- attr(x, "weighting")
147 : khornik 1128 class(m) <- if(inherits(x, "DocumentTermMatrix"))
148 :     TermDocumentMatrix_classes
149 : feinerer 941 else
150 : khornik 1128 DocumentTermMatrix_classes
151 : feinerer 918 m
152 :     }
153 :    
154 : khornik 1128 termFreq <-
155 :     function(doc, control = list())
156 :     {
157 : feinerer 1275 stopifnot(inherits(doc, "TextDocument"), is.list(control))
158 : feinerer 1273
159 : feinerer 1320 ## Tokenize the corpus
160 :     .tokenize <- control$tokenize
161 :     if (is.null(.tokenize) || identical(.tokenize, "words"))
162 :     .tokenize <- words
163 :     else if (identical(.tokenize, "MC"))
164 :     .tokenize <- MC_tokenizer
165 :     else if (identical(.tokenize, "scan"))
166 :     .tokenize <- scan_tokenizer
167 :     if (is.function(.tokenize))
168 :     txt <- .tokenize(doc)
169 :     else
170 :     stop("invalid tokenizer")
171 : feinerer 781
172 : khornik 1128 ## Conversion to lower characters
173 : feinerer 1254 .tolower <- control$tolower
174 :     if (is.null(.tolower) || isTRUE(.tolower))
175 :     .tolower <- tolower
176 :     if (is.function(.tolower))
177 :     txt <- .tolower(txt)
178 : feinerer 781
179 : khornik 1128 ## Punctuation removal
180 : feinerer 1254 .removePunctuation <- control$removePunctuation
181 :     if (isTRUE(.removePunctuation))
182 :     .removePunctuation <- removePunctuation
183 :     else if (is.list(.removePunctuation))
184 :     .removePunctuation <-
185 :     function(x) do.call(removePunctuation,
186 :     c(list(x), control$removePunctuation))
187 : feinerer 1023
188 : feinerer 1159 ## Number removal
189 : feinerer 1254 .removeNumbers <- control$removeNumbers
190 :     if (isTRUE(.removeNumbers))
191 :     .removeNumbers <- removeNumbers
192 : feinerer 1159
193 : khornik 1128 ## Stopword filtering
194 : feinerer 1254 .stopwords <- control$stopwords
195 :     if (isTRUE(.stopwords))
196 : feinerer 1310 .stopwords <- function(x) x[is.na(match(x, stopwords(meta(doc, "language"))))]
197 : feinerer 1254 else if (is.character(.stopwords))
198 :     .stopwords <- function(x) x[is.na(match(x, control$stopwords))]
199 : feinerer 1116
200 : khornik 1128 ## Stemming
201 : feinerer 1254 .stemming <- control$stemming
202 :     if (isTRUE(.stemming))
203 : feinerer 1310 .stemming <- function(x) stemDocument(x, meta(doc, "language"))
204 : feinerer 781
205 : feinerer 1159 ## Default order for options which support reordering
206 : feinerer 1173 or <- c("removePunctuation", "removeNumbers", "stopwords", "stemming")
207 : feinerer 1159
208 :     ## Process control options in specified order
209 :     nc <- names(control)
210 :     n <- nc[nc %in% or]
211 : feinerer 1254 for (name in sprintf(".%s", c(n, setdiff(or, n)))) {
212 : feinerer 1159 g <- get(name)
213 :     if (is.function(g))
214 :     txt <- g(txt)
215 :     }
216 :    
217 : khornik 1128 ## Check if the document content is NULL
218 : feinerer 796 if (is.null(txt))
219 : feinerer 1299 return(setNames(integer(0), character(0)))
220 : feinerer 796
221 : khornik 1128 ## If dictionary is set tabulate against it
222 : feinerer 781 dictionary <- control$dictionary
223 :     tab <- if (is.null(dictionary))
224 :     table(txt)
225 :     else
226 :     table(factor(txt, levels = dictionary))
227 :    
228 : feinerer 1151 ## Ensure local bounds
229 :     bl <- control$bounds$local
230 :     if (length(bl) == 2L && is.numeric(bl))
231 :     tab <- tab[(tab >= bl[1]) & (tab <= bl[2])]
232 : feinerer 781
233 : feinerer 1151 ## Filter out too short or too long terms
234 :     nc <- nchar(names(tab), type = "chars")
235 : feinerer 1167 wl <- control$wordLengths
236 :     lb <- if (is.numeric(wl[1])) wl[1] else 3
237 :     ub <- if (is.numeric(wl[2])) wl[2] else Inf
238 :     tab <- tab[(nc >= lb) & (nc <= ub)]
239 : feinerer 781
240 : khornik 1128 ## Return named integer
241 : feinerer 1404 storage.mode(tab) <- "integer"
242 :     class(tab) <- c("term_frequency", class(tab))
243 :     tab
244 : feinerer 781 }
245 :    
246 : khornik 1128 print.TermDocumentMatrix <-
247 :     print.DocumentTermMatrix <-
248 :     function(x, ...)
249 :     {
250 : feinerer 938 format <- c("term", "document")
251 : khornik 1128 if (inherits(x, "DocumentTermMatrix"))
252 :     format <- rev(format)
253 : feinerer 1329 writeLines(sprintf("<<%s (%ss: %d, %ss: %d)>>",
254 :     class(x)[1], format[1L], nrow(x), format[2L], ncol(x)))
255 :     writeLines(sprintf("Non-/sparse entries: %d/%.0f",
256 : khornik 1128 length(x$v), prod(dim(x)) - length(x$v)))
257 : feinerer 1384 sparsity <- if (!prod(dim(x))) 100
258 :     else round((1 - length(x$v)/prod(dim(x))) * 100)
259 : feinerer 1329 writeLines(sprintf("Sparsity : %s%%", sparsity))
260 :     writeLines(sprintf("Maximal term length: %s",
261 :     max(nchar(Terms(x), type = "chars"), 0)))
262 :     writeLines(sprintf("Weighting : %s (%s)",
263 :     attr(x, "weighting")[1L], attr(x, "weighting")[2L]))
264 : khornik 1128 invisible(x)
265 : feinerer 938 }
266 : feinerer 923
267 : khornik 1128 inspect.TermDocumentMatrix <-
268 :     inspect.DocumentTermMatrix <-
269 :     function(x)
270 :     {
271 : feinerer 938 print(x)
272 :     cat("\n")
273 :     print(as.matrix(x))
274 :     }
275 : feinerer 918
276 : khornik 1128 `[.TermDocumentMatrix` <-
277 :     `[.DocumentTermMatrix` <-
278 :     function(x, i, j, ..., drop)
279 :     {
280 : khornik 1246 m <- NextMethod("[")
281 : feinerer 1306 attr(m, "weighting") <- attr(x, "weighting")
282 : feinerer 941 class(m) <- if (inherits(x, "DocumentTermMatrix"))
283 : khornik 1128 DocumentTermMatrix_classes
284 : feinerer 938 else
285 : khornik 1128 TermDocumentMatrix_classes
286 : feinerer 938 m
287 : feinerer 923 }
288 :    
289 : khornik 1135 `dimnames<-.DocumentTermMatrix` <-
290 :     function(x, value)
291 :     {
292 :     x <- NextMethod("dimnames<-")
293 :     dnx <- x$dimnames
294 :     if(!is.null(dnx))
295 :     names(dnx) <- c("Docs", "Terms")
296 :     x$dimnames <- dnx
297 :     x
298 :     }
299 :    
300 :     `dimnames<-.TermDocumentMatrix` <-
301 :     function(x, value)
302 :     {
303 :     x <- NextMethod("dimnames<-")
304 :     dnx <- x$dimnames
305 :     if(!is.null(dnx))
306 :     names(dnx) <- c("Terms", "Docs")
307 :     x$dimnames <- dnx
308 :     x
309 :     }
310 :    
311 : khornik 1128 nDocs <-
312 :     function(x)
313 : khornik 1210 UseMethod("nDocs")
314 :    
315 : khornik 1128 nTerms <-
316 :     function(x)
317 : khornik 1210 UseMethod("nTerms")
318 : feinerer 923
319 : khornik 1210 nDocs.DocumentTermMatrix <-
320 : feinerer 1278 nTerms.TermDocumentMatrix <-
321 : khornik 1210 function(x)
322 :     x$nrow
323 :    
324 :     nDocs.TermDocumentMatrix <-
325 : feinerer 1278 nTerms.DocumentTermMatrix <-
326 : khornik 1210 function(x)
327 :     x$ncol
328 :    
329 : khornik 1128 Docs <-
330 :     function(x)
331 : khornik 1210 UseMethod("Docs")
332 :    
333 : khornik 1128 Terms <-
334 :     function(x)
335 : khornik 1210 UseMethod("Terms")
336 : feinerer 923
337 : khornik 1210 Docs.DocumentTermMatrix <-
338 :     Terms.TermDocumentMatrix <-
339 :     function(x)
340 :     {
341 :     s <- x$dimnames[[1L]]
342 :     if(is.null(s))
343 :     s <- rep.int(NA_character_, x$nrow)
344 :     s
345 :     }
346 :    
347 :     Docs.TermDocumentMatrix <-
348 :     Terms.DocumentTermMatrix <-
349 : feinerer 1278 function(x)
350 : khornik 1210 {
351 :     s <- x$dimnames[[2L]]
352 :     if(is.null(s))
353 :     s <- rep.int(NA_character_, x$ncol)
354 :     s
355 :     }
356 : feinerer 1278
357 : feinerer 1145 c.term_frequency <-
358 : khornik 1203 function(..., recursive = FALSE)
359 : feinerer 1145 {
360 : khornik 1203 do.call("c", lapply(list(...), as.TermDocumentMatrix))
361 : feinerer 1145 }
362 :    
363 : khornik 1128 c.TermDocumentMatrix <-
364 : khornik 1203 function(..., recursive = FALSE)
365 : khornik 1128 {
366 : khornik 1203 m <- lapply(list(...), as.TermDocumentMatrix)
367 : feinerer 1026
368 : khornik 1203 if(length(m) == 1L)
369 :     return(m[[1L]])
370 : feinerer 1026
371 : feinerer 1306 weighting <- attr(m[[1L]], "weighting")
372 : feinerer 1026
373 : stefan7th 1036 allTermsNonUnique <- unlist(lapply(m, function(x) Terms(x)[x$i]))
374 :     allTerms <- unique(allTermsNonUnique)
375 : feinerer 1026 allDocs <- unlist(lapply(m, Docs))
376 :    
377 :     cs <- cumsum(lapply(m, nDocs))
378 :     cs <- c(0, cs[-length(cs)])
379 :     j <- lapply(m, "[[", "j")
380 :    
381 : khornik 1128 m <- simple_triplet_matrix(i = match(allTermsNonUnique, allTerms),
382 :     j = unlist(j) + rep.int(cs, sapply(j, length)),
383 :     v = unlist(lapply(m, "[[", "v")),
384 :     nrow = length(allTerms),
385 :     ncol = length(allDocs),
386 :     dimnames =
387 :     list(Terms = allTerms,
388 :     Docs = allDocs))
389 : feinerer 1131 ## <NOTE>
390 :     ## - We assume that all arguments have the same weighting
391 :     ## - Even if all matrices have the same input weighting it might be necessary
392 :     ## to take additional steps (e.g., normalization for tf-idf or check for
393 :     ## (0,1)-range for binary tf)
394 :     ## </NOTE>
395 : khornik 1203 .TermDocumentMatrix(m, weighting)
396 : feinerer 1026 }
397 :    
398 : khornik 1128 c.DocumentTermMatrix <-
399 : khornik 1203 function(..., recursive = FALSE)
400 : khornik 1128 {
401 : khornik 1203 t(do.call("c", lapply(list(...), as.TermDocumentMatrix)))
402 : feinerer 1129 }
403 : khornik 1128
404 :     findFreqTerms <-
405 :     function(x, lowfreq = 0, highfreq = Inf)
406 :     {
407 : feinerer 1273 stopifnot(inherits(x, c("DocumentTermMatrix", "TermDocumentMatrix")),
408 :     is.numeric(lowfreq), is.numeric(highfreq))
409 :    
410 : feinerer 987 if (inherits(x, "DocumentTermMatrix")) x <- t(x)
411 : feinerer 1100 rs <- slam::row_sums(x)
412 : feinerer 1103 names(rs[rs >= lowfreq & rs <= highfreq])
413 : feinerer 938 }
414 : feinerer 925
415 : khornik 1128 findAssocs <-
416 : feinerer 1266 function(x, terms, corlimit)
417 : khornik 1128 UseMethod("findAssocs", x)
418 :     findAssocs.TermDocumentMatrix <-
419 : feinerer 1266 function(x, terms, corlimit)
420 :     findAssocs(t(x), terms, corlimit)
421 : khornik 1128 findAssocs.DocumentTermMatrix <-
422 : feinerer 1266 function(x, terms, corlimit)
423 : khornik 1128 {
424 : feinerer 1276 stopifnot(is.character(terms), is.numeric(corlimit),
425 : feinerer 1270 corlimit >= 0, corlimit <= 1)
426 : feinerer 1273
427 : feinerer 1276 j <- match(unique(terms), Terms(x), nomatch = 0L)
428 : feinerer 1268 suppressWarnings(
429 :     findAssocs(slam::crossapply_simple_triplet_matrix(x[, j], x[, -j], cor),
430 : feinerer 1276 terms, rep_len(corlimit, length(terms))))
431 : feinerer 938 }
432 : khornik 1128 findAssocs.matrix <-
433 : feinerer 1266 function(x, terms, corlimit)
434 :     {
435 : feinerer 1273 stopifnot(is.numeric(x))
436 :    
437 : feinerer 1276 i <- match(terms, rownames(x), nomatch = 0L)
438 :     names(i) <- terms
439 :     mapply(function(i, cl) {
440 :     xi <- x[i, ]
441 :     t <- sort(round(xi[which(xi >= cl)], 2), TRUE)
442 :     if (!length(t))
443 :     names(t) <- NULL
444 :     t
445 :     }, i, corlimit)
446 : feinerer 1266 }
447 : feinerer 923
448 : khornik 1128 removeSparseTerms <-
449 :     function(x, sparse)
450 :     {
451 : feinerer 1273 stopifnot(inherits(x, c("DocumentTermMatrix", "TermDocumentMatrix")),
452 : feinerer 1274 is.numeric(sparse), sparse > 0, sparse < 1)
453 : feinerer 1273
454 :     m <- if (inherits(x, "DocumentTermMatrix")) t(x) else x
455 :     t <- table(m$i) > m$ncol * (1 - sparse)
456 :     termIndex <- as.numeric(names(t[t]))
457 :     if (inherits(x, "DocumentTermMatrix")) x[, termIndex] else x[termIndex,]
458 : feinerer 938 }
459 : khornik 1381
460 :     CategorizedDocumentTermMatrix <-
461 :     function(x, c)
462 :     {
463 :     if(inherits(x, "TermDocumentMatrix"))
464 :     x <- t(x)
465 :     else if(!inherits(x, "DocumentTermMatrix"))
466 :     stop("wrong class")
467 :    
468 :     if(length(c) != nDocs(x))
469 :     stop("invalid category ids")
470 :    
471 :     attr(x, "Category") <- c
472 :    
473 :     class(x) <- c("CategorizedDocumentTermMatrix",
474 :     DocumentTermMatrix_classes)
475 :    
476 :     x
477 :     }

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