[Distr-commits] r1298 - in pkg: distr distr/R distr/demo distr/inst distr/man distr/vignettes distrDoc distrDoc/inst distrDoc/man distrDoc/vignettes distrEllipse distrEllipse/R distrEllipse/inst distrEllipse/man distrEx distrEx/R distrEx/inst distrEx/man distrMod distrMod/R distrMod/inst distrMod/man distrMod/tests/Examples distrRmetrics distrRmetrics/inst distrRmetrics/man distrSim distrSim/R distrSim/inst distrSim/man distrTEst distrTEst/R distrTEst/inst distrTEst/man distrTeach distrTeach/inst distrTeach/man startupmsg startupmsg/inst utils
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Mar 1 17:00:35 CET 2019
Author: ruckdeschel
Date: 2019-03-01 17:00:34 +0100 (Fri, 01 Mar 2019)
New Revision: 1298
Added:
pkg/distr/man/distr-defunct.Rd
pkg/distrEx/R/DiagnUtils.R
pkg/distrEx/R/GammaWeibullExpectation.R
pkg/distrMod/R/asCvMVarianceQtl.R
pkg/distrMod/man/CauchyLocationFamily.Rd
pkg/distrMod/man/LogisticLocationScaleFamily.Rd
Removed:
pkg/distr/man/GeomParameter-class.Rd
Modified:
pkg/distr/DESCRIPTION
pkg/distr/NAMESPACE
pkg/distr/R/0pre270.R
pkg/distr/R/AllClasses.R
pkg/distr/R/AllGenerics.R
pkg/distr/R/AllInitialize.R
pkg/distr/R/ContDistribution.R
pkg/distr/R/DiscreteDistribution.R
pkg/distr/R/GeometricDistribution.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/UtilitiesDistributions.R
pkg/distr/R/bAcDcLcDistribution.R
pkg/distr/R/decomposePM.R
pkg/distr/R/flat.R
pkg/distr/R/internalUtils.R
pkg/distr/R/internalUtils_LCD.R
pkg/distr/R/liesInSupport.R
pkg/distr/R/plot-methods.R
pkg/distr/R/plot-methods_LebDec.R
pkg/distr/R/qqplot.R
pkg/distr/R/solve.R
pkg/distr/demo/ConvolutionNormalDistr.R
pkg/distr/demo/Expectation.R
pkg/distr/demo/StationaryRegressorDistr.R
pkg/distr/demo/nFoldConvolution.R
pkg/distr/demo/range.R
pkg/distr/inst/NEWS
pkg/distr/man/0distr-package.Rd
pkg/distr/man/DiscreteDistribution-class.Rd
pkg/distr/man/MinMaximum-methods.Rd
pkg/distr/man/internals.Rd
pkg/distr/man/liesInSupport.Rd
pkg/distr/man/operators-methods.Rd
pkg/distr/man/options.Rd
pkg/distr/man/plot-methods.Rd
pkg/distr/man/qqplot.Rd
pkg/distr/vignettes/newDistributions-knitr.Rnw
pkg/distrDoc/DESCRIPTION
pkg/distrDoc/inst/NEWS
pkg/distrDoc/man/0distrDoc-package.Rd
pkg/distrDoc/vignettes/distr.Rnw
pkg/distrEllipse/DESCRIPTION
pkg/distrEllipse/R/EllipticalDistribution.R
pkg/distrEllipse/R/MVMixingDistribution.R
pkg/distrEllipse/inst/NEWS
pkg/distrEllipse/man/0distrEllipse-package.Rd
pkg/distrEx/DESCRIPTION
pkg/distrEx/NAMESPACE
pkg/distrEx/R/AllClass.R
pkg/distrEx/R/AsymTotalVarDist.R
pkg/distrEx/R/CvMDist.R
pkg/distrEx/R/DiscreteMVDistribution.R
pkg/distrEx/R/Expectation.R
pkg/distrEx/R/HellingerDist.R
pkg/distrEx/R/Internalfunctions.R
pkg/distrEx/R/OAsymTotalVarDist.R
pkg/distrEx/R/TotalVarDist.R
pkg/distrEx/R/distrExIntegrate.R
pkg/distrEx/R/liesInSupport.R
pkg/distrEx/R/sysdata.rda
pkg/distrEx/inst/NEWS
pkg/distrEx/man/0distrEx-package.Rd
pkg/distrEx/man/AsymTotalVarDist.Rd
pkg/distrEx/man/CvMDist.Rd
pkg/distrEx/man/DiscreteMVDistribution-class.Rd
pkg/distrEx/man/E.Rd
pkg/distrEx/man/HellingerDist.Rd
pkg/distrEx/man/OAsymTotalVarDist.Rd
pkg/distrEx/man/TotalVarDist.Rd
pkg/distrEx/man/distrExIntegrate.Rd
pkg/distrEx/man/internals.Rd
pkg/distrEx/man/liesInSupport.Rd
pkg/distrMod/DESCRIPTION
pkg/distrMod/NAMESPACE
pkg/distrMod/R/0distrModUtils.R
pkg/distrMod/R/AllClass.R
pkg/distrMod/R/AllGeneric.R
pkg/distrMod/R/AllPlot.R
pkg/distrMod/R/AllReturnClasses.R
pkg/distrMod/R/AllShow.R
pkg/distrMod/R/Estimator.R
pkg/distrMod/R/Expectation.R
pkg/distrMod/R/L2GroupFamilies.R
pkg/distrMod/R/L2ParamFamily.R
pkg/distrMod/R/MCEstimate.R
pkg/distrMod/R/MCEstimator.R
pkg/distrMod/R/MDEstimator.R
pkg/distrMod/R/MLEstimator.R
pkg/distrMod/R/SimpleL2ParamFamilies.R
pkg/distrMod/R/existsPIC.R
pkg/distrMod/R/internalMleCalc.R
pkg/distrMod/R/mleCalc-methods.R
pkg/distrMod/R/qqplot.R
pkg/distrMod/R/returnlevelplot.R
pkg/distrMod/R/setAs.R
pkg/distrMod/inst/NEWS
pkg/distrMod/man/0distrMod-package.Rd
pkg/distrMod/man/CauchyLocationScaleFamily.Rd
pkg/distrMod/man/InternalReturnClasses-class.Rd
pkg/distrMod/man/L2ParamFamily-class.Rd
pkg/distrMod/man/L2ParamFamily.Rd
pkg/distrMod/man/MCEstimate-class.Rd
pkg/distrMod/man/MCEstimator.Rd
pkg/distrMod/man/MDEstimator.Rd
pkg/distrMod/man/MLEstimator.Rd
pkg/distrMod/man/ParamFamily-class.Rd
pkg/distrMod/man/internalmleHelpers.Rd
pkg/distrMod/man/internals.Rd
pkg/distrMod/man/meRes.Rd
pkg/distrMod/man/returnlevelplot.Rd
pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save
pkg/distrRmetrics/DESCRIPTION
pkg/distrRmetrics/inst/NEWS
pkg/distrRmetrics/man/0distrRmetrics-package.Rd
pkg/distrSim/DESCRIPTION
pkg/distrSim/R/plot-methods.R
pkg/distrSim/inst/NEWS
pkg/distrSim/man/0distrSim-package.Rd
pkg/distrSim/man/plot-methods.Rd
pkg/distrTEst/DESCRIPTION
pkg/distrTEst/R/plot-methods.R
pkg/distrTEst/inst/NEWS
pkg/distrTEst/man/0distrTEst-package.Rd
pkg/distrTEst/man/plot-methods.Rd
pkg/distrTeach/DESCRIPTION
pkg/distrTeach/inst/CITATION
pkg/distrTeach/inst/NEWS
pkg/distrTeach/man/0distrTeach-package.Rd
pkg/startupmsg/DESCRIPTION
pkg/startupmsg/inst/NEWS
pkg/utils/DESCRIPTIONutils.R
pkg/utils/DESCRIPTIONutilsExamples.R
pkg/utils/ladealles.R
Log:
pre-release work: merged back branch 2.8 into trunk
Modified: pkg/distr/DESCRIPTION
===================================================================
--- pkg/distr/DESCRIPTION 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/DESCRIPTION 2019-03-01 16:00:34 UTC (rev 1298)
@@ -1,6 +1,6 @@
Package: distr
-Version: 2.7.0
-Date: 2018-07-08
+Version: 2.8.0
+Date: 2019-03-01
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
@@ -20,4 +20,4 @@
URL: http://distr.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 1186
+VCS/SVNRevision: 1295
Modified: pkg/distr/NAMESPACE
===================================================================
--- pkg/distr/NAMESPACE 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/NAMESPACE 2019-03-01 16:00:34 UTC (rev 1298)
@@ -1,7 +1,7 @@
useDynLib(distr, .registration = TRUE, .fixes = "C_")
import("methods")
import("stats")
-importFrom("grDevices", "dev.list", "dev.new", "xy.coords")
+importFrom("grDevices", "dev.list", "dev.new", "xy.coords", "dev.off")
importFrom("graphics", "plot", "abline", "layout", "legend", "lines", "mtext", "par", "points", "title")
importFrom("MASS", "ginv")
importFrom("utils", "str")
@@ -30,7 +30,7 @@
"CauchyParameter", "ChisqParameter",
"DiracParameter", "ExpParameter",
"FParameter", "GammaParameter",
- "HyperParameter", "GeomParameter",
+ "HyperParameter",
"LogisParameter", "LnormParameter",
"NbinomParameter", "NormParameter",
"PoisParameter", "TParameter",
Modified: pkg/distr/R/0pre270.R
===================================================================
--- pkg/distr/R/0pre270.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/0pre270.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -6,9 +6,30 @@
}
}else{
devNew <- function(...){
- if(length(dev.list())>0)
- if(!is.null(getOption("newDevice")))
- if(getOption("newDevice")) dev.new(...)
+ if(length(dev.list())>0){
+ if(!is.null(getOption("newDevice"))){
+ nrOpen <- length(grDevices::dev.list())
+ if(getOption("newDevice")==TRUE) {
+ if(interactive()){
+ while(nrOpen >20){
+ invisible(readline(prompt=
+ paste(gettext(
+ "Too many open graphic devices; please shut some."),
+ "\n", gettext(
+ "When you have shut some devices, press [enter] to continue"),
+ "\n", sep="")))
+ nrOpen <- length(grDevices::dev.list())
+ }
+ }else{
+ if(nrOpen >20){
+ while(nrOpen<-length(grDevices::dev.list())>5)
+ grDevices::dev.off(which=grDevices::dev.list()[2])
+ }
+ }
+ dev.new(...)
+ }
+ }
+ }
}
}
options("newDevice"=FALSE)
Modified: pkg/distr/R/AllClasses.R
===================================================================
--- pkg/distr/R/AllClasses.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/AllClasses.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -196,16 +196,17 @@
## no longer needed: this is a negBinom with size 1 no longer
#-
### !!! deprecated as of version 1.9 !!!
+## defunct as of 2.8.0
##
## Class: GeomParameter
-setClass("GeomParameter",
- representation = representation(prob = "numeric"),
- prototype = prototype(prob = 0.5, name =
- gettext("Parameter of a Geometric distribution")
- ),
- contains = "Parameter"
- )
-### !!! end of deprecated !!!
+#setClass("GeomParameter",
+# representation = representation(prob = "numeric"),
+# prototype = prototype(prob = 0.5, name =
+# gettext("Parameter of a Geometric distribution")
+# ),
+# contains = "Parameter"
+# )
+### !!! end of deprecated !!! of defunct
## Class: CauchyParameter
setClass("CauchyParameter",
@@ -812,7 +813,7 @@
## DiscreteDistribution
setClass("DiscreteDistribution",
- representation = representation(support = "numeric"),
+ representation = representation(support = "numeric", .finSupport = "logical"),
prototype = prototype(
r = function(n){ rbinom(n, size=1, prob=0.5) },
d = function(x, log = FALSE)
@@ -824,7 +825,8 @@
{ qbinom(p, size=1, prob=0.5,
lower.tail = lower.tail, log.p = log.p) },
img = new("Reals"),
- support = 0:1
+ support = 0:1,
+ .finSupport = c(TRUE,TRUE)
),
contains = "UnivariateDistribution"
)
@@ -868,7 +870,8 @@
gettext("lattice of a Dirac distribution")
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE,TRUE)
),
contains = "LatticeDistribution"
)
@@ -897,7 +900,8 @@
gettext("lattice of a Poisson distribution")
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE,FALSE)
),
contains = "LatticeDistribution"
)
@@ -933,7 +937,8 @@
)
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE,FALSE)
),
contains = "LatticeDistribution"
)
@@ -963,7 +968,8 @@
)
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE,TRUE)
),
contains = "LatticeDistribution"
)
@@ -993,7 +999,8 @@
)
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE,TRUE)
),
contains = "LatticeDistribution"
)
@@ -1025,7 +1032,8 @@
)
),
.logExact = TRUE,
- .lowerExact = TRUE
+ .lowerExact = TRUE,
+ .finSupport = c(TRUE, FALSE)
),
contains = "Nbinom"
)
Modified: pkg/distr/R/AllGenerics.R
===================================================================
--- pkg/distr/R/AllGenerics.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/AllGenerics.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -300,7 +300,7 @@
setGeneric("liesIn", function(object, x) standardGeneric("liesIn"))
if(!isGeneric("liesInSupport"))
- setGeneric("liesInSupport", function(object, x)
+ setGeneric("liesInSupport", function(object, x,...)
standardGeneric("liesInSupport"))
if(!isGeneric("convpow"))
setGeneric("convpow", function(D1, ...) standardGeneric("convpow"))
Modified: pkg/distr/R/AllInitialize.R
===================================================================
--- pkg/distr/R/AllInitialize.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/AllInitialize.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -25,17 +25,18 @@
## PARAMETERS
################################################################################
-setMethod("initialize", "GeomParameter",
- function(.Object, prob = .5) {
- .Deprecated(new = "new(\"NbinomParameter\"(size = 1, prob, name)",
- package = "distr",
- msg = gettext(
-"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
- ))
- .Object at prob <- prob
- .Object at name <- gettext("Parameter of a Geometric distribution")
- .Object
- })
+# defunct as of 2.8.0
+#setMethod("initialize", "GeomParameter",
+# function(.Object, prob = .5) {
+# .Deprecated(new = "new(\"NbinomParameter\"(size = 1, prob, name)",
+# package = "distr",
+# msg = gettext(
+#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
+# ))
+# .Object at prob <- prob
+# .Object at name <- gettext("Parameter of a Geometric distribution")
+# .Object
+# })
################################################################################
## DISTRIBUTIONS
################################################################################
@@ -163,6 +164,7 @@
support = NULL, param = NULL, img = new("Reals"),
.withSim = FALSE, .withArith = FALSE,
.lowerExact = FALSE, .logExact = FALSE,
+ .finSupport = c(TRUE,TRUE),
Symmetry = NoSymmetry()) {
## don't use this if the call is new("DiscreteDistribution")
@@ -224,6 +226,7 @@
.Object at .lowerExact <- .lowerExact
.Object at .logExact <- .logExact
.Object at Symmetry <- Symmetry
+ .Object at .finSupport <- .finSupport
.Object
})
@@ -233,14 +236,14 @@
support = NULL, a = 1, b = 0, X0 = Binom(), param = NULL,
img = new("Reals"), .withSim = FALSE, .withArith = FALSE,
.lowerExact = FALSE, .logExact = FALSE,
- Symmetry = NoSymmetry()) {
+ Symmetry = NoSymmetry(), .finSupport = c(TRUE,TRUE)) {
## don't use this if the call is new("DiscreteDistribution")
LL <- length(sys.calls())
if(sys.calls()[[LL-3]] == "new(\"AffLinDiscreteDistribution\")")
X <- new("DiscreteDistribution")
else X <- new("DiscreteDistribution", r = r, d = d, p = p, q = q, support = support,
param = param, img = img, .withSim = .withSim,
- .withArith = .withArith)
+ .withArith = .withArith, .finSupport = .finSupport)
.Object at support <- X at support
.Object at img <- X at img
.Object at param <- X at param
@@ -256,6 +259,7 @@
.Object at .lowerExact <- .lowerExact
.Object at .logExact <- .logExact
.Object at Symmetry <- Symmetry
+ .Object at .finSupport <- .finSupport
.Object
})
@@ -265,7 +269,7 @@
support = NULL, lattice = NULL, param = NULL,
img = new("Reals"), .withSim = FALSE, .withArith = FALSE,
.lowerExact = FALSE, .logExact = FALSE,
- Symmetry = NoSymmetry()) {
+ Symmetry = NoSymmetry(), .finSupport = c(TRUE,TRUE)) {
LL <- length(sys.calls())
@@ -274,7 +278,8 @@
else
D <- new("DiscreteDistribution", r = r, d = d, p = p,
q = q, support = support, param = param, img = img,
- .withSim = .withSim, .withArith = .withArith)
+ .withSim = .withSim, .withArith = .withArith,
+ .finSupport = .finSupport)
OS <- D at support
@@ -301,6 +306,7 @@
.Object at .lowerExact <- .lowerExact
.Object at .logExact <- .logExact
.Object at Symmetry <- Symmetry
+ .Object at .finSupport <- .finSupport
.Object
})
@@ -310,7 +316,7 @@
support = NULL, lattice = NULL, a = 1, b = 0, X0 = Binom(),
param = NULL, img = new("Reals"), .withSim = FALSE,
.withArith = FALSE, .lowerExact = FALSE, .logExact = FALSE,
- Symmetry = NoSymmetry()) {
+ Symmetry = NoSymmetry(), .finSupport = c(TRUE, TRUE)) {
LL <- length(sys.calls())
if(sys.calls()[[LL-3]] == "new(\"AffLinLatticeDistribution\")")
@@ -318,7 +324,7 @@
else X <- new("LatticeDistribution", r = r, d = d, p = p, q = q,
support = support, lattice = lattice, param = param,
img = img, .withSim = .withSim,
- .withArith = .withArith)
+ .withArith = .withArith, .finSupport = .finSupport)
.Object at support <- X at support
.Object at lattice <- X at lattice
@@ -336,6 +342,7 @@
.Object at .lowerExact <- .lowerExact
.Object at .logExact <- .logExact
.Object at Symmetry <- Symmetry
+ .Object at .finSupport <- .finSupport
.Object
})
@@ -384,6 +391,7 @@
.Object at lattice <- new("Lattice", pivot = location, width = 1,
Length = 1)
.Object at .withArith <- .withArith
+ .Object at .finSupport <- c(TRUE,TRUE)&(location> -Inf & location < Inf)
.Object
})
@@ -420,6 +428,7 @@
.Object at lattice = new("Lattice", pivot = 0, width = 1,
Length = size+1)
.Object at .withArith <- .withArith
+ .Object at .finSupport <- c(TRUE,TRUE)
.Object
})
@@ -458,6 +467,7 @@
.Object at lattice <- new("Lattice", pivot = 0, width = 1,
Length = min(k,m)+1 )
.Object at .withArith <- .withArith
+ .Object at .finSupport <- c(TRUE,TRUE)
.Object
})
@@ -495,6 +505,7 @@
.Object at lattice <- new("Lattice", pivot = 0, width = 1,
Length = Inf)
.Object at .withArith <- .withArith
+ .Object at .finSupport <- c(TRUE,FALSE)
.Object
})
@@ -534,6 +545,7 @@
)
.Object at lattice <- new("Lattice", pivot = 0, width = 1,
Length = Inf)
+ .Object at .finSupport <- c(TRUE,FALSE)
.Object
})
@@ -564,6 +576,7 @@
log.p = log.p) },
list(probSub = prob))
.Object at .withArith <- .withArith
+ .Object at .finSupport <- c(TRUE,FALSE)
.Object
})
@@ -896,17 +909,12 @@
body(.Object at q) <- substitute(
{ if (log.p) p <- exp(p)
if (!lower.tail) p <- 1-p
- ifelse( p <= 0.25,
- -qexp(2*p, rate = rateSub, lower.tail =FALSE),
- ifelse( p <= 0.5,
- -qexp(1-2*p, rate = rateSub),
- ifelse( p <= 0.75 ,
- qexp(2*p - 1, rate = rateSub),
- qexp(2*(1-p), rate = rateSub,
- lower.tail = FALSE)
- )
- )
- )
+ q0 <- p
+ q0[p <=0.25] <- -qexp(2*p[p <=0.25], rate = rateSub, lower.tail =FALSE)
+ q0[p>0.25&p<=.50] <- -qexp(1-2*p[p>0.25&p<=.50], rate = rateSub)
+ q0[p>0.5&p<=.75] <- qexp(2*p[p>0.5&p<=.75] - 1, rate = rateSub)
+ q0[p>0.75] <- qexp(2*(1-p[p>0.75]), rate = rateSub, lower.tail = FALSE)
+ return(q0)
}, list(rateSub = rate)
)
.Object at .withSim <- FALSE
@@ -1026,7 +1034,7 @@
## Class: Weibull distribution
setMethod("initialize", "Weibull",
- function(.Object, shape = 1, scale = 1) {
+ function(.Object, shape = 1, scale = 1, .withArith = FALSE) {
.Object at img <- new("Reals")
.Object at param <- new("WeibullParameter",
shape = shape, scale = scale
@@ -1054,7 +1062,7 @@
lower.tail = lower.tail, log.p = log.p) },
list(shapeSub = shape, scaleSub = scale)
)
- .Object at .withArith <- FALSE
+ .Object at .withArith <- .withArith
.Object
})
Modified: pkg/distr/R/ContDistribution.R
===================================================================
--- pkg/distr/R/ContDistribution.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/ContDistribution.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -223,8 +223,12 @@
Symmetry = Symmetry)
if(is.null(gaps) && withgaps) setgaps(obj)
- if(!is.null(obj at gaps))
+ if(!is.null(obj at gaps)&&length(obj at gaps)){
obj at q <- .modifyqgaps(pfun = obj at p, qfun = obj at q, gaps = obj at gaps)
+ }else{
+ if(exists("..q0fun", envir=environment(obj at q)))
+ obj at q <- get("..q0fun", envir=environment(obj at q))
+ }
return(obj)
}
@@ -285,6 +289,9 @@
if(nrow(mattab.d)==0) mattab.d <- NULL
if(length(mattab.d)==0) mattab.d <- NULL
} else mattab.d <- NULL
+ finit <- if(is.null(dim(mattab.d))) 0 else
+ apply(mattab.d, 1, function(x) all(is.finite(x)))
+ mattab.d <- if(sum(finit)>0) mattab.d[finit,,drop=FALSE] else NULL
eval(substitute( "slot<-"(object,'gaps', value = mattab.d)))
return(invisible())
})
@@ -689,7 +696,7 @@
setMethod("q.r", signature(object = "AbscontDistribution"),
function(object){
- if(!is.null(gaps(object)))
+ if(!is.null(gaps(object))&&length(gaps(object)))
.modifyqgaps(pfun = p(object), qfun = q.l(object),
gaps = gaps(object), leftright = "right")
else
Modified: pkg/distr/R/DiscreteDistribution.R
===================================================================
--- pkg/distr/R/DiscreteDistribution.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/DiscreteDistribution.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -237,9 +237,14 @@
W <- sort(abs(c(w1,w2)))
if (abs(abs(w1)-abs(w2))<getdistrOption("DistrResolution") ||
W[2] %% W[1] < getdistrOption("DistrResolution") )
- return(e1.L + e2.L)
+ res <- e1.L + e2.L
+ res at .finSupport <- e1.L at .finSupport&e2.L at .finSupport
+ return(res)
}
- .convDiscrDiscr(e1,e2)})
+ res <- .convDiscrDiscr(e1,e2)
+ res at .finSupport <- e1 at .finSupport&e2 at .finSupport
+ return(res)
+ })
setMethod("+", c("Dirac","DiscreteDistribution"),
function(e1,e2){e2+location(e1)})
@@ -256,7 +261,14 @@
Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
- Distr
+ if(is.finite(e2)){
+ Distr at .finSupport <- e1 at .finSupport
+ }else{
+ ep <- .Machine$double.eps
+ Distr at .finSupport <- c(p(e1)(0)<ep,p(e1)(0)>1-ep)
+ }
+ if(e2<0) Distr at .finSupport <- rev(Distr at .finSupport)
+ return(Distr)
})
setMethod("+", c("DiscreteDistribution","numeric"),
function(e1, e2) { Distr <- .plusm(e1,e2, "DiscreteDistribution")
@@ -267,7 +279,9 @@
Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)+e2)
- Distr
+ isfe2 <- c(e2 >(-Inf), e2<Inf)
+ Distr at .finSupport <- e1 at .finSupport & isfe2
+ return(Distr)
})
setMethod("*", c("AffLinDiscreteDistribution","numeric"),
@@ -276,7 +290,14 @@
if(is(e1 at Symmetry,"SphericalSymmetry"))
Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
- Distr
+ if(is.finite(e2)){
+ Distr at .finSupport <- e1 at .finSupport
+ }else{
+ ep <- .Machine$double.eps
+ Distr at .finSupport <- c(p(e1)(0)<ep,p(e1)(0)>1-ep)
+ }
+ if(e2<0) Distr at .finSupport <- rev(Distr at .finSupport)
+ return(Distr)
})
setMethod("+", c("AffLinDiscreteDistribution","numeric"),
function(e1, e2) {
@@ -284,7 +305,9 @@
if(is(e1 at Symmetry,"SphericalSymmetry"))
Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
- Distr
+ isfe2 <- c(e2 >(-Inf), e2<Inf)
+ Distr at .finSupport <- e1 at .finSupport & isfe2
+ return(Distr)
})
## Group Math for discrete distributions
@@ -295,12 +318,16 @@
list(f = as.name(.Generic), g = x at r))
object <- new("DiscreteDistribution", r = rnew,
.withSim = TRUE, .withArith = TRUE)
+ object at .finSupport <- x at .finSupport&NA
object
})
setMethod("Math", "Dirac",
function(x){ loc <- location(x)
lc <- callGeneric(loc)
- Dirac(lc)})
+ object <- Dirac(lc)
+ object at .finSupport <- x at .finSupport&NA
+ object
+ })
## exact: abs for discrete distributions
setMethod("abs", "DiscreteDistribution",function(x){
@@ -417,12 +444,17 @@
q = qnew, d = dnew, support = supportnew,
.withSim = x at .withSim, .withArith = TRUE,
.lowerExact = .lowerExact(x))
+ object at .finSupport <- c(TRUE, all(x at .finSupport))
object
})
-## exact: abs for discrete distributions
+## exact: eps for discrete distributions
setMethod("exp", "DiscreteDistribution",
- function(x) .expm.d(x))
+ function(x){ obj <- .expm.d(x)
+ obj at .finSupport <- c(TRUE, x at .finSupport[2])
+ obj
+ }
+ )
### preliminary to export special functions
@@ -436,7 +468,11 @@
basl <- log(base)
if(p(x)(0)>ep)
stop(gettextf("log(%s) is not well-defined with positive probability ", xs))
- else return(.logm.d(x)/basl)})
+ else{
+ obj <- .logm.d(x)/basl
+ obj at .finSupport <- c(TRUE, x at .finSupport[2])
+ return(obj)
+ }})
setMethod("log", "Dirac",
function(x, base = exp(1)){
@@ -472,6 +508,8 @@
object <- DiscreteDistribution(
supp=digamma(support(x)),
prob=prob(x), .withArith = TRUE)
+
+ object at .finSupport <- c(TRUE, x at .finSupport[2])
object
})
@@ -481,6 +519,7 @@
body(rnew) <- substitute({ lgamma(g(n, ...)) }, list(g = x at r))
object <- new("DiscreteDistribution", r = rnew,
.withSim = TRUE, .withArith = TRUE)
+ object at .finSupport <- c(TRUE, x at .finSupport[2])
object
})
@@ -490,6 +529,7 @@
body(rnew) <- substitute({ gamma(g(n, ...)) }, list(g = x at r))
object <- new("DiscreteDistribution", r = rnew,
.withSim = TRUE, .withArith = TRUE)
+ object at .finSupport <- c(TRUE, x at .finSupport[2])
object
})
setMethod("sqrt", "DiscreteDistribution",
Modified: pkg/distr/R/GeometricDistribution.R
===================================================================
--- pkg/distr/R/GeometricDistribution.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/GeometricDistribution.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -9,38 +9,45 @@
### Replaced by NbinomParameter ....
### pre v1.9 /deprecated
-setMethod("prob", "GeomParameter", function(object)
- {.Deprecated(new = "",
- package = "distr",
- msg = gettext(
-"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
- )
- )
- object at prob
- }
- )
-setMethod("prob", "NbinomParameter", function(object) object at prob)
+### defunct as of 2.8.0
+#setMethod("prob", "GeomParameter", function(object)
+# {.Defunct(new = "",
+# package = "distr",
+# msg = gettext(
+#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
+# )
+# )
+# object at prob
+# }
+# )
+## code is in NegbinomDistribution.R
+# setMethod("prob", "NbinomParameter", function(object) object at prob)
+
+
## Replace Methods
### Replaced by NbinomParameter ....
### pre v1.9: /deprecated
-setReplaceMethod("prob", "GeomParameter",
- function(object, value)
- {.Deprecated(new = "",
- package = "distr",
- msg = gettext(
-"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
- )
- )
- object at prob <- value;
- object})
-setReplaceMethod("prob", "NbinomParameter",
- function(object, value)
- { object at prob <- value; object}
- )
+### defunct as of 2.8.0
+#setReplaceMethod("prob", "GeomParameter",
+# function(object, value)
+# {.Defunct(new = "",
+# package = "distr",
+# msg = gettext(
+#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon."
+# )
+# )
+# object at prob <- value;
+# object})
+## code is in NegbinomDistribution.R
+#setReplaceMethod("prob", "NbinomParameter",
+# function(object, value)
+# { object at prob <- value; object}
+# )
+
### no longer needed from version 1.9 on
#setValidity("GeomParameter", function(object){
# if(length(prob(object)) != 1)
Modified: pkg/distr/R/LatticeDistribution.R
===================================================================
--- pkg/distr/R/LatticeDistribution.R 2019-03-01 15:58:46 UTC (rev 1297)
+++ pkg/distr/R/LatticeDistribution.R 2019-03-01 16:00:34 UTC (rev 1298)
@@ -8,6 +8,13 @@
.withArith = FALSE, .withSim = FALSE,
DiscreteDistribution = NULL, check = TRUE,
Symmetry = NoSymmetry()){
+ if(is(lattice,"Lattce")){
+ if(width(lattice)>0){
+ .finS <- c(TRUE,is.finite(Length(lattice)))
+ }else{
+ .finS <- c(is.finite(Length(lattice)), TRUE)
+ }
+ }else .finS <- c(TRUE,TRUE)
if (is(DiscreteDistribution, "AffLinDiscreteDistribution"))
{ D <- DiscreteDistribution
if (is(lattice, "Lattice"))
@@ -18,12 +25,13 @@
" the support of argument 'DiscreteDistribution'." ,
sep = ""))
}
- return(new("AffLinLatticeDistribution", r = D at r, d = D at d,
+ return(new("AffLinLatticeDistribution", r = D at r, d = D at d,
q = D at q, p = D at p, support = D at support,
a = D at a, b = D at b, X0 = D at X0,
lattice = lattice, .withArith = .withArith,
.withSim = .withSim, img = D at img,
- param = D at param, Symmetry = Symmetry))
+ param = D at param, Symmetry = Symmetry,
+ .finSupport = .finS))
}else{
if (check){
if( !.is.vector.lattice(support(D)))
@@ -36,7 +44,8 @@
a = D at a, b = D at b, X0 = D at X0,
.withArith = .withArith,
.withSim = .withSim, img = D at img,
- param = D at param, Symmetry = Symmetry))
+ param = D at param, Symmetry = Symmetry,
+ .finSupport = .finS))
}
}
@@ -54,7 +63,8 @@
q = D at q, p = D at p, support = D at support,
lattice = lattice, .withArith = .withArith,
.withSim = .withSim, img = D at img,
- param = D at param, Symmetry = Symmetry))
+ param = D at param, Symmetry = Symmetry,
+ .finSupport = .finS))
}else{
if (check){
if( !.is.vector.lattice(support(D)))
@@ -67,7 +77,8 @@
lattice = .make.lattice.es.vector(D at support),
.withArith = .withArith,
.withSim = .withSim, img = D at img,
- param = D at param, Symmetry = Symmetry))
+ param = D at param, Symmetry = Symmetry,
+ .finSupport = .finS))
}
}
@@ -84,7 +95,8 @@
return(new("LatticeDistribution", r = r(D), d = d(D),
q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
- .withSim = .withSim, Symmetry = Symmetry))
+ .withSim = .withSim, Symmetry = Symmetry,
+ .finSupport = .finS))
}
if (is(lattice, "Lattice"))
@@ -101,7 +113,8 @@
return(new("LatticeDistribution", r = r(D), d = d(D),
q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
- .withSim = .withSim, Symmetry = Symmetry))
+ .withSim = .withSim, Symmetry = Symmetry,
+ .finSupport = .finS))
}else{
#if (check)
stop("Lengths of lattice and probabilities differ.")
@@ -120,7 +133,8 @@
return(new("LatticeDistribution", r = r(D), d = d(D),
q = q.l(D), p = p(D), support = supp,
lattice = lattice, .withArith = .withArith,
- .withSim = .withSim, Symmetry = Symmetry))
+ .withSim = .withSim, Symmetry = Symmetry,
+ .finSupport = .finS))
}
}
}else if (!is.null(supp))
@@ -136,7 +150,8 @@
lattice = .make.lattice.es.vector(D at support),
.withArith = D at .withArith,
.withSim = D at .withSim, img = D at img,
- param = D at param, Symmetry = Symmetry))
+ param = D at param, Symmetry = Symmetry,
+ .finSupport = .finS))
}else
stop("Insufficient information given to determine distribution.")
}
@@ -335,8 +350,10 @@
SymmCenter(e2 at Symmetry))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1298
More information about the Distr-commits
mailing list