[Distr-commits] r396 - in branches/distr-2.1/pkg/distr: . R chm man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Feb 8 22:45:13 CET 2009
Author: ruckdeschel
Date: 2009-02-08 22:45:13 +0100 (Sun, 08 Feb 2009)
New Revision: 396
Added:
branches/distr-2.1/pkg/distr/R/makeAbscontDistribution.R
branches/distr-2.1/pkg/distr/chm/MakeAbscontDistribution.html
branches/distr-2.1/pkg/distr/man/MakeAbscontDistribution.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/ContDistribution.R
branches/distr-2.1/pkg/distr/R/Convpow.r
branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R
branches/distr-2.1/pkg/distr/R/LatticeDistribution.R
branches/distr-2.1/pkg/distr/R/MinMaximum.R
branches/distr-2.1/pkg/distr/R/Truncate.R
branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R
branches/distr-2.1/pkg/distr/R/UnivarMixingDistribution.R
branches/distr-2.1/pkg/distr/R/bAffLinUnivarLebDecDistribution.R
branches/distr-2.1/pkg/distr/R/flat.R
branches/distr-2.1/pkg/distr/R/getLow.R
branches/distr-2.1/pkg/distr/R/internalUtils.R
branches/distr-2.1/pkg/distr/R/internalUtils_LCD.R
branches/distr-2.1/pkg/distr/R/plot-methods.R
branches/distr-2.1/pkg/distr/R/plot-methods_LebDec.R
branches/distr-2.1/pkg/distr/chm/00Index.html
branches/distr-2.1/pkg/distr/chm/ConvPow.html
branches/distr-2.1/pkg/distr/chm/Distr.chm
branches/distr-2.1/pkg/distr/chm/Distr.hhp
branches/distr-2.1/pkg/distr/chm/Distr.toc
branches/distr-2.1/pkg/distr/chm/Huberize-methods.html
branches/distr-2.1/pkg/distr/chm/UnivarLebDecDistribution-class.html
branches/distr-2.1/pkg/distr/chm/UnivarMixingDistribution-class.html
branches/distr-2.1/pkg/distr/chm/gap-methods.html
branches/distr-2.1/pkg/distr/chm/getLow.html
branches/distr-2.1/pkg/distr/chm/internals.html
branches/distr-2.1/pkg/distr/chm/operators-methods.html
branches/distr-2.1/pkg/distr/chm/p.l-methods.html
branches/distr-2.1/pkg/distr/chm/prob-methods.html
branches/distr-2.1/pkg/distr/chm/q.r-methods.html
branches/distr-2.1/pkg/distr/man/ConvPow.Rd
branches/distr-2.1/pkg/distr/man/Huberize-methods.Rd
branches/distr-2.1/pkg/distr/man/UnivarLebDecDistribution-class.Rd
branches/distr-2.1/pkg/distr/man/UnivarMixingDistribution-class.Rd
branches/distr-2.1/pkg/distr/man/gap-methods.Rd
branches/distr-2.1/pkg/distr/man/getLow.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/p.l-methods.Rd
branches/distr-2.1/pkg/distr/man/prob-methods.Rd
branches/distr-2.1/pkg/distr/man/q.r-methods.Rd
Log:
several enhancements / corrections in package distr:
-convpow:
+method for AcDcLcDistribution gains argument 'ep' to control
when to ignore discrete parts (or a.c. parts)
which summands in binomial expansion of (acPart+discretePart)^\ast n to ignore
+minor fix in method for DiscreteDistribution
- gaps/support :
+class UnivarMixingDistribution gains overall slots gaps support
+added corresponding accessors
+correspondingly, for UnivarLebDecDistribution as daughter class,
accessors gaps(), support() refer to "overall" slots, not to slots of acPart, discretePart
+deleted special support, gaps method for UnivarLebDecDistribution;
now inherits from UnivarMixingDistribution
+new utility function .consolidategaps to "merge" adjacent gaps
+setgaps method for UnivarMixingDistribution
+correspondingly,
* method "*", c("AffLinUnivarLebDecDistribution","numeric"),
* method "+", c("AffLinUnivarLebDecDistribution","numeric"),
* method "*", c("UnivarLebDecDistribution","numeric"),
* method "+", c("UnivarLebDecDistribution","numeric"),
* generating function "UnivarLebDecDistribtion"
had to be modified
+utility 'mergegaps' catches situation where support has length 0
+abs - and Truncate - methods for AbscontDistribution use '.consolidategaps'
-getLow/getUp:
+now available for UnivarLebDecDistribution, UnivarMixingDistribution
-new / enhanced utilities (non-exported)
+'modifyqgaps' in order to achieve correct values for slot q
in case slot p hast constancy regions (gaps)
+.qmixfun can cope with gaps and may return both left and right continuous versions
+.pmixfun may return both left and right continuous versions
in case slot p hast constancy regions (gaps)
- to avoid ambiguities in method dispatch:
+explicit method "+" for Dirac,DiscreteDistribution
-q.r, p.l (methods for right continuous quantile function
and left continuous cdf)
+ for class AbscontDistribution (q.r with 'modifyqgaps')
+ for class UnivarLebDecDistribution
+ for class UnivarMixingDistribution
-new prob methods:
(+ reminder: prob for 'DiscreteDistribution' returns
vector of probabilities for the support points
(named by values of support points) )
+ method for UnivarLebDecDistribution: returns a
two-row matrix with
* column names values of support points
* first row named "cond" the probabilities of discrete part
* second row named "abd" the probabilities of discrete part
multiplied with discreteWeight; hence the absolute probabilities
of the support points
-enhanced methods p.ac, d.ac, p.discrete, d.discrete:
* they all have an extra argument 'CondOrAbs' with default value
"cond" which if it does not partially match "abs", returns exactly
slot p (resp. d) the respective acPart/discretePart of the object
else return value is weighted by acWeight/discreteWeight
-new function 'makeAbscontDistribution' to convert arbitrary univariate
distributions to AbscontDistribution: takes slot p and uses
AbscontDistribution(); (useful for howtoap - paper)
-enhanced "+" method for DiscreteDistribution,DiscreteDistribution ---
catches addition with Dirac-Distribution
-enhanced flat.LCD:
setgaps is called only if slot gaps is not yet filled
-fixed bug in "+",LatticeDistribution,LatticeDistribution
+it may be that even if both lattices of e1, e2 have same width,
the convoluted support has another width!
example: c(-1.5,1.5), c(-3,0,3)
-fixed bugs in plot_
-matrix-valued ylim argument has not yet been dealt with correctly
Modified: branches/distr-2.1/pkg/distr/NAMESPACE
===================================================================
--- branches/distr-2.1/pkg/distr/NAMESPACE 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/NAMESPACE 2009-02-08 21:45:13 UTC (rev 396)
@@ -15,7 +15,8 @@
"Naturals", "standardMethods",
"distrARITH", "distrMASK", "getLabel", "devNew")
export("AbscontDistribution")
-export("DistrList", "UnivarDistrList")
+export("DistrList", "UnivarDistrList")
+export("makeAbscontDistribution")
exportClasses("rSpace", "EuclideanSpace", "Reals",
"Naturals")
exportClasses("Parameter")
Modified: branches/distr-2.1/pkg/distr/R/AllClasses.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/AllClasses.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/AllClasses.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -985,8 +985,13 @@
setClass("UnivarMixingDistribution",
representation = representation(mixCoeff = "numeric",
- mixDistr = "UnivarDistrList"),
- prototype = prototype(mixCoeff = 1, mixDistr = new("UnivarDistrList")),
+ mixDistr = "UnivarDistrList",
+ gaps = "OptionalMatrix",
+ support = "numeric"),
+ prototype = prototype(mixCoeff = 1,
+ mixDistr = new("UnivarDistrList"),
+ gaps = NULL,
+ support = numeric(0)),
contains = "UnivariateDistribution",
validity = function(object){
if(any(object at mixCoeff< -.Machine$double.eps) ||
Modified: branches/distr-2.1/pkg/distr/R/AllGenerics.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/AllGenerics.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/AllGenerics.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -355,18 +355,18 @@
setGeneric("acWeight<-", function(object, value) standardGeneric("acWeight<-"))
if(!isGeneric("p.discrete"))
- setGeneric("p.discrete", function(object) standardGeneric("p.discrete"))
+ setGeneric("p.discrete", function(object, ...) standardGeneric("p.discrete"))
if(!isGeneric("d.discrete"))
- setGeneric("d.discrete", function(object) standardGeneric("d.discrete"))
+ setGeneric("d.discrete", function(object, ...) standardGeneric("d.discrete"))
if(!isGeneric("q.discrete"))
setGeneric("q.discrete", function(object) standardGeneric("q.discrete"))
if(!isGeneric("r.discrete"))
setGeneric("r.discrete", function(object) standardGeneric("r.discrete"))
if(!isGeneric("p.ac"))
- setGeneric("p.ac", function(object) standardGeneric("p.ac"))
+ setGeneric("p.ac", function(object, ...) standardGeneric("p.ac"))
if(!isGeneric("d.ac"))
- setGeneric("d.ac", function(object) standardGeneric("d.ac"))
+ setGeneric("d.ac", function(object, ...) standardGeneric("d.ac"))
if(!isGeneric("q.ac"))
setGeneric("q.ac", function(object) standardGeneric("q.ac"))
if(!isGeneric("r.ac"))
Modified: branches/distr-2.1/pkg/distr/R/ContDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/ContDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/ContDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -95,7 +95,6 @@
}else{
if(is.null(p))
p <- .Q2P(q, ngrid = ngrid)
- xseq <- seq(-5,5,0.001)
r <- function(n) q(runif(n))
if( is.null(d)){
if(is.null(low1))
@@ -219,6 +218,8 @@
.withArith = wA, .lowerExact = .lowerExact, .logExact = .logExact)
if(is.null(gaps) && withgaps) setgaps(obj)
+ if(!is.null(obj at gaps))
+ obj at q <- .modifyqgaps(pfun = obj at p, qfun = obj at q, gaps = obj at gaps)
return(obj)
}
@@ -274,6 +275,7 @@
ox <- order(mattab.d[,1])
mattab.d <- matrix(mattab.d[ox,], ncol = 2)
+ mattab.d <- .consolidategaps(mattab.d)
} else mattab.d <- NULL
eval(substitute( "slot<-"(object,'gaps', value = mattab.d)))
return(invisible())
@@ -412,7 +414,8 @@
else {VZW <- gaps(x)[,1] <= 0 & gaps(x)[,2] >= 0
gapsnew <- t(apply(abs(gaps(x)), 1, sort))
gapsnew[VZW,2] <- pmin(-gaps(x)[VZW,1], gaps(x)[VZW,2])
- gapsnew[VZW,1] <- 0}
+ gapsnew[VZW,1] <- 0
+ gapsnew <- .consolidategaps(gapsnew)}
lower <- max(0, getLow(x))
upper <- max(-getLow(x) , abs(getUp(x)))
@@ -505,3 +508,19 @@
function(x) x^0.5)
}
+
+#------------------------------------------------------------------------
+# new p.l, q.r methods
+#------------------------------------------------------------------------
+
+setMethod("p.l", signature(object = "AbscontDistribution"),
+ function(object) p(object))
+
+setMethod("q.r", signature(object = "AbscontDistribution"),
+ function(object){
+ if(!is.null(gaps(object)))
+ .modifyqgaps(pfun = p(object), qfun = q(object),
+ gaps = gaps(object), leftright = "right")
+ else
+ q(object)
+ })
Modified: branches/distr-2.1/pkg/distr/R/Convpow.r
===================================================================
--- branches/distr-2.1/pkg/distr/R/Convpow.r 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/Convpow.r 2009-02-08 21:45:13 UTC (rev 396)
@@ -120,7 +120,7 @@
#
setMethod("convpow",
signature(D1 = "AcDcLcDistribution"),
- function(D1, N){
+ function(D1, N, ep = getdistrOption("TruncQuantile")){
if( !.isNatural0(N))
stop("N has to be a natural (or 0)")
if (N==0) return(Dirac(0))
@@ -129,6 +129,10 @@
if(is(e1,"DiscreteDistribution")) return(convpow(e1,N))
if(is(e1,"AbscontDistribution")) return(convpow(e1,N))
+ if(!is.numeric(ep)) stop("argument 'ep' must be a numeric.")
+ if(length(ep)!=1) stop("argument 'ep' must be a numeric of length 1.")
+ if((ep<0)||(ep>1)) stop("argument 'ep' must be in (0,1).")
+
aw1 <- acWeight(e1)
dw1 <- 1-aw1
dD1 <- discretePart(e1)
@@ -136,32 +140,39 @@
dD1 <- discretePart(e1)
if(is(dD1,"LatticeDistribution"))
dD1 <- as(dD1,"LatticeDistribution")
- dDm <- max(d.discrete(e1)(support(e1)))*dw1
+ # dDm <- max(d.discrete(e1)(support(e1)))*dw1
- ep <- getdistrOption("TruncQuantile")
-
if(aw1<ep) return(convpow(dD1,N))
- if(1-aw1<ep) return(convpow(aD1,N))
+ if(dw1<ep) return(convpow(aD1,N))
- maxN <- ceiling(2*log(ep)/log(dDm))
+ maxN <- ceiling(2*log(ep)/log(dw1))
Nm <- min(maxN,N)
Mm <- N%/%Nm
Rm <- N-Mm*Nm
- print(maxN)
-
+
sumM <- function(mm){
- DList <- lapply(seq(mm+1)-1,
- function(x) {
+ db <- dbinom(0:mm, size = mm, prob = aw1)
+ im <- (0:mm)[db>ep^2]
+ db <- db[db>ep^2]
+ db <- db/sum(db)
+ if(length(im)>1){
+ DList <- lapply(im,
+ function(x) {
S.a <- convpow(aD1, x)
S.d <- convpow(dD1, mm-x) #as(dD1,
# "DiscreteDistribution"), mm-x)
as(S.a+S.d,"UnivarLebDecDistribution")
- })
- erg <- do.call(flat.LCD, c(DList,
- alist(mixCoeff = dbinom(0:mm, size = mm, prob = aw1))))
- erg}
+ })
+ erg <- do.call(flat.LCD, c(DList, alist(mixCoeff = db)))
+ }else{
+ DList <- as(convpow(aD1,im)+convpow(S.d,mm-im),"UnivarLebDecDistribution")
+ erg <- flat.LCD(DList, mixCoeff = 1)
+ }
+ return(erg)
+ }
+
erg <- sumM(Nm)
- if(Mm>1) erg <- convpow(erg,Mm)
+ if(Mm>1) erg <- convpow(erg,Mm,ep=ep)
if(Rm>0) erg <- sumM(Rm)+ as(erg,"UnivarLebDecDistribution")
if(is(erg,"UnivarLebDecDistribution")) erg <- simplifyD(erg)
return(erg)
@@ -178,7 +189,8 @@
if (N==2) return(D1+D1)
D11 <- if (N%%2==1) D1 else Dirac(0)
DN1 <- convpow(D1,N%/%2)
- return((DN1+DN1)+D11)
+ DN1 <- DN1 + DN1
+ return(DN1+D11)
})
###############################################################################
Modified: branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -203,6 +203,9 @@
setMethod("+", c("DiscreteDistribution","DiscreteDistribution"),
function(e1,e2){
+
+ if(length(support(e1))==1) return(e2+support(e1))
+ if(length(support(e2))==1) return(e1+support(e2))
e1.L <- as(e1, "LatticeDistribution")
e2.L <- as(e2, "LatticeDistribution")
if(is(e1.L, "LatticeDistribution") & is(e2.L, "LatticeDistribution"))
@@ -283,6 +286,10 @@
})
+setMethod("+", c("Dirac","DiscreteDistribution"),
+ function(e1,e2){e2+location(e1)})
+
+
## binary operators for discrete distributions
setMethod("*", c("DiscreteDistribution","numeric"),
Modified: branches/distr-2.1/pkg/distr/R/LatticeDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/LatticeDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/LatticeDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -189,28 +189,28 @@
### Lattice Calculations:
w1 <- width(lattice(e1))
w2 <- width(lattice(e2))
+ sup1 <- support(e1)
+ sup2 <- support(e2)
+ maxl <- length(sup1)*length(sup2)
+ ### length of product grid
+ csup <- unique(sort(c(sup1,sup2)))
+ ### grid width of convolution grid
- if (abs(abs(w1)-abs(w2)) < getdistrOption("DistrResolution")){
- w <- w1
- ### else need common lattice
- }else{
+ w <- min(diff(csup))
+ commonsup <- unique(sort(c(outer(sup1,sup2,"+"))))
+ ### grid width of convolution grid
+ mw <- min(diff(commonsup))
+ if (abs(abs(w1)-abs(w2)) > getdistrOption("DistrResolution")){
W <- sort(abs(c(w1,w2)))
if (W[2] %% W[1] > getdistrOption("DistrResolution")){
-
+
## check whether arrangement on common grid really
## saves something
-
- sup1 <- support(e1)
- sup2 <- support(e2)
+
prob1 <- d(e1)(sup1)
prob2 <- d(e2)(sup2)
- maxl <- length(sup1)*length(sup2)
- ### length of product grid
- commonsup <- unique(sort(c(outer(sup1,sup2,"+"))))
- ### grid width of convolution grid
- mw <- min(diff(commonsup))
### convolutional grid
- comsup <- seq(min(commonsup),max(commonsup), by=mw)
+ comsup <- seq(min(commonsup),max(commonsup), by = mw)
fct <- function(sup0, prob0, bw){
### expand original grid,prob onto new width:
@@ -222,13 +222,13 @@
prob = prb0))
}
if(length(comsup) < maxl)
- return( fct(sup1,prob1,bw) + fct(sup2,prob2,bw))
+ return( fct(sup1,prob1,mw) + fct(sup2,prob2,mw))
else
return(as(e1, "DiscreteDistribution") +
as(e2, "DiscreteDistribution"))
}
else
- w <- W[1] #generate common lattice / support
+ w <- mw #generate common lattice / support
}
newlat <- NULL
@@ -276,12 +276,13 @@
L1 <- length(supp1)
newd <- newd[1:L1]
+
if (L1 > getdistrOption("DefaultNrGridPoints")){
rsum.u <- min( sum( rev(cumsum(rev(newd))) >=
getdistrOption("TruncQuantile")/2)+1,
length(supp1)
)
- rsum.l <- 1 + sum( cumsum(newd) <
+ rsum.l <- 1 + sum( cumsum(newd) <
getdistrOption("TruncQuantile")/2)
newd <- newd[rsum.l:rsum.u]
newd <- newd/sum(newd)
@@ -294,7 +295,8 @@
rsum.l <- 1 + sum( cumsum(newd) < .Machine$double.eps)
newd <- newd[rsum.l:rsum.u]
newd <- newd/sum(newd)
- supp1 <- supp1[rsum.l:rsum.u]}
+ supp1 <- supp1[rsum.l:rsum.u]
+ }
return(LatticeDistribution(supp = supp1, prob = newd,
lattice = newlat, .withArith = TRUE))
Modified: branches/distr-2.1/pkg/distr/R/MinMaximum.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/MinMaximum.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/MinMaximum.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -195,7 +195,7 @@
px.u <- pnew(xseq, lower.tail = FALSE)
qnew <- .makeQNew(xseq, px.l, px.u, FALSE, qL, qU)
-
+
return(AbscontDistribution( r = rnew,
d = dnew, p = pnew, q = qnew, gaps = gaps(e1),
.withArith = TRUE))
Modified: branches/distr-2.1/pkg/distr/R/Truncate.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/Truncate.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/Truncate.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -10,7 +10,9 @@
newgaps[,1] <- pmax(newgaps[,1],lower)
newgaps[,2] <- pmin(newgaps[,1],upper)
newgaps <- newgaps[newgaps[,1]<newgaps[,2],]
- if(nrow(newgaps)==0) newgaps <- NULL}
+ newgaps <- if(nrow(newgaps)==0) NULL else
+ .consolidategaps(newgaps)
+ }
if(lower == -Inf && upper == Inf) return(object)
Modified: branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -27,7 +27,9 @@
r = discretePart at r, d = NULL, q = discretePart at q,
mixCoeff = c(acWeight = 0, discreteWeight = 1),
mixDistr = new("UnivarDistrList", list(acPart = acPart,
- discretePart = discretePart))
+ discretePart = discretePart)),
+ support = support(discretePart),
+ gaps = gaps(acPart)
)
)}
if(discreteWeight < getdistrOption("TruncQuantile"))
@@ -36,7 +38,9 @@
r = acPart at r, d = NULL, q = acPart at q,
mixCoeff = c(acWeight = 1, discreteWeight = 0),
mixDistr = new("UnivarDistrList", list(acPart = acPart,
- discretePart = discretePart))
+ discretePart = discretePart)),
+ support = support(discretePart),
+ gaps = gaps(acPart)
)
)
@@ -58,14 +62,15 @@
supp <- discretePart at support
gaps <- .mergegaps(acPart at gaps,discretePart at support)
- mixDistr[[1]]@gaps <- gaps
+ #mixDistr[[1]]@gaps <- gaps
qL1 <- min(getLow(acPart), getLow(discretePart))
qU1 <- max(getUp(acPart), getUp(discretePart))
n <- getdistrOption("DefaultNrGridPoints")
h <- (qU1-qL1)/n
- xseq <- unique(sort(c(seq(from = qL1, to = qU1, by = h),gaps,supp,
- supp-getdistrOption("DistrResolution") )))
+ ep <- getdistrOption("DistrResolution")
+ xseq <- unique(sort(c(seq(from = qL1, to = qU1, by = h),gaps-ep,gaps,
+ gaps+ep,supp-ep,supp, supp+ep )))
px.l <- pnew(xseq, lower.tail = TRUE)
px.u <- pnew(xseq, lower.tail = FALSE)
@@ -79,7 +84,8 @@
new("UnivarLebDecDistribution", p = pnew, r = rnew, d = NULL, q = qnew,
mixCoeff = mixCoeff, mixDistr = mixDistr, .withSim = .withSim,
- .withArith = .withArith, .lowerExact = .lowerExact)
+ .withArith = .withArith, .lowerExact = .lowerExact, support = supp,
+ gaps = gaps)
}
############################## Accessor / Replacement functions
@@ -124,31 +130,127 @@
discreteWeight = 1-value)
obj})
+#setMethod("support", "UnivarLebDecDistribution",
+# function(object) object at mixDistr[[2]]@support)
-setMethod("support", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[2]]@support)
+#setMethod("gaps", "UnivarLebDecDistribution",
+# function(object) object at mixDistr[[1]]@gaps)
-setMethod("gaps", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[1]]@gaps)
-
setMethod("p.discrete", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[2]]@p)
+ function(object, CondOrAbs="cond"){
+ CondOrAbs0 <- pmatch(CondOrAbs,c("cond","abs"),nomatch=1)
+ pd <- object at mixDistr[[2]]@p
+ if(CondOrAbs0==1)
+ return(pd)
+ else {wd <- discreteWeight(object)
+ return(function(q, lower.tail = TRUE, log.p = FALSE ){
+ wd * pd(q, lower.tail = lower.tail, log.p = log.p)
+ })
+ }
+ })
+setMethod("d.discrete", "UnivarLebDecDistribution",
+ function(object, CondOrAbs="cond"){
+ CondOrAbs0 <- pmatch(CondOrAbs,c("cond","abs"),nomatch=1)
+ dd <- object at mixDistr[[2]]@d
+ if(CondOrAbs0==1)
+ return(dd)
+ else {wd <- discreteWeight(object)
+ return(function(x, log = FALSE ){
+ wd * dd(x, log = log)
+ })
+ }
+ })
setMethod("q.discrete", "UnivarLebDecDistribution",
function(object) object at mixDistr[[2]]@q)
-setMethod("d.discrete", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[2]]@d)
setMethod("r.discrete", "UnivarLebDecDistribution",
function(object) object at mixDistr[[2]]@r)
setMethod("p.ac", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[1]]@p)
+ function(object, CondOrAbs="cond"){
+ CondOrAbs0 <- pmatch(CondOrAbs,c("cond","abs"),nomatch=1)
+ pd <- object at mixDistr[[1]]@p
+ if(CondOrAbs0==1)
+ return(pd)
+ else {wa <- acWeight(object)
+ return(function(q, lower.tail = TRUE, log.p = FALSE ){
+ wa * pd(q, lower.tail = lower.tail, log.p = log.p)
+ })
+ }
+ })
+setMethod("d.ac", "UnivarLebDecDistribution",
+ function(object, CondOrAbs="cond"){
+ CondOrAbs0 <- pmatch(CondOrAbs,c("cond","abs"),nomatch=1)
+ dd <- object at mixDistr[[1]]@d
+ if(CondOrAbs0==1)
+ return(dd)
+ else {wa <- acWeight(object)
+ return(function(x, log = FALSE ){
+ wa * dd(x, log = log)
+ })
+ }
+ })
setMethod("q.ac", "UnivarLebDecDistribution",
function(object) object at mixDistr[[1]]@q)
-setMethod("d.ac", "UnivarLebDecDistribution",
- function(object) object at mixDistr[[1]]@d)
setMethod("r.ac", "UnivarLebDecDistribution",
function(object) object at mixDistr[[1]]@r)
+
+
+setMethod("p.l", "UnivarLebDecDistribution", function(object){
+ ep <- getdistrOption("TruncQuantile")
+ w.d <- discreteWeight(object)
+ w.a <- acWeight(object)
+ if(w.d<ep) return(p(object))
+ mixCoeff <- c(w.a,w.d)
+ p.a <- p(acPart(object))
+ p.d <- p.l(discretePart(object))
+ return(function(q, lower.tail = TRUE, log.p = FALSE){
+ p <- cbind(p.a(q, lower.tail = lower.tail),
+ p.d(q, lower.tail = lower.tail))
+ p <- as.vector(p%*%mixCoeff)
+ if(log.p) p <- log(p)
+ return(p)
+ })
+ })
+
+### right continuous quantile function
+
+setMethod("q.r", "UnivarLebDecDistribution", function(object){
+ ep <- getdistrOption("TruncQuantile")
+ if(discreteWeight(object)<ep) return(q(object))
+ supp <- support(object)
+ gaps <- gaps(object)
+ aP <- acPart(object)
+ dP <- discretePart(object)
+ pl <- p.l(object)
+ qL1 <- min(getLow(aP), getLow(dP))
+ qU1 <- max(getUp(aP), getUp(dP))
+ n <- getdistrOption("DefaultNrGridPoints")
+ h <- (qU1-qL1)/n
+ xseq <- unique(sort(c(seq(from = qL1, to = qU1, by = h),
+ gaps-ep,gaps,gaps+ep,
+ supp-ep,supp, supp+ep )))
+ px.l <- pl(q=xseq, lower.tail = TRUE)
+ px.u <- pl(q=xseq, lower.tail = FALSE)
+
+ qL2 <- min(aP at q(0),dP at q(0))
+ qU2 <- max(aP at q(1),dP at q(1))
+
+ return( .makeQNew(xseq, px.l, px.u, FALSE, qL2, qU2))
+})
+
+
+
+
+
+
+setMethod("prob", "UnivarLebDecDistribution",
+function(object) {pr0 <- prob(as(object at mixDistr[[2]],"DiscreteDistribution"))
+ d <- discreteWeight(object)
+ return(rbind("cond"=pr0,"abs"=d*pr0))})
+
+
+
############################## setAs relations
setAs("AbscontDistribution", "UnivarLebDecDistribution",
@@ -274,7 +376,8 @@
q = Distr at q, X0 = e1, mixDistr = Distr at mixDistr,
mixCoeff = Distr at mixCoeff,
a = e2, b = 0, .withSim = e1 at .withSim,
- .withArith = TRUE)
+ .withArith = TRUE, support= support(Distr),
+ gaps = gaps(Distr))
object})
setMethod("+", c("UnivarLebDecDistribution","numeric"),
@@ -293,7 +396,8 @@
q = Distr at q, X0 = e1, mixDistr = Distr at mixDistr,
mixCoeff = Distr at mixCoeff,
a = 1, b = e2, .withSim = e1 at .withSim,
- .withArith = TRUE)
+ .withArith = TRUE, support= support(Distr),
+ gaps = gaps(Distr))
object})
#setMethod("*", c("numeric","UnivarLebDecDistribution"),
Modified: branches/distr-2.1/pkg/distr/R/UnivarMixingDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/UnivarMixingDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/UnivarMixingDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -30,13 +30,30 @@
all( as.logical(lapply(mixDistr, function(x) is(x,"DiscreteDistribution")))))
dnew <- .dmixfun(mixDistr = mixDistr, mixCoeff = mixCoeff)
-
+ gaps <- NULL
+ for(i in 1:l){
+ if(is.null(gaps)){
+ try(gaps <- gaps(mixDistr[[i]]), silent=TRUE)
+ }else{
+ if(!is(try(gaps0 <- gaps(mixDistr[[i]]), silent=TRUE),"try-error"))
+ gaps <- .mergegaps2(gaps,gaps0)
+ }
+ }
+ support <- numeric(0)
+ for(i in 1:l){
+ if(!is(try(support0 <- support(mixDistr[[i]]), silent=TRUE),"try-error"))
+ support <- unique(sort(c(support,support0)))
+ }
+
+ gaps <- .mergegaps(gaps,support)
+
qnew <- .qmixfun(mixDistr = mixDistr, mixCoeff = mixCoeff,
- Cont = TRUE, pnew = pnew)
+ Cont = TRUE, pnew = pnew, gaps = gaps)
obj <- new("UnivarMixingDistribution", p = pnew, r = rnew, d = NULL, q = qnew,
mixCoeff = mixCoeff, mixDistr = mixDistr, .withSim = .withSim,
- .withArith = .withArith,.lowerExact =.lowerExact)
+ .withArith = .withArith,.lowerExact =.lowerExact, gaps = gaps,
+ support = support)
if (withSimplify)
obj <- simplifyD(obj)
@@ -53,3 +70,25 @@
setMethod("mixDistr", "UnivarMixingDistribution", function(object)object at mixDistr)
setReplaceMethod("mixDistr", "UnivarMixingDistribution", function(object,value){
object at mixDistr<- value; object})
+
+setMethod("support", "UnivarMixingDistribution", function(object)object at support)
+setMethod("gaps", "UnivarMixingDistribution", function(object)object at gaps)
+
+
+#------------------------------------------------------------------------
+# new p.l, q.r methods
+#------------------------------------------------------------------------
+
+setMethod("p.l", signature(object = "UnivarMixingDistribution"),
+ function(object) .pmixfun(mixDistr = mixDistr(object),
+ mixCoeff = mixCoeff(object),
+ leftright = "left"))
+
+setMethod("q.r", signature(object = "UnivarMixingDistribution"),
+ function(object){
+ if(!is.null(gaps(object)))
+ .modifyqgaps(pfun = p(object), qfun = q(object),
+ gaps = gaps(object), leftright = "right")
+ else
+ q(object)
+ })
Modified: branches/distr-2.1/pkg/distr/R/bAffLinUnivarLebDecDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/bAffLinUnivarLebDecDistribution.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/bAffLinUnivarLebDecDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -10,6 +10,13 @@
if (isTRUE(all.equal(e2,1))) return(e1)
if (isTRUE(all.equal(e2,0)))
return(new("Dirac", location = 0))
+
+ if(.isEqual(e1 at a*e2,1)&&.isEqual(e1 at b,0)){
+ obj <- e1 at X0
+ if(getdistrOption("simplifyD"))
+ obj <- simplifyD(obj)
+ return(obj)
+ }
Distr <- UnivarLebDecDistribution(
discretePart = discretePart(e1)*e2,
@@ -17,19 +24,14 @@
discreteWeight = discreteWeight(e1),
acWeight = acWeight(e1))
- if(.isEqual(e1 at a*e2,1)&&.isEqual(e1 at b,0)){
- obj <- e1 at X0
- if(getdistrOption("simplifyD"))
- obj <- simplifyD(obj)
- return(obj)
- }
object <- new("AffLinUnivarLebDecDistribution",
r = Distr at r, d = Distr at d, p = Distr at p,
q = Distr at q, X0 = e1 at X0, mixDistr = Distr at mixDistr,
mixCoeff = Distr at mixCoeff,
a = e1 at a*e2, b = e1 at b, .withSim = e1 at .withSim,
.withArith = TRUE,
- .logExact = .logExact(e1), .lowerExact = .lowerExact(e1)
+ .logExact = .logExact(e1), .lowerExact = .lowerExact(e1),
+ gaps = gaps(Distr), support = support(Distr)
)
object})
@@ -38,12 +40,6 @@
if (length(e2)>1) stop("length of operator must be 1")
if (isTRUE(all.equal(e2,0))) return(e1)
- Distr <- UnivarLebDecDistribution(
- discretePart = discretePart(e1)+e2,
- acPart = acPart(e1)+e2,
- discreteWeight = discreteWeight(e1),
- acWeight = acWeight(e1))
-
if(.isEqual(e1 at a,1)&&.isEqual(e1 at b+e2,0)){
obj <- e1 at X0
if(getdistrOption("simplifyD"))
@@ -51,13 +47,20 @@
return(obj)
}
+ Distr <- UnivarLebDecDistribution(
+ discretePart = discretePart(e1)+e2,
+ acPart = acPart(e1)+e2,
+ discreteWeight = discreteWeight(e1),
+ acWeight = acWeight(e1))
+
object <- new("AffLinUnivarLebDecDistribution",
r = Distr at r, d = Distr at d, p = Distr at p,
q = Distr at q, X0 = e1 at X0, mixDistr = Distr at mixDistr,
mixCoeff = Distr at mixCoeff,
a = e1 at a, b = e1 at b+e2, .withSim = e1 at .withSim,
.withArith = TRUE,
- .logExact = .logExact(e1), .lowerExact = .lowerExact(e1)
+ .logExact = .logExact(e1), .lowerExact = .lowerExact(e1),
+ gaps = gaps(Distr), support = support(Distr)
)
object})
Modified: branches/distr-2.1/pkg/distr/R/flat.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/flat.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/flat.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -57,7 +57,7 @@
f.c <- AbscontDistribution( r = rnew.c, d = dnew.c, p = pnew.c,
q = qnew.c,
.withSim = .withSim, .withArith = TRUE)
- if(withgaps) setgaps(f.c)
+ if(withgaps && is.null(gaps(f.c))) setgaps(f.c)
}
else f.c <- Norm()
Modified: branches/distr-2.1/pkg/distr/R/getLow.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/getLow.R 2009-02-06 20:53:24 UTC (rev 395)
+++ branches/distr-2.1/pkg/distr/R/getLow.R 2009-02-08 21:45:13 UTC (rev 396)
@@ -90,3 +90,43 @@
lower.tail = FALSE))
})
+
+ setMethod("getLow", "UnivarLebDecDistribution",
+ function(object, eps = getdistrOption("TruncQuantile"))
+ min(getLow(discretePart(object)),
+ getLow(acPart(object), eps = eps)))
+ setMethod("getUp", "UnivarLebDecDistribution",
+ function(object, eps = getdistrOption("TruncQuantile"))
+ max(getUp(discretePart(object)),
+ getUp(acPart(object), eps = eps)))
+
+ setMethod("getLow", "UnivarMixingDistribution",
+ function(object, eps = getdistrOption("TruncQuantile")){
+ l <- length(mixCoeff)
+ low <- Inf
+ for(i in 1:l){
+ if(!is(try(low0 <- getLow(mixDistr[[i]], eps = eps),
+ silent = TRUE), "try-error"))
+ low <- min(low,low0)
+ else {
+ if(!is(try(low0 <- getLow(mixDistr[[i]]),
+ silent = TRUE), "try-error"))
+ low <- min(low,low0)
+ }
+ }
+ return(low)})
+ setMethod("getUp", "UnivarMixingDistribution",
+ function(object, eps = getdistrOption("TruncQuantile")){
+ l <- length(mixCoeff)
+ up <- -Inf
+ for(i in 1:l){
+ if(!is(try(up0 <- getUp(mixDistr[[i]], eps = eps),
+ silent = TRUE), "try-error"))
+ up <- max(up,up0)
+ else {
+ if(!is(try(up0 <- getUp(mixDistr[[i]]),
+ silent = TRUE), "try-error"))
+ up <- max(up,up0)
+ }
+ }
+ return(up)})
Modified: branches/distr-2.1/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/internalUtils.R 2009-02-06 20:53:24 UTC (rev 395)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 396
More information about the Distr-commits
mailing list