Nothing
#' @rdname sptensor
#' @aliases sptensor,matrix,ANY,numeric-method
#' @export
#' @importFrom assertive.base assert_are_identical
setMethod("sptensor", c("matrix", "ANY", "numeric"), function(subs, vals, dims) {
# dimensions should match
assert_are_identical(ncol(subs), length(vals))
assert_are_identical(nrow(subs), length(dims))
# coerce subscripts and dimensions to integer
subs <- apply(subs, c(1,2), as.integer)
dims <- as.integer(dims)
# if any vals are zero, don't include them
nonzeros <- which(vals != 0)
subs <- subs[, nonzeros, drop = FALSE]
vals <- vals[nonzeros]
# ascending order subscripts
ascending_indices <- order(vec_index(subs, dims))
subs <- subs[, ascending_indices, drop = FALSE]
vals <- vals[ascending_indices]
# drop duplicated subscripts?
duped <- duplicated(subs, MARGIN = 2)
subs <- subs[, !duped, drop = FALSE]
vals <- vals[!duped]
# empty dimnames
empty_dimnames <- vector("list", length(dims))
methods::new("sptensor", subs = subs, vals = vals, dims = dims, dimnames = empty_dimnames)
})
#' @rdname sptensor
#' @aliases sptensor,matrix,missing,numeric-method
#' @export
setMethod("sptensor", c("matrix", "missing", "numeric"), function(subs, vals, dims) {
vals = rep(1, ncol(subs))
sptensor(subs, vals, dims)
})
#' @rdname sptensor
#' @aliases sptensor,list,ANY,numeric-method
#' @export
#' @importFrom assertive.properties assert_is_non_empty assert_are_same_length
setMethod("sptensor", c("list", "ANY", "numeric"), function(subs, vals, dims) {
assert_is_non_empty(subs)
walk(subs, ~assert_are_same_length(.x, dims))
# convert subs list to matrix
subs <- list_to_matidx(subs)
# create sptensor
if (missing(vals)) sptensor(subs, dims = dims)
else sptensor(subs, vals, dims = dims)
})
# identity
#' @describeIn is_tensor sparse tensor
#' @export
is_sptensor <- function(x) inherits(x, "sptensor")
#' @rdname dim
#' @aliases dim,sptensor-method
#' @export
setMethod("dim", c(x = "sptensor"), function(x) x@dims)
#' @rdname dimnames
#' @aliases dimnames,sptensor-method
#' @export
setMethod("dimnames", c(x = "sptensor"), function(x) x@dimnames)
#' @rdname dimnames
#' @aliases dimnames<-,sptensor-method,list
#' @export
setMethod("dimnames<-", c(x = "sptensor", value = "list"), function(x, value) {
# ensure provided dimnames match dimensions of tensor
dims <- dim(x)
assertive.properties::assert_is_of_length(value, length(dims))
dims_value <- vapply(value, length, integer(1L))
if(!all(dims_value == dims | dims_value == 0)) {
stop("dimnames components must have same length as dimensions of tensor", call. = FALSE)
}
x@dimnames <- value
x
})
#' @rdname dimnames
#' @aliases dimnames<-,sptensor-method,NULL
#' @export
setMethod("dimnames<-", c(x = "sptensor", value = "NULL"), function(x, value) {
warning("dimnames cannot be NULL. converting to a list of NULL values", call. = FALSE)
dims <- dim(x)
NULL_dimnames <- vector("list", length(dims))
x@dimnames <- NULL_dimnames
x
})
#' @rdname dimnames
#' @aliases dimnames<-,sptensor-method,ANY
#' @export
setMethod("dimnames<-", c(x = "sptensor", value = "ANY"), function(x, value) {
stop("dimnames must be a list of length equal to the length of the dim(X)", call. = FALSE)
})
#' @rdname nzsubs
#' @aliases nzsubs,sptensor-method
#' @export
setMethod("nzsubs", "sptensor", function(x) x@subs)
#' @rdname zsubs
#' @aliases zsubs,sptensor-method
#' @keywords internal
setMethod("zsubs", "sptensor", function(x) {
allsubslist <- mat_to_listidx(allsubs(x))
nzsubslist <- mat_to_listidx(nzsubs(x))
zsubslist <- setdiff(allsubslist, nzsubslist)
if (length(zsubslist) > 0 )list_to_matidx(zsubslist)
else matrix(numeric(0), nrow = length(dim(x)))
})
#' @rdname allsubs
#' @aliases allsubs,sptensor-method
#' @keywords internal
setMethod("allsubs", "sptensor", function(x) {
array_index(seq_along(x), dim(x))
})
#' @rdname nzvals
#' @aliases nzvals,sptensor-method
#' @export
setMethod("nzvals", "sptensor", function(x) x@vals)
#' @rdname show
setMethod("show", c(object = "sptensor"), function(object) {
x <- object
width <- min(5L, length(x@vals))
# header message
msg_dims <- paste(dim(x), "x", sep = "", collapse = "")
msg_dims <- strtrim(msg_dims, nchar(msg_dims)-1)
msg <- paste("<A", msg_dims,"sparse tensor with",length(x@vals),"non-zero entries>", sep = " " )
cat(msg)
cat("\n")
# subscripts
if (all(is.na(x@subs))) {
msg_subs <- "<empty>"
} else {
msg_subs <- apply(x@subs, 2, function(s) paste("<",paste(s,collapse=","),">", sep =""))
if (length(msg_subs) > width) {
msg_subs <- c(msg_subs[1:width], "...")
}
}
cat("subs:", msg_subs)
cat("\n")
# values
if (length(x@vals) == 0) {
msg_vals <- "<empty"
}
else {
msg_vals <- x@vals
if (length(msg_vals) > width) {
msg_vals <- c(msg_vals[1:width], "...")
}
}
cat("vals:", msg_vals)
})
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.