# Re: [S] Large (sparse) matrix is killing me (code)

Arman Maghbouleh (arman@csli.stanford.edu)
Sun, 25 Oct 1998 22:55:19 -0800 (PST)

I did get two emails, within a few minutes of posting, asking for code
to do the following:

## create and multiply large sparse vectors:
## tempvec <- vector.sparse(values=1:3, indices=c(1,4,6), len=10^20)
## tempvec2 <- vector.sparse(1:3,c(1,4,9), 10^20)
## length(tempvec2) == 1e+20
## tempvec%*%tempvec2 == 5
## create sparse matrices from sparse vectors:
## tempMat <- matrix.sparse.row(tempvec, tempvec2)
## dim(tempMat) == c(2,1e+20)
## access rows of sparse matrices in a natural way
## tempMat[1,]%*%tempMat[2,] == 5
## tempMat[3,] <- tempvec
## dim(tempMat) == c(3,1e+20)
## just about nothing else is implemented except nice printing of the above.

So, here it is:

#####################
## Sparse Vectors
#####################
vector.sparse <- function(values, indices, len, default=0)
{
if(length(values) != length(indices))
stop("Each element should have a corresponding index and vice versa.")
mode(default) <- mode(values)
structure(list(elements=values, indices=indices),
lengthx=len, ## can't use length, since system uses it
default=default,
class= "vector.sparse")
}
length.vector.sparse <- function(vec.sparse)
{attr(vec.sparse, "len")}
default.vector.sparse <- function(vec.sparse)
{attr(vec.sparse, "default")}
is.vector.sparse <- function(object)
{inherits(object, "vector.sparse")}

print.vector.sparse <- function(vec.sparse, ...)
{
cat("A sparse vector of length:", length(vec.sparse))
cat("\nThe default value is: ", default.vector.sparse(vec.sparse), "(First line corresponds to column numbers)\n")
vals <- c(vec.sparse\$elements)
names(vals) <- vec.sparse\$indices
print(vals)
invisible(vec.sparse)
}
unsparse.vector.sparse <- function(vec.sparse)
{
res <- rep(default.vector.sparse(vec.sparse), length(vec.sparse))
res[vec.sparse\$indices] <- vec.sparse\$elements
res
}
"[[.vector.sparse" <- function(vec.sparse, index, drop=T)
{stop("list access is not defined for a sparse vector")}

"[.vector.sparse" <- function(vec.sparse, index, drop=T)
{stop("access operations are not yet implemented for sparse vectors")}

"%*%.vector.sparse" <- function(x, y)
{
if(default.vector.sparse(x)!=0 || default.vector.sparse(y)!=0)
stop("multipication is not yet implemented for sparse vectors with default values other than 0.")
if(!is.vector.sparse(x) || !is.vector.sparse(y))
stop("multipication between sparse vectors and non-sparse vectors is not yet implemented")
commonIndices <- match(x\$indices, y\$indices, nomatch=0)
if(any(commonIndices!=0))
{
x\$elements[commonIndices!=0] %*% y\$elements[commonIndices]
}
else
0
}

#####################
## Sparse Matrices
#####################
matrix.sparse.row <- function(..., listOfRows=NULL)
{
## each row must be a sparse vector
if(is.null(listOfRows))
listOfRows<-list(...)
if(!all(sapply(listOfRows, is.vector.sparse)))
stop("All rows of matrix.sparse.row must be sparce vectors.")

lengths <- sapply(listOfRows, length.vector.sparse)
if(!all(lengths==lengths[1]))
stop("All rows of matrix.sparse.row must have same length.")

defVals <- sapply(listOfRows, default.vector.sparse)
if(!all(defVals==defVals[1]))
stop("All rows of matrix.sparse.row must have same default value.")

structure(listOfRows,
ncol=lengths[1],
default=defVals[1],
class="matrix.sparse.row")
}

dim.matrix.sparse.row <- function(mat.sparse)
{c(length(mat.sparse), attr(mat.sparse, "ncol"))}
default.matrix.sparse.row <- function(mat.sparse)
{attr(mat.sparse[1,], "default")}
is.matrix.sparse.row <- function(object)
{inherits(object, "matrix.sparse.row")}

print.matrix.sparse.row <- function(mat.sparse, ...)
{
cat("A row-only-access sparse matrix with", ncol(mat.sparse),
"columns.")
cat("\nThe default value is: ", default.matrix.sparse.row(mat.sparse), " (First line of each row corresponds to column numbers)\n")
rowPrinter <- function(rowNum, mat.sparse){
cat("Row[", rowNum, ",]\n", sep="")
vec.sparse <- mat.sparse[rowNum,]
vals <- vec.sparse\$elements
names(vals) <- vec.sparse\$indices
print(vals)
}
sapply(seq(nrow(mat.sparse)),rowPrinter, mat.sparse)
invisible(mat.sparse)
}
"[[.matrix.sparse.row" <- function(mat.sparse, index, drop=T)
{stop("list access is not defined for a sparse matrix")}

"[.matrix.sparse.row" <- function(mat.sparse, index, ..., drop=T)
{
if(length(index)!=1)
stop("Extracting more, or less than one row, is not yet implemented for sparse matrices")
if(length(list(...)))
stop("Extracting columns, is not yet implemented for sparse matrices.")
mat.sparse <- unclass(mat.sparse)
mat.sparse[[index]]
}

"[<-.matrix.sparse.row" <- function(mat.sparse, index, ..., value)
{
if(length(index)!=1)
stop("Setting more, or less than one row, is not yet implemented for sparse matrices")
## xxxx should put in more error checking here
if(length(list(...)))
stop("Setting columns, is not yet implemented for sparse matrices.")
mat.sparse[[index]] <- value
mat.sparse
}

"%*%.matrix.sparse.row" <- function(x, y)
{
stop("multipication is not yet implemented for sparse matrices.")
}

## -------------------------------------------------------------------------
## Arman Maghbouleh Linguistics Dept. Stanford University

-----------------------------------------------------------------------
This message was distributed by s-news@wubios.wustl.edu. To unsubscribe
send e-mail to s-news-request@wubios.wustl.edu with the BODY of the
message: unsubscribe s-news