[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