R/SphericalDistribution.R

In distrEllipse: S4 Classes for Elliptically Contoured Distributions

## Generating function

SphericalDistribution <- function(radDistr = sqrt(Chisq(df=dim)), dim = 2,
                                  p = NULL, q = NULL){
   ell <- EllipticalDistribution(radDistr = radDistr,
               loc = numeric(dim), scale = diag(dim), p = p, q = q)
   sph <- as(ell, "SphericalDistribution")
   sph@Symmetry <- SphericalSymmetry(SymmCenter(Symmetry(ell)))
   sph
   }

## accessors

setMethod("dimension", "SphericalDistribution",
           function(object) dimension(object@img))
setMethod("dim", "SphericalDistribution",
           function(x) dimension(x@img))

setMethod("radDistr", "SphericalDistribution",
           function(object) object@radDistr)

setMethod("scale", "SphericalDistribution",
           function(x,  center, scale) as.matrix(diag(dimension(x))))

setMethod("location", "SphericalDistribution",
           function(object) numeric(dimension(object)))

#not necessary:
##setMethod("Symmetry", "SphericalDistribution", function(object) object@Symmetry)

## replacements

setReplaceMethod("radDistr", "SphericalDistribution",
           function(object,value){
              if(!is(value,"UnivariateDistribution"))
                  stop("RHS must be a univariate Distribution")
              if(p.l(value)(0)>0)
                 stop("RHS must have pos. support")
              object@radDistr <- value
              object }
           )

## wrappers:

## Defunct accessors
#setMethod("plot.rd", "SphericalDistribution",
#           function(x, ... ){ .Deprecated("plotRd")
#                              plot(x@radDistr,...)})
#setMethod("r.rd", "SphericalDistribution", function(object) {
#                                                .Deprecated("rRd")
#                                                r(object@radDistr)})
#setMethod("d.rd", "SphericalDistribution", function(object) {
#                                                .Deprecated("dRd")
#                                                d(object@radDistr)})
#setMethod("p.rd", "SphericalDistribution", function(object) {
#                                                .Deprecated("pRd")
#                                                p(object@radDistr)})
#setMethod("q.rd", "SphericalDistribution", function(object) {
#                                                .Deprecated("qRd")
#                                                q.l(object@radDistr)})

setMethod("plotRd", "SphericalDistribution",
           function(x, ... ) plot(x@radDistr,...))
setMethod("rRd", "SphericalDistribution", function(object) r(object@radDistr))
setMethod("dRd", "SphericalDistribution", function(object) d(object@radDistr))
setMethod("pRd", "SphericalDistribution", function(object) p(object@radDistr))
setMethod("qRd", "SphericalDistribution", function(object) q.l(object@radDistr))

## functionals:

setMethod("E", signature(object = "SphericalDistribution",
                        fun = "missing", cond = "missing"),
           function(object,...) numeric(dimension(object)))

setMethod("var", signature(x = "SphericalDistribution"),
           function(x,...) diag(dimension(x)) *
                    E(radDistr(x), fun = function(y)y^2,...)/dimension(x)
           )


setAs("SphericalDistribution", "EllipticalDistribution",
            function(from){
               sc <- SymmCenter(Symmetry(from))
               slotNames <- slotNames(from)
               lst <- sapply(slotNames, function(x) slot(from,x))
               names(lst) <- slotNames
               dim <- dimension(from)
               lst$"param" <- new("EllipticalParameter",
                                   loc = numeric(dim),
                                   scale = diag(dim))
               lst$"Symmetry" <- EllipticalSymmetry(numeric(dim))
               ell <- new("EllipticalDistribution")
               for (i in 1: length(lst))
                   slot(ell, name = names(lst)[i]) <- lst[[i]]
               ell})
               

setMethod("plot", signature(x = "SphericalDistribution", y = "missing"),
      function(x, Nsim = getdistrEllipseOption("Nsim"), ...,
               withED = getdistrEllipseOption("withED"),
               lwd.Ed = getdistrEllipseOption("lwd.Ed"),
               col.Ed = getdistrEllipseOption("col.Ed"),
               withMean = getdistrEllipseOption("withMean"),
               cex.mean = getdistrEllipseOption("cex.mean"),
               pch.mean = getdistrEllipseOption("pch.mean"),
               col.mean = getdistrEllipseOption("col.mean")){
      dots <- match.call(call = sys.call(sys.parent(1)),
                         expand.dots = FALSE)$"..."
      cex <- 0.5
      if(hasArg("cex")) cex <- dots$cex
      col <- "black"
      if(hasArg("col")) col <- dots$col
      
      qchs <- qchisq(.95, df = 2)^.5
      col.Ed <- rep(col.Ed, length.out = 2)

      X <- r(x)(2000)

      if(hasArg("panel"))
         pairs(t(X), ...)
      else
         pairs(t(X), ...,
               panel = function(x,y, cex = cex, col = col, ...){
                  dots$col <- NULL
                  dots$cex <- NULL
                  do.call(points, c(list(x = x, y = y), dots))
                  if(withED){
                     co <- var(cbind(x,y))
                     eig <- eigen(co)
                     ev <- eig$values^.5
                     x1 <- eig$vectors[,1]*ev[1]*qchs
                     x2 <- eig$vectors[,2]*ev[2]*qchs
                     
                     lines(x = c(0,x1[1]) + mean(x),
                           y = c(0,x1[2]) + mean(y), lwd = lwd.Ed,
                        col = col.Ed[1])
                     lines( x = c(0,x2[1]) + mean(x),
                         y = c(0,x2[2]) + mean(y), lwd = lwd.Ed,
                         col = col.Ed[2])
                     }
                     if(withMean)
                     points(mean(x),mean(y), col = col.mean,
                         cex = cex.mean , pch = pch.mean)
                  } )
      return(invisible(NULL))
      } )


setMethod("+", c("SphericalDistribution","numeric"),
           function(e1,e2) as(e1, "EllipticalDistribution")+e2)
setMethod("*", c("SphericalDistribution","numeric"),
           function(e1,e2)as(e1, "EllipticalDistribution")*e2)
setMethod("%*%", signature(x="matrix",y="SphericalDistribution"),
           function(x,y) x %*% as(y, "EllipticalDistribution"))

setMethod("+", c("numeric", "SphericalDistribution"),
          function(e1, e2){
            e2 + e1
          })


setMethod("*", c("numeric", "SphericalDistribution"),
          function(e1, e2){
            e2 * e1
          })

setMethod("-", c("SphericalDistribution", "missing"),
          function(e1){
            e1*(-1)
          })


setMethod("-", c("SphericalDistribution", "numeric"),
          function(e1, e2){
            return(e1 + (-e2))
          })

setMethod("-", c("numeric", "SphericalDistribution"),
          function(e1, e2){
            -1*e2 + e1
          })