The R Project SVN R-packages

setAs("CHMfactor", "sparseMatrix",
      function(from) .Call(CHMfactor_to_sparse, from))

setAs("CHMfactor", "Matrix", function(from) as(from, "sparseMatrix"))

setMethod("image", "CHMfactor",
          function(x, ...) {
              x <- as(as(x, "sparseMatrix"), "dgTMatrix")
              callGeneric()
          })

.CHM_solve <-
    function(a, b,
         system = c("A", "LDLt", "LD", "DLt", "L", "Lt", "D", "P", "Pt"),
         ...)
{
    if(length(list(...)))
    warning("arguments in", deparse(list(...)), "are disregarded")
    sysDef <- eval(formals()$system)
    .Call(CHMfactor_solve, a, b,
      match(match.arg(system, sysDef), sysDef, nomatch = 0))
}

setMethod("solve", signature(a = "CHMfactor", b = "ddenseMatrix"),
      .CHM_solve, valueClass = "dgeMatrix")

setMethod("solve", signature(a = "CHMfactor", b = "matrix"),
      .CHM_solve, valueClass = "dgeMatrix")

setMethod("solve", signature(a = "CHMfactor", b = "numeric"),
      function(a, b, ...)
      .CHM_solve(a, matrix(if(is.double(b)) b else as.double(b),
                   length(b), 1L), ...),
      valueClass = "dgeMatrix")

setMethod("solve", signature(a = "CHMfactor", b = "dsparseMatrix"),
      function(a, b,
           system = c("A", "LDLt", "LD", "DLt", "L", "Lt", "D", "P", "Pt"),
           ...) {
          if(length(list(...)))
          warning("arguments in", deparse(list(...)), "are disregarded")
          sysDef <- eval(formals()$system)
          .Call(CHMfactor_spsolve, a, as(b, "dgCMatrix"),
            match(match.arg(system, sysDef), sysDef, nomatch = 0))
      }, valueClass = "dgCMatrix")

## Catch-all the rest : make sure 'system' is not lost
setMethod("solve", signature(a = "CHMfactor", b = "ANY"),
      function(a, b, system = c("A", "LDLt", "LD", "DLt", "L", "Lt", "D", "P", "Pt"),
           ...)
          solve(a, as(b, "dMatrix"), system, ...))

setMethod("determinant", signature(x = "CHMfactor", logarithm = "missing"),
          function(x, logarithm, ...) determinant(x, TRUE))

setMethod("determinant", signature(x = "CHMfactor", logarithm = "logical"),
          function(x, logarithm, ...)
      {
          ldet <- .Call(CHMfactor_ldetL2, x)
          modulus <- if (logarithm) ldet else exp(ldet)
          attr(modulus, "logarithm") <- logarithm
          val <- list(modulus = modulus, sign = as.integer(1))
          class(val) <- "det"
          val
      })

setMethod("update", signature(object = "CHMfactor"),
          function(object, parent, mult = 0, ...)
      {
          stopifnot(is(parent, "sparseMatrix"))
          .Call(CHMfactor_update, object, parent, mult)
      })

## Currently hidden:
ldetL2up <- function(x, parent, Imult)
{
    ## Purpose: compute  log Det |A + m*I|  for many values of m
    ## ----------------------------------------------------------------------
    ## Arguments: x: CHMfactor to be updated
    ##      parent : CsparseMatrix M; for symmetric M, A = M, otherwise A = MM'
    ##       Imult : a numeric *vector* of 'm's (= I multipliers)
    ## ----------------------------------------------------------------------
    ## Author: Doug Bates, Date: 19 Mar 2008

    stopifnot(is(x, "CHMfactor"),
              is(parent, "CsparseMatrix"),
              nrow(x) == nrow(parent))
    .Call(CHMfactor_ldetL2up, x, parent, as.double(Imult))
}