R/mixComp.R

In mixAR: Mixture Autoregressive Models

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

setClass("MixComp",
         representation(m = "matrix"   ## numeric?
                        ), ## prototype, validity, access, where, version, sealed, package,
         )

## Currently, the methods assume that each column of `m' represents values for one component
## external functions should not use it, as I may change the internal representation.
#
# todo: write methods that return colwise or rowwise matrix.
#
# Group op may be usable but rhere is a difference here in the natural meaning of the
# multiplicative ops (*,/) and the additive ones (+,-).
#
# todo: Still, maybe could use ops with one of the meanings and define exceptions
#       individually.

setGeneric("mix_ncomp",
           function(x)
              standardGeneric("mix_ncomp"),
           useAsDefault = FALSE)

setMethod("mix_ncomp", signature(x = "MixComp"),
          function(x){
              ncol(x@m)
          })

setMethod("Math",                                             # 2012-11-09 new;
    signature(x = "MixComp"),
    function (x)
    {
        callGeneric(x@m)
    }
)

setMethod("-", signature(e1 = "MixComp", e2 = "missing"),  # 2012-11-09 new; unary "-"
          function(e1, e2) {
              wrk <-  - e1@m
              new("MixComp", m = wrk)
          })

setMethod("dim", signature(x = "MixComp"),
	  function(x) dim(x@m), valueClass = "integer")

