SubsettableListOfArrays.R

subsetListOfArrays <- function (object, i, j, IJ, IX, I, JX, J) {
    len <- vapply(object, length, 0)
    I <- intersect(I, names(len)[len > 1L])
    J <- intersect(J, names(len)[len > 1L])
    if (missing(i)) {
        IX <- I <- character(0)
        if (missing(j)) 
            IJ <- character(0)
    }
    else {
        if (is.character(i)) {
            i <- match(i, rownames(object))
            if (any(is.na(i))) 
                stop("Subscript not found in rownames")
        }
    }
    if (missing(j)) {
        JX <- J <- character(0)
    }
    else {
        if (is.character(j)) {
            j <- match(j, colnames(object))
            if (any(is.na(j))) 
                stop("Subscript not found in colnames")
        }
    }
    for (a in IJ) object[[a]] <- object[[a]][i, j, drop = FALSE]
    for (a in IX) object[[a]] <- object[[a]][i, , drop = FALSE]
    for (a in I) object[[a]] <- object[[a]][i]
    for (a in JX) object[[a]] <- object[[a]][j, , drop = FALSE]
    for (a in J) object[[a]] <- object[[a]][j]
    object
}

recycleMatrix <- function(m, nrow.out=nrow(m), ncol.out=ncol(m), ...) {
    if (any(dim(m) != c(nrow.out, ncol.out))) {
        recyc.row <- S4Vectors:::recycleVector(seq_len(nrow(m)), nrow.out)
        recyc.col <- S4Vectors:::recycleVector(seq_len(ncol(m)), ncol.out)
        m[recyc.row, recyc.col, ...]
    } else {
        m
    }
}

recycleListOfArrays <- function(object, IJ, IX, I, JX, J) {
    max.nrow <-
        max(unlist(c(lapply(object[IJ], nrow),
                     lapply(object[IX], nrow),
                     lapply(object[I], length))))
    max.ncol <-
        max(unlist(c(lapply(object[IJ], ncol),
                     lapply(object[JX], ncol),
                     lapply(object[J], length))))
    for (ij in IJ) {
        object[[ij]] <- recycleMatrix(object[[ij]], max.nrow, max.ncol, drop=FALSE)
    }
    for (ix in IX) {
        object[[ix]] <- recycleMatrix(object[[ix]], max.nrow, , drop=FALSE)
    }
    for (i in I) {
        object[[i]] <- S4Vectors:::recycleVector(object[[i]], max.nrow)
    }
    for (jx in JX) {
        object[[ij]] <- recycleMatrix(object[[ij]], max.ncol, , drop=FALSE)
    }
    for (j in J) {
        object[[j]] <- S4Vectors:::recycleVector(object[[j]], max.ncol)
    }
    return(object)
}

setClass("SubsettableListOfArrays",
         representation(listOfArrays="list",
                        IJ="character",
                        IX="character",
                        I="character",
                        JX="character",
                        J="character",
                        dnn="character",
                        required="character"))


validSubsettableListOfArrays <- function(object) {
    problems <- character(0)

    ## Using tryCatch in case nrow or ncol throws an error
    tryCatch({
        nr <- nrow(object)
        nc <- ncol(object)
        if (is.null(nr) || is.null(nc))
            stop("Missing dimension")
    }, error=function(...) problems <<- c(problems, "Object is missing a dimension"))
    if (length(problems))
        return(problems)

    missing.names <- setdiff(object@required, names(object))
    if (length(missing.names))
        return(sprintf("Object is missing list items with the following names: %s",
                       deparse(missing.names)))

    add.dim.problem <- function(name)
        problems <<- c(problems, sprintf("%s has wrong dimension", name))
    nm <- names(object)
    IJ <- intersect(object@IJ, nm)
    IX <- intersect(object@IX, nm)
    I <- intersect(object@I, nm)
    JX <- intersect(object@JX, nm)
    J <- intersect(object@J, nm)
    for (name in IJ)
        if (is.null(dim(object[[name]])) ||
            nrow(object[[name]]) != nr ||
            ncol(object[[name]]) != nc)
            add.dim.problem(name)
    for (name in IX)
        if (is.null(dim(object[[name]])) ||
            nrow(object[[name]]) != nr)
            add.dim.problem(name)
    for (name in I)
        if (length(object[[name]]) != nr)
            add.dim.problem(name)
    for (name in JX)
        if (is.null(dim(object[[name]])) ||
            nrow(object[[name]]) != nc)
            add.dim.problem(name)
    for (name in J)
        if (length(object[[name]]) != nc)
            add.dim.problem(name)
    if (length(problems))
        return(problems)
    else
        return(TRUE)
}
setValidity("SubsettableListOfArrays", validSubsettableListOfArrays)

