R/sparse_matrix.R

In casxue/bis557: Coursework for BIS 557

#' Functions for sparse.matrix class
#'
#' @description Constructor for class sparse.matrix
#' @param i an integer vector
#' @param j an integer vector
#' @param x a numeric vector
#' @param dims an integer vector
#' @return a sparse.matrix object
#' @export
sparse.matrix <- function (i, j, x, dims = c(max(i), max(j)))
{
    me <- list(df = data.frame(i = i, j = j, x = x), dims = dims)

    class(me) <- "sparse.matrix"
    return(me)
}


#' Addition function for sparse.matrix class
#'
#' @description Addition function for two sparse.matrix objects
#' @param a a sparse.matrix object
#' @param b a sparse.matrix object
#' @return a sparse.matrix object
#' @export
sparse_add <- function (a, b) 
{
    if (sum(a$dims == b$dims) != 2)  stop()

    c <- merge(a$df, b$df, by = c("i", "j"), all = TRUE, suffixes = c("1", "2"))
    c$x1[is.na(c$x1)] <- 0
    c$x2[is.na(c$x2)] <- 0
    c$x <- c$x1 + c$x2

    order <- order(c$j)
    c <- c[order,]

    return(sparse.matrix(c$i, c$j, c$x, a$dims))
}

#' Addition operator for sparse.matrix class
#'
#' @description addition operator for two sparse.matrix objects
#' @param a a sparse.matrix object
#' @param b a sparse.matrix object
#' @return a sparse.matrix object
#' @export
'+.sparse.matrix' <- function (a, b) 
{
    return(sparse_add(a, b))
}


#' Multiplication functions for sparse.matrix class
#'
#' @description Multiplication function for two sparse.matrix objects
#' @param a a sparse.matrix object
#' @param b a sparse.matrix object
#' @return a sparse.matrix object
#' @export
sparse_multiply <- function (a, b) 
{
    if (a$dims[2] != b$dims[1])  stop()

    i <- integer(0)
    j <- integer(0)
    x <- numeric(0)

    for (p in 1:a$dims[1])
    {
        for (q in 1:b$dims[2])
        {
            ks <- intersect(a$df$j[which(a$df$i == p)], b$df$i[which(b$df$j == q)])
            if (length(ks) == 0)  next
            i <- c(i, p)
            j <- c(j, q)
            x <- c(x, sum(sapply(ks, function (k) {a$df$x[which(a$df$i == p & a$df$j == k)]}) * 
                sapply(ks, function (k) {b$df$x[which(b$df$j == q & b$df$i == k)]})))
        }
    }

    c <- sparse.matrix(i = i, j = j, x = x, dims = c(a$dims[1], b$dims[2]))
    order <- order(c$df$j)
    c$df <- c$df[order,]
    rownames(c$df) <- 1:nrow(c$df)

    return(c)
}

`%*%.default` = .Primitive("%*%") # assign default as current definition
`%*%` = function (x,...) { #make S3
    UseMethod("%*%", x)
}

#' Matrix multiplication operator for sparse.matrix class
#'
#' @description matrix multiplication operator for two sparse.matrix objects
#' @param a a sparse.matrix object
#' @param b a sparse.matrix object
#' @return a sparse.matrix object
#' @export
'%*%.sparse.matrix' <- function (a, b) 
{
    return(sparse_multiply(a, b))
}


#' Transpose function for sparse.matrix class
#'
#' @description Transpose function for sparse.matrix object
#' @param x a sparse.matrix object
#' @return a sparse.matrix object
#' @export
't.sparse.matrix' <- function (x) 
{
	a <- x
    return(sparse.matrix(i = a$df$j, j = a$df$i, x = a$df$x, dims = c(a$dims[2], a$dims[1])))
}