setMethod("-", signature(e1 = "numeric", e2 = "MixComp"),
          function(e1, e2) {
              mc <- e2@m
              ## 2020-04-22 was: nrow(mc==1) - but that was certainly not the intent
              if(nrow(mc) == 1) ## special case
                  wrk <- e1 - matrix( rep(mc, length(e1)), ncol = ncol(mc), byrow = TRUE)
              else
                  wrk <-  e1 - e2@m                 # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("-", signature(e1 = "MixComp", e2 = "numeric"),
          function(e1, e2) {
              wrk <-  e1@m - e2                 # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("+", signature(e1 = "numeric", e2 = "MixComp"),
          function(e1, e2) {
              wrk <-  e1 + e2@m                 # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("+", signature(e1 = "MixComp", e2 = "numeric"),
          function(e1, e2) {
              wrk <-  e1@m + e2                 # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("*", signature(e1 = "MixComp", e2 = "numeric"),
          function(e1, e2) {
              wrk <-  t( t(e1@m) * e2 )         # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("*", signature(e1 = "numeric", e2 = "MixComp"),
          function(e1, e2) {
              wrk <-  t( e1 * t(e2@m) )         # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("*", signature(e1 = "MixComp", e2 = "MixComp"),    # 2011-07-20 new! todo: +,-,/
          function(e1, e2) {
              wrk <-  e1@m * e2@m
              new("MixComp", m = wrk)
          })


setMethod("/", signature(e1 = "MixComp", e2 = "numeric"),
          function(e1, e2) {
              wrk <-  t( t(e1@m) / e2 )         # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("/", signature(e1 = "numeric", e2 = "MixComp"),
          function(e1, e2) {
              wrk <-  t( e1 / t(e2@m) )         # relies on the recycling rule
              new("MixComp", m = wrk)
          })

setMethod("^",
    signature(e1 = "MixComp", e2 = "numeric"),
    function (e1, e2)
    {
        wrk <-  e1@m ^ e2                 # relies on the recycling rule
        new("MixComp", m = wrk)
    }
)

setMethod("*", signature(e1 = "function", e2 = "MixComp"),
          function(e1, e2) {
              wrk <- apply(e2@m, 1:2, e1)
              new("MixComp", m = wrk)
          })

setMethod("*", signature(e1 = "character", e2 = "MixComp"),  ## e1 = names of functions
          function(e1, e2) {
              if(length(e1)==1){
                  fchar <- e1
                  fun <- match.fun(fchar)
                  wrk <- apply(e2@m, 1:2, fun)
              }else{
                  wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
                  for(i in seq_len(ncol(e2@m))){
                      fchar <- e1[i]
                      fun <- match.fun(fchar)
                      wrk[, i] <- do.call(fun, list(e2@m[, i])) 
                  }
              }
              new("MixComp", m = wrk)
          })

"%of%" <- function(e1, e2) apply(e2, 1:2, e1)   ## e1 is function or name of one.

setGeneric("%of%")

# if do.call is used, then the function can be a string or the function itself,
# but it needs to be vectorised (which is the case for pdfs, cdfs, etc.).
#
setMethod("%of%", signature(e1 = "function", e2 = "MixComp"),
          function(e1, e2) {
              wrk <- apply(e2@m, 1:2, e1)               # todo: change to: wrk <- e1(e2@m) !!!
              new("MixComp", m = wrk)
          })

setMethod("%of%", signature(e1 = "character", e2 = "MixComp"),  ## e1 = names of functions
          function(e1, e2) {
              if(length(e1) == 1)
                  wrk <- apply(e2@m, 1:2, e1)  ## or, todo:(?)  do.call(e1, list(e2@m))
              else{
                  wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
                  for(i in seq_len(ncol(e2@m))){
                                  # this does not work: wrk[, i] <- apply(e2@m[, i], 1:2, e1[i])
                      fchar <- e1[i]
                      fun <- match.fun(fchar)
                      wrk[, i] <- do.call(fun, list(e2@m[, i]))
                  }
              }
              new("MixComp", m = wrk)
          })

setMethod("%of%", signature(e1 = "list", e2 = "MixComp"),  ## e1 = names of functions
          function(e1, e2) {
              if(length(e1)==1)
                  wrk <- apply(e2@m, 1:2, e1[[1]])  ## or, todo:(?)  do.call(e1, list(e2@m))
              else{
                  wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
                  for(i in seq_len(ncol(e2@m)))
                                  # this does not work: wrk[, i] <- apply(e2@m[, i], 1:2, e1[i])
                      wrk[, i] <- do.call(e1[[i]], list(e2@m[, i]))
              }
              new("MixComp", m = wrk)
          })

.mplus <- function(...){    # note: do.call("+", wrk) will not do since "+" is binary operator

       # 2017-05-02: edited
       # res <- 0           # todo: replace with apply(cbind(...), 1, sum) ?
       # for(cur in list(...))              # note: recycling will occur if lengths are different.
       #     res <- res + cur               # todo: maybe insert zeroes? Any of the two (res & cur)
       # res                                #       may be longer at a given moment.

    wrk <- list(...)
    if(length(wrk) == 0)
        0
    else{
        res <- wrk[[1]]
        for(cur in wrk[-1])
            res <- res + cur
        res
    }
}

inner <- function(x, y, star = "*", plus = .mplus){
    stopifnot(length(x) == length(y)) # new 2017-05-02

    star <-  match.fun(star)
    plus <-  match.fun(plus)

    wrk <- vector("list", length = length(x))
    for(i in seq_along(x))
        wrk[[i]] <- star(x[[i]], y[[i]])
    do.call(plus, wrk)
}

setGeneric("inner")

setMethod("inner", signature(x = "MixComp", y = "missing" , star = "missing", plus = "missing"),
          function(x){
              rowSums(x@m)
          })

## todo: define also as %*%?
setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "missing", plus = "missing"),
          function(x, y){
              drop(x@m %*% y)           # note that `drop', returns a vector.
          })

setMethod("inner", signature(x = "numeric", y = "MixComp",  star = "missing", plus = "missing"),
          function(x, y){
              drop(x %*% y@m)
          })

setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "ANY", plus = "missing"),
          function(x, y, star){
              star <-  match.fun(star)
              wrk <- x@m
              for(j in 1:ncol(wrk)){
                  b <- y[j]
                  wrk[, j] <- sapply(wrk[, j], star, b)
              }
              rowSums(wrk)
          })

setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "ANY", plus = "ANY"),
          function(x, y, star, plus){
              star <-  match.fun(star)
              wrk <- x@m
              for(j in 1:ncol(wrk)){
                  b <- y[j]
                  wrk[, j] <- sapply(wrk[, j], star, b)
              }

              if(identical(plus, "+"))  # todo: give warning here?
                  plus <- sum           # todo: ili da slozha tova v generic?
              apply(wrk, 1, plus)
          })

mixFilter <- function(x, coef, index, shift = 0, residual = FALSE, scale = 1){ ## todo: check the defaults!
    stop("Bosh: no default method for `mixFilter'")
}

setGeneric("mixFilter")

setMethod("mixFilter", signature(x = "numeric", coef = "raggedCoef", index = "numeric"),
          function(x, coef, index, shift = 0, residual = FALSE, scale = 1){
              ## Za shift razchita, che se retsiklira ako ne e vector.
              ## wrk <- mapply(raghat1, coef@a, shift=shift, MoreArgs=list(x=x, index=index))
                 # rezultatat se oachakva da e po edna kolonka za vsyaka komponenta.
                 # Note: coef@a is a list and `mapply' sends its elements wrapped in `list()'
                 #       (zatova slagam krapka v `raghat1')
              ## Ne, `mapply' ne varshi rabota - ne map-va coef@a a go predava kato edno
              ## tsyalo!
              ## krapka, todo: opravi!

              k <- length(coef@a)
              if(length(shift)==1)
                  shift <- rep(shift, k)

              if(length(scale)==1)
                  scale <- rep(scale, k)

              i <- 0
              for(flt in coef@a){
                  i <- i + 1
#cat("i =", i, ", flt = ", flt, "\n")
                  y <- raghat1(flt, x, index, shift[i], residual, scale[i])
#cat("y =", y, "\n\n")
                  if(i==1)
                      wrk <- y
                  else
                      wrk <- cbind(wrk, y)
              }
              new("MixComp", m = wrk)
          })

                                                      # 1st arg. is filter for use in sapply()
raghat1 <- function(filter, x, index, shift = 0, residual = FALSE, scale = 1){
    if(is.list(filter))               ## krapka, vzh. komentara pri mixFilter. todo: izchisti!
        filter <- filter[[1]]

    res <- rep(shift, length(index))
    for(i in seq_along(filter)){                  # expression x[index-i] assumes there are
        res <- res + filter[i]*x[index-i]         # enough past x's for all elements of index.
    }
    if(residual)
        res <- x[index] - res

    if(scale != 1)                               # probably meaningful only when residual=TRUE
        res <- res/scale
                             ## todo: kakto e tragnalo moga da dobavya i argument za cdf, etc.
#browser()
    res
}