Diff of /pkg/R/ddenseMatrix.R

Parent Directory | Revision Log | Patch

	revision 1575, Mon Sep 18 14:47:40 2006 UTC	revision 2551, Sat Jun 19 20:45:45 2010 UTC
#	Line 4	Line 4
4	## >> but << needs all sub(sub(sub)) classes of "ddenseMatrix" listed	## >> but << needs all sub(sub(sub)) classes of "ddenseMatrix" listed
5	##   -----  in  ../src/Mutils.c	##   -----  in  ../src/Mutils.c
6
	## Should this method return 'from' without duplication when it has
	## class dgeMatrix?
7	setAs("ddenseMatrix", "dgeMatrix",	setAs("ddenseMatrix", "dgeMatrix",
8	function(from) {	function(from) .Call(dup_mMatrix_as_dgeMatrix, from))
9	if (class(from) != "dgeMatrix")
10	from <- .Call(dup_mMatrix_as_dgeMatrix, from)	setAs("ddenseMatrix", "matrix",
11	from	function(from) as(as(from, "dgeMatrix"), "matrix"))
	})
12
13	## d(ouble) to l(ogical):	## d(ouble) to l(ogical):
14	setAs("dgeMatrix", "lgeMatrix", d2l_Matrix)	setAs("dgeMatrix", "lgeMatrix", function(from) d2l_Matrix(from, "dgeMatrix"))
15	setAs("dtrMatrix", "ltrMatrix", d2l_Matrix)	setAs("dsyMatrix", "lsyMatrix", function(from) d2l_Matrix(from, "dsyMatrix"))
16	setAs("dtpMatrix", "ltpMatrix", d2l_Matrix)	setAs("dspMatrix", "lspMatrix", function(from) d2l_Matrix(from, "dspMatrix"))
17	setAs("dsyMatrix", "lsyMatrix", d2l_Matrix)	setAs("dtrMatrix", "ltrMatrix", function(from) d2l_Matrix(from, "dtrMatrix"))
18	setAs("dspMatrix", "lspMatrix", d2l_Matrix)	setAs("dtpMatrix", "ltpMatrix", function(from) d2l_Matrix(from, "dtpMatrix"))
19
20		if(FALSE) ## FIXME, this fails for ("dtpMatrix" -> "CsparseMatrix") where .dense2C() works
21	setAs("ddenseMatrix", "CsparseMatrix",	setAs("ddenseMatrix", "CsparseMatrix",
22	function(from) {	function(from) {
23	if (class(from) != "dgeMatrix")	if (class(from) != "dgeMatrix") # don't lose symmetry/triangularity/...
24	from <- .Call(dup_mMatrix_as_dgeMatrix, from)	as_Csparse(from)
25	.Call(dense_to_Csparse, from)	else .Call(dense_to_Csparse, from)
26	})	})
27
28	## special case	## special case
#	Line 32	Line 30
30	function(from) .Call(dense_to_Csparse, from))	function(from) .Call(dense_to_Csparse, from))
31
32	setAs("matrix", "CsparseMatrix",	setAs("matrix", "CsparseMatrix",
33	function(from)	function(from) .Call(dense_to_Csparse, from))
34	.Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from)))	##       function(from) {
35		##          if(is.numeric(from))
36		##              .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from))
37		##          else if(is.logical(from)) ## FIXME: this works, but maybe wastefully
38		##                 as(Matrix(from, sparse=TRUE), "CsparseMatrix")
39		##          else stop('not-yet-implemented coercion to "CsparseMatrix"')
40		##       })
41
42
43	## special case needed in the Matrix function	## special case needed in the Matrix function
44	setAs("matrix", "dgCMatrix",	setAs("matrix", "dgCMatrix",
#	Line 56	Line 61
61	## dgeMatrix. Methods for special forms override these.	## dgeMatrix. Methods for special forms override these.
62
63	setMethod("norm", signature(x = "ddenseMatrix", type = "missing"),	setMethod("norm", signature(x = "ddenseMatrix", type = "missing"),
64	function(x, type, ...) callGeneric(as(x, "dgeMatrix")))	function(x, type, ...) norm(as(x, "dgeMatrix")))
65
66	setMethod("norm", signature(x = "ddenseMatrix", type = "character"),	setMethod("norm", signature(x = "ddenseMatrix", type = "character"),
67	function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))	function(x, type, ...) norm(as(x, "dgeMatrix"), type))
68
69	setMethod("rcond", signature(x = "ddenseMatrix", type = "missing"),	setMethod("rcond", signature(x = "ddenseMatrix", norm = "missing"),
70	function(x, type, ...) callGeneric(as(x, "dgeMatrix")))	function(x, norm, ...) rcond(as(x, "dgeMatrix"), ...))
71
72	setMethod("rcond", signature(x = "ddenseMatrix", type = "character"),	setMethod("rcond", signature(x = "ddenseMatrix", norm = "character"),
73	function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))	function(x, norm, ...) rcond(as(x, "dgeMatrix"), norm, ...))
74
75	## Not really useful; now require *identical* class for result:	## Not really useful; now require *identical* class for result:
76	## setMethod("t", signature(x = "ddenseMatrix"),	## setMethod("t", signature(x = "ddenseMatrix"),
77	##        function(x) callGeneric(as(x, "dgeMatrix")))	##        function(x) callGeneric(as(x, "dgeMatrix")))
78
	setMethod("tcrossprod", signature(x = "ddenseMatrix", y = "missing"),
	function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))
	setMethod("crossprod", signature(x = "ddenseMatrix", y = "missing"),
	function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))
