hsloot / rmo

An R package for Marshall--Olkin distributions and copulas.
https://hsloot.github.io/rmo/
GNU General Public License v3.0
5 stars 2 forks source link

[FEATURE] Add S4 methods to create `intensities`, `ex_intensities` and `qmatrix` #83

Closed hsloot closed 3 years ago

hsloot commented 3 years ago

Summary

The package should provide S4 methods to create either an intensities vector, an ex_intensities vector or the Markov intensity matrix qmatrix.

Possible implementation

## valueOf-S4.R

setGeneric("intensities", 
  function(object, d, ...) {
    standardGeneric("intensities")
  })

setGeneric("exIntensities", 
  function(object, d, ...) {
    standardGeneric("exIntensities")
  })

setGeneric("exQMatrix", 
  function(object, d, ...) {
    standardGeneric("exQMatrix")
  })

setMethod("intensities", "BernsteinFunction",
  function(object, d, ...) {
    tmp <- sapply(1:d, function(i) valueOf(object, d-i, i, ...))
    out <- numeric(2^d-1)
    for (j in seq_along(out)) {
      count <- 0
      for (i in 1:d) {
        count <- count + Rcpp__is_within(i, j)
      }
      out[j] <- tmp[count]
      }

  out
  })

setMethod("exIntensities", "BernsteinFunction", 
  function(object, d, ...) {
    sapply(1:d, function(i) valueOf(object, d-i, i, n = d, k = i))
  })

setMethod("exQMatrix", "BernsteinFunction", 
  function(object, d, ...) {
    out <- matrix(0, nrow = d+1, ncol = d+1)
    out[1, -1] <- exIntensities(object, d, ...)
    for (i in 1:d) {
      if (i < d) {
        for (j in (i+1):d) {
          out[1+i, 1+j] <- (d-j+1)/(d-i+1) * out[i, j] + (j+1-i) / (d-i+1) * out[i,j+1]
        }
      }
    }
    diag(out) <- -apply(out, 1, sum)

    out
  })