[Distr-commits] r1255 - in branches/distr-2.8/pkg/distr: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Aug 8 01:19:25 CEST 2018
Author: ruckdeschel
Date: 2018-08-08 01:19:25 +0200 (Wed, 08 Aug 2018)
New Revision: 1255
Added:
branches/distr-2.8/pkg/distr/man/distr-defunct.Rd
Removed:
branches/distr-2.8/pkg/distr/man/GeomParameter-class.Rd
Modified:
branches/distr-2.8/pkg/distr/NAMESPACE
branches/distr-2.8/pkg/distr/R/AllClasses.R
branches/distr-2.8/pkg/distr/R/AllGenerics.R
branches/distr-2.8/pkg/distr/R/AllInitialize.R
branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R
branches/distr-2.8/pkg/distr/R/GeometricDistribution.R
branches/distr-2.8/pkg/distr/R/LatticeDistribution.R
branches/distr-2.8/pkg/distr/R/MinMaximum.R
branches/distr-2.8/pkg/distr/R/Truncate.R
branches/distr-2.8/pkg/distr/R/UnivarLebDecDistribution.R
branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R
branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R
branches/distr-2.8/pkg/distr/R/decomposePM.R
branches/distr-2.8/pkg/distr/R/flat.R
branches/distr-2.8/pkg/distr/R/internalUtils.R
branches/distr-2.8/pkg/distr/R/liesInSupport.R
branches/distr-2.8/pkg/distr/inst/NEWS
branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd
branches/distr-2.8/pkg/distr/man/liesInSupport.Rd
Log:
+ accessor & replacer for prob, GeomParameter are finally Defunct
+ liesInSupport gains an argument checkFin; in case of DiscreteDistributions, it tries to use
additional information from internal slot .finSupport, and e.g. if there is a lattice.
+ liesInSupport now also is available for UnivarLebDecDistribution, LatticeDistribution, and UnivarMixingDistribution
under the hood:
+ DiscreteDistribution(s) gain a logical slot .finSupport to better control whether the
"true" support (not the possibly truncated one in slot support) is infinite (more precisely
it is of length 2 -- first coordinate if the lower bound of the support is finite, second if
the upper bound is finite)
Modified: branches/distr-2.8/pkg/distr/NAMESPACE
===================================================================
--- branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-07 23:19:25 UTC (rev 1255)
@@ -30,7 +30,7 @@
"CauchyParameter", "ChisqParameter",
"DiracParameter", "ExpParameter",
"FParameter", "GammaParameter",
- "HyperParameter", "GeomParameter",
+ "HyperParameter",
"LogisParameter", "LnormParameter",
"NbinomParameter", "NormParameter",
"PoisParameter", "TParameter",
Modified: branches/distr-2.8/pkg/distr/R/AllClasses.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/AllClasses.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/AllClasses.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -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: branches/distr-2.8/pkg/distr/R/AllGenerics.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -300,7 +300,7 @@
setGeneric("liesIn", function(object, x) standardGeneric("liesIn"))
if(!isGeneric("liesInSupport"))
- setGeneric("liesInSupport", function(object, x)
+ setGeneric("liesInSupport", function(object, x, checkFin = FALSE)
standardGeneric("liesInSupport"))
if(!isGeneric("convpow"))
setGeneric("convpow", function(D1, ...) standardGeneric("convpow"))
Modified: branches/distr-2.8/pkg/distr/R/AllInitialize.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -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
})
Modified: branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -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,16 @@
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])
+ }
+ )
### preliminary to export special functions
@@ -436,7 +467,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 +507,8 @@
object <- DiscreteDistribution(
supp=digamma(support(x)),
prob=prob(x), .withArith = TRUE)
+
+ object at .finSupport <- c(TRUE, x at .finSupport[2])
object
})
@@ -481,6 +518,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 +528,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: branches/distr-2.8/pkg/distr/R/GeometricDistribution.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/GeometricDistribution.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/GeometricDistribution.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -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: branches/distr-2.8/pkg/distr/R/LatticeDistribution.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/LatticeDistribution.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/LatticeDistribution.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -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))
if( length(supp1) >= 2 * length(supp2)){
- return(DiscreteDistribution(supp = supp2, prob = newd2,
- .withArith = TRUE, Symmetry = Symmetry))
+ res <- DiscreteDistribution(supp = supp2, prob = newd2,
+ .withArith = TRUE, Symmetry = Symmetry)
+ res at .finSupport <- e1 at .finSupport & e2 at .finSupport
+ return(res)
}else{
lat <- Lattice(pivot=supp1[1],width=wa, Length=length(supp1))
@@ -350,6 +367,7 @@
}else{
Lattice(pivot = su12.r, width = -wa, Length = Inf)}
}
+ e0 at .finSupport <- e1 at .finSupport & e2 at .finSupport
return(e0)
}
})
@@ -369,17 +387,19 @@
if(is(e1 at Symmetry,"SphericalSymmetry"))
Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry)+e2)
- LatticeDistribution(lattice = L,
+ res <- LatticeDistribution(lattice = L,
DiscreteDistribution = Distr, Symmetry = Symmetry,
- check = FALSE)
+ check = FALSE)
+ res at .finSupport <- e1 at .finSupport & c(e2>(-Inf),(e2<Inf))
+ return(res)
})
setMethod("*", c("LatticeDistribution", "numeric"),
function(e1, e2)
{if (.isEqual(e2,0))
return(Dirac( location = 0 ))
- else
- { L <- lattice(e1)
+ else{
+ L <- lattice(e1)
pivot(L) <- pivot(L) * e2
width(L) <- width(L) * e2
Distr <- as(e1, "DiscreteDistribution") * e2
@@ -390,9 +410,17 @@
if(is(e1 at Symmetry,"SphericalSymmetry"))
Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry) * e2)
- return(LatticeDistribution(lattice = L,
+ res <- LatticeDistribution(lattice = L,
DiscreteDistribution = Distr, Symmetry = Symmetry,
- check = FALSE))
+ check = FALSE)
+ if(is.finite(e2)){
+ res at .finSupport <- e1 at .finSupport
+ }else{
+ ep <- .Machine$double.eps
+ res at .finSupport <- c((p(e1)(0)<= ep),(p(e1)(0)>=1-ep))
+ }
+ if(e2<0) res at .finSupport <- rev(res at .finSupport)
+ return(res)
}
}
)
@@ -404,12 +432,14 @@
Symmetry <- NoSymmetry()
if(is(e1 at Symmetry,"SphericalSymmetry"))
Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry) + e2)
- LatticeDistribution(lattice = L,
+ res <- LatticeDistribution(lattice = L,
DiscreteDistribution =
as(e1, "AffLinDiscreteDistribution") + e2,
Symmetry = Symmetry,
check = FALSE)
- })
+ res at .finSupport <- e1 at .finSupport & c(e2>(-Inf),(e2<Inf))
+ return(res)
+ })
setMethod("*", c("AffLinLatticeDistribution", "numeric"),
function(e1, e2)
@@ -422,11 +452,19 @@
Symmetry <- NoSymmetry()
if(is(e1 at Symmetry,"SphericalSymmetry"))
Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry) * e2)
- return(LatticeDistribution(lattice = L,
+ res <- LatticeDistribution(lattice = L,
DiscreteDistribution =
as(e1, "AffLinDiscreteDistribution") *
e2, Symmetry = Symmetry,
- check = FALSE))
+ check = FALSE)
+ if(is.finite(e2)){
+ res at .finSupport <- e1 at .finSupport
+ }else{
+ ep <- .Machine$double.eps
+ res at .finSupport <- c((p(e1)(0)<= ep),(p(e1)(0)>=1-ep))
+ }
+ if(e2<0) res at .finSupport <- rev(res at .finSupport)
+ return(res)
}
}
)
Modified: branches/distr-2.8/pkg/distr/R/MinMaximum.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/MinMaximum.R 2018-08-06 12:46:06 UTC (rev 1254)
+++ branches/distr-2.8/pkg/distr/R/MinMaximum.R 2018-08-07 23:19:25 UTC (rev 1255)
@@ -75,7 +75,10 @@
p1 <- p(e1)(supp,lower.tail = FALSE)
p2 <- p(e2)(supp,lower.tail = FALSE)
d0 <- d1*p2 + d2*p1 + d1*d2
- DiscreteDistribution(supp=supp, prob=d0, .withArith= TRUE)
+ res <- DiscreteDistribution(supp=supp, prob=d0, .withArith= TRUE)
+ res at .finSupport <- c(e1 at .finSupport[1]&e2 at .finSupport[1],
+ e1 at .finSupport[2]|e2 at .finSupport[2])
+ res
})
setMethod("Minimum",
@@ -213,7 +216,9 @@
supp <- support(e1)
pnew <- 1 - (p(e1)(supp, lower.tail = FALSE))^e2
dnew <- c(pnew[1],diff(pnew))
- DiscreteDistribution(supp = supp, prob = dnew, .withArith = TRUE)
+ res <- DiscreteDistribution(supp = supp, prob = dnew, .withArith = TRUE)
+ res at .finSupport = e1 at .finSupport
+ res
})
setMethod("Minimum",
Modified: branches/distr-2.8/pkg/distr/R/Truncate.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/Truncate.R 2018-08-06 12:46:06 UTC (rev 1254)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1255
More information about the Distr-commits
mailing list