# SCM Repository

[matrix] Diff of /pkg/Matrix/R/diagMatrix.R
 [matrix] / pkg / Matrix / R / diagMatrix.R

# Diff of /pkg/Matrix/R/diagMatrix.R

revision 2820, Mon Aug 20 14:06:23 2012 UTC revision 2840, Fri Oct 5 22:18:37 2012 UTC
# Line 36  Line 36
36      }      }
37  }  }
38
39  .sparseDiagonal <- function(n, x = rep.int(1,m), uplo = "U",  .sparseDiagonal <- function(n, x = 1, uplo = "U",
40                              shape = if(missing(cols)) "t" else "g",                              shape = if(missing(cols)) "t" else "g",
41                              kind, cols = if(n) 0:(n - 1L) else integer(0))                              unitri, kind,
42                                cols = if(n) 0:(n - 1L) else integer(0))
43  {  {
44      stopifnot(n == (n. <- as.integer(n)), (n <- n.) >= 0)      stopifnot(n == (n. <- as.integer(n)), (n <- n.) >= 0)
45      if(!missing(cols))      if(!(mcols <- missing(cols)))
46          stopifnot(0 <= (cols <- as.integer(cols)), cols < n)          stopifnot(0 <= (cols <- as.integer(cols)), cols < n)
47      m <- length(cols)      m <- length(cols)
48      if(missing(kind))      if(missing(kind))
# Line 53  Line 54
54                  "d"                  "d"
55              }              }
56      else stopifnot(any(kind == c("d","l","n")))      else stopifnot(any(kind == c("d","l","n")))
if(kind != "n") {
if((lx <- length(x)) == 1) x <- rep.int(x, m)
else if(lx != m) stop("length(x) must be either 1 or #{cols}")
}
57      stopifnot(is.character(shape), nchar(shape) == 1,      stopifnot(is.character(shape), nchar(shape) == 1,
58                any(shape == c("t","s","g"))) # triangular / symmetric / general                any(shape == c("t","s","g"))) # triangular / symmetric / general
59      if(kind == "n") {      if((missing(unitri) || unitri) && shape == "t" &&
60           (mcols || cols == 0:(n-1L)) &&
61           ((any(kind == c("l", "n")) && allTrue(x)) ||
62            (    kind == "d"          && allTrue(x == 1)))) { ## uni-triangular
63            new(paste0(kind,"tCMatrix"), Dim = c(n,n),
64                       uplo = uplo, diag = "U", p = rep.int(0L, n+1L))
65        }
66        else if(kind == "n") {
67          if(shape == "g")          if(shape == "g")
68              new("ngCMatrix", Dim = c(n,m), i = cols, p = 0:m)              new("ngCMatrix", Dim = c(n,m), i = cols, p = 0:m)
69          else new(paste0("n", shape, "CMatrix"), Dim = c(n,m), uplo = uplo,          else new(paste0("n", shape, "CMatrix"), Dim = c(n,m), uplo = uplo,
70                   i = cols, p = 0:m)                   i = cols, p = 0:m)
71      }      }
72      ## kind != "n" -- have x slot :      else { ## kind != "n" -- have x slot :
73      else if(shape == "g")          if((lx <- length(x)) == 1) x <- rep.int(x, m)
74            else if(lx != m) stop("length(x) must be either 1 or #{cols}")
75            if(shape == "g")
76          new(paste0(kind, "gCMatrix"), Dim = c(n,m),          new(paste0(kind, "gCMatrix"), Dim = c(n,m),
77              x = x, i = cols, p = 0:m)              x = x, i = cols, p = 0:m)
78      else new(paste0(kind, shape, "CMatrix"), Dim = c(n,m), uplo = uplo,      else new(paste0(kind, shape, "CMatrix"), Dim = c(n,m), uplo = uplo,
79               x = x, i = cols, p = 0:m)               x = x, i = cols, p = 0:m)
80  }  }
81    }
82
83  ## Pkg 'spdep' had (relatively slow) versions of this as_dsCMatrix_I()  ## Pkg 'spdep' had (relatively slow) versions of this as_dsCMatrix_I()
84  .symDiagonal <- function(n, x = rep.int(1,n), uplo = "U")  .symDiagonal <- function(n, x = rep.int(1,n), uplo = "U")
85      .sparseDiagonal(n, x, uplo, shape = "s")      .sparseDiagonal(n, x, uplo, shape = "s")
86
87  # instead of   diagU2N(as(Diagonal(n), "CsparseMatrix")), diag = "N" in any case:  # instead of   diagU2N(as(Diagonal(n), "CsparseMatrix")), diag = "N" in any case:
88  .trDiagonal <- function(n, x = rep.int(1,n), uplo = "U")  .trDiagonal <- function(n, x = 1, uplo = "U", unitri=TRUE)
89      .sparseDiagonal(n, x, uplo, shape = "t")      .sparseDiagonal(n, x, uplo, shape = "t", unitri=unitri)
90
91
92  ## This is modified from a post of Bert Gunter to R-help on  1 Sep 2005.  ## This is modified from a post of Bert Gunter to R-help on  1 Sep 2005.

Legend:
 Removed from v.2820 changed lines Added in v.2840