setMethod("names", "SubsettableListOfArrays", function(x) {
    names(x@listOfArrays)
})

setMethod("names<-", c(x="SubsettableListOfArrays"), function(x, value) {
    ## TODO: If the following line is not included in every setter
    ## method, the setter will still take effect if the validity check
    ## fails, leaving you with an invalid object. Presumably this line
    ## triggers some sort of different code path by having multiple
    ## references exist to the object. This is obviously not the
    ## correct solution, but it works for now.
    y <- x
    names(x@listOfArrays) <- value
    validObject(x)
    return(x)
})

setMethod("[[", c(x="SubsettableListOfArrays", i="ANY", j="missing"), function (x, i, j, ...) {
    stopifnot(length(list(...)) == 0)
    x@listOfArrays[[i]]
})

setMethod("[[<-", c(x="SubsettableListOfArrays", i="ANY", j="missing"), function (x, i, j, ..., value) {
    y <- x
    stopifnot(length(list(...)) == 0)
    x@listOfArrays[[i]] <- value
    validObject(x)
    return(x)
})

setMethod("$", c(x="SubsettableListOfArrays"), function(x, name) {
    x[[name]]
})

setMethod("$<-", c(x="SubsettableListOfArrays"), function(x, name, value) {
    x[[name]] <- value
    x
})

setMethod("nrow", "SubsettableListOfArrays", function(x) {
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        return(nrow(x[[name]]))
    IX <- intersect(x@IX, nm)
    for (name in IX)
        return(nrow(x[[name]]))
    I <- intersect(x@I, nm)
    for (name in I)
        return(length(x[[name]]))
    return(0)
})

setMethod("ncol", "SubsettableListOfArrays", function(x) {
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        return(ncol(x[[name]]))
    JX <- intersect(x@JX, nm)
    for (name in JX)
        return(nrow(x[[name]]))
    J <- intersect(x@J, nm)
    for (name in J)
        return(length(x[[name]]))
    return(0)
})

setMethod("dim", "SubsettableListOfArrays", function(x) {
    maybeSetNames(c(nrow(x), ncol(x)), x@dnn)
})

setMethod("[", signature=c(x="SubsettableListOfArrays", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., drop) {
    if (!missing(drop) && drop)
        stop("Subsetting with drop=TRUE is not allowed")
    if (length(list(...)) > 0)
        stop("Object only has 2 dimensions")
    if (nargs() == 2) {
        ## List-like indexing
        x@listOfArrays <- x@listOfArrays[i]
    } else {
        x@listOfArrays <- subsetListOfArrays(
            x@listOfArrays, i, j,
            IJ=x@IJ, IX=x@IX, I=x@I,
            JX=x@JX, J=x@J)
    }
    validObject(x)
    return(x)
})

setMethod("rownames", "SubsettableListOfArrays", function(x) {
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        return(rownames(x[[name]]))
    IX <- intersect(x@IX, nm)
    for (name in IX)
        return(rownames(x[[name]]))
    I <- intersect(x@I, nm)
    for (name in I)
        return(names(x[[name]]))
    return(character(0))
})

setMethod("colnames", "SubsettableListOfArrays", function(x) {
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        return(colnames(x[[name]]))
    JX <- intersect(x@JX, nm)
    for (name in JX)
        return(rownames(x[[name]]))
    J <- intersect(x@J, nm)
    for (name in J)
        return(names(x[[name]]))
    return(character(0))
})

setMethod("rownames<-", c(x="SubsettableListOfArrays"), function(x, value) {
    y <- x
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        rownames(x[[name]]) <- value
    IX <- intersect(x@IX, nm)
    for (name in IX)
        rownames(x[[name]]) <- value
    I <- intersect(x@I, nm)
    for (name in I)
        names(x[[name]]) <- value
    return(x)
})