79	setMethod("diag", signature(x = "ddenseMatrix"),	setMethod("diag", signature(x = "ddenseMatrix"),
80	function(x = 1, nrow, ncol = n) callGeneric(as(x, "dgeMatrix")))	function(x, nrow, ncol) diag(as(x, "dgeMatrix")))
81
82		setMethod("solve", signature(a = "ddenseMatrix", b = "missing"),
83		function(a, b, ...) solve(as(a, "dgeMatrix")))
84
85	## These methods cause an infinite loop in pre-2.4.0	for(.b in c("Matrix","ANY")) ## << against ambiguity notes
86	## setMethod("solve", signature(a = "ddenseMatrix", b = "missing"),	setMethod("solve", signature(a = "ddenseMatrix", b = .b),
87	##           function(a, b, ...) callGeneric(as(a, "dgeMatrix")))	function(a, b, ...) solve(as(a, "dgeMatrix"), b))
88		for(.b in c("matrix","numeric")) ## << against ambiguity notes
89	## setMethod("solve", signature(a = "ddenseMatrix", b = "ANY"),	setMethod("solve", signature(a = "ddenseMatrix", b = .b),
90	##           function(a, b, ...) callGeneric(as(a, "dgeMatrix"), b))	function(a, b, ...) solve(as(a, "dgeMatrix"), Matrix(b)))
	## General method for dense matrix multiplication in case specific methods
	## have not been defined.
	setMethod("%*%", signature(x = "ddenseMatrix", y = "ddenseMatrix"),
	function(x, y) .Call(dgeMatrix_matrix_mm,
	.Call(dup_mMatrix_as_dgeMatrix, x), y, FALSE),
	valueClass = "dgeMatrix")
91
92	setMethod("lu", signature(x = "ddenseMatrix"),	setMethod("lu", signature(x = "ddenseMatrix"),
93	function(x, ...) callGeneric(as(x, "dgeMatrix")))	function(x, ...) lu(as(x, "dgeMatrix"), ...))
94
95		setMethod("chol", signature(x = "ddenseMatrix"), cholMat)
96
97	setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "missing"),	setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "missing"),
98	function(x, logarithm, ...) callGeneric(as(x, "dgeMatrix")))	function(x, logarithm, ...) determinant(as(x, "dgeMatrix")))
99
100	setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "logical"),	setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "logical"),
101	function(x, logarithm, ...)	function(x, logarithm, ...)
102	callGeneric(as(x, "dgeMatrix"), logarithm))	determinant(as(x, "dgeMatrix"), logarithm))
103
104	## now done for "dMatrix":	## now done for "dMatrix":
105	## setMethod("expm", signature(x = "ddenseMatrix"),	## setMethod("expm", signature(x = "ddenseMatrix"),
106	##           function(x) callGeneric(as(x, "dgeMatrix")))	##           function(x) callGeneric(as(x, "dgeMatrix")))
107
	setMethod("Schur", signature(x = "ddenseMatrix", vectors = "missing"),
	function(x, vectors, ...) callGeneric(as(x, "dgeMatrix")))
	setMethod("Schur", signature(x = "ddenseMatrix", vectors = "logical"),
	function(x, vectors, ...) callGeneric(as(x, "dgeMatrix"), vectors))
	## Cheap version: work via "dgeMatrix" and use the group methods there:
	## FIXME(?): try to preserve "symmetric", "triangular", ...
	setMethod("Arith", ##  "+", "-", "*", "^", "%%", "%/%", "/"
	signature(e1 = "ddenseMatrix", e2 = "ddenseMatrix"),
	function(e1, e2) callGeneric(as(e1, "dgeMatrix"),
	as(e2, "dgeMatrix")))
	setMethod("Arith",
	signature(e1 = "ddenseMatrix", e2 = "numeric"),
	function(e1, e2) callGeneric(as(e1, "dgeMatrix"), e2))
	setMethod("Arith",
	signature(e1 = "numeric", e2 = "ddenseMatrix"),
	function(e1, e2) callGeneric(e1, as(e2, "dgeMatrix")))
