R/raggedCoef.R

In GeoBosh/mixAR: Mixture Autoregressive Models

## Do not edit this file manually.
## It has been automatically generated from *.org sources.

ragged2char <- function(raglist, filler = NA_character_){
    p <- sapply(raglist, length)
    pmax <- max(p)

    mat <- sapply(raglist, function(x) c(x, rep(0, max(0,pmax-length(x)))))
    mat <- if(pmax ==1) matrix(mat, ncol = 1)
           else        t(mat)
    mat <- apply(mat, 2, function(x) format(x, width = 3))

    for(i in seq_along(raglist))
        if(p[i] < pmax)
            mat[i, (p[i]+1):pmax] <- filler  # 2012-11-03 was: NA_character_

    mat
}

setClass("raggedCoef",
         slots = c(a = "list", p = "numeric"),
         validity = function(object){              # the current validity check is very basic.
             if(length(object@a) != length(object@p))
                 "slot `p' should have the same length as slot `a'"
             else
                 TRUE
         }
         )

setMethod("show", "raggedCoef",
          function(object) {
              cl <- class(object)
              p <- max(object@p)

              cat("An object of class \"", cl, "\"\n", sep = "")
              cat("Number of rows:", length(object@p), "\n")
              cat("Components' lengths:", object@p, "\n")
              cat("\n")
              if(p > 0){
                  mcoef <- ragged2char(object@a)
                  rownames(mcoef) <- paste("Component_", 1:nrow(mcoef), sep = "")
                  colnames(mcoef) <- paste("co_", seq_len(p), sep = "")

                  print(mcoef, na.print = "", quote = FALSE)
                  cat("\n")
                  ## 2018-11-03 commenting out, was:
                  ##     str(object)
              }else
                  cat("All components are of length 0.\n")

              invisible(object)
	  })

.init_warn <-  "When the coef are in a list, other arguments are ignored."
.init_wrong_args <- "Wrong arguments for raggedCoef initialization."

                   ## Ne slagam argumenti `a' i `p' ponezhe ako chovek reshi da dade imenuvani
                   ## elementi za @a toy ne bi tryabvalo da se trevozhi, che imenata im mozhe
                   ## da savpadat s vatreshni imena na slot-ove v raggedCoef.
                   ##
                   ## 2012-12-03 ako ima tochno dva argumenta i te sa "a" and "p"
                   ##            prosto gi izpolzvam, ponezhe ne e chubavo da ne mozhe da se
                   ##            sazdade obektat po negovite slotove.
                   ##  TODO: dokumentiray!
setMethod("initialize", "raggedCoef",
          function(.Object, ...) {
              wrk <- list(...)
              nams <- names(wrk)
              if(length(wrk) == 2  && !is.null(nams) && "a" %in% nams && "p" %in% nams){
                  .Object@a <- wrk[["a"]]
                  .Object@p <- wrk[["p"]]
                  # todo: check for validity?
              }else if(length(wrk) > 0 && inherits(wrk[[1]], "list")){
                  .Object@a <- wrk[[1]]
                  if(length(wrk) >= 2)
                      warning(.init_warn)
              }else{
                  numq <- sapply(wrk, is.numeric)
                  if(all(numq))
                      .Object@a <- wrk
                  else
                      stop(.init_wrong_args)
              }

              .Object@p <- if(length(.Object@a) > 0)
                               sapply(.Object@a, length)
                           else
                               numeric(0)
              .Object
          }
          )

raggedCoef <- function(p, value = NA_real_){         # create raggedCoef objects
    if(missing(value) && is.list(p))
        return( new("raggedCoef", p) )
        
    res <- if(is(value, "raggedCoef")){
               value
           }else if(is.list(value)){
               new("raggedCoef", value)
           }else if(length(value) == 1){
               value <- lapply(p, function(x) rep(value, x))
               new("raggedCoef", value)
           }else{
               one2n <- seq_len(sum(p))
               wrk <- do.call("+",  lapply(head(cumsum(p),-1), function(x) one2n > x))
               value <- lapply(seq_along(p) - 1, function(x) value[wrk == x])
               new("raggedCoef", value)
           }
    if(!missing(p)  &&  !all(res@p == p))
        stop("The value of raggedCoef does not match the order.")
    res
}

setMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "missing"),                          # "[["
          function(x, i, j, ...) {
              x@a[[i,...]]
          })

setMethod("[[", signature(x = "raggedCoef"),
          function(x, i, j) {
                # 2012-11-03 was: x@a[[i,j,...]] - tova vinagi dava greshka (may)!  this
                #    operation makes sense for taking a single element.
              x@a[[i]][[j]]
          })

## todo: Mozhe da ima nuzhda ot fuktsiya podobna na "[", no zapalvasta strukturnite nuli s NA.
##         Tova e nay-dobre da stane kato dobavya dopalnitelen argument tuk,
##         no za tazi tsel tryabva da proucha dali tova e dopustimo.

## Here, by definition the methods for "[" treat the ragged array as a matrix,
##   so the behaviour should replicate that for "matrix". (or should it?)
##
## Exception Initially I thought it a good idea to make calls with `i' only, like x[2] or
##            x[1:2], equivalent to x[2,] and x[1:2,].  Then I abandoned this idea.
##            Eventually I made x[2,] and x[2] equivalent since the trouble of making them
##            behave differently seemed not worth the effort (see the comments in the method
##            with j missing).
##
## Further to the above, there is a difference between x[[2]] and x[2,]. Both choose the
## second component but `[[' extracts it with its natural length, while `[' pads it with
## zeroes to the longest component in the object.
##
setMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing"),                   # "[", []
          function(x, i, j, ..., drop) {
              nr <- length(x@p)
              nc <- max(0,x@p)                 ## 0 avoids getting -Inf if x@p is of length 0.

              res <- matrix(rep(0,nr*nc), nrow = nr, ncol = nc) # use of rep() is paranoic,
                                                         # to cater for the case nr=0 and nc=0
              for(k in seq_len(nr)){
                  r <- x@a[[k]]
                  res[k,seq_along(r)] <- r     ## dali raboti ako p[k]==0?   todo: Check !!!
              }
              res
          })

