Nothing
## METHODS FOR GENERIC: anyNA
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("anyNA", signature(x = "diagonalMatrix"),
function(x) anyNA(x@x))
setMethod("anyNA", signature(x = "indMatrix"),
function(x) FALSE)
setMethod("anyNA", signature(x = "nMatrix"),
function(x) FALSE)
for(.kind in c("d", "l")) {
setMethod("anyNA", signature(x = paste0(.kind, "sparseMatrix")),
function(x) anyNA(x@x))
setMethod("anyNA", signature(x = paste0(.kind, "denseMatrix")),
function(x) {
if(!.hasSlot(x, "uplo"))
return(anyNA(x@x))
packed <- .isPacked(x)
nonunit <- !.hasSlot(x, "diag") || x@diag == "N"
if(packed && nonunit)
return(anyNA(x@x))
k <- indTri(n = x@Dim[1L], upper = x@uplo == "U",
diag = nonunit, packed = packed)
anyNA(x@x[k])
})
}
rm(.kind)
setMethod("anyNA", signature(x = "nsparseVector"),
function(x) FALSE)
setMethod("anyNA", signature(x = "sparseVector"),
function(x) anyNA(x@x))
## METHODS FOR GENERIC: is.na
## [[ one more in ./abIndex.R ]]
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Returning an all-FALSE matrix preserving the structure of 'x',
## which can be any R object inheriting from Matrix
allFalseMatrix <- function(x) {
r <- new(if(.hasSlot(x, "diag")) # triangularMatrix, diagonalMatrix
"ntCMatrix"
else if(.hasSlot(x, "uplo")) # symmetricMatrix
"nsCMatrix"
else "ngCMatrix") # generalMatrix
r@Dim <- d <- x@Dim
r@Dimnames <- x@Dimnames
r@p <- integer(d[2L] + 1)
r
}
setMethod("is.na", signature(x = "diagonalMatrix"),
function(x) {
r <- new("ldiMatrix")
r@Dim <- d <- x@Dim
r@Dimnames <- x@Dimnames
r@x <- if(x@diag == "N") is.na(x@x) else logical(d[1L])
r
})
setMethod("is.na", signature(x = "indMatrix"),
allFalseMatrix)
setMethod("is.na", signature(x = "nMatrix"),
allFalseMatrix)
setMethod("is.na", signature(x = "dsparseMatrix"),
function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
r <- .sparse2kind(diagU2N(x), "l", drop0 = FALSE)
r@x <- is.na(r@x)
.sparse2kind(r, "n", drop0 = TRUE)
} else allFalseMatrix(x)
})
setMethod("is.na", signature(x = "lsparseMatrix"),
function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
r <- diagU2N(x)
r@x <- is.na(r@x)
.sparse2kind(r, "n", drop0 = TRUE)
} else allFalseMatrix(x)
})
.is.na.ge <- function(x) {
if(anyNA(x@x)) # don't allocate in FALSE case
new("ngeMatrix", Dim = x@Dim, Dimnames = x@Dimnames, x = is.na(x@x))
else allFalseMatrix(x)
}
.is.na.tr <- function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
d <- x@Dim
i <- is.na(x@x)
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = x@diag != "N", packed = FALSE)
i[k] <- FALSE
if(any(i))
new("ntrMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.na.tp <- function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
d <- x@Dim
i <- is.na(x@x)
if(x@diag != "N") {
k <- indDiag(n = d[1L], upper = x@uplo == "U",
packed = TRUE)
i[k] <- FALSE
}
if(any(i))
new("ntpMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.na.sy <- function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
d <- x@Dim
i <- is.na(x@x)
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = FALSE, packed = FALSE)
i[k] <- FALSE
if(any(i))
new("nsyMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.na.sp <- function(x) {
if(anyNA(x@x)) # don't allocate in FALSE case
new("nspMatrix", Dim = x@Dim, Dimnames = x@Dimnames,
x = is.na(x@x), uplo = x@uplo)
else allFalseMatrix(x)
}
for(.kind in c("d", "l"))
for(.xx in c("ge", "tr", "tp", "sy", "sp"))
setMethod("is.na", signature(x = paste0(.kind, .xx, "Matrix")),
get(paste0(".is.na.", .xx),
mode = "function", inherits = FALSE))
rm(.is.na.ge, .is.na.tr, .is.na.tp,
.is.na.sy, .is.na.sp,
.kind, .xx)
setMethod("is.na", signature(x = "sparseVector"),
function(x) new("nsparseVector", length = x@length,
i = x@i[is.na(x@x)]))
setMethod("is.na", signature(x = "nsparseVector"),
function(x) new("nsparseVector", length = x@length))
## METHODS FOR GENERIC: is.finite
## [[ one more in ./abIndex.R ]]
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
allTrueMatrix <- function(x, symmetric = NA, packed = TRUE) {
if(is.na(symmetric))
## TRUE for symmetricMatrix, diagonalMatrix
## FALSE for triangularMatrix, generalMatrix
symmetric <- if(.hasSlot(x, "uplo"))
!.hasSlot(x, "diag")
else .hasSlot(x, "diag")
r <- new(if(!symmetric)
"ngeMatrix"
else if(packed)
"nspMatrix"
else "nsyMatrix")
r@Dim <- d <- x@Dim
r@Dimnames <- x@Dimnames
r@x <- rep.int(TRUE, if(symmetric && packed) {
n <- d[1L]
0.5 * n * (n + 1)
} else prod(d))
if(symmetric && .hasSlot(x, "uplo"))
r@uplo <- x@uplo
r
}
..allTrueMatrix <- function(x) allTrueMatrix(x)
setMethod("is.finite", signature(x = "diagonalMatrix"),
function(x) {
r <- allTrueMatrix(x, symmetric = TRUE, packed = TRUE)
if(x@diag == "N") {
k <- indDiag(n = x@Dim[1L], upper = r@uplo == "U",
packed = TRUE)
r@x[k] <- is.finite(x@x)
}
r
})
setMethod("is.finite", signature(x = "indMatrix"),
..allTrueMatrix)
setMethod("is.finite", signature(x = "nMatrix"),
..allTrueMatrix)
setMethod("is.finite", signature(x = "dsparseMatrix"),
function(x) {
if(!all(is.finite(x@x))) {
## FIXME: use packed=TRUE once [<- is fast for packedMatrix
r <- allTrueMatrix(x, symmetric = NA, packed = FALSE)
if(.hasSlot(x, "p"))
x <- .CR2T(x)
n <- x@Dim[1L]
w <- which(!is.finite(x@x))
r@x[as.double(n) * x@j[w] + x@i[w] + 1] <- FALSE
r
} else allTrueMatrix(x, symmetric = NA, packed = TRUE)
})
setMethod("is.finite", signature(x = "lsparseMatrix"),
function(x) {
if(anyNA(x@x)) { # don't allocate in FALSE case
## FIXME: use packed=TRUE once [<- is fast for packedMatrix
r <- allTrueMatrix(x, symmetric = NA, packed = FALSE)
if(.hasSlot(x, "p"))
x <- .CR2T(x)
n <- x@Dim[1L]
w <- which(is.na(x@x))
r@x[as.double(n) * x@j[w] + x@i[w] + 1] <- FALSE
r
} else allTrueMatrix(x, symmetric = NA, packed = TRUE)
})
.is.finite.ge <- function(x)
new("ngeMatrix", Dim = x@Dim, Dimnames = x@Dimnames, x = is.finite(x@x))
.is.finite.tr <- function(x) {
d <- x@Dim
i <- is.finite(x@x)
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = x@diag != "N", packed = FALSE)
i[k] <- TRUE
new("ngeMatrix", Dim = d, Dimnames = x@Dimnames, x = i)
}
.is.finite.tp <- function(x) {
d <- x@Dim
i <- rep.int(TRUE, prod(d))
k <- indTri(n = d[1L], upper = x@uplo == "U",
diag = TRUE, packed = FALSE)
i[k] <- is.finite(x@x)
if(x@diag != "N") {
k <- indDiag(n = d[1L], packed = FALSE)
i[k] <- TRUE
}
new("ngeMatrix", Dim = d, Dimnames = x@Dimnames, x = i)
}
.is.finite.sy <- function(x)
new("nsyMatrix", Dim = x@Dim, Dimnames = x@Dimnames,
x = is.finite(x@x), uplo = x@uplo)
.is.finite.sp <- function(x)
new("nspMatrix", Dim = x@Dim, Dimnames = x@Dimnames,
x = is.finite(x@x), uplo = x@uplo)
for(.kind in c("d", "l"))
for(.xx in c("ge", "tr", "tp", "sy", "sp"))
setMethod("is.finite", signature(x = paste0(.kind, .xx, "Matrix")),
get(paste0(".is.finite.", .xx),
mode = "function", inherits = FALSE))
rm(.is.finite.ge, .is.finite.tr, .is.finite.tp,
.is.finite.sy, .is.finite.sp, ..allTrueMatrix,
.kind, .xx)
setMethod("is.finite", signature(x = "sparseVector"),
function(x) {
r <- rep.int(TRUE, x@length)
r[x@i[!is.finite(x@x)]] <- FALSE
r
})
setMethod("is.finite", signature(x = "nsparseVector"),
function(x) rep.int(TRUE, x@length))
## METHODS FOR GENERIC: is.infinite
## NB: completely (!) parallel to 'is.infinite'
## [[ one more in ./abIndex.R ]]
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("is.infinite", signature(x = "ddiMatrix"),
function(x) {
r <- new("ldiMatrix")
r@Dim <- d <- x@Dim
r@Dimnames <- x@Dimnames
r@x <- if(x@diag == "N") is.infinite(x@x) else logical(d[1L])
r
})
setMethod("is.infinite", signature(x = "indMatrix"),
allFalseMatrix)
setMethod("is.infinite", signature(x = "nMatrix"),
allFalseMatrix)
setMethod("is.infinite", signature(x = "lMatrix"),
allFalseMatrix)
setMethod("is.infinite", signature(x = "dsparseMatrix"),
function(x) {
if(any(is.infinite(x@x))) {
r <- .sparse2kind(x <- diagU2N(x), "l", drop0 = FALSE)
r@x <- is.infinite(x@x)
.sparse2kind(r, "n", drop0 = TRUE)
} else allFalseMatrix(x)
})
.is.infinite.ge <- function(x) {
if(any(i <- is.infinite(x@x)))
new("ngeMatrix", Dim = x@Dim, Dimnames = x@Dimnames, x = i)
else allFalseMatrix(x)
}
.is.infinite.tr <- function(x) {
if(any(i <- is.infinite(x@x))) {
d <- x@Dim
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = x@diag != "N", packed = FALSE)
i[k] <- FALSE
if(any(i))
new("ntrMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.infinite.tp <- function(x) {
if(any(i <- is.infinite(x@x))) {
d <- x@Dim
if(x@diag != "N") {
k <- indDiag(n = d[1L], upper = x@uplo == "U",
packed = TRUE)
i[k] <- FALSE
}
if(any(i))
new("ntpMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.infinite.sy <- function(x) {
if(any(i <- is.infinite(x@x))) {
d <- x@Dim
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = FALSE, packed = FALSE)
i[k] <- FALSE
if(any(i))
new("nsyMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.infinite.sp <- function(x) {
if(any(i <- is.infinite(x@x)))
new("nspMatrix", Dim = x@Dim, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
}
for(.xx in c("ge", "tr", "tp", "sy", "sp"))
setMethod("is.infinite", signature(x = paste0("d", .xx, "Matrix")),
get(paste0(".is.infinite.", .xx),
mode = "function", inherits = FALSE))
rm(.is.infinite.ge, .is.infinite.tr, .is.infinite.tp,
.is.infinite.sy, .is.infinite.sp,
.xx)
setMethod("is.infinite", signature(x = "sparseVector"),
function(x) new("nsparseVector", length = x@length,
i = x@i[is.infinite(x@x)]))
setMethod("is.infinite", signature(x = "nsparseVector"),
function(x) new("nsparseVector", length = x@length))
## METHODS FOR GENERIC: is.nan
## NB: completely (!) parallel to 'is.infinite'
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("is.nan", signature(x = "ddiMatrix"),
function(x) {
r <- new("ldiMatrix")
r@Dim <- d <- x@Dim
r@Dimnames <- x@Dimnames
r@x <- if(x@diag == "N") is.nan(x@x) else logical(d[1L])
r
})
setMethod("is.nan", signature(x = "indMatrix"),
allFalseMatrix)
setMethod("is.nan", signature(x = "nMatrix"),
allFalseMatrix)
setMethod("is.nan", signature(x = "lMatrix"),
allFalseMatrix)
setMethod("is.nan", signature(x = "dsparseMatrix"),
function(x) {
if(any(is.nan(x@x))) {
r <- .sparse2kind(x <- diagU2N(x), "l", drop0 = FALSE)
r@x <- is.nan(x@x)
.sparse2kind(r, "n", drop0 = TRUE)
} else allFalseMatrix(x)
})
.is.nan.ge <- function(x) {
if(any(i <- is.nan(x@x)))
new("ngeMatrix", Dim = x@Dim, Dimnames = x@Dimnames, x = i)
else allFalseMatrix(x)
}
.is.nan.tr <- function(x) {
if(any(i <- is.nan(x@x))) {
d <- x@Dim
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = x@diag != "N", packed = FALSE)
i[k] <- FALSE
if(any(i))
new("ntrMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.nan.tp <- function(x) {
if(any(i <- is.nan(x@x))) {
d <- x@Dim
if(x@diag != "N") {
k <- indDiag(n = d[1L], upper = x@uplo == "U",
packed = TRUE)
i[k] <- FALSE
}
if(any(i))
new("ntpMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.nan.sy <- function(x) {
if(any(i <- is.nan(x@x))) {
d <- x@Dim
k <- indTri(n = d[1L], upper = x@uplo != "U",
diag = FALSE, packed = FALSE)
i[k] <- FALSE
if(any(i))
new("nsyMatrix", Dim = d, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
} else allFalseMatrix(x)
}
.is.nan.sp <- function(x) {
if(any(i <- is.nan(x@x)))
new("nspMatrix", Dim = x@Dim, Dimnames = x@Dimnames,
x = i, uplo = x@uplo)
else allFalseMatrix(x)
}
for(.xx in c("ge", "tr", "tp", "sy", "sp"))
setMethod("is.nan", signature(x = paste0("d", .xx, "Matrix")),
get(paste0(".is.nan.", .xx),
mode = "function", inherits = FALSE))
rm(.is.nan.ge, .is.nan.tr, .is.nan.tp,
.is.nan.sy, .is.nan.sp,
.xx)
setMethod("is.nan", signature(x = "sparseVector"),
function(x) new("nsparseVector", length = x@length,
i = x@i[is.nan(x@x)]))
setMethod("is.nan", signature(x = "nsparseVector"),
function(x) new("nsparseVector", length = x@length))
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.