1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
################################
##
## Class: NormParameter
##
################################
## Access methods
setMethod("mean", "NormParameter", function(x, ...) x@mean)
setMethod("sd", signature(x = "NormParameter"), function(x, ...) x@sd)
## Replace Methoden
setReplaceMethod("mean", "NormParameter",
function(object, value){ object@mean <- value; object})
setReplaceMethod("sd", "NormParameter",
function(object, value)
{ object@sd <- as.matrix(value); object})
validNormParameter <- function(object){
if(!is.matrix(sd(object)) && is.numeric(mean(object))) return(TRUE)
if(nrow(sd(object)) != ncol((sd(object))))
stop("Covariance matrix not sqared")
if(nrow(sd(object)) != length(mean(object)))
stop("Covariance matrix and mean vector do not have the same dimension")
return(TRUE)
}
setValidity("NormParameter", validNormParameter)
################################
##
## Class: UniNormParameter
##
################################
setClass("UniNormParameter", contains = "NormParameter")
setValidity("UniNormParameter", function(object){
if(length(mean(object)) != 1)
stop("mean has to be a numeric of length 1")
if(length(sd(object)) != 1)
stop("sd has to be a numeric of length 1")
sd <- as.numeric(sd(object))
if(sd <= 0)
stop("sd has to be positive")
else return(TRUE)
})
################################
##
## Class: normal distribution
##
################################
Norm <- function(mean = 0, sd = 1) {
N <- new("Norm", mean = mean, sd = sd)
N@Symmetry <- SphericalSymmetry(mean)
N}
## wrapped access methods
setMethod("mean", "Norm", function(x, ...) mean(param(x)))
setMethod("sd", signature(x = "Norm"), function(x) sd(param(x)))
## wrapped replace methods
setMethod("mean<-", "Norm",
function(object, value) new("Norm", mean = value, sd = sd(object)))
setMethod("sd<-", "Norm",
function(object, value) new("Norm", mean = mean(object), sd = value))
## clipped moments for normal distribution: found in distrEx...
###setMethod("m1df", "Norm",
### function(object){
### function(t) -d(object)(t) * sd(param(object))^2
### + mean(param(object)) * p(object)(t)
### })
###
###setMethod("m2df", "Norm",
### function(object){
### mean <- mean(param(object))
### sd <- sd(param(object))
### d <- d(object)
### p <- p(object)
### function(t) -(t-mean) * d(t) * sd^2 + p(t) * sd^2 -
### 2 * mean * d(t) * sd^2 + mean^2 * p(t)
### })
###
## convolution operator for normal distributions
setMethod("+", c("Norm","Norm"),
function(e1,e2){
N<- new("Norm", sd = sqrt(sd(e1)^2 + sd(e2)^2),
mean = mean(e1) + mean(e2), .withArith = TRUE)
N@Symmetry <- SphericalSymmetry(mean(e1)+mean(e2))
N
})
## extra methods for normal distribution
setMethod("+", c("Norm","numeric"),
function(e1, e2){
if (length(e2)>1) stop("length of operator must be 1")
N <- new("Norm", mean = mean(e1) + e2, sd = sd(e1), .withArith = TRUE)
N@Symmetry <- SphericalSymmetry(mean(e1)+ e2)
N
})
setMethod("*", c("Norm","numeric"),
function(e1, e2){
if (length(e2)>1) stop("length of operator must be 1")
if (isTRUE(all.equal(e2,0)))
return(new("Dirac", location = 0, .withArith = TRUE))
N<- new("Norm", mean = mean(e1) * e2,
sd = sd(e1) * abs(e2), .withArith = TRUE)
N@Symmetry <- SphericalSymmetry(mean(e1)*e2)
N
})
|
