[Distr-commits] r397 - in branches/distr-2.1/pkg/distr: R chm man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Feb 9 04:12:20 CET 2009
Author: ruckdeschel
Date: 2009-02-09 04:12:20 +0100 (Mon, 09 Feb 2009)
New Revision: 397
Modified:
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/UnivarLebDecDistribution.R
branches/distr-2.1/pkg/distr/R/internalUtils.R
branches/distr-2.1/pkg/distr/R/makeAbscontDistribution.R
branches/distr-2.1/pkg/distr/chm/ConvPow.html
branches/distr-2.1/pkg/distr/chm/Distr.chm
branches/distr-2.1/pkg/distr/man/ConvPow.Rd
Log:
fixed some buglets/errors
- gaps matrix could falsely have 0 rows (instead of being set to NULL)
- some minor enhancements in convpow and "+", "LatticeDistribution","LatticeDistribution"
and correction of a buglet there (e.g., lattice width oould get too small)
- in order to smear out mass point on the border, makeAbscontDistribution()
enlarges upper and lower bounds
Modified: branches/distr-2.1/pkg/distr/R/ContDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/ContDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/ContDistribution.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -276,6 +276,8 @@
ox <- order(mattab.d[,1])
mattab.d <- matrix(mattab.d[ox,], ncol = 2)
mattab.d <- .consolidategaps(mattab.d)
+ if(nrow(mattab.d)==0) mattab.d <- NULL
+ if(length(mattab.d)==0) mattab.d <- NULL
} else mattab.d <- NULL
eval(substitute( "slot<-"(object,'gaps', value = mattab.d)))
return(invisible())
Modified: branches/distr-2.1/pkg/distr/R/Convpow.r
===================================================================
--- branches/distr-2.1/pkg/distr/R/Convpow.r 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/Convpow.r 2009-02-09 03:12:20 UTC (rev 397)
@@ -77,13 +77,16 @@
setMethod("convpow",
signature(D1 = "LatticeDistribution"),
- 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))
-
if (N==1) return(D1)
+ 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).")
+
w <- width(lattice(D1))
supp0 <- support(D1)
@@ -98,18 +101,23 @@
newd <- Re(fft(ftde1^N, inverse = TRUE)) / length(ftde1)
newd <- (abs(newd) >= .Machine$double.eps)*newd
- rsum.u <- min( sum( rev(cumsum(rev(newd))) <=
- getdistrOption("TruncQuantile")/2)+1,
- length(supp1))
- rsum.l <- max( sum( cumsum(newd) <
- getdistrOption("TruncQuantile")/2),
- 1)
+ rsum.u <- min( sum( rev(cumsum(rev(newd))) <= ep/2)+1, length(supp1))
+ rsum.l <- max( sum( cumsum(newd) < ep/2), 1)
newd <- newd[rsum.l:rsum.u]
newd <- newd/sum(newd)
supp1 <- supp1[rsum.l:rsum.u]
-
- return(LatticeDistribution(supp=supp1,prob=newd))
+
+ supp2 <- supp1[newd>ep]
+ newd2 <- newd[newd>ep]
+ newd2 <- newd2/sum(newd2)
+
+ if( length(supp1) >= 2 * length(supp2))
+ return(DiscreteDistribution(supp = supp2, prob = newd2,
+ .withArith = TRUE))
+ else
+ return(LatticeDistribution(supp = supp1, prob = newd,
+ .withArith = TRUE))
})
###############################################################################
@@ -165,7 +173,7 @@
})
erg <- do.call(flat.LCD, c(DList, alist(mixCoeff = db)))
}else{
- DList <- as(convpow(aD1,im)+convpow(S.d,mm-im),"UnivarLebDecDistribution")
+ DList <- as(convpow(aD1,im)+convpow(dD1,mm-im),"UnivarLebDecDistribution")
erg <- flat.LCD(DList, mixCoeff = 1)
}
return(erg)
@@ -187,10 +195,10 @@
if (N==0) return(Dirac(0))
if (N==1) return(D1)
if (N==2) return(D1+D1)
- D11 <- if (N%%2==1) D1 else Dirac(0)
DN1 <- convpow(D1,N%/%2)
DN1 <- DN1 + DN1
- return(DN1+D11)
+ if (N%%2==1) DN1 <- DN1+D1
+ return(DN1)
})
###############################################################################
Modified: branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/DiscreteDistribution.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -361,7 +361,7 @@
object <- new("DiscreteDistribution", r = rnew, p = pnew,
q = qnew, d = dnew, support = supportnew,
.withSim = x at .withSim, .withArith = TRUE,
- .lowerExact = x at .lowerExact)
+ .lowerExact = .lowerExact(x))
object
})
@@ -441,6 +441,6 @@
prob = value,
.withArith = object at .withArith,
.withSim = object at .withSim,
- .lowerExact = object at .lowerExact,
- .logExact = object at .logExact))}
+ .lowerExact = .lowerExact(object),
+ .logExact = .logExact(object)))}
)
Modified: branches/distr-2.1/pkg/distr/R/LatticeDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/LatticeDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/LatticeDistribution.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -199,7 +199,8 @@
w <- min(diff(csup))
commonsup <- unique(sort(c(outer(sup1,sup2,"+"))))
### grid width of convolution grid
- mw <- min(diff(commonsup))
+ dcs <- abs(diff(commonsup))
+ mw <- min(dcs[dcs>getdistrOption("DistrResolution")])
if (abs(abs(w1)-abs(w2)) > getdistrOption("DistrResolution")){
W <- sort(abs(c(w1,w2)))
if (W[2] %% W[1] > getdistrOption("DistrResolution")){
@@ -276,7 +277,6 @@
L1 <- length(supp1)
newd <- newd[1:L1]
-
if (L1 > getdistrOption("DefaultNrGridPoints")){
rsum.u <- min( sum( rev(cumsum(rev(newd))) >=
getdistrOption("TruncQuantile")/2)+1,
@@ -293,13 +293,21 @@
length(supp1)
)
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]
}
+ supp2 <- supp1[newd > getdistrOption("TruncQuantile")]
+ newd2 <- newd[newd > getdistrOption("TruncQuantile")]
+ newd2 <- newd2/sum(newd2)
- return(LatticeDistribution(supp = supp1, prob = newd,
- lattice = newlat, .withArith = TRUE))
+ if( length(supp1) >= 2 * length(supp2))
+ return(DiscreteDistribution(supp = supp2, prob = newd2,
+ .withArith = TRUE))
+ else
+ return(LatticeDistribution(supp = supp1, prob = newd,
+ .withArith = TRUE))
})
## extra methods
Modified: branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/UnivarLebDecDistribution.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -376,6 +376,7 @@
q = Distr at q, X0 = e1, mixDistr = Distr at mixDistr,
mixCoeff = Distr at mixCoeff,
a = e2, b = 0, .withSim = e1 at .withSim,
+ .logExact = .logExact(e1), .lowerExact = .lowerExact(e1),
.withArith = TRUE, support= support(Distr),
gaps = gaps(Distr))
object})
@@ -397,6 +398,7 @@
mixCoeff = Distr at mixCoeff,
a = 1, b = e2, .withSim = e1 at .withSim,
.withArith = TRUE, support= support(Distr),
+ .logExact = .logExact(e1), .lowerExact = .lowerExact(e1),
gaps = gaps(Distr))
object})
Modified: branches/distr-2.1/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/internalUtils.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/internalUtils.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -196,6 +196,7 @@
x <- seq(from = lower, to = upper, by = h)
if(TRUE){#.notwithLArg(D)){
return(diff(p(D)(x)))
+# return((diff(p(D)(x))+diff(rev(p(D)(x,lower=FALSE))))/2)
}else{
M <- q(D)(0.5); L <- length(x)
x.l <- x [ x <= M ]; x.u <- x [ x >= M ]
Modified: branches/distr-2.1/pkg/distr/R/makeAbscontDistribution.R
===================================================================
--- branches/distr-2.1/pkg/distr/R/makeAbscontDistribution.R 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/R/makeAbscontDistribution.R 2009-02-09 03:12:20 UTC (rev 397)
@@ -8,14 +8,14 @@
if(missing(img)) img0 <- img(object)
if(is.null(img)) img0 <- img(object)
pfun <- p(object)
- low0 <- q(object)(0)
- up0 <- q(object)(1)
- low1 <- getLow(object,ep)
- up1 <- getUp(object,ep)
+ low0 <- q(object)(0)*1.001
+ up0 <- q(object)(1)*1.001
+ low1 <- getLow(object,ep)*1.001
+ up1 <- getUp(object,ep)*1.001
wS <- object at .withSim
wA <- object at .withArith
- lE <- object at .lowerExact
- loE <- object at .logExact
+ lE <- .lowerExact(object)
+ loE <- .logExact(object)
AbscontDistribution(p = pfun, gaps = gaps, param = param, img = img0,
.withSim = wS, .withArith = wA, .lowerExact = lE,
.logExact = loE, withgaps = withgaps, low1 = low1, up1 = up1,
Modified: branches/distr-2.1/pkg/distr/chm/ConvPow.html
===================================================================
--- branches/distr-2.1/pkg/distr/chm/ConvPow.html 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/chm/ConvPow.html 2009-02-09 03:12:20 UTC (rev 397)
@@ -41,7 +41,8 @@
## S4 method for signature 'AbscontDistribution':
convpow(D1,N)
## S4 method for signature 'LatticeDistribution':
- convpow(D1,N)
+ convpow(D1,N,
+ ep = getdistrOption("TruncQuantile"))
## S4 method for signature 'DiscreteDistribution':
convpow(D1,N)
## S4 method for signature 'AcDcLcDistribution':
@@ -65,7 +66,10 @@
an integer or 0 (for 0 returns Dirac(0), for 1 D1)</td></tr>
<tr valign="top"><td><code>ep</code></td>
<td>
-numeric of length 1 in (0,1) — if <code>(acWeight(object)<ep)</code>
+numeric of length 1 in (0,1) —
+for <code>"LatticeDistribution"</code>: support points will be
+cancelled if their probability is less than <code>ep</code>;
+for <code>"UnivarLebDecDistribution"</code>: if <code>(acWeight(object)<ep)</code>
we work with the discrete parts only, and, similarly, if
<code>(discreteWeight(object)<ep)</code> we with the absolutely continuous
parts only.</td></tr>
Modified: branches/distr-2.1/pkg/distr/chm/Distr.chm
===================================================================
(Binary files differ)
Modified: branches/distr-2.1/pkg/distr/man/ConvPow.Rd
===================================================================
--- branches/distr-2.1/pkg/distr/man/ConvPow.Rd 2009-02-08 21:45:13 UTC (rev 396)
+++ branches/distr-2.1/pkg/distr/man/ConvPow.Rd 2009-02-09 03:12:20 UTC (rev 397)
@@ -24,7 +24,8 @@
\usage{
convpow(D1,...)
\S4method{convpow}{AbscontDistribution}(D1,N)
- \S4method{convpow}{LatticeDistribution}(D1,N)
+ \S4method{convpow}{LatticeDistribution}(D1,N,
+ ep = getdistrOption("TruncQuantile"))
\S4method{convpow}{DiscreteDistribution}(D1,N)
\S4method{convpow}{AcDcLcDistribution}(D1,N,
ep = getdistrOption("TruncQuantile"))
@@ -35,7 +36,10 @@
\code{"LatticeDistribution"} or of \code{"UnivarLebDecDistribution"}}
\item{\dots}{not yet used; meanwhile takes up N }
\item{N}{ an integer or 0 (for 0 returns Dirac(0), for 1 D1)}
- \item{ep}{ numeric of length 1 in (0,1) --- if \code{(acWeight(object)<ep)}
+ \item{ep}{ numeric of length 1 in (0,1) ---
+ for \code{"LatticeDistribution"}: support points will be
+ cancelled if their probability is less than \code{ep};
+ for \code{"UnivarLebDecDistribution"}: if \code{(acWeight(object)<ep)}
we work with the discrete parts only, and, similarly, if
\code{(discreteWeight(object)<ep)} we with the absolutely continuous
parts only.}
More information about the Distr-commits
mailing list