108	setMethod("Math",	setMethod("Math",
109	signature(x = "ddenseMatrix"),	signature(x = "ddenseMatrix"),
110	function(x) callGeneric(as(x, "dgeMatrix")))	function(x) callGeneric(as(x, "dgeMatrix")))
111
112
113
114	### for R 2.2.x (and later): -- -- -- -- -- -- -- -- -- -- -- -- -- -- --	.trilDense <- function(x, k = 0, ...) {
115		k <- as.integer(k[1])
116	### cbind2	d <- dim(x)
117	setMethod("cbind2", signature(x = "ddenseMatrix", y = "numeric"),	stopifnot(-d[1] <= k, k <= d[1]) # had k <= 0
118	function(x, y) {	## returns "lower triangular" if k <= 0 && sqr
119	d <- dim(x); nr <- d[1]; nc <- d[2]	.Call(dense_band, x, -d[1], k)
	y <- rep(y, length.out = nr) # 'silent procrustes'
	## beware of (packed) triangular, symmetric, ...
	x <- as(x, "dgeMatrix")
	x@x <- c(x@x, as.double(y))
	x@Dim[2] <- nc + 1:1
	if(is.character(dn <- x@Dimnames[[2]]))
	x@Dimnames[[2]] <- c(dn, "")
	x
	})
	## the same, (x,y) <-> (y,x):
	setMethod("cbind2", signature(x = "numeric", y = "ddenseMatrix"),
	function(x, y) {
	d <- dim(y); nr <- d[1]; nc <- d[2]
	x <- rep(x, length.out = nr)
	y <- as(y, "dgeMatrix")
	y@x <- c(as.double(x), y@x)
	y@Dim[2] <- nc + 1:1
	if(is.character(dn <- y@Dimnames[[2]]))
	y@Dimnames[[2]] <- c("", dn)
	y
	})
	setMethod("cbind2", signature(x = "ddenseMatrix", y = "matrix"),
	function(x, y) callGeneric(x, as(y, "dgeMatrix")))
	setMethod("cbind2", signature(x = "matrix", y = "ddenseMatrix"),
	function(x, y) callGeneric(as(x, "dgeMatrix"), y))
	setMethod("cbind2", signature(x = "ddenseMatrix", y = "ddenseMatrix"),
	function(x, y) {
	nr <- rowCheck(x,y)
	ncx <- x@Dim[2]
	ncy <- y@Dim[2]
	## beware of (packed) triangular, symmetric, ...
	hasDN <- !is.null(dnx <- dimnames(x)) |
	!is.null(dny <- dimnames(y))
	x <- as(x, "dgeMatrix")
	y <- as(y, "dgeMatrix")
	x@x <- c(x@x, y@x)
	x@Dim[2] <- ncx + ncy
	if(hasDN) {
	## R and S+ are different in which names they take
	## if they differ -- but there's no warning in any case
	rn <- if(!is.null(dnx[[1]])) dnx[[1]] else dny[[1]]
	cx <- dnx[[2]] ; cy <- dny[[2]]
	cn <- if(is.null(cx) && is.null(cy)) NULL
	else c(if(!is.null(cx)) cx else rep.int("", ncx),
	if(!is.null(cy)) cy else rep.int("", ncy))
	x@Dimnames <- list(rn, cn)
120	}	}
	x
	})
	### rbind2 -- analogous to cbind2 --- more to do for @x though:
	setMethod("rbind2", signature(x = "ddenseMatrix", y = "numeric"),
	function(x, y) {
	if(is.character(dn <- x@Dimnames[[1]])) dn <- c(dn, "")
	new("dgeMatrix", Dim = x@Dim + 1:0,
	Dimnames = list(dn, x@Dimnames[[2]]),
	x = c(rbind2(as(x,"matrix"), y)))
	})
	## the same, (x,y) <-> (y,x):
	setMethod("rbind2", signature(x = "numeric", y = "ddenseMatrix"),
	function(x, y) {
	if(is.character(dn <- y@Dimnames[[1]])) dn <- c("", dn)
	new("dgeMatrix", Dim = y@Dim + 1:0,
	Dimnames = list(dn, y@Dimnames[[2]]),
	x = c(rbind2(x, as(y,"matrix"))))
	})
	setMethod("rbind2", signature(x = "ddenseMatrix", y = "matrix"),
	function(x, y) callGeneric(x, as(y, "dgeMatrix")))
	setMethod("rbind2", signature(x = "matrix", y = "ddenseMatrix"),
	function(x, y) callGeneric(as(x, "dgeMatrix"), y))
	setMethod("rbind2", signature(x = "ddenseMatrix", y = "ddenseMatrix"),
	function(x, y) {
	nc <- colCheck(x,y)
	nrx <- x@Dim[1]
	nry <- y@Dim[1]
	dn <-
	if(!is.null(dnx <- dimnames(x)) |
	!is.null(dny <- dimnames(y))) {
	## R and S+ are different in which names they take
	## if they differ -- but there's no warning in any case
	list(if(is.null(rx <- dnx[[1]]) && is.null(ry <- dny[[1]]))
	NULL else
	c(if(!is.null(rx)) rx else rep.int("", nrx),
	if(!is.null(ry)) ry else rep.int("", nry)),
	if(!is.null(dnx[[2]])) dnx[[2]] else dny[[2]])
	} else list(NULL, NULL)
	## beware of (packed) triangular, symmetric, ...
	new("dgeMatrix", Dim = c(nrx + nry, nc), Dimnames = dn,
	x = c(rbind2(as(x,"matrix"), as(y,"matrix"))))
	})
	### FIXME: band() et al should be extended from "ddense" to "dense" !
	###        However, needs much work to generalize dup_mMatrix_as_dgeMatrix()
