[Distr-commits] r1184 - in pkg/distr: . R inst man src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jul 8 16:28:00 CEST 2018
Author: ruckdeschel
Date: 2018-07-08 16:27:59 +0200 (Sun, 08 Jul 2018)
New Revision: 1184
Added:
pkg/distr/inst/unitTests/
pkg/distr/src/distr.h
pkg/distr/src/init.c
pkg/distr/tests/doSvUnit.R
pkg/distr/tests/unitTests/
Removed:
pkg/distr/inst/unitTests/
pkg/distr/src/distr.h
pkg/distr/src/init.c
pkg/distr/tests/doSvUnit.R
pkg/distr/tests/unitTests/
Modified:
pkg/distr/DESCRIPTION
pkg/distr/NAMESPACE
pkg/distr/R/AllInitialize.R
pkg/distr/R/CompoundDistribution.R
pkg/distr/R/ContDistribution.R
pkg/distr/R/Convpow.R
pkg/distr/R/DiscreteDistribution.R
pkg/distr/R/ExtraConvolutionMethods.R
pkg/distr/R/LatticeDistribution.R
pkg/distr/R/MinMaximum.R
pkg/distr/R/Truncate.R
pkg/distr/R/UnivarLebDecDistribution.R
pkg/distr/R/UnivarMixingDistribution.R
pkg/distr/R/bAcDcLcDistribution.R
pkg/distr/R/getLow.R
pkg/distr/R/internalUtils.R
pkg/distr/R/internalUtils_LCD.R
pkg/distr/R/internalUtils_trunc.R
pkg/distr/R/internals-qqplot.R
pkg/distr/R/liesInSupport.R
pkg/distr/R/makeAbscontDistribution.R
pkg/distr/R/plot-methods.R
pkg/distr/R/plot-methods_LebDec.R
pkg/distr/R/qqbounds.R
pkg/distr/R/qqplot.R
pkg/distr/inst/NEWS
pkg/distr/man/0distr-package.Rd
pkg/distr/man/AbscontDistribution-class.Rd
pkg/distr/man/AbscontDistribution.Rd
pkg/distr/man/Arcsine-class.Rd
pkg/distr/man/Beta-class.Rd
pkg/distr/man/Binom-class.Rd
pkg/distr/man/Cauchy-class.Rd
pkg/distr/man/Chisq-class.Rd
pkg/distr/man/DExp-class.Rd
pkg/distr/man/Dirac-class.Rd
pkg/distr/man/DiscreteDistribution-class.Rd
pkg/distr/man/Exp-class.Rd
pkg/distr/man/Fd-class.Rd
pkg/distr/man/Gammad-class.Rd
pkg/distr/man/Geom-class.Rd
pkg/distr/man/Hyper-class.Rd
pkg/distr/man/LatticeDistribution-class.Rd
pkg/distr/man/Lnorm-class.Rd
pkg/distr/man/Logis-class.Rd
pkg/distr/man/Nbinom-class.Rd
pkg/distr/man/Norm-class.Rd
pkg/distr/man/Pois-class.Rd
pkg/distr/man/Td-class.Rd
pkg/distr/man/Truncate-methods.Rd
pkg/distr/man/Unif-class.Rd
pkg/distr/man/UnivarLebDecDistribution-class.Rd
pkg/distr/man/Weibull-class.Rd
pkg/distr/man/internals.Rd
pkg/distr/man/q-methods.Rd
Log:
[distr] merged branch 2.7 back to trunk
Modified: pkg/distr/DESCRIPTION
===================================================================
--- pkg/distr/DESCRIPTION 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/DESCRIPTION 2018-07-08 14:27:59 UTC (rev 1184)
@@ -1,20 +1,23 @@
Package: distr
-Version: 2.6.2
-Date: 2017-04-22
+Version: 2.7.0
+Date: 2018-07-08
Title: Object Oriented Implementation of Distributions
Description: S4-classes and methods for distributions.
-Authors at R: c(person("Florian", "Camphausen", role="ctb", comment="contributed as student in the initial phase --2005"),
- person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", "Ruckdeschel", role=c("cre", "cph"),
- email="peter.ruckdeschel at uni-oldenburg.de"), person("Thomas", "Stabla", role="ctb", comment="contributed as student in the
- initial phase --2005"), person("R Core Team", role = c("ctb", "cph"), comment="for source file ks.c/ routines 'pKS2' and
- 'pKolmogorov2x'"))
-Depends: R(>= 2.14.0), methods, graphics, startupmsg, sfsmisc, SweaveListingUtils
-Suggests: distrEx, svUnit (>= 0.7-11)
+Authors at R: c(person("Florian", "Camphausen", role="ctb", comment="contributed as student in the
+ initial phase --2005"), person("Matthias", "Kohl", role=c("aut", "cph")),
+ person("Peter", "Ruckdeschel", role=c("cre", "cph"),
+ email="peter.ruckdeschel at uni-oldenburg.de"), person("Thomas", "Stabla", role="ctb",
+ comment="contributed as student in the initial phase --2005"), person("R Core Team",
+ role = c("ctb", "cph"), comment="for source file ks.c/ routines 'pKS2' and
+ 'pKolmogorov2x'"))
+Depends: R(>= 2.14.0), methods, graphics, startupmsg, sfsmisc
+Suggests: distrEx, svUnit (>= 0.7-11), knitr
Imports: stats, grDevices, utils, MASS
+VignetteBuilder: knitr
ByteCompile: yes
Encoding: latin1
License: LGPL-3
URL: http://distr.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 1132
+SVNRevision: 1173
Modified: pkg/distr/NAMESPACE
===================================================================
--- pkg/distr/NAMESPACE 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/NAMESPACE 2018-07-08 14:27:59 UTC (rev 1184)
@@ -7,7 +7,6 @@
importFrom("utils", "str")
importFrom("sfsmisc", "D1ss")
import("startupmsg")
-import("SweaveListingUtils")
export("Beta", "Binom", "Cauchy", "Chisq",
"Dirac","Exp", "DExp", "Fd", "Gammad",
Modified: pkg/distr/R/AllInitialize.R
===================================================================
--- pkg/distr/R/AllInitialize.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/AllInitialize.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -1,5 +1,5 @@
#### as to whether to use Generating functions or to use initialize methods:
-#### http://tolstoy.newcastle.edu.au/R/e2/devel/07/01/1976.html
+#### https://tolstoy.newcastle.edu.au/R/e2/devel/07/01/1976.html
################################################################################
## SPACES
Modified: pkg/distr/R/CompoundDistribution.R
===================================================================
--- pkg/distr/R/CompoundDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/CompoundDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -23,16 +23,18 @@
is0 <- 0 %in% supp
lI <- vector("list", length(supp))
if(is0) lI[[1]] <- Dirac(0)
+ ## bugfix :: bug detected by Wolfgang Kreitmeier <wkreitmeier at gmx.de> 29.07.2016
if(length(suppNot0)){
if(is(SummandsDistr,"UnivariateDistribution")){
- dsuppNot0 <- c(suppNot0,diff(suppNot0))
- S <- 0
+# dsuppNot0 <- c(suppNot0,diff(suppNot0))
+# S <- 0
for (i in 1:length(suppNot0)){
- x0 <- convpow(SummandsDistr,dsuppNot0[i])
- S <- S + x0
+# x0 <- convpow(SummandsDistr,suppNot0[i])
+ S <- convpow(SummandsDistr,suppNot0[i])
+# S <- S + x0
lI[[i+is0]] <- S
- Symmetry <- Symmetry(SummandsDistr)
- }
+ }
+ Symmetry <- Symmetry(SummandsDistr)
}else{
supp <- min(supp):max(supp)
if( (length(supp)!=length(SummandsDistr)) &&
Modified: pkg/distr/R/ContDistribution.R
===================================================================
--- pkg/distr/R/ContDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/ContDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -22,6 +22,7 @@
d1 <- d
wS <- .withSim
wA <- .withArith
+ q.l0 <- q
if(is.null(r)){
if(is.null(q)){
if(is.null(p)){
@@ -72,9 +73,9 @@
}
}
p <- .D2P(d = d1, ql = low1, qu = up1, ngrid = ngrid)
- q <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
+ q <- q.l0 <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
qL = low, qU = up)
- r <- function(n) q(runif(n))
+ r <- function(n) q.l0(runif(n))
}else{
if(is.null(low1)){
i <- 0; x0 <- -1
@@ -87,21 +88,22 @@
up1 <- x0
}
- q <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
+ q <- q.l0 <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
qL = low, qU = up)
- r <- function(n) q(runif(n))
+ r <- function(n) q.l0(runif(n))
if( is.null(d))
d <- .P2D(p = p, ql = low1, qu = up1, ngrid = ngrid)
}
}else{
+ q.l0 <- q
if(is.null(p))
- p <- .Q2P(q, ngrid = ngrid)
- r <- function(n) q(runif(n))
+ p <- .Q2P(q.l0, ngrid = ngrid)
+ r <- function(n) q.l0(runif(n))
if( is.null(d)){
if(is.null(low1))
- low1 <- q(ep)
+ low1 <- q.l0(ep)
if(is.null(up1))
- up1 <- q(1-ep)
+ up1 <- q.l0(1-ep)
d <- .P2D(p = p, ql = low1, qu = up1, ngrid = ngrid)
}
}
@@ -111,14 +113,15 @@
if(is.null(q)){
erg <- RtoDPQ(r = r, e = e, n = ngrid)
wS <- TRUE
- d <- erg$d; p <- erg$p; q<- erg$q
+ d <- erg$d; p <- erg$p; q<- q.l0<- erg$q
}else{
+ q.l0 <- q
p <- .Q2P(q, ngrid = ngrid)
if( is.null(d)){
if(is.null(low1))
- low1 <- q(ep)
+ low1 <- q.l0(ep)
if(is.null(up1))
- up1 <- q(1-ep)
+ up1 <- q.l0(1-ep)
d <- .P2D(p = p, ql = low1, qu = up1, ngrid = ngrid)
}
}
@@ -134,7 +137,7 @@
while(p(x0)< 1-ep && i < 20) x0 <- x0 * 2
up1 <- x0
}
- q <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
+ q <- q.l0 <- .P2Q(p = p, ql = low1, qu = up1, ngrid = ngrid,
qL = low, qU = up)
d <- .P2D(p = p, ql = low1, qu = up1, ngrid = ngrid)
}
@@ -192,7 +195,7 @@
}
p <- .D2P(d = d1, ql = low1, qu=up1, ngrid = ngrid)
- q <- .P2Q(p = p, ql = low1, qu=up1, ngrid = ngrid,
+ q <- q.l0 <- .P2Q(p = p, ql = low1, qu=up1, ngrid = ngrid,
qL = low, qU = up)
}else
p <- .Q2P(q, ngrid = ngrid)
@@ -208,13 +211,13 @@
while(p(x0)< 1-ep && i < 20) x0 <- x0 * 2
up1 <- x0
}
- q <- .P2Q(p = p, ql = low1, qu=up1, ngrid = ngrid,
+ q <- q.l0 <- .P2Q(p = p, ql = low1, qu=up1, ngrid = ngrid,
qL = low, qU = up)
}
}
}
}
- obj <- new("AbscontDistribution", r = r, d = d1, p = p, q = q,
+ obj <- new("AbscontDistribution", r = r, d = d1, p = p, q = q.l0,
gaps = gaps, param = param, img = img, .withSim = wS,
.withArith = wA, .lowerExact = .lowerExact, .logExact = .logExact,
Symmetry = Symmetry)
@@ -256,8 +259,8 @@
upper <- getUp(object, eps = getdistrOption("TruncQuantile")*2)
#lower <- 0 ; upper <- 8
dist <- upper - lower
- low1 <- max(q(object)(0),lower-0.1*dist)
- upp1 <- min(q(object)(1),upper+0.1*dist)
+ low1 <- max(q.l(object)(0),lower-0.1*dist)
+ upp1 <- min(q.l(object)(1),upper+0.1*dist)
grid <- seq(from = low1, to = upp1, length = ngrid)
dxg <- d(object)(grid)
@@ -322,9 +325,9 @@
## quantile function
- yL <- if ((q(e1)(0) == -Inf)||(q(e2)(0) == -Inf))
+ yL <- if ((q.l(e1)(0) == -Inf)||(q.l(e2)(0) == -Inf))
-Inf else getLow(e1)+getLow(e2)
- yR <- if ((q(e1)(1) == Inf)||(q(e2)(1) == Inf))
+ yR <- if ((q.l(e1)(1) == Inf)||(q.l(e2)(1) == Inf))
Inf else getUp(e1)+getUp(e2)
px.l <- pfun(x + 0.5*h)
@@ -352,8 +355,8 @@
###setMethod("m1df", "AbscontDistribution",
### function(object){
-### lower <- q(object)(TruncQuantile)
-### upper <- q(object)(1 - TruncQuantile)
+### lower <- q.l(object)(TruncQuantile)
+### upper <- q.l(object)(1 - TruncQuantile)
###
### gitter.x <- seq(from = lower, to = upper, length = DefaultNrGridPoints)
###
@@ -369,8 +372,8 @@
###setMethod("m2df", "AbscontDistribution",
### function(object){
-### lower <- q(object)(TruncQuantile)
-### upper <- q(object)(1 - TruncQuantile)
+### lower <- q.l(object)(TruncQuantile)
+### upper <- q.l(object)(1 - TruncQuantile)
###
### gitter.x <- seq(from = lower, to = upper, length = DefaultNrGridPoints)
###
@@ -426,7 +429,7 @@
n <- 10^getdistrOption("RtoDPQ.e")+1
u <- seq(0,1,length=n+1); u <- (u[1:n]+u[2:(n+1)])/2
- y <- callGeneric(q(x)(u))
+ y <- callGeneric(q.l(x)(u))
DPQnew <- RtoDPQ(r=rnew, y=y)
object <- AbscontDistribution(d = DPQnew$d, p = DPQnew$p,
@@ -466,18 +469,18 @@
else
quote({log(1-p(xx)(q))})
- qxlog <- if("lower.tail" %in% names(formals(q(xx))))
+ qxlog <- if("lower.tail" %in% names(formals(q.l(xx))))
quote({qx <- if(lower.tail)
- q(xx)((1+p1)/2)
+ q.l(xx)((1+p1)/2)
else
- q(xx)(p1/2,lower.tail=FALSE)})
+ q.l(xx)(p1/2,lower.tail=FALSE)})
else
- quote({qx <- q(xx)(if(lower.tail) (1+p1)/2 else 1-p1/2)})
- if("lower.tail" %in% names(formals(q(xx)))&&
- "log.p" %in% names(formals(q(xx))))
- qxlog <- quote({qx <- if(lower.tail) q(xx)((1+p1)/2)
+ quote({qx <- q.l(xx)(if(lower.tail) (1+p1)/2 else 1-p1/2)})
+ if("lower.tail" %in% names(formals(q.l(xx)))&&
+ "log.p" %in% names(formals(q.l(xx))))
+ qxlog <- quote({qx <- if(lower.tail) q.l(xx)((1+p1)/2)
else
- q(xx)(if(log.p)p-log(2)
+ q.l(xx)(if(log.p)p-log(2)
else p1/2,lower.tail=FALSE,log.p=log.p)})
dnew <- function(x, log = FALSE){}
body(dnew) <- substitute({
@@ -552,7 +555,7 @@
px.l <- pnew(x.g + 0.5*h)
px.u <- pnew(x.g + 0.5*h, lower.tail = FALSE)
- yR <- max(q(xx)(1), abs(q(xx)(0)))
+ yR <- max(q.l(xx)(1), abs(q.l(xx)(0)))
qnew <- .makeQNew(x.g + 0.5*h, px.l, px.u,
notwithLLarg = FALSE, lower, yR)
@@ -650,7 +653,7 @@
n <- 10^getdistrOption("RtoDPQ.e")+1
u <- seq(0,1,length=n+1); u <- (u[1:n]+u[2:(n+1)])/2
- y <- lgamma(q(x)(u))
+ y <- lgamma(q.l(x)(u))
DPQnew <- RtoDPQ(r=rnew, y=y)
object <- AbscontDistribution( r = rnew, d = DPQnew$d, p = DPQnew$p,
@@ -664,7 +667,7 @@
body(rnew) <- substitute({ gamma(g(n, ...)) }, list(g = x at r))
n <- 10^getdistrOption("RtoDPQ.e")+1
u <- seq(0,1,length=n+1); u <- (u[1:n]+u[2:(n+1)])/2
- y <- gamma(q(x)(u))
+ y <- gamma(q.l(x)(u))
DPQnew <- RtoDPQ(r=rnew, y=y)
object <- AbscontDistribution( r = rnew, d = DPQnew$d, p = DPQnew$p,
@@ -687,8 +690,8 @@
setMethod("q.r", signature(object = "AbscontDistribution"),
function(object){
if(!is.null(gaps(object)))
- .modifyqgaps(pfun = p(object), qfun = q(object),
+ .modifyqgaps(pfun = p(object), qfun = q.l(object),
gaps = gaps(object), leftright = "right")
else
- q(object)
+ q.l(object)
})
Modified: pkg/distr/R/Convpow.R
===================================================================
--- pkg/distr/R/Convpow.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/Convpow.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -55,8 +55,8 @@
## continuity correction by h/2
## quantile function
- yL <- if (q(D1)(0) == -Inf) -Inf else N*lower
- yR <- if (q(D1)(1) == Inf) Inf else N*upper
+ yL <- if (q.l(D1)(0) == -Inf) -Inf else N*lower
+ yR <- if (q.l(D1)(1) == Inf) Inf else N*upper
px.l <- pfun(x + 0.5*h)
px.u <- pfun(x + 0.5*h, lower.tail = FALSE)
qfun <- .makeQNew(x + 0.5*h, px.l, px.u, .notwithLArg(D1), yL, yR)
Modified: pkg/distr/R/DiscreteDistribution.R
===================================================================
--- pkg/distr/R/DiscreteDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/DiscreteDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -117,8 +117,8 @@
### right continuous quantile function
setMethod("q.r", "DiscreteDistribution", function(object){
- if (.inArgs("log.p", q(object))){
- if (.inArgs("lower.tail", q(object))){
+ if (.inArgs("log.p", q.l(object))){
+ if (.inArgs("lower.tail", q.l(object))){
function(p, lower.tail = TRUE, log.p = FALSE){
s <- support(object)
psx <- p(object)(s, lower.tail = lower.tail,
@@ -127,7 +127,7 @@
o.warn <- getOption("warn"); options(warn = -2)
on.exit(options(warn=o.warn))
- qx0 <- q(object)(ps0, lower.tail = lower.tail,
+ qx0 <- q.l(object)(ps0, lower.tail = lower.tail,
log.p = log.p)
options(warn = o.warn)
@@ -151,7 +151,7 @@
o.warn <- getOption("warn"); options(warn = -2)
on.exit(options(warn=o.warn))
- qx0 <- q(object)(ps0, lower.tail = lower.tail,
+ qx0 <- q.l(object)(ps0, lower.tail = lower.tail,
log.p = log.p)
options(warn = o.warn)
@@ -168,7 +168,7 @@
}
}
}else{
- if (.inArgs("lower.tail", q(object))){
+ if (.inArgs("lower.tail", q.l(object))){
function(p, lower.tail = TRUE, log.p = FALSE){
if (log.p) p <- exp(p)
s <- support(object)
@@ -177,7 +177,7 @@
o.warn <- getOption("warn"); options(warn = -2)
on.exit(options(warn=o.warn))
- qx0 <- q(object)(ps0, lower.tail = lower.tail,
+ qx0 <- q.l(object)(ps0, lower.tail = lower.tail,
log.p = log.p)
options(warn = o.warn)
@@ -202,7 +202,7 @@
o.warn <- getOption("warn"); options(warn = -2)
on.exit(options(warn=o.warn))
- qx0 <- q(object)(ps0, lower.tail = lower.tail,
+ qx0 <- q.l(object)(ps0, lower.tail = lower.tail,
log.p = log.p)
options(warn = o.warn)
@@ -332,18 +332,18 @@
quote({log(1-p(x)(q))})
- qxlog <- if("lower.tail" %in% names(formals(q(x))))
+ qxlog <- if("lower.tail" %in% names(formals(q.l(x))))
quote({qx <- if(lower.tail)
- q(x)((1+p1)/2)
+ q.l(x)((1+p1)/2)
else
- q(x)(p1/2,lower.tail=FALSE)})
+ q.l(x)(p1/2,lower.tail=FALSE)})
else
- quote({qx <- q(x)(if(lower.tail) (1+p1)/2 else 1-p1/2)})
- if("lower.tail" %in% names(formals(q(x)))&&
- "log.p" %in% names(formals(q(x))))
- qxlog <- quote({qx <- if(lower.tail) q(x)((1+p1)/2)
+ quote({qx <- q.l(x)(if(lower.tail) (1+p1)/2 else 1-p1/2)})
+ if("lower.tail" %in% names(formals(q.l(x)))&&
+ "log.p" %in% names(formals(q.l(x))))
+ qxlog <- quote({qx <- if(lower.tail) q.l(x)((1+p1)/2)
else
- q(x)(if(log.p)p-log(2)
+ q.l(x)(if(log.p)p-log(2)
else p1/2,lower.tail=FALSE,log.p=log.p)})
Modified: pkg/distr/R/ExtraConvolutionMethods.R
===================================================================
--- pkg/distr/R/ExtraConvolutionMethods.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/ExtraConvolutionMethods.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -117,9 +117,9 @@
.notwithLArg(e1)||.notwithLArg(e2), pxl = pl , pxu = pu)
}
## quantile function
- yL <- if ((q(e1)(0) == -Inf)||(q(e2)(0) == -Inf))
+ yL <- if ((q.l(e1)(0) == -Inf)||(q.l(e2)(0) == -Inf))
-Inf else lower
- yR <- if ((q(e1)(1) == Inf)||(q(e2)(1) == Inf))
+ yR <- if ((q.l(e1)(1) == Inf)||(q.l(e2)(1) == Inf))
Inf else upper
## contintuity correction
Modified: pkg/distr/R/LatticeDistribution.R
===================================================================
--- pkg/distr/R/LatticeDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/LatticeDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -82,7 +82,7 @@
}
return(new("LatticeDistribution", r = r(D), d = d(D),
- q = q(D), p = p(D), support = supp,
+ q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
.withSim = .withSim, Symmetry = Symmetry))
}
@@ -99,7 +99,7 @@
.withSim = .withSim,
Symmetry = Symmetry )
return(new("LatticeDistribution", r = r(D), d = d(D),
- q = q(D), p = p(D), support = supp,
+ q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
.withSim = .withSim, Symmetry = Symmetry))
}else{
@@ -118,7 +118,7 @@
.withSim = .withSim,
Symmetry = Symmetry )
return(new("LatticeDistribution", r = r(D), d = d(D),
- q = q(D), p = p(D), support = supp,
+ q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
.withSim = .withSim, Symmetry = Symmetry))
}
Modified: pkg/distr/R/MinMaximum.R
===================================================================
--- pkg/distr/R/MinMaximum.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/MinMaximum.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -42,8 +42,8 @@
xseq <- seq(from = qL1, to = qU1, by = h)
px.l <- pnew(xseq, lower.tail = TRUE)
px.u <- pnew(xseq, lower.tail = FALSE)
- qL2 <- min(q(e1)(0),q(e2)(0))
- qU2 <- max(q(e1)(1),q(e2)(1))
+ qL2 <- min(q.l(e1)(0),q.l(e2)(0))
+ qU2 <- max(q.l(e1)(1),q.l(e2)(1))
qnew <- .makeQNew(xseq, px.l, px.u, FALSE, qL2, qU2)
@@ -183,8 +183,8 @@
}
## new quantile function
- qL <- q(e1)(0)
- qU <- q(e1)(1)
+ qL <- q.l(e1)(0)
+ qU <- q.l(e1)(1)
ql <- getLow(e1)
qu <- getUp(e1)
Modified: pkg/distr/R/Truncate.R
===================================================================
--- pkg/distr/R/Truncate.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/Truncate.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -87,8 +87,8 @@
xseq <- seq(from = qL1, to = qU1, by = h)
px.l <- pnew(xseq, lower.tail = TRUE)
px.u <- pnew(xseq, lower.tail = FALSE)
- qL2 <- max(q(object)(0),lower)
- qU2 <- min(q(object)(1),upper)
+ qL2 <- max(q.l(object)(0),lower)
+ qU2 <- min(q.l(object)(1),upper)
qnew <- .makeQNew(xseq, px.l, px.u, FALSE, qL2, qU2)
@@ -113,9 +113,9 @@
if(is.finite(Length(lattice(object)))||
!.logExact(object)||
(width(lattice(object)) < 0 &&
- lower > q(object)(getdistrOption("TruncQuantile")))||
+ lower > q.l(object)(getdistrOption("TruncQuantile")))||
(width(lattice(object)) > 0 &&
- upper < q(object)(getdistrOption("TruncQuantile"),
+ upper < q.l(object)(getdistrOption("TruncQuantile"),
lower.tail = FALSE))
){
erg <- getMethod("Truncate","DiscreteDistribution")(object,
Modified: pkg/distr/R/UnivarLebDecDistribution.R
===================================================================
--- pkg/distr/R/UnivarLebDecDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/UnivarLebDecDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -21,6 +21,14 @@
if(discreteWeight <0 || acWeight<0 || acWeight+discreteWeight>1)
stop("no proper weights given")
}
+
+## PR 2018 04 13
+## detected by Tuomo.OJALA at 3ds.com:
+## in a loop the names of slots acWeight, discreteWeight will grow;
+## fix this by setting the prior names to NULL
+ names(acWeight) <- NULL
+ names(discreteWeight) <- NULL
+
if(discreteWeight > 1 - getdistrOption("TruncQuantile"))
{return(
new("UnivarLebDecDistribution", p = discretePart at p,
@@ -47,6 +55,7 @@
mixDistr <- new("UnivarDistrList", list(acPart = acPart,
discretePart = discretePart))
mixCoeff <- c(acWeight = acWeight, discreteWeight = discreteWeight)
+
rnew <- function(n)
{U <- rbinom(n, size = 1, prob = acWeight)
AC <- acPart at r(n); DISCRETE <- discretePart at r(n)
@@ -226,7 +235,7 @@
setMethod("q.r", "UnivarLebDecDistribution", function(object){
ep <- getdistrOption("TruncQuantile")
- if(discreteWeight(object)<ep) return(q(object))
+ if(discreteWeight(object)<ep) return(q.l(object))
supp <- support(object)
gaps <- gaps(object)
aP <- acPart(object)
Modified: pkg/distr/R/UnivarMixingDistribution.R
===================================================================
--- pkg/distr/R/UnivarMixingDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/UnivarMixingDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -98,10 +98,10 @@
setMethod("q.r", signature(object = "UnivarMixingDistribution"),
function(object){
if(!is.null(gaps(object)))
- .modifyqgaps(pfun = p(object), qfun = q(object),
+ .modifyqgaps(pfun = p(object), qfun = q.l(object),
gaps = gaps(object), leftright = "right")
else
- q(object)
+ q.l(object)
})
#------------------------------------------------------------------------
Modified: pkg/distr/R/bAcDcLcDistribution.R
===================================================================
--- pkg/distr/R/bAcDcLcDistribution.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/bAcDcLcDistribution.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -75,8 +75,9 @@
setMethod("/", c("numeric",
"AcDcLcDistribution"),
function(e1,e2){
- e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2))
+ if (is((e2s <- as.character(deparse(match.call(
+ call = sys.call(sys.parent(1)))$e2))), "try-error"))
+ e2s <- "e2"
e2 <- .ULC.cast(e2)
@@ -124,8 +125,10 @@
setMethod("/", c("AcDcLcDistribution",
"AcDcLcDistribution"),
function(e1,e2){
- e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2))
+ if (is((e2s <- as.character(deparse(match.call(
+ call = sys.call(sys.parent(1)))$e2))), "try-error"))
+ e2s <- "e2"
+
# if( is(e2,"AbscontDistribution"))
# e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
Modified: pkg/distr/R/getLow.R
===================================================================
--- pkg/distr/R/getLow.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/getLow.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -4,51 +4,51 @@
setMethod("getLow", "AbscontDistribution",
function(object, eps = getdistrOption("TruncQuantile")) {
- q0 <- q(object)(0)
+ q0 <- q.l(object)(0)
if (q0 > - Inf){
return(q0)
}else{
- qF <- q(object)
+ qF <- q.l(object)
qe <- qF(eps)
if (!is.na(qe) && qe > -Inf)
return(qe)
else{
if(.inArgs("log.p",qF))
- return(qF(p = .fm(x = .5, f = q(object)),
+ return(qF(p = .fm(x = .5, f = q.l(object)),
log.p = TRUE))
else
- return(qF(p = exp(.fm(x = .5, f = q(object)))))
+ return(qF(p = exp(.fm(x = .5, f = q.l(object)))))
}
}
})
setMethod("getUp", "AbscontDistribution",
function(object, eps = getdistrOption("TruncQuantile")) {
- q1 <- q(object)(1)
+ q1 <- q.l(object)(1)
if (q1 < Inf){
return(q1)
}else{
- qF <- q(object)
+ qF <- q.l(object)
if (.inArgs("lower.tail", qF)){
qe <- qF(eps, lower.tail = FALSE)
if (!is.na(qe) && qe < Inf)
return(qe)
else{
if(.inArgs("log.p",qF))
- return(qF(p = .fM2(x = .5, f = q(object)),
+ return(qF(p = .fM2(x = .5, f = q.l(object)),
log.p = TRUE))
else
- return(qF(p = exp(.fM2(x = .5, f = q(object)))))
+ return(qF(p = exp(.fM2(x = .5, f = q.l(object)))))
}
}else{
- qe <- q(object)(1-eps)
+ qe <- q.l(object)(1-eps)
if (!is.na(qe) && qe < Inf)
return(qe)
else{
if(.inArgs("log.p",qF))
- return(qF(p = .fM(x = .5, f = q(object)),
+ return(qF(p = .fM(x = .5, f = q.l(object)),
log.p = TRUE))
else
- return(qF(p = exp(.fM(x = .5, f = q(object)))))
+ return(qF(p = exp(.fM(x = .5, f = q.l(object)))))
}
}
}
@@ -61,32 +61,32 @@
setMethod("getLow", "LatticeDistribution",
function(object, ...){
lattice <- lattice(object)
- qF <- q(object)
+ qF <- q.l(object)
if(is.finite(Length(lattice)) || width(lattice)>0)
return(min(support(object)))
if(.inArgs("log.p",qF))
- return(qF(p = .fm(x = .5, f = q(object)), log.p = TRUE))
+ return(qF(p = .fm(x = .5, f = q.l(object)), log.p = TRUE))
else
- return(qF(p = exp(.fm(x = .5, f = q(object)))))
+ return(qF(p = exp(.fm(x = .5, f = q.l(object)))))
})
setMethod("getUp", "LatticeDistribution",
function(object, ...){
lattice <- lattice(object)
if(is.finite(Length(lattice)) || width(lattice)<0)
return(max(support(object)))
- qF <- q(object)
+ qF <- q.l(object)
if (.inArgs("lower.tail", qF)){
if(.inArgs("log.p",qF))
- return(qF(p = .fM(x = .5, f = q(object)),
+ return(qF(p = .fM(x = .5, f = q.l(object)),
log.p = TRUE))
else
- return(qF(p = exp(.fM(x = .5, f = q(object)))))
+ return(qF(p = exp(.fM(x = .5, f = q.l(object)))))
}
if(.inArgs("log.p",qF))
- return(qF(p = .fM2(x = .5, f = q(object)),
+ return(qF(p = .fM2(x = .5, f = q.l(object)),
lower.tail = FALSE, log.p = TRUE))
else
- return(qF(p = exp(.fM2(x = .5, f = q(object))),
+ return(qF(p = exp(.fM2(x = .5, f = q.l(object))),
lower.tail = FALSE))
})
Modified: pkg/distr/R/internalUtils.R
===================================================================
--- pkg/distr/R/internalUtils.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/internalUtils.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -268,7 +268,11 @@
.isIn <- function(p0, pmat, tol = min( getdistrOption("TruncQuantile")/2,
.Machine$double.eps^.7
))
- {list1 <- lapply(1:nrow(pmat), function(x){
+ {## PR 2018 04 13
+ ## detected by Tuomo.OJALA at 3ds.com: the gaps matrix can
+ ## have zero rows -> check this in the following line
+ if(nrow(pmat)==0) return(FALSE)
+ list1 <- lapply(1:nrow(pmat), function(x){
(p0+tol > pmat[x,1]) & (p0-tol < pmat[x,2]) })
apply(matrix(unlist(list1), ncol = nrow(pmat)), 1, any)}
Modified: pkg/distr/R/internalUtils_LCD.R
===================================================================
--- pkg/distr/R/internalUtils_LCD.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/internalUtils_LCD.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -185,7 +185,7 @@
.loupmixfun <- function(mixDistr){
if(length(mixDistr)==0) return(list(qL = NA, ql = NA, qU = NA, qu = NA))
if(length(mixDistr)==1){
- q1 <- q(mixDistr[[1]])
+ q1 <- q.l(mixDistr[[1]])
return(list(qL = q1(p = 0, lower.tail = TRUE),
ql = q1(p = getdistrOption("TruncQuantile"), lower.tail = TRUE),
qU = q1(p = 0, lower.tail = FALSE),
Modified: pkg/distr/R/internalUtils_trunc.R
===================================================================
--- pkg/distr/R/internalUtils_trunc.R 2018-07-08 14:25:50 UTC (rev 1183)
+++ pkg/distr/R/internalUtils_trunc.R 2018-07-08 14:27:59 UTC (rev 1184)
@@ -2,7 +2,7 @@
ep <- .Machine$double.eps^2
plN <- p(object)(upper, lower.tail = TRUE, log.p=TRUE)
rnew <- function(n){
- q(object)(plN-rexp(n), lower.tail = TRUE, log.p=TRUE)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1184
More information about the Distr-commits
mailing list