[Distr-commits] r361 - branches/distr-2.1/pkg/distr branches/distr-2.1/pkg/distr/R branches/distr-2.1/pkg/distr/man branches/distr-2.1/pkg/distrEx/R branches/distr-2.1/pkg/distrEx/man branches/distr-2.1/pkg/distrEx/src pkg/distr/chm pkg/distr/man pkg/distrEx/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 28 23:35:30 CET 2008
Author: ruckdeschel
Date: 2008-11-28 23:35:30 +0100 (Fri, 28 Nov 2008)
New Revision: 361
Added:
branches/distr-2.1/pkg/distr/R/CompoundDistribution.R
branches/distr-2.1/pkg/distr/man/CompoundDistribution-class.Rd
branches/distr-2.1/pkg/distr/man/CompoundDistribution.Rd
pkg/distr/chm/options.html
pkg/distr/man/options.Rd
Modified:
branches/distr-2.1/pkg/distr/NAMESPACE
branches/distr-2.1/pkg/distr/R/AllClasses.R
branches/distr-2.1/pkg/distr/R/AllGenerics.R
branches/distr-2.1/pkg/distr/R/bAcDcLcDistribution.R
branches/distr-2.1/pkg/distr/R/internalUtils_LCD.R
branches/distr-2.1/pkg/distr/R/plot-methods_LebDec.R
branches/distr-2.1/pkg/distr/R/print-show-methods.R
branches/distr-2.1/pkg/distr/man/0distr-package.Rd
branches/distr-2.1/pkg/distr/man/Math-methods.Rd
branches/distr-2.1/pkg/distr/man/internals.Rd
branches/distr-2.1/pkg/distr/man/operators-methods.Rd
branches/distr-2.1/pkg/distr/man/plot-methods.Rd
branches/distr-2.1/pkg/distr/man/showobj-methods.Rd
branches/distr-2.1/pkg/distrEx/R/Expectation.R
branches/distr-2.1/pkg/distrEx/R/Expectation_LebDec.R
branches/distr-2.1/pkg/distrEx/R/Functionals.R
branches/distr-2.1/pkg/distrEx/man/E.Rd
branches/distr-2.1/pkg/distrEx/man/Var.Rd
branches/distr-2.1/pkg/distrEx/src/distrEx.dll
pkg/distrEx/R/Expectation_LebDec.R
Log:
+ Compound Distributions are now implemented; see ?CompoundDistribution, class?CompoundDistribution
+ forgot options.Rd file recently
Modified: branches/distr-2.1/pkg/distr/NAMESPACE
===================================================================
--- branches/distr-2.1/pkg/distr/NAMESPACE 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/NAMESPACE 2008-11-28 22:35:30 UTC (rev 361)
@@ -40,6 +40,8 @@
"Hyper", "Logis", "Lnorm", "Nbinom", "Norm",
"Pois", "Td", "Unif", "Weibull", "Arcsine",
"ExpOrGammaOrChisq")
+exportClasses("UnivDistrListOrDistribution")
+exportClasses("CompoundDistribution")
exportClasses("DistrList",
"UnivarDistrList")
exportMethods("Max", "Max<-", "Min", "Min<-", "d", "df",
@@ -76,3 +78,5 @@
export("UnivarMixingDistribution", "UnivarLebDecDistribution")
export("RtoDPQ.LC", "flat.LCD", "flat.mix")
exportMethods("abs","exp","^")
+exportMethods("NumbOfSummandsDistr","SummandsDistr")
+export("CompoundDistribution")
Modified: branches/distr-2.1/pkg/distr/R/AllClasses.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/AllClasses.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/AllClasses.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -979,6 +979,18 @@
contains = "UnivarLebDecDistribution"
)
+
+setClassUnion("UnivDistrListOrDistribution",
+ c("UnivarDistrList","UnivariateDistribution"))
+
+setClass("CompoundDistribution", representation=representation(
+ NumbOfSummandsDistr = "DiscreteDistribution",
+ SummandsDistr = "UnivDistrListOrDistribution"),
+ prototype=prototype(NumbOfSummandsDistr = new("Pois"),
+ SummandsDistr=new("Norm")),
+ contains = "UnivarMixingDistribution"
+ )
+
################################
##
## virtual Distribution class Unions
@@ -986,7 +998,9 @@
################################
setClassUnion("AcDcLcDistribution", c("AbscontDistribution",
- "DiscreteDistribution", "UnivarLebDecDistribution"))
+ "DiscreteDistribution", "UnivarLebDecDistribution",
+ "CompoundDistribution"))
setClassUnion("AffLinDistribution", c("AffLinAbscontDistribution",
"AffLinDiscreteDistribution", "AffLinUnivarLebDecDistribution"))
+
Modified: branches/distr-2.1/pkg/distr/R/AllGenerics.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/AllGenerics.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/AllGenerics.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -399,3 +399,11 @@
if(!isGeneric("showobj"))
setGeneric("showobj", function(object, ...) standardGeneric("showobj"))
+
+
+if(!isGeneric("NumbOfSummandsDistr"))
+ setGeneric("NumbOfSummandsDistr", function(object)
+ standardGeneric("NumbOfSummandsDistr"))
+if(!isGeneric("SummandsDistr"))
+ setGeneric("SummandsDistr", function(object)
+ standardGeneric("SummandsDistr"))
Added: branches/distr-2.1/pkg/distr/R/CompoundDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/CompoundDistribution.R (rev 0)
+++ branches/distr-2.1/pkg/distr/R/CompoundDistribution.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -0,0 +1,83 @@
+
+setMethod("NumbOfSummandsDistr", signature="CompoundDistribution",
+ function(object) object at NumbOfSummandsDistr)
+setMethod("SummandsDistr", signature="CompoundDistribution",
+ function(object) object at SummandsDistr)
+
+CompoundDistribution<- function( NumbOfSummandsDistr, SummandsDistr, .withSim = FALSE,
+ withSimplify = FALSE){
+ if(!is(NumbOfSummandsDistr,"DiscreteDistribution"))
+ stop("Argument 'NumbOfSummandsDistr' must be of class 'DiscreteDistribution'")
+ supp <- support(NumbOfSummandsDistr)
+ if(!(all(.isInteger(supp))&&all(supp >=0)))
+ stop("Support of 'NumbOfSummandsDistr' must be non neg. integers")
+
+ if(!is(SummandsDistr,"UnivDistrListOrDistribution"))
+ stop("Argument 'SummandsDistr' must be of class 'UnivDistrListOrDistribution'")
+ supp <- support(NumbOfSummandsDistr)
+ supp <- as(supp,"integer")
+ suppNot0 <- supp[supp!=0L]
+ is0 <- 0 %in% supp
+ lI <- vector("list", length(supp))
+ if(is0) lI[[1]] <- Dirac(0)
+ if(length(suppNot0)){
+ if(is(SummandsDistr,"UnivariateDistribution")){
+ dsuppNot0 <- c(suppNot0,diff(suppNot0))
+ S <- 0
+ for (i in 1:length(suppNot0)){
+ x0 <- convpow(SummandsDistr,dsuppNot0[i])
+ S <- S + x0
+ lI[[i+is0]] <- S
+ }
+ }else{
+ supp <- min(supp):max(supp)
+ if( (length(supp)!=length(SummandsDistr)) &&
+ !(is0 && length(supp)==1+length(SummandsDistr)))
+ stop("Lengths of support of 'NumbOfSummandDistr' and list in 'SummandDistr' do not match")
+ if(is0 && length(supp)==length(SummandsDistr))
+ SummandsDistr <- SummandsDistr[2:length(SummandsDistr)]
+ S <- 0
+ for(i in 1:(length(supp)-is0)){
+ S <- S + SummandsDistr[[i]]
+ lI[[i+is0]] <- S
+ }
+ }
+ UV <- do.call("UnivarMixingDistribution",
+ args = c(list(mixCoeff = d(NumbOfSummandsDistr)(supp),
+ withSimplify = FALSE),
+ lI)
+ )
+ obj <- new("CompoundDistribution",
+ NumbOfSummandsDistr = NumbOfSummandsDistr,
+ SummandsDistr = SummandsDistr,
+ p = UV at p, r = UV at r, d = UV at d, q = UV at q,
+ mixCoeff = UV at mixCoeff, mixDistr = UV at mixDistr,
+ .withSim = .withSim, .withArith = TRUE)
+
+ if(withSimplify) return(simplifyD(obj))
+ else return(obj)
+
+ }
+}
+
+setMethod("+", c("CompoundDistribution","numeric"),
+ function(e1, e2) simplifyD(e1)+e2)
+setMethod("*", c("CompoundDistribution","numeric"),
+ function(e1, e2) simplifyD(e1)*e2)
+
+
+setMethod("Math", "AcDcLcDistribution",
+ function(x){
+ callGeneric(simplifyD(.ULC.cast(x)))
+ })
+
+setAs("CompoundDistribution", "UnivarLebDecDistribution",
+ function(from)simplifyD(from))
+
+
+
+
+
+
+
+####################################
Modified: branches/distr-2.1/pkg/distr/R/bAcDcLcDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/bAcDcLcDistribution.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/bAcDcLcDistribution.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -1,20 +1,22 @@
-
setMethod("*", c("AcDcLcDistribution","AcDcLcDistribution"),
function(e1,e2){
- if( is(e1,"AffLinUnivarLebDecDistribution"))
- e1 <- as(e1, "UnivarLebDecDistribution")
- if( is(e2,"AffLinUnivarLebDecDistribution"))
- e2 <- as(e2, "UnivarLebDecDistribution")
+ e1 <- .ULC.cast(e1)
+ e2 <- .ULC.cast(e2)
- if( is(e1,"AbscontDistribution"))
- e1 <- as(as(e1,"AbscontDistribution"), "UnivarLebDecDistribution")
- if( is(e2,"AbscontDistribution"))
- e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
- if(is(e1,"DiscreteDistribution"))
- e1 <- as(as(e1,"DiscreteDistribution"), "UnivarLebDecDistribution")
- if(is(e2,"DiscreteDistribution"))
- e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+# if( is(e1,"AffLinUnivarLebDecDistribution"))
+# e1 <- as(e1, "UnivarLebDecDistribution")
+# if( is(e2,"AffLinUnivarLebDecDistribution"))
+# e2 <- as(e2, "UnivarLebDecDistribution")
+#
+# if( is(e1,"AbscontDistribution"))
+# e1 <- as(as(e1,"AbscontDistribution"), "UnivarLebDecDistribution")
+# if( is(e2,"AbscontDistribution"))
+# e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
+# if(is(e1,"DiscreteDistribution"))
+# e1 <- as(as(e1,"DiscreteDistribution"), "UnivarLebDecDistribution")
+# if(is(e2,"DiscreteDistribution"))
+# e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
ep <- getdistrOption("TruncQuantile")
@@ -31,7 +33,7 @@
as(exp(log(e1DC$pos$D)+log(e2DC$pos$D)),
"UnivarLebDecDistribution")
else as(Dirac(1), "UnivarLebDecDistribution")
-
+
e12mm <- if(w12mm>ep)
as(exp(log(-e1DC$neg$D)+log(-e2DC$neg$D)),
"UnivarLebDecDistribution")
@@ -48,17 +50,17 @@
e12pm <- .del0dmixfun(e12pm)
e12mp <- .del0dmixfun(e12mp)
-
+
obj <- flat.LCD(mixCoeff = mixCoeff,
e12pp, e12mm, e12pm, e12mp,
as(Dirac(0),"UnivarLebDecDistribution"))
-
+
if(getdistrOption("simplifyD"))
obj <- simplifyD(obj)
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1(n, ...) * g2(n, ...) },
- list(g1 = e1 at r, g2 = e2 at r))
+ list(g1 = e1 at r, g2 = e2 at r))
obj at r <- rnew
return(obj)
})
@@ -69,17 +71,19 @@
e2s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e2))
- if( is(e2,"AffLinUnivarLebDecDistribution"))
- e2 <- as(e2, "UnivarLebDecDistribution")
+ e2 <- .ULC.cast(e2)
- if( is(e2,"AbscontDistribution"))
- e2 <- as(as(e2, "AbscontDistribution"),
- "UnivarLebDecDistribution")
+# if( is(e2,"AffLinUnivarLebDecDistribution"))
+# e2 <- as(e2, "UnivarLebDecDistribution")
- if( is(e2,"DiscreteDistribution"))
- e2 <- as(as(e2, "DiscreteDistribution"),
- "UnivarLebDecDistribution")
+# if( is(e2,"AbscontDistribution"))
+# e2 <- as(as(e2, "AbscontDistribution"),
+# "UnivarLebDecDistribution")
+# if( is(e2,"DiscreteDistribution"))
+# e2 <- as(as(e2, "DiscreteDistribution"),
+# "UnivarLebDecDistribution")
+
if (discreteWeight(e2)>getdistrOption("TruncQuantile"))
if (d.discrete(e2)(0)>getdistrOption("TruncQuantile"))
stop(gettextf("1 / %s is not well-defined with positive probability ", e2s))
@@ -97,10 +101,10 @@
e2D <- simplifyD(e2D)
obj <- e1*e2D
-
+
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1 / g2(n, ...) },
- list(g1 = e1, g2 = e2 at r))
+ list(g1 = e1, g2 = e2 at r))
obj at r <- rnew
return(obj)
})
@@ -110,12 +114,14 @@
function(e1,e2){
e2s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e2))
- if( is(e2,"AbscontDistribution"))
- e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
+# if( is(e2,"AbscontDistribution"))
+# e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
- if( is(e2,"DiscreteDistribution"))
- e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+# if( is(e2,"DiscreteDistribution"))
+# e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+ e2 <- .ULC.cast(e2)
+
if (discreteWeight(e2)>getdistrOption("TruncQuantile"))
if (d.discrete(e2)(0)>getdistrOption("TruncQuantile"))
stop(gettextf("1 / %s is not well-defined with positive probability ", e2s))
@@ -124,24 +130,24 @@
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1(n, ...) / g2(n, ...) },
- list(g1 = e1 at r, g2 = e2 at r))
+ list(g1 = e1 at r, g2 = e2 at r))
obj at r <- rnew
return(obj)
})
setMethod("^", c("AcDcLcDistribution","Integer"),
-function(e1,e2){
+function(e1,e2){
ep <- getdistrOption("TruncQuantile")
d00 <- discretePart(e1)@d(0)
d0 <- discreteWeight(e1)*d00
- if(d0 > ep){
+ if(d0 > ep){
d1 <- 1-(1-d0)^e2
su <- support(discretePart(e1))
pr <- d(discretePart(e1))(su)
acW <- acWeight(e1)/(1-d0)
discreteP <- DiscreteDistribution(
supp = su[su!=0],
- prob = pr[su!=0]/(1-d00))
+ prob = pr[su!=0]/(1-d00))
e1 <- UnivarLebDecDistribution(acPart = acPart(e1),
discretePart = discreteP, acWeight = acW)
}
@@ -149,17 +155,17 @@
e1DC <- decomposePM(e1)
mixCoeff <- c(e1DC$pos$w,e1DC$neg$w)
mixCoeff <- mixCoeff/sum(mixCoeff)
- e1p <- if(mixCoeff[1]>ep)
- as(exp(e2*log(e1DC$pos$D)),"UnivarLebDecDistribution")
- else as(Dirac(1), "UnivarLebDecDistribution")
- e1m <- if(mixCoeff[2]>ep)
- as((-1)^e2*exp(e2*log(-e1DC$neg$D)),"UnivarLebDecDistribution")
- else as(Dirac((-1)^e2), "UnivarLebDecDistribution")
- erg <- flat.LCD(mixCoeff = mixCoeff, e1p, e1m)
+ e1p <- if(mixCoeff[1]>ep)
+ as(exp(e2*log(e1DC$pos$D)),"UnivarLebDecDistribution")
+ else as(Dirac(1), "UnivarLebDecDistribution")
+ e1m <- if(mixCoeff[2]>ep)
+ as((-1)^e2*exp(e2*log(-e1DC$neg$D)),"UnivarLebDecDistribution")
+ else as(Dirac((-1)^e2), "UnivarLebDecDistribution")
+ erg <- flat.LCD(mixCoeff = mixCoeff, e1p, e1m)
-#
- if(d0 > ep){
- dw <- discreteWeight(erg)
+#
+ if(d0 > ep){
+ dw <- discreteWeight(erg)
acW <- acWeight(erg) * (1-d1)
su <- support(discretePart(erg))
su0 <- c(su,0)
@@ -167,42 +173,43 @@
pr <- c(d(discretePart(erg))(su) * dw * (1-d1), d1)
suo <- su0[o]
pro <- pr[o]/(1-acW)
- discreteP <- DiscreteDistribution(supp = suo, prob = pro)
+ discreteP <- DiscreteDistribution(supp = suo, prob = pro)
erg <- UnivarLebDecDistribution(acPart = acPart(erg),
- discretePart = discreteP, acWeight = acW)
+ discretePart = discreteP, acWeight = acW)
}
- if(getdistrOption("simplifyD"))
+ if(getdistrOption("simplifyD"))
erg <- simplifyD(erg)
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1(n, ...)^g2 },
- list(g1 = e1 at r, g2 = e2))
+ list(g1 = e1 at r, g2 = e2))
erg at r <- rnew
return(erg)
})
setMethod("^", c("AcDcLcDistribution","numeric"),
function(e1,e2){
- if (is(try(mc <- match.call(call = sys.call(sys.parent(1))),
+ if (is(try(mc <- match.call(call = sys.call(sys.parent(1))),
silent=TRUE), "try-error"))
- {e1s <- "e1"; e2s <- "e2"}
+ {e1s <- "e1"; e2s <- "e2"}
else {e1s <- as.character(deparse(mc$e1))
e2s <- as.character(deparse(mc$e2))}
-
+
if (length(e2)>1) stop("length of operator must be 1")
if (isTRUE(all.equal(e2,1))) return(e1)
if (isTRUE(all.equal(e2,0))) return(Dirac(1))
- if( is(e1,"AbscontDistribution") || is(e1,"DiscreteDistribution") ||
- is(e1,"AffLinUnivarLebDecDistribution"))
- e1 <- as(e1, "UnivarLebDecDistribution")
+ e1 <- .ULC.cast(e1)
+# if( is(e1,"AbscontDistribution") || is(e1,"DiscreteDistribution") ||
+# is(e1,"AffLinUnivarLebDecDistribution"))
+# e1 <- as(e1, "UnivarLebDecDistribution")
if (e2<0) return((1/e1)^(-e2))
-
- if (.isNatural(e2, tol = 1e-10))
- return(get("^")(e1 = e1, e2 = as(e2,"Integer")))
+ if (.isNatural(e2, tol = 1e-10))
+ return(get("^")(e1 = e1, e2 = as(e2,"Integer")))
+
ep <- getdistrOption("TruncQuantile")
d00 <- discretePart(e1)@d(0)
d0 <- discreteWeight(e1)*d00
@@ -213,14 +220,14 @@
e1s, e2s))
### special treatment if e2>=0 and d.discrete(e1)>0
- if(d0 > ep){
+ if(d0 > ep){
d1 <- 1-(1-d0)^e2
su <- support(discretePart(e1))
pr <- d(discretePart(e1))(su)
acW <- acWeight(e1)/(1-d0)
discreteP <- DiscreteDistribution(
supp = su[su!=0],
- prob = pr[su!=0]/(1-d00))
+ prob = pr[su!=0]/(1-d00))
e1 <- UnivarLebDecDistribution(acPart = acPart(e1),
discretePart = discreteP, acWeight = acW)
}
@@ -228,8 +235,8 @@
erg <- exp( e2 * log(e1))
### special treatment if e2>=0 and d.discrete(e1)>0
- if(d0 > ep){
- dw <- discreteWeight(erg)
+ if(d0 > ep){
+ dw <- discreteWeight(erg)
acW <- acWeight(erg) * (1-d1)
su <- support(discretePart(erg))
su0 <- c(su,0)
@@ -237,20 +244,20 @@
pr <- c(d(discretePart(erg))(su) * dw * (1-d1), d1)
suo <- su0[o]
pro <- pr[o]/(1-acW)
- discreteP <- DiscreteDistribution(supp = suo, prob = pro)
+ discreteP <- DiscreteDistribution(supp = suo, prob = pro)
erg <- UnivarLebDecDistribution(acPart = acPart(erg),
- discretePart = discreteP, acWeight = acW)
+ discretePart = discreteP, acWeight = acW)
}
-
+
if(getdistrOption("simplifyD"))
erg <- simplifyD(erg)
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1(n, ...)^g2 },
- list(g1 = e1 at r, g2 = e2))
+ list(g1 = e1 at r, g2 = e2))
erg at r <- rnew
- return(erg)
+ return(erg)
}
)
@@ -262,65 +269,70 @@
### check if there are problems
if (is((e1s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e1))), "try-error"))
- e1s <- "e1"
+ e1s <- "e1"
if (is((e2s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e2))), "try-error"))
- e2s <- "e2"
+ e2s <- "e2"
- if( is(e1,"AffLinUnivarLebDecDistribution"))
- e1 <- as(e1, "UnivarLebDecDistribution")
- if( is(e2,"AffLinUnivarLebDecDistribution"))
- e2 <- as(e2, "UnivarLebDecDistribution")
-
- if( is(e1,"AbscontDistribution"))
- e1 <- as(as(e1,"AbscontDistribution"), "UnivarLebDecDistribution")
- if( is(e2,"AbscontDistribution"))
- e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
+# if( is(e1,"AffLinUnivarLebDecDistribution"))
+# e1 <- as(e1, "UnivarLebDecDistribution")
+# if( is(e2,"AffLinUnivarLebDecDistribution"))
+# e2 <- as(e2, "UnivarLebDecDistribution")
+# if( is(e1,"AbscontDistribution"))
+# e1 <- as(as(e1,"AbscontDistribution"), "UnivarLebDecDistribution")
+# if( is(e2,"AbscontDistribution"))
+# e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
- if( is(e1,"DiscreteDistribution"))
- e1 <- as(as(e1,"DiscreteDistribution"), "UnivarLebDecDistribution")
- if( is(e2,"DiscreteDistribution"))
- e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+
+# if( is(e1,"DiscreteDistribution"))
+# e1 <- as(as(e1,"DiscreteDistribution"), "UnivarLebDecDistribution")
+# if( is(e2,"DiscreteDistribution"))
+# e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+
+ e1 <- .ULC.cast(e1)
+ e2 <- .ULC.cast(e2)
+
+
ep <- getdistrOption("TruncQuantile")
-
+
if(p(e2)(0)-discreteWeight(e2)*d.discrete(e2)(0)>ep)
{ ## must be able to work with negative exponents
if (d.discrete(e1)(0)*discreteWeight(e1) > ep)
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
if ((discreteWeight(e2)>1-ep) && all(.isInteger(support(e2)))){
- Dlist <- lapply(support(e2), function(x)
+ Dlist <- lapply(support(e2), function(x)
as(do.call("^",list(e1=e1,e2=x)), "UnivarLebDecDistribution"))
- erg <- as(simplifyD( do.call(flat.LCD,
+ erg <- as(simplifyD( do.call(flat.LCD,
c(Dlist, alist(mixCoeff = d.discrete(e2)(support(e2)))))),
"UnivarLebDecDistribution")
if(getdistrOption("simplifyD")) erg <- simplifyD(erg)
return(erg)
- }
+ }
if (p(e1)(0) > ep)
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
}
-
+
if(p(e1)(0)>ep)
{ ## works only for purely natural e2
if ((discreteWeight(e2)>1-ep) && all(.isInteger(support(e2)))){
- Dlist <- lapply(support(e2), function(x)
+ Dlist <- lapply(support(e2), function(x)
as(do.call("^",list(e1=e1,e2=x)), "UnivarLebDecDistribution"))
- erg <- as(simplifyD( do.call(flat.LCD,
+ erg <- as(simplifyD( do.call(flat.LCD,
c(Dlist, alist(mixCoeff = d.discrete(e2)(support(e2)))))),
"UnivarLebDecDistribution")
if(getdistrOption("simplifyD")) erg <- simplifyD(erg)
return(erg)
- }
+ }
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
}
@@ -331,10 +343,10 @@
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1(n, ...)^g2(n, ...) },
- list(g1 = e1 at r, g2 = e2 at r))
+ list(g1 = e1 at r, g2 = e2 at r))
erg at r <- rnew
- return(erg)
+ return(erg)
})
@@ -343,50 +355,51 @@
### check if there are problems
if (is((e1s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e1))), "try-error"))
- e1s <- "e1"
+ e1s <- "e1"
if (is((e2s <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$e2))), "try-error"))
- e2s <- "e2"
+ e2s <- "e2"
- if( is(e2,"AffLinUnivarLebDecDistribution"))
- e2 <- as(e2, "UnivarLebDecDistribution")
- if( is(e2,"AbscontDistribution"))
- e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
- if( is(e2,"DiscreteDistribution"))
- e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
+ e2 <- .ULC.cast(e2)
+ #e2 <- .if( is(e2,"AffLinUnivarLebDecDistribution"))
+ # e2 <- as(e2, "UnivarLebDecDistribution")
+ #if( is(e2,"AbscontDistribution"))
+ # e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
+ #if( is(e2,"DiscreteDistribution"))
+ # e2 <- as(as(e2,"DiscreteDistribution"), "UnivarLebDecDistribution")
ep <- getdistrOption("TruncQuantile")
if(p(e2)(0)-discreteWeight(e2)*d.discrete(e2)(0)>ep)
{ ## must be able to work with negative exponents
if (abs(e1) < ep)
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
if ((discreteWeight(e2)>1-ep) && all(.isInteger(support(e2)))){
- erg <- DiscreteDistribution(e1^support(e2),
+ erg <- DiscreteDistribution(e1^support(e2),
d.discrete(e2)(support(e2)))
- if(!getdistrOption("simplifyD"))
+ if(!getdistrOption("simplifyD"))
erg <- as(erg,"UnivarLebDecDistribution")
- return(erg)
+ return(erg)
}
-
+
if (e1 < -ep)
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
}
if(e1< -ep)
{ ## works only for purely natural e2
if ((discreteWeight(e2)>1-ep) && all(.isInteger(support(e2)))){
- erg <- DiscreteDistribution(e1^support(e2),
+ erg <- DiscreteDistribution(e1^support(e2),
d.discrete(e2)(support(e2)))
- if(!getdistrOption("simplifyD"))
+ if(!getdistrOption("simplifyD"))
erg <- as(erg,"UnivarLebDecDistribution")
- return(erg)
- }
+ return(erg)
+ }
- stop(gettextf("%s^%s is not well-defined with positive probability ",
+ stop(gettextf("%s^%s is not well-defined with positive probability ",
e1s, e2s))
}
le1 <- log(e1)
@@ -396,12 +409,18 @@
rnew <- function(n, ...){}
body(rnew) <- substitute({ g1^g2(n, ...) },
- list(g1 = e1, g2 = e2 at r))
+ list(g1 = e1, g2 = e2 at r))
erg at r <- rnew
- return(erg)
+ return(erg)
})
+setMethod("+", signature(e1="AcDcLcDistribution", e2="AcDcLcDistribution"),
+ function(e1,e2)(.ULC.cast(e1)+(-.ULC.cast(e2))))
+setMethod("-", signature(e1="AcDcLcDistribution", e2="AcDcLcDistribution"),
+ function(e1,e2)(.ULC.cast(e1)+(-.ULC.cast(e2))))
+
+
setMethod("sign", "AcDcLcDistribution",
function(x){
if(is(x,"AbscontDistribution")) d0 <-0
@@ -415,3 +434,6 @@
setMethod("sqrt", "AcDcLcDistribution",
function(x) x^0.5)
+
+setMethod("Math", "AcDcLcDistribution",
+ function(x) callGeneric(.ULC.cast(x)))
Modified: branches/distr-2.1/pkg/distr/R/internalUtils_LCD.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/internalUtils_LCD.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/internalUtils_LCD.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -170,3 +170,13 @@
}
return(mixDistr)
}
+
+.ULC.cast <- function(x){
+ if( is(x,"AbscontDistribution"))
+ x <- as(as(x,"AbscontDistribution"), "UnivarLebDecDistribution")
+ if(is(x,"DiscreteDistribution"))
+ x <- as(as(x,"DiscreteDistribution"), "UnivarLebDecDistribution")
+ if(!is(x,"UnivarLebDecDistribution"))
+ x <- as(x,"UnivarLebDecDistribution")
+ return(x)
+}
Modified: branches/distr-2.1/pkg/distr/R/plot-methods_LebDec.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/plot-methods_LebDec.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/plot-methods_LebDec.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -357,3 +357,8 @@
}
)
+
+
+setMethod("plot", signature(x="CompoundDistribution", y = "missing"),
+ function(x,...) plot(simplifyD(x),...))
+
Modified: branches/distr-2.1/pkg/distr/R/print-show-methods.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/print-show-methods.R 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/R/print-show-methods.R 2008-11-28 22:35:30 UTC (rev 361)
@@ -112,6 +112,23 @@
}
)
+setMethod("showobj", "CompoundDistribution",
+ function(object, className = class(object)[1]){
+ txt <- gettextf("An object of class \"%s\"\n\n", className)
+ txt <- c(txt,
+ gettextf("The frequency distribution is:\n%s",
+ paste(showobj(NumbOfSummandsDistr(object)), collapse="")))
+ txt <- c(txt,
+ gettextf("The summands distribution is/are:\n%s",
+ paste(showobj(SummandsDistr(object)), collapse="")))
+ txt <- c(txt,
+ gettextf("\nThis Distribution is:\n%s",
+ paste(showobj(simplifyD(object)), collapse="")))
+ return(txt)
+ }
+ )
+
+
#------ UnivarLebDecDistribution ---------- #
setMethod("show", "UnivarLebDecDistribution",
Modified: branches/distr-2.1/pkg/distr/man/0distr-package.Rd
===================================================================
--- branches/distr-2.1/pkg/distr/man/0distr-package.Rd 2008-11-28 16:06:29 UTC (rev 360)
+++ branches/distr-2.1/pkg/distr/man/0distr-package.Rd 2008-11-28 22:35:30 UTC (rev 361)
@@ -118,6 +118,7 @@
|>|>"UnivarMixingDistribution"
|>|>|>"UnivarLebDecDistribution"
|>|>|>|>"AffLinUnivarLebDecDistribution"
+|>|>|>"CompoundDistribution"
|>|>"AbscontDistribution"
|>|>|>"AffLinAbscontDistribution"
|>|>|>"Arcsine"
@@ -152,10 +153,14 @@
"DistrList"
|>"UnivarDistrList"
-"AcDcLc" = union ( "AbscontDistribution",
- "DiscreteDistribution",
- "UnivarLebDecDistribution" )
+"AcDcLcDistribution" = union ( "AbscontDistribution",
+ "DiscreteDistribution",
+ "UnivarLebDecDistribution",
+ "CompoundDistribution" )
+"UnivDistrListOrDistribution" = union("UnivarDistrList",
+ "UnivariateDistribution")
+
Parameter classes
"OptionalParameter"
Added: branches/distr-2.1/pkg/distr/man/CompoundDistribution-class.Rd
===================================================================
--- branches/distr-2.1/pkg/distr/man/CompoundDistribution-class.Rd (rev 0)
+++ branches/distr-2.1/pkg/distr/man/CompoundDistribution-class.Rd 2008-11-28 22:35:30 UTC (rev 361)
@@ -0,0 +1,88 @@
+\name{CompoundDistribution-class}
+\docType{class}
+\alias{CompoundDistribution-class}
+\alias{NumbOfSummandsDistr}
+\alias{SummandsDistr}
+\alias{NumbOfSummandsDistr-methods}
+\alias{SummandsDistr-methods}
+\alias{NumbOfSummandsDistr,CompoundDistribution-method}
+\alias{SummandsDistr,CompoundDistribution-method}
+\alias{coerce,CompoundDistribution,UnivarLebDecDistribution-method}
+\alias{UnivDistrListOrDistribution-class}
+
+\title{Class "CompoundDistribution"}
+\description{\code{CompoundDistribution}-class is a class to formalize
+ compound distributions; it is a subclass to
+ class \code{UnivarMixingDistribution}.}
+\section{Objects from the Class}{
+Objects can be created by calls of the form
+\code{new("CompoundDistribution", ...)}.
+ More frequently they are created via the generating function
+ \code{\link{CompoundDistribution}}.
+}
+\section{Slots}{
+ \describe{
+ \item{\code{NumbOfSummandsDistr}:}{Object of class \code{"DiscreteDistribution"},
+ the frequency distribution.}
+ \item{\code{SummandsDistr}:}{Object of class \code{"UnivDistrListOrDistribution"},
+ that is, either of class code{"UnivarDistrList"} (non i.i.d. case) or
+ of class \code{"UnivariateDistribution"} (i.i.d. case); the summand distribution(s).}
+ \item{\code{mixCoeff}:}{Object of class \code{"numeric"}: a vector of
+ probabilities for the mixing components.}
+ \item{\code{mixDistr}:}{Object of class \code{"UnivarDistrList"}: a list of
+ univariate distributions containing the mixing components; must be of same
+ length as \code{mixCoeff}.}
+ \item{\code{img}:}{Object of class \code{"Reals"}: the space of the image of this distribution which has dimension 1
+ and the name "Real Space" }
+ \item{\code{param}:}{Object of class \code{"Parameter"}: the parameter of this distribution, having only the
+ slot name "Parameter of a discrete distribution" }
+ \item{\code{r}:}{Object of class \code{"function"}: generates random numbers}
+ \item{\code{d}:}{fixed to \code{NULL}}
+ \item{\code{p}:}{Object of class \code{"function"}: cumulative distribution function}
+ \item{\code{q}:}{Object of class \code{"function"}: quantile function}
+ \item{\code{.withArith}:}{logical: used internally to issue warnings as to interpretation of arithmetics}
+ \item{\code{.withSim}:}{logical: used internally to issue warnings as to accuracy}
+ }
+}
+\section{Extends}{
+Class \code{"UnivarMixingDistribution"}
+class \code{"UnivarDistribution"} by class \code{"UnivarMixingDistribution"},
+class \code{"Distribution"} by class \code{"UnivariateDistribution"}.
+}
+\section{Methods}{
+ \describe{
+ \item{show}{\code{signature(object = "CompoundDistribution")} prints the object}
+ \item{SummandsDistr}{\code{signature(object = "CompoundDistribution")} returns the corresponding slot}
+ \item{NumbOfSummandsDistr}{\code{signature(object = "CompoundDistribution")} returns the corresponding slot}
+ }
+}
+\section{setAs relations}{
+ There is a coerce method to coerce objects of class \code{"CompoundDistribution"} to
+ class \code{UnivarLebDecDistribution}; this is done by a simple call to \code{simplifyD}.
+}
+
+
+\author{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 361
More information about the Distr-commits
mailing list