R/LoomGraph-class.R

In Bioconductor/LoomExperiment: LoomExperiment container

### =========================================================================
### LoomGraph Objects
### -------------------------------------------------------------------------
###

#' @importFrom S4Vectors SelfHits
#' @export
setClass('LoomGraph',
    contains = 'SelfHits'
)

#' @export
setClass('LoomGraphs',
    contains = 'SimpleList',
    prototype = prototype(
        elementType = 'LoomGraph'
    )
)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Vaidity
###

#' @importFrom S4Vectors isEmpty
.valid.LoomGraph <- function(x) {
    mcol <- mcols(x)
    if (!is.integer(c(from(x), to(x)))) {
        '\n The nodes of a LoomGraph must be an integer'
    } else if (min(from(x), to(x)) < 0) {
        '\n The nodes of a LoomGraph must be non-negative'
    } else if (!is.null(mcol) && !all(names(mcol) == 'w')) {
        '\n A LoomGraph may only have one metadata column named "w"'
    } else if (!is.null(w <- mcol$w) && !is.numeric(w)) {
        '\n The "w" mcol of a LoomGraph must numeric '
    } else {
        NULL
    }
}

setValidity2('LoomGraph', .valid.LoomGraph)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructors
###

#' @importFrom methods new
.new_LoomGraph <- function(df) {
    new('LoomGraph', df)
}

.new_LoomGraphs <- function(li) {
    new('LoomGraphs', listData = li)
}

#' @export
LoomGraph <- function(from, to, nnode=max(from, to), ..., weight=NULL) {
    if (!is.numeric(c(from, to)))
        stop(
            '"from" and "to" arguments to LoomGraph constructor  must be numeric'
        )
    sh <- SelfHits(from=as.integer(from), to=as.integer(to), nnode=nnode, ...)
    mcols(sh)$w <- weight
    .new_LoomGraph(sh)
}

#' @export
LoomGraphs <- function(...) {
    list <- list(...)
    .new_LoomGraphs(list)
}


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Coercion.
###

.from_DataFrame_to_LoomGraph <- function(from)
{
    nam <- names(from)
    if (!all(nam %in% c('a', 'b', 'w')))
        stop('columns of DataFrame must be named "a" and "b" or "a", "b", "w"')
    a <- as.integer(from$a)
    b <- as.integer(from$b)
    lg <- LoomGraph(a, b, max(a,b))
    if('w' %in% nam)
        mcols(lg)$w <- as.numeric(from$w)
    lg
}

setAs('DataFrame', 'LoomGraph', .from_DataFrame_to_LoomGraph)

#' @importFrom S4Vectors from to
.from_LoomGraph_to_DataFrame <- function(from)
{
    a <- from(from)
    b <- to(from)
    if (is.null(w <- mcols(from)))
        DataFrame(a=a, b=b)
    else
        DataFrame(a=a, b=b, w)
}

setAs('LoomGraph', 'DataFrame', .from_LoomGraph_to_DataFrame)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Miscellanious methods.
###

#' @export
setMethod('rbind', 'LoomGraph',
    function(..., deparse.level = 1)
{
    li <- list(...)
    nr <- 0
    for (x in li)
        nr <- nr + nnode(x)
    offset <- 0L
    li <- lapply(li, function(x) {
        pe <- parent.env(environment())
        from <- from(x) + pe$offset
        to <- to(x) + pe$offset
        pe$offset <- pe$offset + nnode(x)
        LoomGraph(from, to, nr, weight = mcols(x)[[1]])
    })
    x <- do.call(c, li)
    x
})

#' @export
setMethod('cbind', 'LoomGraph',
    function(..., deparse.level = 1)
{
    li <- list(...)
    nc <- 0
    for (x in li)
        nc <- nc + nnode(x)
    offset <- 0L
    li <- lapply(li, function(x) {
        pe <- parent.env(environment())
        from <- from(x) + pe$offset
        to <- to(x) + pe$offset
        pe$offset <- pe$offset + nnode(x)
        LoomGraph(from, to, nc, weight = mcols(x)[[1]])
    })
    x <- do.call(c, li)
    x
})

setMethod('rbind', 'LoomGraphs',
    function(..., deparse.level = 1)
{
    li <- list(...)
    res <- lapply(seq_along(li[[1]]), function(i) {
        lg <- lapply(li, function(x) {
            x[[i]]
        })
        do.call(rbind, lg)
    })
    do.call(LoomGraphs, res)
})

setMethod('cbind', 'LoomGraphs',
    function(..., deparse.level = 1)
{
    li <- list(...)
    res <- lapply(seq_along(li[[1]]), function(i) {
        lg <- lapply(li, function(x) {
            x[[i]]
        })
        do.call(cbind, lg)
    })
    do.call(LoomGraphs, res)
})

.correctHits <- function(x, i, decr)
{
    ifelse(x >= i, decr-1, decr)
}

setMethod('loomSelectHits', c('LoomGraph', 'ANY'),
    function(x, i, nr = NULL, ...)          
{
    x <- x[from(x) %in% i & to(x) %in% i]
    from_top <- seq_len(max(i))
    i <- from_top[!from_top %in% i]

    from <- from(x)
    from_i <- rep(0, length(from))
    for (n in i)
        from_i <- .correctHits(from, n, from_i)
    from <- from + from_i
    to <- to(x)
    to_i <- rep(0, length(to))
    for (n in i)
        to_i <- .correctHits(to, n, to_i)
    to <- to + to_i

    if (length(from) == 0 && length(to) == 0)
        nr <- 0
    if (is.null(nr))
        nr <- max(from, to)
    suppressWarnings(LoomGraph(from, to, nr, weight = mcols(x)[[1]]))
})

setMethod('loomDropHits', c('LoomGraph', 'ANY'),
    function(x, i, nr = NULL, ...)          
{
    x <- x[!from(x) %in% i & !to(x) %in% i]

    from <- from(x)
    from_i <- rep(0, length(from))
    for (n in i)
        from_i <- .correctHits(from, n, from_i)
    from <- from + from_i
    to <- to(x)
    to_i <- rep(0, length(to))
    for (n in i)
        to_i <- .correctHits(to, n, to_i)
    to <- to + to_i

    if (length(from) == 0 && length(to) == 0)
        nr <- 0
    if (is.null(nr))
        nr <- max(from, to)
    suppressWarnings(LoomGraph(from, to, nr, weight = mcols(x)[[1]]))
})

setReplaceMethod('loomDropHits', c('LoomGraph', 'ANY', 'ANY'),
    function(x, i, ..., value)
{
    from <- from(x)
    to <- to(x)
    from <- as.integer(replace(from, from %in% i, value))
    to <- as.integer(replace(to, to %in% i, value))

    nnode <- max(from, to)
    x@nLnode <- nnode
    x@nRnode <- nnode
    x@from <- from
    x@to <- to
    x
})