# Arrays with arbitrary offsets

"Oarray" <-
function(data=NA, dim=length(data), dimnames=NULL, offset=NA,
  drop.negative=TRUE)
{
  if (is.na(offset))
    offset <- rep(1, length(dim))
  else {
    if (!is.numeric(offset) || length(offset)!=length(dim))
      stop("\"offset\" must be numeric vector with same length as \"dim\"")
    if (drop.negative && any(offset<0))
      stop("Non-negative offsets only")
  }
  robj <- array(data=data, dim=dim, dimnames=dimnames)
  attr(robj, "offset") <- offset
  attr(robj, "drop.negative") <- drop.negative
  class(robj) <- "Oarray"
  robj
}

"as.Oarray" <- function(x, offset=NA, drop.negative=TRUE)
{
  x <- as.array(x)
  dim <- dim(x)
  Oarray(x, dim(x), dimnames(x), offset, drop.negative)
}

"as.array.default" <- get("as.array", pos=grep("package:base",
  search()), mode="function")

"as.array" <- function(x, ...)
  UseMethod("as.array")

"as.array.Oarray" <- function(x)
{
  x <- unclass(x)
  attr(x, "offset") <- NULL
  attr(x, "drop.negative") <- NULL
  NextMethod(x)
}

"is.Oarray" <- function(x)
  inherits(x, "Oarray") && !is.null(attr(x, "offset")) &&
    !is.null(attr(x, "drop.negative"))

# this function takes numeric index sets from the original call
# and maps them using the offset: note that drop=FALSE only works
# if provided as the final argument

".handleTheOffset" <- function(mc, dim, offset, dn)
{
  for (i in seq(along=dim)) {
    ii <- mc[[2+i]]

    if (missing(ii)) next

    if (is.symbol(ii) || is.call(ii))
      ii <- eval.parent(ii, 3)

    if (is.numeric(ii)) {

      if (!dn || all(ii>=0))
        ii <- ifelse(ii>=offset[i], ii - offset[i] + 1, dim[i]+1)
      else {
        if (all(ii <= -offset[i]))
          ii <- ii + offset[i] - 1
        else stop("subscript out of bounds")
      }

      mc[[2+i]] <- ii
    }
  }
  mc
}

"[.Oarray" <- function(x, ...)
{
  mc <- match.call()
  k <- length(mc)
  offset <- attr(x, "offset")
  dn <- attr(x, "drop.negative")
  dim <- dim(x)

  if (k==3 && mc[[3]]=="")
    return(as.array(x))

  if (k < 2+length(dim))
    stop("incorrect number of dimensions")

  mc <- .handleTheOffset(mc, dim, offset, dn)
  mc[[1]] <- as.name("[")
  mc[[2]] <- as.name("x")
  x <- as.array(x)
  eval(mc)
}

"[<-.Oarray" <- function(x, ..., value)
{
  mc <- match.call()
  assign("mc", mc, envir=.GlobalEnv)
  k <- length(mc)
  offset <- attr(x, "offset")
  dn <- attr(x, "drop.negative")
  dim <- dim(x)

  if (k==4 && mc[[3]]=="")
    return(Oarray(value, dim, dimnames(x), offset, dn))

  if (k < 3+length(dim))
    stop("incorrect number of dimensions")

  mc <- .handleTheOffset(mc, dim, offset, dn)
  mc[[1]] <- as.name("[<-")
  mc[[2]] <- as.name("x")
  x <- as.array(x)
  robj <- eval(mc)
  Oarray(robj, dim, dimnames(x), offset, dn)
}

"print.Oarray" <-
function(x, ...)
{
  d <- dim(x)
  dn <- dimnames(x)
  if (is.null(dn))
    dn <- vector("list", length(d))
  offset <- attr(x, "offset")
  x <- as.array(x)

  for (i in seq(along=dn))
    if (is.null(dn[[i]])) {
      dn[[i]] <- 0:(d[i]-1) + offset[i]
      if (i==1 || i==2) {
        wd <- nchar(dn[[i]])
        dn[[i]] <- formatC(dn[[i]], format="d", width=max(wd))
        if (i==1)
          dn[[i]] <- paste("[", dn[[i]], ",]", sep="")
        else
          dn[[i]] <- paste("[,", dn[[i]], "]", sep="")
      }
    }
  dimnames(x) <- dn
  NextMethod("print")
}
