[Distr-commits] r1423 - in branches/distr-2.9/pkg/distr: . R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 28 18:38:40 CET 2024
Author: ruckdeschel
Date: 2024-01-28 18:38:39 +0100 (Sun, 28 Jan 2024)
New Revision: 1423
Modified:
branches/distr-2.9/pkg/distr/DESCRIPTION
branches/distr-2.9/pkg/distr/R/AllInitialize.R
branches/distr-2.9/pkg/distr/R/flat.R
branches/distr-2.9/pkg/distr/R/internalUtils.R
branches/distr-2.9/pkg/distr/inst/NEWS
Log:
distr pkgs
Modified: branches/distr-2.9/pkg/distr/DESCRIPTION
===================================================================
--- branches/distr-2.9/pkg/distr/DESCRIPTION 2024-01-28 17:33:31 UTC (rev 1422)
+++ branches/distr-2.9/pkg/distr/DESCRIPTION 2024-01-28 17:38:39 UTC (rev 1423)
@@ -1,6 +1,6 @@
Package: distr
-Version: 2.9.3
-Date: 2023-07-20
+Version: 2.9.4
+Date: 2024-01-28
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
@@ -21,4 +21,4 @@
URL: https://r-forge.r-project.org/projects/distr/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-VCS/SVNRevision: 1324
+VCS/SVNRevision: 1422
Modified: branches/distr-2.9/pkg/distr/R/AllInitialize.R
===================================================================
--- branches/distr-2.9/pkg/distr/R/AllInitialize.R 2024-01-28 17:33:31 UTC (rev 1422)
+++ branches/distr-2.9/pkg/distr/R/AllInitialize.R 2024-01-28 17:38:39 UTC (rev 1423)
@@ -62,6 +62,44 @@
# .Object at .withArith <- .withArith
# .Object })
+ ### -------------------------------------------------------------
+ ### Comment added 20240127
+ ### -------------------------------------------------------------
+ ### We alway had to do some fiddling with the interaction of setting a
+ ### prototype in our S4 class definitions, and, at the same time using a user-defined
+ ### initialize method.
+ ###
+ ### This initialize method is called automatically in every call to new("<class>", ... )
+ ### whether or not arg "..." is empty or not.
+ ###
+ ### Our system was (and is) to allow for new("<class>"), i.e., with empty "...",
+ ### and if so, filling all slots in a consistent way through the prototype.
+ ### Otherwise "..." is not empty, so [for our classes] must contain information
+ ### on the distribution in respective r, d, p, and q arguments.
+ ### Non of them is obligatory, i.e., any of these can be left NULL (but not all of
+ ### them). So the task of our initialize method then is to check whether the
+ ### inforamtion passed on the r, d, p, and q slots through the "..." arg of new(...)
+ ### is sufficient to create the respective distribution.
+ ###
+ ### In a clean code world, ideally this check whether "..." is empty or not
+ ### should be done in the code of new(...), which is not ours though; so this
+ ### is not feasible.
+ ### Hence, our initialize method must find out whether the new() call, from which
+ ### the initialize method itself has been called, has an empty "..." argument or not.
+ ### This has always been done through mounting up the system.call stack.
+ ### More specifically, we get the calling new() call mounting up three nodes,
+ ### i.e., through sys.calls()[[LL-3]], where LL is the depth of the initialize call.
+ ###
+ ### By a change made by R Core in Dec 2023 to robustify calls to functions
+ ### in the methods package, these (automatic) calls to new() now have a NAMESPACE
+ ### qualifier "methods::" prepended.
+ ###
+ ### So to get everything right in our package, instead of checking whether
+ ### sys.calls()[[LL-3]] == "new(toDef)" or sys.calls()[[LL-3]] == "new(<Classname>)",
+ ### we now also include the checks with the prepended "methods::"
+ ### -------------------------------------------------------------
+
+
## class AbscontDistribution
setMethod("initialize", "AbscontDistribution",
function(.Object, r = NULL, d = NULL, p = NULL, q = NULL,
@@ -73,11 +111,12 @@
) {
## don't use this if the call is new("AbscontDistribution")
LL <- length(sys.calls())
- if(sys.calls()[[LL-3]] == "new(toDef)")
- {return(.Object)}
- if(sys.calls()[[LL-3]] == "new(\"AbscontDistribution\")")
- {return(.Object)}
-
+
+ if((sys.calls()[[LL-3]]=="new(\"AbscontDistribution\")")||
+ (sys.calls()[[LL-3]]=="methods::new(\"AbscontDistribution\")")||
+ (sys.calls()[[LL-3]]=="new(toDef)")||
+ (sys.calls()[[LL-3]]=="methods::new(toDef)")) return(.Object)
+
if(is.null(r))
warning("you have to specify slot r at least")
@@ -167,12 +206,13 @@
.finSupport = c(TRUE,TRUE),
Symmetry = NoSymmetry()) {
- ## don't use this if the call is new("DiscreteDistribution")
+ ## don't use this if the call is [methods::]new("DiscreteDistribution")
+ ## or if the call is [methods::]new(toDef)
LL <- length(sys.calls())
- if(sys.calls()[[LL-3]] == "new(toDef)")
- {return(.Object)}
- if(sys.calls()[[LL-3]] == "new(\"DiscreteDistribution\")")
- {return(.Object)}
+ if((sys.calls()[[LL-3]]=="new(\"DiscreteDistribution\")")||
+ (sys.calls()[[LL-3]]=="methods::new(\"DiscreteDistribution\")")||
+ (sys.calls()[[LL-3]]=="new(toDef)")||
+ (sys.calls()[[LL-3]]=="methods::new(toDef)")) return(.Object)
if(is.null(r))
warning("you have to specify slot r at least")
@@ -239,7 +279,8 @@
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\")")
+ if((sys.calls()[[LL-3]] == "new(\"AffLinDiscreteDistribution\")" )||
+ (sys.calls()[[LL-3]] == "methods::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,
@@ -273,7 +314,9 @@
LL <- length(sys.calls())
- if(sys.calls()[[LL-3]] == "new(\"LatticeDistribution\")")
+ syscl <- sys.calls()[[LL-3]]
+ if((sys.calls()[[LL-3]] == "new(\"LatticeDistribution\")" )||
+ (sys.calls()[[LL-3]] == "methods::new(\"LatticeDistribution\")" ))
D <- new("DiscreteDistribution")
else
D <- new("DiscreteDistribution", r = r, d = d, p = p,
@@ -319,7 +362,9 @@
Symmetry = NoSymmetry(), .finSupport = c(TRUE, TRUE)) {
LL <- length(sys.calls())
- if(sys.calls()[[LL-3]] == "new(\"AffLinLatticeDistribution\")")
+ syscl <- sys.calls()[[LL-3]]
+ if((sys.calls()[[LL-3]] == "new(\"AffLinLatticeDistribution\")" )||
+ (sys.calls()[[LL-3]] == "methods::new(\"AffLinLatticeDistribution\")" ))
X <- new("LatticeDistribution")
else X <- new("LatticeDistribution", r = r, d = d, p = p, q = q,
support = support, lattice = lattice, param = param,
Modified: branches/distr-2.9/pkg/distr/R/flat.R
===================================================================
--- branches/distr-2.9/pkg/distr/R/flat.R 2024-01-28 17:33:31 UTC (rev 1422)
+++ branches/distr-2.9/pkg/distr/R/flat.R 2024-01-28 17:38:39 UTC (rev 1423)
@@ -22,7 +22,12 @@
ldots <- ldots[mixCoeff >ep]
l <- length(ldots)
- mixCoeff <- mixCoeff[mixCoeff >ep]
+ ### new 20240127: if only one mixCoeff is really different from 0 catch this
+ if(l == 1)
+ return( ldots[mixCoeff >ep] )
+
+ mixCoeff <- mixCoeff[mixCoeff >ep]
+
mixDistr.c <- lapply(ldots, function(x)acPart(x))
mixDistr.d <- lapply(ldots, function(x)discretePart(x))
@@ -50,7 +55,10 @@
finSupport <- c(TRUE,TRUE)
if(l.d>0){
mixDistr.dfs <- sapply(mixDistr.d, function(x) x at .finSupport)
- finSupport <- apply(mixDistr.dfs,1,all)
+ ## 20230720: detected by Christoph Dalitz <christoph.dalitz at hs-niederrhein.de>
+ ## can be a vector if the list elements are all Dirac distributions55
+ if(is.null(dim(mixDistr.dfs))) mixDistr.dfs <- matrix(mixDistr.dfs,nrow=1)
+ finSupport <- apply(mixDistr.dfs,1,all)
}
if(l.c){
rnew.c <- .rmixfun(mixDistr = mixDistr.c, mixCoeff = mixCoeff.c)
Modified: branches/distr-2.9/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.9/pkg/distr/R/internalUtils.R 2024-01-28 17:33:31 UTC (rev 1422)
+++ branches/distr-2.9/pkg/distr/R/internalUtils.R 2024-01-28 17:38:39 UTC (rev 1423)
@@ -834,6 +834,9 @@
h <- diff(x)
l <- length(x)
+
+ ### 20240127
+ if(l < 3) stop("Too few grid points for .primefun.")
xm <- (x[-l]+x[-1])/2
@@ -862,6 +865,10 @@
.csimpsum <- function(fx){
l <- length(fx)
+
+ ### 20240127
+ if(l < 3) stop("Too few grid points for .csimpsum.")
+
l2 <- l%/%2
if (l%%2 == 0) {
fx <- c(fx[1:l2],(fx[l2]+fx[l2+1])/2,fx[(l2+1):l])
@@ -883,7 +890,9 @@
if (Cont){
mfun <- if (is.null (myPf)) approxfun else myPf
l <- length(x)
- if ((l%%2==0)&& is.null(myPf)){
+ ### 20240127
+ if (l < 3) stop("Too few grid points for .makePNew.")
+ if ((l%%2==0)&& is.null(myPf)){
l2 <- l/2
if (is.null(pxl))
x.l <- c(x[1:l2],(x[l2]+x[l2+1])/2,x[(l2+1):l])
@@ -1005,6 +1014,7 @@
rm(pnew, qnew, dnew, rnew)
object
}
+
.expm.c <- function(e1){
gapsnew <- if(is.null(e1 at gaps)) NULL else exp(e1 at gaps)
@@ -1047,6 +1057,7 @@
rm(pnew, qnew, dnew, rnew)
object
}
+
.logm.d <- function(e1){
supportnew <- log(e1 at support)
@@ -1071,6 +1082,7 @@
rm(pnew, qnew, dnew, rnew)
object
}
+
.logm.c <- function(e1){
gapsnew <- if(is.null(e1 at gaps)) NULL else log(e1 at gaps)
Modified: branches/distr-2.9/pkg/distr/inst/NEWS
===================================================================
--- branches/distr-2.9/pkg/distr/inst/NEWS 2024-01-28 17:33:31 UTC (rev 1422)
+++ branches/distr-2.9/pkg/distr/inst/NEWS 2024-01-28 17:38:39 UTC (rev 1423)
@@ -21,6 +21,12 @@
by K. Hornik, Dec, 15, 2023, with some helpful hints by Michael Lawrence
in a mail Dec, 19, 2023
+under the hood:
++ in changes in R-Core in the methods package, internal calls to new()
+ were prepended by a NAMESPACE qualifier methods:: in Dec 2023;
+ we had to accomodate for this in our initialize methods; for details
+ see ll.64-100 in code file initialize.R
+
##############
v 2.9.2
##############
More information about the Distr-commits
mailing list