R/access.R

In tfojo1/jheem: Executes the JHEEM (Johns Hopkins Epidemiological and Economic Model) - a compartmental model of HIV

##-- DIMENSION INDICES --##
## I am not actually using these anywhere right now


AGE = 1
RACE = 2
SUBPOPULATION = 3
SEX = 4
RISK = 5
NON.HIV.SUBSET = 6
CONTINUUM.IN.HIV = 6
CD4.IN.HIV = 7
HIV.SUBSET.IN.HIV = 8
CONTINUUM.IN.ALL = CONTINUUM.IN.HIV+1
CD4.IN.ALL = CD4.IN.HIV+1
HIV.SUBSET.IN.ALL = HIV.SUBSET.IN.HIV+1


##--------------------------##
##-- THE ACCESS FUNCTIONS --##
##--------------------------##

#'@title Read access population or transition arrays generated by JHEEM by dimension names
#'
#'@family functions to access JHEEM arrays
#'
#'@param arr An array generated by a \code{\link{jheem-class}} object, usually by a call to get.XXX.skeleton (eg  \code{\link{get.population.skeleton}} or \code{\link{get.transition.array.skeleton.hiv.negative}})
#'@param age,race,subpopulation,sex,risk,non.hiv.subset,continuum,cd4,hiv.subset,age.from,race.from,subpopulation.from,sex.from,risk.from,non.hiv.subset.from,continuum.from,cd4.from,hiv.subset.from,age.to,race.to,subpopulation.to,sex.to,risk.to,non.hiv.subset.to,continuum.to,cd4.to,hiv.subset.to For each possible array dimension, the values within that dimension (either numeric indices or character names) to subset
#'@param collapse.length.one.dimensions If false, even if a dimension in the return value only has length one, it will be preserved in the return value. If true, length one dimensions are removed (as with normal array subsetting)
#'
#'@export
access <- function(arr,
                   age=NULL, race=NULL, subpopulation=NULL, sex=NULL, risk=NULL, non.hiv.subset=NULL, continuum=NULL, cd4=NULL, hiv.subset=NULL,
                   age.from=NULL, race.from=NULL, subpopulation.from=NULL, sex.from=NULL, risk.from=NULL, non.hiv.subset.from=NULL, continuum.from=NULL, cd4.from=NULL, hiv.subset.from=NULL,
                   age.to=NULL, race.to=NULL, subpopulation.to=NULL, sex.to=NULL, risk.to=NULL, non.hiv.subset.to=NULL, continuum.to=NULL, cd4.to=NULL, hiv.subset.to=NULL,
                   year=NULL,
                   collapse.length.one.dimensions=T)
{
    #Pull out the dimension names
    access.dims = list(age=age, race=race, subpopulation=subpopulation, sex=sex, risk=risk, non.hiv.subset=non.hiv.subset, continuum=continuum, cd4=cd4, hiv.subset=hiv.subset,
                       age.from=age.from, race.from=race.from, subpopulation.from=subpopulation.from, sex.from=sex.from, risk.from=risk.from, non.hiv.subset.from=non.hiv.subset.from, continuum.from=continuum.from, cd4.from=cd4.from, hiv.subset.from=hiv.subset.from,
                       age.to=age.to, race.to=race.to, subpopulation.to=subpopulation.to, sex.to=sex.to, risk.to=risk.to, non.hiv.subset.to=non.hiv.subset.to, continuum.to=continuum.to, cd4.to=cd4.to, hiv.subset.to=hiv.subset.to,
                       year=year)
    access.dims = access.dims[!sapply(access.dims, is.null)]

    #Check to make sure they're all contained in the array
    check.access.names(arr, access.dims)

    #Set up the new dimnames for the return value
    new.dim.names = dimnames(arr)
    for (change.dim in names(access.dims))
    {
        if (class(access.dims[[change.dim]])=='character')
            new.dim.names[[change.dim]] = access.dims[[change.dim]]
        else
            new.dim.names[[change.dim]] = dimnames(arr)[[change.dim]][access.dims[[change.dim]]]
    }

    if (collapse.length.one.dimensions)
        new.dim.names = new.dim.names[sapply(new.dim.names, length) > 1]

    #Subset the array
    arr = arr[get.access.indices(arr, access.dims)]

    #hydrate up the dimensions and return
    if (length(new.dim.names)>0)
    {
        dim(arr) = sapply(new.dim.names, length)
        dimnames(arr) = new.dim.names
    }
    arr
}


