inst/doc/newDistributions-knitr.R

In distr: Object Oriented Implementation of Distributions

## ----knitRPreparations,include=FALSE------------------------------------------
library(knitr)
opts_chunk$set(tidy=FALSE)

## ----Prepa0, include=FALSE, results="hide"------------------------------------
require(distr)

## ----Prepa, echo=FALSE, results="asis"------------------------------
## preparation: set option withSweave to TRUE
require(distr)
distroptions(withSweave = TRUE)
options(width=70)

## ----exam1, eval = TRUE, fig.width=8.0, fig.height=6.5--------------
require(distr)
N <- Norm(mean = 2, sd = 1.3)
P <- Pois(lambda = 1.2)
Z <- 2*N + 3 + P
Z
plot(Z, panel.first = grid(), lwd=3)
p(Z)(0.4)
q(Z)(0.3)
## in RStudio or Jupyter IRKernel, use q.l(.)(.) instead of q(.)(.)
Zs <- r(Z)(50)
Zs

## ----DiscrDist, eval = TRUE-----------------------------------------
D <- DiscreteDistribution(supp = c(1,5,7,21), prob = c(0.1,0.1,0.6,0.2))
D
plot(D, panel.first = grid(lwd=2), lwd = 3)

## ----AbscDist, eval = TRUE------------------------------------------
AC <- AbscontDistribution(d = function(x) exp(-abs(x)^3), withStand = TRUE)
AC
plot(AC, panel.first = grid(lwd=2), lwd = 3)

## ----AllClass1, results="asis", echo=TRUE---------------------------
## Class: BinomParameter
setClass("BinomParameter",
          representation = representation(size = "numeric", prob = "numeric"),
          prototype = prototype(size = 1, prob = 0.5, name =
                      gettext("Parameter of a Binomial distribution")
                      ),
          contains = "Parameter"
          )

## ----AllClass2, results="asis", echo=TRUE---------------------------
## Class: binomial distribution
setClass("Binom",
          prototype = prototype(
                      r = function(n){ rbinom(n, size = 1,prob = 0.5) },
                      d = function(x, log = FALSE){
                              dbinom(x, size = 1, prob = 0.5, log = log)
                                          },
                      p = function(q, lower.tail = TRUE, log.p = FALSE ){
                              pbinom(q, size = 1, prob = 0.5,
                                     lower.tail = lower.tail, log.p = log.p)
                                          },
                      q = function(p, lower.tail = TRUE, log.p = FALSE ){
                              qbinom(p, size = 1, prob = 0.5,
                                     lower.tail = lower.tail, log.p = log.p)
                                          },
                      img = new("Naturals"),
                      param = new("BinomParameter"),
                      support = 0:1,
                      lattice = new("Lattice",
                                pivot = 0, width = 1, Length = 2, name =
                                gettext(
                                  "lattice of a Binomial distribution"
                                       )
                                ),
                     .logExact = TRUE,
                     .lowerExact = TRUE
                      ),
          contains = "LatticeDistribution"
          )

## ----BinomDist1, results="asis", echo=TRUE--------------------------
## Access Methods
setMethod("size", "BinomParameter", function(object) object@size)
setMethod("prob", "BinomParameter", function(object) object@prob)
## Replace Methods
setReplaceMethod("size", "BinomParameter",
                  function(object, value){ object@size <- value; object})
setReplaceMethod("prob", "BinomParameter",
                  function(object, value){ object@prob <- value; object})

## ----AllGenerics, results="asis", echo=TRUE-------------------------
if(!isGeneric("size"))
   setGeneric("size", function(object) standardGeneric("size"))
if(!isGeneric("prob"))
   setGeneric("prob", function(object) standardGeneric("prob"))

## ----BinomDist2, results="asis", echo=TRUE--------------------------
setValidity("BinomParameter", function(object){
  if(length(prob(object)) != 1)
    stop("prob has to be a numeric of length 1")
  if(prob(object) < 0)
    stop("prob has to be in [0,1]")
  if(prob(object) > 1)
    stop("prob has to be in [0,1]")
  if(length(size(object)) != 1)
    stop("size has to be a numeric of length 1")
  if(size(object) < 1)
    stop("size has to be a natural greater than 0")
  if(!identical(floor(size(object)), size(object)))
    stop("size has to be a natural greater than 0")
  else return(TRUE)
})

## ----BinomDist3, results="asis", echo=TRUE--------------------------
Binom <- function(size = 1,prob = 0.5) new("Binom", size = size, prob = prob)

## ----BinomDist4, results="asis", echo=TRUE--------------------------
## Convolution for two binomial distributions Bin(n1,p1) and Bin(n2,p2)
## Distinguish cases
## p1 == p2 und p1 != p2


setMethod("+", c("Binom","Binom"),
          function(e1,e2){
            newsize <- size(e1) + size(e2)

            if(isTRUE(all.equal(prob(e1),prob(e2))))
               return(new("Binom", prob = prob(e1), size = newsize,
                          .withArith = TRUE))

            return(as(e1, "LatticeDistribution") + e2)
          })

## ----Prepa2, echo=FALSE, results="asis"-----------------------------
## preparation: set option withSweave to TRUE
require(distrEx)

## ----Expect, results="asis", echo=TRUE------------------------------
setMethod("E", signature(object = "Binom",
                         fun = "missing",
                         cond = "missing"),
    function(object, low = NULL, upp = NULL, ...){
    if(!is.null(low)) if(low <= min(support(object))) low <- NULL
    if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
    if(is.null(low) && is.null(upp))
        return(size(object)*prob(object))
    else{
        if(is.null(low)) low <- -Inf
        if(is.null(upp)) upp <- Inf
        if(low == -Inf){
           if(upp == Inf) return(size(object)*prob(object))
           else return(m1df(object, upper = upp, ...))
        }else{
           E1 <- m1df(object, upper = low, ...)
           E2 <- if(upp == Inf)
                    size(object)*prob(object) else m1df(object, upper = upp, ...)
           return(E2-E1)
        }
    }
   })

## ----var, results="asis", echo=TRUE---------------------------------
setMethod("var", signature(x = "Binom"),
    function(x,...){
    dots <- match.call(call = sys.call(sys.parent(1)),
                       expand.dots = FALSE)$"..."
    fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
    if(hasArg(low)) low <- dots$low
    if(hasArg(upp)) upp <- dots$upp
    if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
        return(var(as(x,"DiscreteDistribution"),...))
    else
        return(size(x)*prob(x)*(1-prob(x)))
    })

## ----skew, results="asis", echo=TRUE--------------------------------
setMethod("skewness", signature(x = "Binom"),
    function(x,  ...){
    dots <- match.call(call = sys.call(sys.parent(1)),
                       expand.dots = FALSE)$"..."
    fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
    if(hasArg(low)) low <- dots$low
    if(hasArg(upp)) upp <- dots$upp
    if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
       return(skewness(as(x,"DiscreteDistribution"),...))
    else
        return((1-2*prob(x))/sqrt(size(x)*prob(x)*(1-prob(x))))
    })

## ----kurt, results="asis", echo=TRUE--------------------------------
setMethod("kurtosis", signature(x = "Binom"),
    function(x,  ...){
    dots <- match.call(call = sys.call(sys.parent(1)),
                       expand.dots = FALSE)$"..."
    fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
    if(hasArg(low)) low <- dots$low
    if(hasArg(upp)) upp <- dots$upp
    if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
       return(kurtosis(as(x,"DiscreteDistribution"),...))
    else
        p <- prob(x)
        return((1-6*p*(1-p))/(size(x)*p*(1-p)))
    })