--- pkg/Matrix/R/diagMatrix.R 2012/10/05 22:18:37 2840 +++ pkg/Matrix/R/diagMatrix.R 2013/09/10 19:43:53 2904 @@ -6,11 +6,9 @@ Diagonal <- function(n, x = NULL) { ## Allow Diagonal(4), Diagonal(x=1:5), and Diagonal(4, TRUE) - if(missing(n)) - n <- length(x) - else { + n <- if(missing(n)) length(x) else { stopifnot(length(n) == 1, n == as.integer(n), n >= 0) - n <- as.integer(n) + as.integer(n) } if(missing(x)) ## unit diagonal matrix @@ -122,7 +120,7 @@ ## block-diagonal matrix [a dgTMatrix] from list of matrices stopifnot(is.list(lst), (nl <- length(lst)) >= 1) - Tlst <- lapply(lapply(lst, Matrix:::as_Csp2), # includes "diagU2N" + Tlst <- lapply(lapply(lst, as_Csp2), # includes "diagU2N" as, "TsparseMatrix") if(nl == 1) return(Tlst[[1]]) ## else @@ -224,7 +222,9 @@ "l" =, "n" = TRUE, ## otherwise - stop("'", kind,"' kind not yet implemented")), n)) + stop(gettextf("%s kind not yet implemented", + sQuote(kind)), domain=NA)), + n)) } ## diagonal -> triangular, upper / lower depending on "partner": @@ -316,7 +316,8 @@ setAs("diagonalMatrix", "denseMatrix", function(from) as(as(from, "CsparseMatrix"), "denseMatrix")) -.diag.x <- function(m) if(m@diag == "U") rep.int(as1(m@x), m@Dim[1]) else m@x +..diag.x <- function(m) rep.int(as1(m@x), m@Dim[1]) +.diag.x <- function(m) if(m@diag == "U") rep.int(as1(m@x), m@Dim[1]) else m@x .diag.2N <- function(m) { if(m@diag == "U") m@diag <- "N" @@ -336,7 +337,7 @@ d <- dim(from) if(d[1] != (n <- d[2])) stop("non-square matrix") if(any(from[row(from) != col(from)] != 0)) - stop("matrix with non-zero off-diagonals cannot be coerced to diagonalMatrix") + stop("matrix with non-zero off-diagonals cannot be coerced to \"diagonalMatrix\"") x <- diag(from) if(is.logical(x)) { cl <- "ldiMatrix" @@ -415,7 +416,8 @@ x[i, ] <- value else if(na == 3) x[i] <- value - else stop("Internal bug: nargs()=",na,"; please report") + else stop(gettextf("Internal bug: nargs()=%d; please report", + na), domain=NA) } else x[i,j] <- value if(isDiagonal(x)) as(x, "diagonalMatrix") else x @@ -434,6 +436,27 @@ replDiag(x, i=i, , value=value) }) +setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing", + j = "index", value = "replValue"), + function(x,i,j, ..., value) replDiag(x, j=j, value=value)) + +## x[] <- value : +setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing", + j = "missing", value = "ANY"), + function(x,i,j, ..., value) + { + if(all0(value)) { # be faster + r <- new(paste0(.M.kindC(getClassDef(class(x))),"tTMatrix"))# of all "0" + r@Dim <- x@Dim + r@Dimnames <- x@Dimnames + r + } else { ## typically non-sense: assigning to full sparseMatrix + x[TRUE] <- value + x + } + }) + + setReplaceMethod("[", signature(x = "diagonalMatrix", i = "matrix", # 2-col.matrix j = "missing", value = "replValue"), @@ -462,10 +485,8 @@ } }) -setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing", - j = "index", value = "replValue"), - function(x,i,j, ..., value) replDiag(x, j=j, value=value)) +## value = "sparseMatrix": setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing", j = "index", value = "sparseMatrix"), function (x, i, j, ..., value) @@ -479,6 +500,7 @@ function (x, i, j, ..., value) callGeneric(x=x, i=i, j=j, value = as(value, "sparseVector"))) +## value = "sparseVector": setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing", j = "index", value = "sparseVector"), replDiag) @@ -493,12 +515,9 @@ setMethod("t", signature(x = "diagonalMatrix"), function(x) { x@Dimnames <- x@Dimnames[2:1] ; x }) -setMethod("isDiagonal", signature(object = "diagonalMatrix"), - function(object) TRUE) -setMethod("isTriangular", signature(object = "diagonalMatrix"), - function(object) TRUE) -setMethod("isSymmetric", signature(object = "diagonalMatrix"), - function(object, ...) TRUE) +setMethod("isDiagonal", "diagonalMatrix", function(object) TRUE) +setMethod("isTriangular", "diagonalMatrix", function(object, ...) TRUE) +setMethod("isSymmetric", "diagonalMatrix", function(object, ...) TRUE) setMethod("symmpart", signature(x = "diagonalMatrix"), function(x) x) setMethod("skewpart", signature(x = "diagonalMatrix"), setZero) @@ -759,7 +778,8 @@ } else if(is.logical(r)) e1 <- as(e1, "lMatrix") - else stop("intermediate 'r' is of type", typeof(r)) + else stop(gettextf("intermediate 'r' is of type %s", + typeof(r)), domain=NA) e1@x <- r .diag.2N(e1) } @@ -1150,7 +1170,8 @@ } }) -rm(dense.subCl, diCls)# not used elsewhere +rm(arg1, arg2, other, DI, cl, c1, c2, + dense.subCl, diCls)# not used elsewhere setMethod("summary", signature(object = "diagonalMatrix"), function(object, ...) {