Nothing
validDim <- function(dim)
.Call(R_Dim_validate, dim)
validDimGetsValue <- function(value, mn) {
if(mode(value) != "numeric")
gettextf("assigned dimensions are not of type \"%s\" or \"%s\"",
"integer", "double")
else if(length(value) != 2L)
gettextf("assigned dimensions do not have length %d", 2L)
else if(anyNA(value))
gettext("assigned dimensions are NA")
else if(any(value < 0L))
gettext("assigned dimensions are negative")
else if(is.double(value) && any(trunc(value) > .Machine$integer.max))
gettextf("assigned dimensions exceed %s", "2^31-1")
else if((p <- prod(value)) != mn)
gettextf("assigned dimensions [product %.0f] do not match object length [%.0f]",
p, as.double(mn))
else TRUE
}
validDN <- function(dn, dim)
.Call(R_DimNames_validate, dn, dim)
fixupDN <- function(dn)
.Call(R_DimNames_fixup, dn)
fixupDN.if.valid <- function(dn, dim) {
if(is.character(s <- validDim(dim)) || is.character(s <- validDN(dn, dim)))
stop(s, domain = NA)
fixupDN(dn)
}
symDN <- function(dn)
.Call(R_symDN, dn)
symmetrizeDN <- function(x) {
if(isS4(x)) # assuming is(x, "Matrix")
`dimnames<-`(x, symDN(x@Dimnames))
else if(!is.null(dn <- dimnames(x))) # assuming list of length 2
`dimnames<-`(x, symDN(dn))
else x
}
isSymmetricDN <- function(dn)
.Call(R_DimNames_is_symmetric, dn)
is.null.DN <- function(dn) {
if(is.null(dn))
return(TRUE)
if(!is.null(names(dn)))
names(dn) <- NULL
ch0 <- character(0L)
identical(dn, list(NULL, NULL)) ||
identical(dn, list( ch0, NULL)) ||
identical(dn, list(NULL, ch0)) ||
identical(dn, list( ch0, ch0))
}
## METHODS FOR GENERIC: dim
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("dim", c(x = "Matrix"),
function(x) x@Dim)
setMethod("dim", c(x = "MatrixFactorization"),
function(x) x@Dim)
## METHODS FOR GENERIC: dim<-
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("dim<-", c(x = "denseMatrix"),
function(x, value) {
if(is.character(s <- validDimGetsValue(value, prod(d <- x@Dim))))
stop(s, domain = NA)
value <- as.integer(value)
if(all(value == d))
return(x)
r <- .M2gen(x)
r@Dim <- value
if(length(r@factors))
r@factors <- list()
r
})
setMethod("dim<-", c(x = "sparseMatrix"),
function(x, value) {
if(is.character(s <- validDimGetsValue(value, prod(d <- x@Dim))))
stop(s, domain = NA)
value <- as.integer(value)
if(all(value == d))
return(x)
r <- spV2M(.M2V(x), nrow = value[1L], ncol = value[2L])
switch(.M.repr(x), "C" = .M2C(r), "R" = .M2R(r), r)
})
setMethod("dim<-", c(x = "sparseVector"),
function(x, value) {
if(is.character(s <- validDimGetsValue(value, length(x))))
stop(s, domain = NA)
value <- as.integer(value)
spV2M(x, nrow = value[1L], ncol = value[2L])
})
## METHODS FOR GENERIC: length
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("length", c(x = "Matrix"),
function(x)
if((r <- prod(x@Dim)) > .Machine$integer.max)
r
else as.integer(r))
setMethod("length", c(x = "MatrixFactorization"),
function(x)
if((r <- prod(x@Dim)) > .Machine$integer.max)
r
else as.integer(r))
setMethod("length", c(x = "sparseVector"),
function(x)
if(is.integer(r <- x@length))
r
else if(r - 1 <= .Machine$integer.max)
as.integer(r)
else trunc(r))
## METHODS FOR GENERIC: dimnames
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("dimnames", c(x = "Matrix"),
function(x) x@Dimnames)
setMethod("dimnames", c(x = "symmetricMatrix"),
function(x) symDN(x@Dimnames))
setMethod("dimnames", c(x = "MatrixFactorization"),
function(x) x@Dimnames)
## METHODS FOR GENERIC: dimnames<-
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("dimnames<-", c(x = "Matrix", value = "NULL"),
function(x, value) {
x@Dimnames <- list(NULL, NULL)
x
})
for(.cl in c("generalMatrix", "symmetricMatrix"))
setMethod("dimnames<-", c(x = .cl, value = "NULL"),
function(x, value) {
if(length(x@factors))
x@factors <- list()
x@Dimnames <- list(NULL, NULL)
x
})
rm(.cl)
setMethod("dimnames<-", c(x = "MatrixFactorization", value = "NULL"),
function(x, value) {
x@Dimnames <- list(NULL, NULL)
x
})
setMethod("dimnames<-", c(x = "Matrix", value = "list"),
function(x, value) {
x@Dimnames <- fixupDN.if.valid(value, x@Dim)
x
})
for(.cl in c("generalMatrix", "symmetricMatrix"))
setMethod("dimnames<-", c(x = .cl, value = "list"),
function(x, value) {
if(length(x@factors))
x@factors <- list()
x@Dimnames <- fixupDN.if.valid(value, x@Dim)
x
})
rm(.cl)
setMethod("dimnames<-", c(x = "MatrixFactorization", value = "list"),
function(x, value) {
x@Dimnames <- fixupDN.if.valid(value, x@Dim)
x
})
## METHODS FOR GENERIC: unname
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("unname", c(obj = "Matrix"),
function(obj, force = FALSE) {
obj@Dimnames <- list(NULL, NULL)
obj
})
setMethod("unname", c(obj = "MatrixFactorization"),
function(obj, force = FALSE) {
obj@Dimnames <- list(NULL, NULL)
obj
})
## METHODS FOR GENERIC: drop
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("drop", c(x = "Matrix"),
function(x) if(any(x@Dim == 1L)) drop(.M2m(x)) else x)
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.