setMethod("[", signature(x = "raggedCoef",i = "numeric",j = "missing"),
          function(x, i, j, ..., drop) {   # x[2] and x[2,] both are dispatched by this method
                                           # since j is `missing' but nargs() is different.
                                           #    cat("nargs:", nargs(),"\n"); print(missing(j))
                                  # So, to implement different behaviour for these cases I
                                  # need to check here nargs() as well, not worth the trouble.

                         # x[][i, ..., drop=drop]
                         # todo: check !!! ako `...' e prazen i drop e missing, dali call-at e
                         #  ekvivalenten na [i] ili [i,]?  Otgovor: [i] pri vsyako polozhenie!

                       ## todo: A function arg_implied() may be of interest here since similar
                       ##       problems arise in other situations of this sort.

              x[][i, , ..., drop = drop] # tozi variant e ako iskam x[i] da e kato x[i,]
          })

setMethod("[", signature(x = "raggedCoef", i = "missing", j = "numeric"),
          function(x, i, j, ..., drop) {
              x[][ ,j, ..., drop = drop]
          })

setMethod("[", signature(x = "raggedCoef",i = "numeric",j = "numeric"),
          function(x, i, j, ..., drop) {
              x[][i,j, ..., drop = drop]
          })

                                                     # 2012-11-03 dobavyam assignment methods

                                             # todo: "ANY" in the methods below should really
                                             #       be "numeric" or more carefully specified.
                                                                                      # "[[<-"
setReplaceMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "numeric"),
          function(x, i, value) {
              if(length(value) != x@p[i])
                  stop("Replacement  value must have the same length as the current value.")
              x@a[[i]] <- value
              x
          })

setReplaceMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "ANY", value = "numeric"),
          function(x, i, j, value) {
              x@a[[c(i,j)]] <- value   # x@a[[i]][[j]] <- value
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "ANY", value = "numeric"),
          function(x, i, j, value) {
              x@a[[c(i,j)]] <- value   # x@a[[i]][[j]] <- value
              x
          })
                                                                                       # "[<-"
setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "list"),
          function(x, i, value) {
              if(!all(x@p[i] == sapply(value, length)))
                  stop("The length of raggedCoef objects cannot be changed by replacement.")
              for(r in seq_along(i))
                  x@a[[ i[r] ]] <- value[[r]]
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY", j = "missing", value = "matrix"),
          function(x, i, value) {
              p <- x@p
              if(ncol(value) < max(p[i]))
                  stop("Right-hand side must have at least max(x@p[i]) columns.")
              for(r in seq_along(i))
                  x@a[[ i[r] ]] <- value[i[r], seq_len(p[i[r]])] # 2020-03-28 was: ... value[i, ...
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "numeric"),
          function(x, i, value) {     # here i should be of length one.
              p <- x@p
              if(length(value) < p[i])
                  stop("Right-hand side must have at least p[i] elements.")
              x@a[[ i ]] <- value[seq_len(p[i])]
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "list"),  # []
          function(x, value) {
              if(!all(x@p == sapply(value, length)))
                  stop("Replacement value should be consistent with the current one.")
              x@a <- value
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "matrix"),# []
          function(x, value) {
              p <- x@p
              if(ncol(value) < max(p))
                  stop("Right-hand side must have at least max(p) columns.")

              for(k in seq_along(p))
                  x@a[[k]] <- value[k, seq_len(p[k])]
              x
          })

setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "numeric"),#[]
          function(x, value) {
              if(length(value) != sum(x@p))
                  stop("Wrong length of right-hand side.")
              rag_modify(x,value)
          })

## TOOD: ensure that the results are integer (max(x@p) for dim()
setMethod("length", signature(x = "raggedCoef"), function(x) sum(x@p))
setMethod("dim", signature(x = "raggedCoef"), function(x) c(length(x@a), max(x@p)) )

## setMethod("dimnames", signature(x = "raggedCoef"), function(x) ???)

setMethod("anyNA", signature(x = "raggedCoef"), function(x) anyNA(x@a, recursive = TRUE))

                                                 # 2012-11-03 rename from ragvec to ragged2vec
ragged2vec <- function(x){   # return the ragged coefficients as a vector (a "flatten" op.)
    do.call("c",x@a)      # todo: better is(?) unlist(x@a)
}

rag_modify <- function(rag,v){            ## modify the coefficients using a vector
    wrk <- rag@a                          ## (barza krapka, nuzhdae se ot po-dobro obmislyane)
    p <- rag@p
    index <- 0
    for(i in seq_along(p)){ # 2011-07-11           # todo:
        wrk[[i]] <- v[index + seq_len(p[i])]       # c(1,cumsum(p))
        index <- index + p[i]                      # use relist()  ?
    }                                              #    vhz. sasto okolo one2n in raggedCoef()
    rag@a <- wrk
    rag
}

                                                           # todo: dali da machna row_lengths?
row_lengths <- function(x){ ## basically, x is a list here.
    ## 2020-03-28 was: sapply(x,length)
    lengths(x)
}
setGeneric("row_lengths")
setMethod("row_lengths", signature(x = "raggedCoef"),
          function(x){
              x@p
          })

## 2012-11-03 macham; nikoga ne e izpolzvana + trudno ime.
## row_maxlength <- function(x){  ## should work whenever row_lengths is sensible.
##     max(row_lengths(x))
## }