R/lincomb.R

In INBO-BMK/INLA: Full Bayesian Analysis of Latent Gaussian Models using Integrated Nested Laplace Approximations

## Export: inla.make.lincomb inla.make.lincombs

##!\name{make.lincomb}
##!\alias{make.lincomb}
##!\alias{make.lincombs}
##!\alias{inla.make.lincomb}
##!\alias{inla.make.lincombs}
##!\title{Create linear combinations}
##!\description{Create a linear combination or several
##!linear combinations, as input to \code{inla(...,  lincomb = <lincomb>)}}
##!\usage{
##!inla.make.lincomb(...)
##!inla.make.lincombs(...)
##!}
##!\arguments{
##!   \item{...}{Arguments; see examples}
##!}
##!\value{
##! A structure to be passed on to \code{\link{inla}} argument \code{lincomb} 
##!}
##!\author{Havard Rue \email{hrue@r-inla.org}}
##!\seealso{TODO}
##!\examples{
##!##See the worked out examples and description in the FAQ
##!##section on {www.r-inla.org}
##!}

`inla.make.lincomb` = function(...)
{
    arg = match.call(expand.dots=TRUE)

    ## we might need to expand arguments?
    if (all(is.null(names(arg)))) {
        arg = eval(parse(text=arg[2]), envir = parent.frame(), enclos = environment(list(...)))
    }

    f.arg = list()
    f.arg[[ length(arg) ]] = list
    for(k in 1:length(arg)) {
        var = names(arg)[k]
        if (var != "") {
            value = eval(arg[[k]], envir = parent.frame(), enclos = environment(list(...)))

            if (length(value) == 1) {
                ff.arg = list(list(weight = value))
            } else {
                ii = which(!is.na(value) & (value != 0))
                ff.arg = list(list(idx = ii, weight = value[ii]))
            }

            names(ff.arg) = var
            f.arg[[k]] = ff.arg
        }
    }
    if (is.null(f.arg[[1]][[1]]))
        f.arg[[1]] = NULL

    lc = list(f.arg)
    names(lc) = "lc"

    return (lc)
}

`inla.make.lincombs` = function(...)
{
    ## this is the more general version, which constructs one lincomb
    ## for each row

    arg = match.call(expand.dots=TRUE)

    ## we might need to expand arguments?
    if (all(is.null(names(arg)))) {
        arg = eval(parse(text=arg[2]), envir = parent.frame(),
                enclos = environment(list(...)))
    }

    ## check that all 'rows' has the same lengths. store the evalued
    ## args in values[[.]]
    values = list()
    is.m = numeric(length(arg))
    n = -1
    for(k in 1:length(arg)) {
        if (names(arg)[k] != "") {
            values[[k]] = eval(arg[[k]], envir = parent.frame(),  enclos = environment(list(...)))
            if (is.matrix(values[[k]]) || is(values[[k]], "Matrix")) {
                if (is(values[[k]], "Matrix")) {
                    ## Make sure we have a dgTMatrix with unique representation:
                    values[[k]] = inla.as.dgTMatrix(values[[k]])
                }
                stopifnot(nrow(values[[k]]) == n || n < 0)
                n = nrow(values[[k]])
                is.m[k] = TRUE
            } else {
                stopifnot(length(values[[k]]) == n || n < 0)
                values[[k]][ is.na(values[[k]]) ] = 0
                n = length(values[[k]])
                is.m[k] = FALSE
            }
        }
    }
    ## make the nameing so it is the correct order, like lc001, lc002,
    ## ... etc.
    name = paste("lc", inla.num(1:n), sep="")

    ## create one lincomb for each row. faster if dynamic arrays are
    ## allocated upfront.
    lc = list()
    lc[[n]] = list

    if (TRUE) {

        ## this is the fast version, which is kind of ugly, therefore
        ## the ``slow'' code is below. we simply pass all additional
        ## arguments in the reminder of lapply. There is obviously
        ## something in the memory management of R that I don't
        ## understand....
        lc = lapply(1:n,
                function(idx, ...) {
                    ## preallocate
                    f.arg = list()
                    f.arg[[ length(arg) ]] = list
                    for(k in 1:length(arg)) {
                        if (names(arg)[k] != "") {
                            var = names(arg)[k]
                            if (is.m[k]) {
                                if (is(values[[k]], "dgTMatrix")) {
                                    row = inla.sparse.get(values[[k]], row=idx)
                                    ff.arg = list(list(idx = row$j, weight = row$values))
                                } else {
                                    value = values[[k]][idx,]
                                    ii = which(!is.na(value) & (value != 0))
                                    ff.arg = list(list(idx = ii, weight = value[ii]))
                                }
                            } else {
                                ff.arg = list(list(weight = values[[k]][idx]))
                            }
                            names(ff.arg) = var
                            f.arg[[k]] = ff.arg
                        }
                    }
                    ## the first might or might not be relevant
                    if (is.null(f.arg[[1]][[1]]))
                        f.arg[[1]] = NULL

                    return (f.arg)
                },
                arg=arg, is.m=is.m, values=values)
        names(lc) = name
    } else {

        ## this is the slow version for which the lapply-version is
        ## buildt upon.

        for(idx in 1:n) {

            f.arg = list()
            for(k in 1:length(arg)) {
                if (names(arg)[k] != "") {
                    var = names(arg)[k]
                    if (is.m[k]) {
                        value = values[[k]][idx,]
                        ii = which(!is.na(value) & (value != 0))
                        ff.arg = list(list(idx = ii, weight = value[ii]))
                    } else {
                        ff.arg = list(list(weight = values[[k]][idx]))
                    }
                    names(ff.arg) = var
                    f.arg = c(f.arg, ff.arg)
                }
                if (is.null(f.arg[[1]][[1]]))
                    f.arg[[1]] = NULL
            }
            lc[[idx]] = f.arg
            names(lc)[idx] = name[idx]
        }
    }

    return (lc)
}

`inla.uncbind` = function(A, name.prefix="col")
{
    ## given a matrix with colnames, expand this into
    ## list(a=c1, b=c2, ....)

    if (!is.matrix(A))
        return (NULL)

    result = list()

    ## it's easier to check names of the matrix upfront...
    rownames(A) = NULL
    if (is.null(colnames(A))) {
        colnames(A) =
            paste(name.prefix,
                  inla.num(1:ncol(A), width = inla.numlen(ncol(A))),
                  sep="")
    } else {
        ii = which(is.na(colnames(A)))
        if (length(ii) > 0) {
            colnames(A)[ii] = paste(name.prefix,
                               inla.num(ii, width = inla.numlen(ncol(A))),
                               sep="")
        }
    }

    if (TRUE) {
        ## this is the fast version
        tmp.result = apply(A, 2, function(x) list(x))
        result = sapply(tmp.result, function(x) c(x))
    } else {
        ## and this is the slow one
        for(icol in 1:ncol(A)) {
            ## extract each column and give it its name or 'column001' if
            ## its NULL.
            x = list(A[, icol])
            name = colnames(A)[icol]
            names(x) = name
            result = c(result, x)
        }
    }

    return (result)
}

`inla.unrbind` = function(A, name.prefix = "row")
{
    return (inla.uncbind(t(A), name.prefix = name.prefix))
}