setMethod("colnames<-", c(x="SubsettableListOfArrays"), function(x, value) {
    y <- x
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ)
        colnames(x[[name]]) <- value
    JX <- intersect(x@JX, nm)
    for (name in JX)
        rownames(x[[name]]) <- value
    J <- intersect(x@J, nm)
    for (name in J)
        names(x[[name]]) <- value
    return(x)
})

setMethod("dimnames", "SubsettableListOfArrays", function(x) {
    maybeSetNames(list(rownames(x), colnames(x)), x@dnn)
})

setMethod("dimnames<-", c(x="SubsettableListOfArrays"), function(x, value) {
    y <- x
    rownames(x) <- value[[1]]
    colnames(x) <- value[[2]]
    x@dnn <- names(value)
    nm <- names(x)
    IJ <- intersect(x@IJ, nm)
    for (name in IJ){
        ## We don't really care if setting dimname names on the
        ## contained objects works or not. We're just setting them for
        ## user convenience when they extract individual list
        ## elements; they're never actually used by the SLOA code.
        tryCatch(names(dimnames(x[[name]])) <- x@dnn,
                 error=function (...) NULL)
    }
    return(x)
})

## Based on the LargeDataObject show method from limma
setMethod("show", "SubsettableListOfArrays", function (object)
{
    cat("An object of class \"", class(object), "\"\n", sep = "")
    for (what in names(object)) {
        x <- object[[what]]
        cat("$", what, "\n", sep = "")
        printHead(x)
        cat("\n")
    }
    for (what in setdiff(slotNames(object), "listOfArrays")) {
        x <- slot(object, what)
        if (length(x) > 0) {
            cat("@", what, "\n", sep = "")
            printHead(x)
            cat("\n")
        }
    }
})

setAs("SubsettableListOfArrays", "list",
      function(from) from@listOfArrays)
setMethod("as.list", "SubsettableListOfArrays", function(x) {
    as(x, "list")
})

## TODO: *bind

SubsettableListOfArrays <- function(listOfArrays,
                                    IJ=character(0),
                                    IX=character(0),
                                    I=character(0),
                                    JX=character(0),
                                    J=character(0),
                                    dnn=character(0)
                                    required=character(0),
                                    recycle=FALSE) {
    if (recycle)
        listOfArrays <- recycleListOfArrays(listOfArrays, IJ, IX, I, JX, J)
    args <- c(list(Class="SubsettableListOfArrays"),
              mget(slotNames("SubsettableListOfArrays")))
    do.call(new, args)
}

defineSLOASubclassValidityMethod <- function(IJ=character(0),
                                             IX=character(0),
                                             I=character(0),
                                             JX=character(0),
                                             J=character(0)) {
    function(object) {
        problems <- character(0)
        for (indextype in c("IJ", "IX", "I", "JX", "J")) {
            missing.indices <- setdiff(get(indextype), slot(object, indextype))
            if (length(missing.indices))
                problems %<>% c(sprintf("Index type %s is missing names %s", indextype, deparse(missing.indices)))
        }
        if (length(problems))
            return(problems)
        else
            return(TRUE)
    }
}

defineSLOASubclassConstructor <- function(className,
                               IJ=character(0),
                               IX=character(0),
                               I=character(0),
                               JX=character(0),
                               J=character(0),
                               required=character(0)) {
    function(..., RECYCLE=FALSE) {
        listOfArrays <- list(...)
        if (RECYCLE)
            listOfArrays <- recycleListOfArrays(listOfArrays, IJ, IX, I, JX, J)
        new(className, listOfArrays=listOfArrays,
            IJ=IJ, IX=IX, I=I, JX=JX, J=J,
            required=required)
    }
}

defineSLOASubclass <- function(className,
                               IJ=character(0),
                               IX=character(0),
                               I=character(0),
                               JX=character(0),
                               J=character(0),
                               required=character(0)) {
    setClass(className, contains="SubsettableListOfArrays")
    setValidity(className, defineSLOASubclassValidityMethod(IJ, IX, I, JX, J))
    return(defineSLOASubclassConstructor(className, IJ, IX, I, JX, J, required))
}