#'@title Write access population or transition arrays generated by JHEEM by dimension names
#'
#'@family functions to access JHEEM arrays
#'
#'@inheritParams access
#'@param value The value to overwrite the array subset with. If dimnames(value) is not null, access<- will overwrite the values in arr such that the dimnames of the subset of arr being overwritten match with the dimnames of value
#'
#'@export
'access<-' = function(arr,
                      age=NULL, race=NULL, subpopulation=NULL, sex=NULL, risk=NULL, non.hiv.subset=NULL, continuum=NULL, cd4=NULL, hiv.subset=NULL,
                      age.from=NULL, race.from=NULL, subpopulation.from=NULL, sex.from=NULL, risk.from=NULL, non.hiv.subset.from=NULL, continuum.from=NULL, cd4.from=NULL, hiv.subset.from=NULL,
                      age.to=NULL, race.to=NULL, subpopulation.to=NULL, sex.to=NULL, risk.to=NULL, non.hiv.subset.to=NULL, continuum.to=NULL, cd4.to=NULL, hiv.subset.to=NULL,
                      year=NULL,
                      value)
{
    #Pull out the dimension names
    access.dims = list(age=age, race=race, subpopulation=subpopulation, sex=sex, risk=risk, non.hiv.subset=non.hiv.subset, continuum=continuum, cd4=cd4, hiv.subset=hiv.subset,
                       age.from=age.from, race.from=race.from, subpopulation.from=subpopulation.from, sex.from=sex.from, risk.from=risk.from, non.hiv.subset.from=non.hiv.subset.from, continuum.from=continuum.from, cd4.from=cd4.from, hiv.subset.from=hiv.subset.from,
                       age.to=age.to, race.to=race.to, subpopulation.to=subpopulation.to, sex.to=sex.to, risk.to=risk.to, non.hiv.subset.to=non.hiv.subset.to, continuum.to=continuum.to, cd4.to=cd4.to, hiv.subset.to=hiv.subset.to,
                       year=year)
    access.dims = access.dims[!sapply(access.dims, is.null)]

    #Check to make sure they're all contained in the array
    check.access.names(arr, access.dims)

    #If the value to overwrite with has dimnames set
    # make sure the value dimnames conform to the subset we're going to overwrite
    if (!is.null(dimnames(value)))
    {
        #Set up the dimnames for the value to overwrite
        overwrite.dim.names = dimnames(arr)
        for (change.dim in names(access.dims))
        {
            if (class(access.dims[[change.dim]])=='character')
                overwrite.dim.names[[change.dim]] = access.dims[[change.dim]]
            else
                overwrite.dim.names[[change.dim]] = dimnames(arr)[[change.dim]][access.dims[[change.dim]]]
        }
        overwrite.dim.names = overwrite.dim.names[!is.null(overwrite.dim.names)]

        value = expand.population(value, overwrite.dim.names,
                                  non.conforming.error = "The dimnames of value are not a subset of the dimnames of the portion of arr to be overwritten")
    }

    #Overwrite the subset
    arr[get.access.indices(arr, access.dims)] = value

    #Return
    arr
}

##--------------------------------------##
##-- HELPERS FOR THE ACCESS FUNCTIONS --##
##--------------------------------------##

#Helper
# returns a vector of indices where the dimensions listed in access.dims match
#'@export
get.access.indices <- function(arr, access.dims, dim.names=dimnames(arr))
{
    dims = sapply(dim.names, length)
    if (length(access.dims)==0)
        return (rep(T, prod(dims)))

    #map access dims to numbers
    access.names = names(access.dims)
    to.access = lapply(names(dim.names), function(name){
        if (any(access.names==name))
        {
            if (is(access.dims[[name]],'character'))
            {
                indices = 1:(dims[name])
                names(indices) = dim.names[[name]]
                indices[access.dims[[name]]]
            }
            else if (is(access.dims[[name]],'logical'))
            {
                indices = 1:(dims[name])
                indices[access.dims[[name]]]
            }
            else
                as.integer(access.dims[[name]])
        }
        else
            1:dims[name]
    })

    #call the cpp helper
    do_get_access_indices(dims=dims,
                          to_access=to.access) + 1
}

#Helper
# checks to make sure the arrays are appropriately named for use of the access functions
check.access.names <- function(arr, access.dims)
{
    if (is.null(dimnames(arr)) || is.null(names(dimnames(arr))))
        stop('The access function can only be called on an array whose dimnames are named')

    #    if (length(access.dims)==0)
    #       stop('At least one dimension by which to subset the array must be specified')

    missing.names = setdiff(names(access.dims), names(dimnames(arr)))
    if (length(missing.names)==1)
        stop(paste0("There is no dimension in the given array with name '", missing.names[1], "'"))
    else if (length(missing.names)>0)
        stop(paste0("There are no dimensions in the given array with names: ", paste0(paste0("'", missing.names, "'"), collapse=", ")))

    sapply(names(access.dims), function(name){
        if (class(access.dims[[name]])=='character')
        {
            missing.dim.names = setdiff(access.dims[[name]], dimnames(arr)[[name]])
            if (length(missing.dim.names)==1)
                stop(paste0("'", missing.dim.names[1], "' is not a valid name for the ", name, " dimension"))
            else if (length(missing.dim.names)>0)
                stop(paste0("The following are not valid names for the ", name, " dimension: ", paste0(paste0("'", missing.dim.names, "'"), collapse=', ')))
        }
        else
        {
            missing.dim.indices = setdiff(access.dims[[name]], 1:(dim(arr)[name]))
            if (length(missing.dim.indices)==1)
                stop(paste0("'", missing.dim.indices[1], "' is not a valid index for the ", name, " dimension"))
            else if (length(missing.dim.indices)>0)
                stop(paste0("The following are not valid indices for the ", name, " dimension: ", paste0(paste0("'", missing.dim.indices, "'"), collapse=', ')))
        }
        1 #the return value doesn't matter
    })
}