# SCM Repository

[matrix] Diff of /pkg/R/Auxiliaries.R
 [matrix] / pkg / R / Auxiliaries.R

# Diff of /pkg/R/Auxiliaries.R

revision 1547, Mon Sep 11 14:49:39 2006 UTC revision 1548, Mon Sep 11 22:13:07 2006 UTC
# Line 152  Line 152
152      invisible(x)# as print() S3 methods do      invisible(x)# as print() S3 methods do
153  }  }
154
155    ### FIXME? -- make this into a generic function (?)
156    nnzero <- function(x) {
157        cl <- class(x)
158        if(!extends(cl, "Matrix"))
159            sum(x != 0)
160        else if(extends(cl, "sparseMatrix"))
161            ## NOTA BENE: The number of *structural* non-zeros {could have other '0'}!
162           switch(.sp.class(cl),
163                   "CsparseMatrix" = length(x@i),
164                   "TsparseMatrix" = length(x@i),
165                   "RsparseMatrix" = length(x@j))
166        else ## denseMatrix
167            sum(as_geClass(x)@x != 0)
168    }
169
170  ## For sparseness handling  ## For sparseness handling
171  ## return a 2-column (i,j) matrix of  ## return a 2-column (i,j) matrix of
172  ## 0-based indices of non-zero entries  :  ## 0-based indices of non-zero entries  :
# Line 238  Line 253
253             "lgTMatrix" = as(as(x, "lgCMatrix"), "lgTMatrix"),             "lgTMatrix" = as(as(x, "lgCMatrix"), "lgTMatrix"),
254             "lsTMatrix" = as(as(x, "lsCMatrix"), "lsTMatrix"),             "lsTMatrix" = as(as(x, "lsCMatrix"), "lsTMatrix"),
255             "ltTMatrix" = as(as(x, "ltCMatrix"), "ltTMatrix"),             "ltTMatrix" = as(as(x, "ltCMatrix"), "ltTMatrix"),
256               ## do we need this for "logical" ones, there's no sum() there!
257               "ngTMatrix" = as(as(x, "ngCMatrix"), "ngTMatrix"),
258               "nsTMatrix" = as(as(x, "nsCMatrix"), "nsTMatrix"),
259               "ntTMatrix" = as(as(x, "ntCMatrix"), "ntTMatrix"),
260             ## otherwise:             ## otherwise:
261             stop("not yet implemented for class ", class.x))             stop("not yet implemented for class ", class.x))
262  }  }
# Line 317  Line 336
336      ## FIXME: treat 'factors' smartly {not for triangular!}      ## FIXME: treat 'factors' smartly {not for triangular!}
337  }  }
338
339    ## -> ./ndenseMatrix.R :
340    n2d_Matrix <- function(from) {
341        stopifnot(is(from, "nMatrix"))
342        fixupDense(new(sub("^n", "d", class(from)),
343                       x = as.double(from@x),
344                       Dim = from@Dim, Dimnames = from@Dimnames),
345                   from)
346        ## FIXME: treat 'factors' smartly {not for triangular!}
347    }
348    n2l_spMatrix <- function(from) {
349        stopifnot(is(from, "nMatrix"))
350        new(sub("^n", "l", class(from)),
351            ##x = as.double(from@x),
352            Dim = from@Dim, Dimnames = from@Dimnames)
353    }
354
355  if(FALSE)# unused  if(FALSE)# unused
356  l2d_meth <- function(x) {  l2d_meth <- function(x) {
357      cl <- class(x)      cl <- class(x)
358      as(callGeneric(as(x, sub("^l", "d", cl))), cl)      as(callGeneric(as(x, sub("^l", "d", cl))), cl)
359  }  }
360
361  ## return "d" or "l" or "z"  ## return "d" or "l" or "n" or "z"
362  .M.kind <- function(x, clx = class(x)) {  .M.kind <- function(x, clx = class(x)) {
363      if(is.matrix(x)) { ## 'old style matrix'      if(is.matrix(x)) { ## 'old style matrix'
364          if     (is.numeric(x)) "d"          if     (is.numeric(x)) "d"
365          else if(is.logical(x)) "l"          else if(is.logical(x)) "l" ## FIXME ? "n" if no NA ??
366          else if(is.complex(x)) "z"          else if(is.complex(x)) "z"
367          else stop("not yet implemented for matrix w/ typeof ", typeof(x))          else stop("not yet implemented for matrix w/ typeof ", typeof(x))
368      }      }
369      else if(extends(clx, "dMatrix")) "d"      else if(extends(clx, "dMatrix")) "d"
370        else if(extends(clx, "nMatrix")) "n"
371      else if(extends(clx, "lMatrix")) "l"      else if(extends(clx, "lMatrix")) "l"
372      else if(extends(clx, "zMatrix")) "z"      else if(extends(clx, "zMatrix")) "z"
373        else if(extends(clx, "pMatrix")) "n" # permutation -> pattern
374      else stop(" not yet be implemented for ", clx)      else stop(" not yet be implemented for ", clx)
375  }  }
376
# Line 362  Line 399
399  geClass <- function(x) {  geClass <- function(x) {
400      if     (is(x, "dMatrix")) "dgeMatrix"      if     (is(x, "dMatrix")) "dgeMatrix"
401      else if(is(x, "lMatrix")) "lgeMatrix"      else if(is(x, "lMatrix")) "lgeMatrix"
402        else if(is(x, "nMatrix")) "ngeMatrix"
403      else if(is(x, "zMatrix")) "zgeMatrix"      else if(is(x, "zMatrix")) "zgeMatrix"
404      else stop("general Matrix class not yet implemented for ",      else stop("general Matrix class not yet implemented for ",
405                class(x))                class(x))
# Line 382  Line 420
420      as(x, paste(.M.kind(x), .dense.prefixes[.M.shape(x)], "Matrix", sep=''))      as(x, paste(.M.kind(x), .dense.prefixes[.M.shape(x)], "Matrix", sep=''))
421  }  }
422
423    .sp.class <- function(x) { ## find and return the "sparseness class"
424        if(!is.character(x)) x <- class(x)
425        for(cl in paste(c("C","T","R"), "sparseMatrix", sep=''))
426            if(extends(x, cl))
427                return(cl)
428        ## else (should rarely happen)
429        as.character(NA)
430    }
431
432  as_Csparse <- function(x) {  as_Csparse <- function(x) {
433      as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "CMatrix", sep=''))      as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "CMatrix", sep=''))
434  }  }

Legend:
 Removed from v.1547 changed lines Added in v.1548