Diff of /pkg/R/diagMatrix.R

Parent Directory | Revision Log | Patch

	revision 1654, Fri Oct 27 16:58:15 2006 UTC	revision 1655, Mon Oct 30 17:16:27 2006 UTC
#	Line 86	Line 86
86	setAs("diagonalMatrix", "generalMatrix", # prefer sparse:	setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
87	function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))	function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
88
89		.diag.x <- function(m) {
90		if(m@diag == "U")
91		rep.int(if(is.numeric(m@x)) 1. else TRUE,
92		m@Dim[1])
93		else m@x
94		}
95
96		.diag.2N <- function(m) {
97		if(m@diag == "U") m@diag <- "N"
98		m
99		}
100
101	## given the above, the following  4  coercions should be all unneeded;	## given the above, the following  4  coercions should be all unneeded;
102	## we prefer triangular to general:	## we prefer triangular to general:
103	setAs("ddiMatrix", "dgTMatrix",	setAs("ddiMatrix", "dgTMatrix",
#	Line 93	Line 105
105	.Deprecated("as(, \"sparseMatrix\")")	.Deprecated("as(, \"sparseMatrix\")")
106	n <- from@Dim[1]	n <- from@Dim[1]
107	i <- seq_len(n) - 1:1	i <- seq_len(n) - 1:1
108	new("dgTMatrix", i = i, j = i,	new("dgTMatrix", i = i, j = i, x = .diag.x(from),
	x = if(from@diag == "U") rep(1,n) else from@x,
109	Dim = c(n,n), Dimnames = from@Dimnames) })	Dim = c(n,n), Dimnames = from@Dimnames) })
110
111	setAs("ddiMatrix", "dgCMatrix",	setAs("ddiMatrix", "dgCMatrix",
112	function(from) as(as(from, "dgTMatrix"), "dgCMatrix"))	function(from) as(as(from, "sparseMatrix"), "dgCMatrix"))
113
114	setAs("ldiMatrix", "lgTMatrix",	setAs("ldiMatrix", "lgTMatrix",
115	function(from) {	function(from) {
#	Line 305	Line 316
316
317	### ---------------- diagonal  o  sparse  -----------------------------	### ---------------- diagonal  o  sparse  -----------------------------
318
319
320		## Use function for several signatures, in order to evade
321		## ambiguous dispatch for "ddi", since there's also Arith(ddense., ddense.)
322		diagOdiag <- function(e1,e2) { # result should also be diagonal
323		r <- callGeneric(.diag.x(e1), .diag.x(e2)) # error if not "compatible"
324		if(is.numeric(r)) {
325		if(is.numeric(e2@x)) {
326		e2@x <- r; return(.diag.2N(e2)) }
327		if(!is.numeric(e1@x))
328		## e.g. e1, e2 are logical;
329		e1 <- as(e1, "dMatrix")
330		}
331		else if(is.logical(r))
332		e1 <- as(e1, "lMatrix")
333		else stop("intermediate 'r' is of type", typeof(r))
334		e1@x <- r
335		.diag.2N(e1)
336		}
337
338		setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "diagonalMatrix"),
339		diagOdiag)
340		## These two are just for method disambiguation:
341		setMethod("Ops", signature(e1 = "ddiMatrix", e2 = "diagonalMatrix"),
342		diagOdiag)
343		setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),
344		diagOdiag)
345
346		## For almost everything else, diag* shall be treated "as sparse" :
347	## These are cheap implementations via coercion	## These are cheap implementations via coercion
348
349		## for disambiguation
350	setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),	setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
351	function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))	function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))
352	setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),	setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
353	function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))	function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))
354		## in general:
355		setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),
356		function(e1,e2) callGeneric(as(e1,"sparseMatrix"), e2))
357		setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),
358		function(e1,e2) callGeneric(e1, as(e2,"sparseMatrix")))
359
360
361
362	## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()	## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
363

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.1654   changed lines   Added in v.1655

---

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