R/trefoil-class.R

In pik-piam/trefoil: Trefoil Class Functions

setClass("trefoil",representation(description = "character", units = "character"),contains="array",prototype=prototype(array(0,c(0,0,0)),units="-",description=c("bla","new trefoil object")))

a <- new("trefoil",array(1:6,dim=c(3,2,1),dimnames=list(c("AFR","EUR","NAM"),c(1990,1995),"bla.blub")),description="testobjekt",units="m^2")

.dimextract <- function(x,i,dim,sep=".") {
  sep <- .escapeRegex(sep)
  tmp <- lapply(paste("(^|",sep,")",.escapeRegex(i),"(",sep,"|$)",sep=""),grep,dimnames(x)[[dim]])
  if(any(vapply(tmp,length,length(tmp))==0)) stop("Data element(s) \"",paste(i[vapply(tmp,length,length(tmp))==0],collapse="\", \""),"\" not existent in trefoil object!")
  return(unlist(tmp))
}

setMethod("[",
    signature(x = "trefoil"),
    function (x, i, j, k, drop=FALSE) 
    {
        if(!missing(i)) if(is.character(i)) i <- .dimextract(x,i,1)
        if(!missing(j)) {
          if(is.numeric(j) & any(j>dim(x)[2])) j <- paste("y",j,sep="")
          else if(is.null(j)) j <- 1:dim(x)[2]
          if(is.character(j)) j <- .dimextract(x,i,2)
        }
        if(!missing(k)) if(is.character(k)) k <- .dimextract(x,k,3)
        if(ifelse(missing(i),FALSE,is.array(i) | any(abs(i)>dim(x)[1]))) {
          #indices are supplied as array, return data as numeric
          return(x@.Data[i])
        } else if(missing(j) & ifelse(missing(k),TRUE,is.logical(k)) & ifelse(missing(i),FALSE,all(abs(i)<=dim(x)[1]))) {
          if(length(x@.Data[i,j,k,drop=FALSE])==0) {
            return(x@.Data[i])
          }
        }     
        x@.Data <- x@.Data[i,j,k,drop=FALSE]
        return(x)
        
    }
)

setMethod("[<-",
          signature(x = "trefoil"),
          function (x, i, j, k, value) 
          {       
            if(!missing(i)) if(is.character(i)) i <- .dimextract(x,i,1)
            if(!missing(j)) {
              if(is.numeric(j) & any(j>dim(x)[2])) j <- paste("y",j,sep="")
              else if(is.null(j)) j <- 1:dim(x)[2]
              if(is.character(j)) j <- .dimextract(x,i,2)
            }
            if(!missing(k)) if(is.character(k)) k <- .dimextract(x,k,3)
            if(missing(value)) {
              x@.Data[i] <- k 
              return(x)
            } else {
              if(is.trefoil(value)){
                if(missing(i)) ii <- 1:dim(x)[1] else ii <- i
                if(missing(j)) jj <- 1:dim(x)[2] else jj <- j
                if(missing(k)) kk <- 1:dim(x)[3] else kk <- k
                value <- trefoil_expand(value,x[ii,jj,kk])    
              } else if(length(value)!=length(x@.Data[i,j,k]) & length(value)!=1) {
                #dangerous writing of value as order might be wrong! 
                stop("Replacement does not work! Different replacement length!")
              } else if(length(value)!=1) {
                if(getOption("trefoil.verbosity")>1) cat("NOTE ([<-): Dangerous replacement! As replacement value is not an trefoil object name checking is deactivated!\n")
              }
              x@.Data[i,j,k] <- value
              return(x)
            }
          }
)