121	## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and	## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and
122	##     for triangular ["dtr" and "dtp"]	##     for triangular ["dtr" and "dtp"]
123	setMethod("tril", "ddenseMatrix",	setMethod("tril", "denseMatrix", .trilDense)
124	function(x, k = 0, ...) {	setMethod("tril",      "matrix", .trilDense)
	k <- as.integer(k[1])
	dd <- dim(x); sqr <- dd[1] == dd[2]
	stopifnot(-dd[1] <= k, k <= dd[1]) # had k <= 0
	## returns "lower triangular" if k <= 0 && sqr
	.Call(ddense_band, x, -dd[1], k)
	})
125
126	setMethod("triu", "ddenseMatrix",	.triuDense <- function(x, k = 0, ...) {
	function(x, k = 0, ...) {
127	k <- as.integer(k[1])	k <- as.integer(k[1])
128	dd <- dim(x); sqr <- dd[1] == dd[2]	d <- dim(x)
129	stopifnot(-dd[1] <= k, k <= dd[1]) # had k >= 0	stopifnot(-d[1] <= k, k <= d[1]) # had k >= 0
130	## returns "upper triangular" if k >= 0	## returns "upper triangular" if k >= 0
131	.Call(ddense_band, x, k, dd[2])	.Call(dense_band, x, k, d[2])
132	})	}
133		setMethod("triu", "denseMatrix", .triuDense)
134		setMethod("triu",      "matrix", .triuDense)
135
136	setMethod("band", "ddenseMatrix",	.bandDense <- function(x, k1, k2, ...) {
	function(x, k1, k2, ...) {
137	k1 <- as.integer(k1[1])	k1 <- as.integer(k1[1])
138	k2 <- as.integer(k2[1])	k2 <- as.integer(k2[1])
139	dd <- dim(x); sqr <- dd[1] == dd[2]	dd <- dim(x)
140	stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[1])	sqr <- dd[1] == dd[2]
141	r <- .Call(ddense_band, x, k1, k2)	stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[2])
142	if (k1 < 0  &&  k1 == -k2  && isSymmetric(x)) ## symmetric	r <- .Call(dense_band, x, k1, k2)
143	as(r, paste(.M.kind(x), "syMatrix", sep=''))	if (sqr &&  k1 < 0 &&  k1 == -k2  && isSymmetric(x)) ## symmetric
144		forceSymmetric(r)
145	else	else
146	r	r
147	})	}
148		setMethod("band", "denseMatrix", .bandDense)
149		setMethod("band",      "matrix", .bandDense)
150
151
152		setMethod("symmpart", signature(x = "ddenseMatrix"),
153		function(x) .Call(ddense_symmpart, x))
154		setMethod("skewpart", signature(x = "ddenseMatrix"),
155		function(x) .Call(ddense_skewpart, x))
156

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.1575   changed lines   Added in v.2551

---

root@r-forge.r-project.org	ViewVC Help
Powered by ViewVC 1.0.0