SCM

SCM Repository

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

Diff of /pkg/R/Auxiliaries.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge