R/as.trefoil.R

In pik-piam/trefoil: Trefoil Class Functions

setGeneric("as.trefoil", function(x,...)standardGeneric("as.trefoil"))

setMethod("as.trefoil",signature(x = "trefoil"),function (x) return(x))

setMethod("as.trefoil",
    signature(x = "array"),
    function (x, spatial=NULL, temporal=NULL)
    {
      
      # Add the sets as name to the dimnames, if existent
      if(is.null(names(dimnames(x))) & !is.null(attr(x,"sets"))){
        tmp<-dimnames(x)
        names(tmp)<-attr(x,"sets")
        dimnames(x)<-tmp
      }
      #This part of the function analyses what structure the input has
      d <- list()  #list of dimension types found in the array
      if(!is.null(temporal)) d$temporal <- temporal
      if(!is.null(spatial)) d$regiospatial <- spatial
      for(i in 1:length(dim(x))) {
        if(!is.null(dimnames(x)[[i]])) {
          if(is.null(spatial)) {
            if(length(grep("^(([A-Z]{3})|(glob))$",dimnames(x)[[i]]))==dim(x)[i])    d$regional <- c(d$regional,i)  #regional information
            if(length(grep("^[A-Z]+[\\._][0-9]+$",dimnames(x)[[i]]))==dim(x)[i]) d$regiospatial <- c(d$regiospatial,i)  #regio-spatial information
          }
          if(is.null(temporal)) {
            if(length(grep("^[a-z]?[0-9]{4}$",dimnames(x)[[i]]))==dim(x)[i])     d$temporal <- c(d$temporal,i) #temporal information
          }
        } else if(dim(x)[i]==1)                                         d$nothing <- c(d$nothing,i)   #dimension with no content    
      }  
      
      #Write warning when any type (except type "nothing") is found more than once
      tmp <- lapply(d,length)>1; tmp <- tmp[names(tmp)!="nothing"]
      if(any(tmp)==TRUE) warning("No clear mapping of dimensions to dimension types. First detected possibility is used!") 
      
      #If a regional dimension exists, test whether "glob" appears in the dimnames and rename it with "GLO"
      if(!is.null(d$regional)) {
        for(i in d$regional) {
          dimnames(x)[[i]] <- sub("^glob$","GLO",dimnames(x)[[i]])
        }
      }
      
      #make sure that temporal dimension uses dimnames of the form y0000
      if(!is.null(d$temporal)) {
        for(i in d$temporal) {
          dimnames(x)[[i]] <- sub("^[a-z]?([0-9]{4})$","y\\1",dimnames(x)[[i]])
        } 
      }
      
      #make sure that spatial dimension uses dimnames of the form XXX.123
      if(!is.null(d$regiospatial)) {
        for(i in d$regiospatial) {
          dimnames(x)[[i]] <- sub("_","\\.",dimnames(x)[[i]])
        } 
      }
      
      
      #If no temporal dimension is defined, but a dimension of type nothing exists, use this dimension as temporal dimension  
      if(is.null(d$temporal)) {
        if(length(d$nothing)>0) {
          d$temporal <- d$nothing[1]
          d$nothing <- d$nothing[-1]
          if(length(d$nothing)==0) d$nothing <- NULL
        } else {
          d$temporal <- 0
        }
      }  

      #try to create regiospatial dimension if possible
      if(is.null(d[["regiospatial"]])) {        
          #regional dimension exists
        if(!is.null(d$regional))  {
          dimnames(x)[[d$regional]] <- paste(dimnames(x)[[d$regional]],1:dim(x)[d$regional],sep=".")
          d$regiospatial <- d$regional
        } else {       
          d$regiospatial <- 0
        }
      }
      d$regional <- NULL
      
      #Starting from here d$temporal and d$regiospatial should be defined both
      #If any of these two could neither be found nor created the value should be 0  
      
      if(d$regiospatial==0) {
        if(is.null(dimnames(x))) { 
          x <- array(x,c(dim(x),1))
          dimnames(x)[[length(dim(x))]] <- list("GLO.1")
        } else {
          x <- array(x,c(dim(x),1),c(dimnames(x),"GLO.1"))        
        }
        d$regiospatial <- length(dim(x))
      }
      
      if(d$temporal==0) {
        x <- array(x,c(dim(x),1),c(dimnames(x),NULL))
        d$temporal <- length(dim(x))     
      }
      
      #Check if third dimension exists. If not, create it
      if(length(dim(x))==2) {
        x <- array(x,c(dim(x),1),c(dimnames(x),NULL))
      }
      
      #Now temporal and regiospatial dimension should both exist
      #Return trefoil object
      return(trefoilsort(new("trefoil",wrap(x,list(d$regiospatial,d$temporal,NA)))))
    }
)

setMethod("as.trefoil",
    signature(x = "numeric"),
    function(x)
    {
      return(as.trefoil(as.array(x)))
    }
)

setMethod("as.trefoil",
    signature(x = "NULL"),
    function (x)
    {
      return(NULL)
    }
)

setMethod("as.trefoil",
          signature(x = "data.frame"),
          function (x, datacol=NULL, ...)
          {
            if(is.null(datacol)) {
              for(i in dim(x)[2]:1) {
                if(all(!is.na(suppressWarnings(as.numeric(x[,i]))))) {
                  datacol <- i
                } else {
                  break 
                }
              }
            }
            if(is.null(datacol)) stop("Could not convert dataframe to trefoil object. No data column found!")
            if(datacol==1) return(as.trefoil(as.matrix(x),...))
            dimnames<-list()
            dim<-NULL
            for (i in 1:(datacol-1)){
              dimnames[[i]]<-unique(x[,i])
              dim<-c(dim,length(dimnames[[i]]))
            }
            dimnames[[datacol]]<-dimnames(x)[[2]][-(1:(datacol-1))]
            dim<-c(dim,length(dimnames[[datacol]]))
            out<-array(NA,dim=dim,dimnames=dimnames)
            a <- suppressWarnings(as.matrix(cbind(x[,1:(datacol-1)],rep(dimnames(out)[[datacol]],each=dim(x)[1]))))
            out[a] <- as.vector(as.matrix(x[,datacol:dim(x)[2]]))
            return(as.trefoil(out,...))
          }
)