[Distr-commits] r1422 - in pkg/distr: . R inst man tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 28 18:33:32 CET 2024
Author: ruckdeschel
Date: 2024-01-28 18:33:31 +0100 (Sun, 28 Jan 2024)
New Revision: 1422
Modified:
pkg/distr/DESCRIPTION
pkg/distr/R/AllInitialize.R
pkg/distr/R/flat.R
pkg/distr/R/internalUtils.R
pkg/distr/inst/NEWS
pkg/distr/man/0distr-package.Rd
pkg/distr/tests/Examples/distr-Ex.Rout.save
Log:
[distr] - trunk new release
Modified: pkg/distr/DESCRIPTION
===================================================================
--- pkg/distr/DESCRIPTION 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/DESCRIPTION 2024-01-28 17:33:31 UTC (rev 1422)
@@ -1,6 +1,6 @@
Package: distr
-Version: 2.9.2
-Date: 2023-05-08
+Version: 2.9.3
+Date: 2024-01-27
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: http://distr.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-VCS/SVNRevision: 1406
+VCS/SVNRevision: 1422
Modified: pkg/distr/R/AllInitialize.R
===================================================================
--- pkg/distr/R/AllInitialize.R 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/R/AllInitialize.R 2024-01-28 17:33:31 UTC (rev 1422)
@@ -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: pkg/distr/R/flat.R
===================================================================
--- pkg/distr/R/flat.R 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/R/flat.R 2024-01-28 17:33:31 UTC (rev 1422)
@@ -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))
@@ -51,9 +56,9 @@
if(l.d>0){
mixDistr.dfs <- sapply(mixDistr.d, function(x) x at .finSupport)
## 20230720: detected by Christoph Dalitz <christoph.dalitz at hs-niederrhein.de>
- ## can be a vector if the list elements are all Dirac distributions
- if(is.null(dim(mixDistr.dfs))) mixDistr.dfs <- matrix(mixDistr.dfs,nrow=1)
- finSupport <- apply(mixDistr.dfs,1,all)
+ ## 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: pkg/distr/R/internalUtils.R
===================================================================
--- pkg/distr/R/internalUtils.R 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/R/internalUtils.R 2024-01-28 17:33:31 UTC (rev 1422)
@@ -834,6 +834,9 @@
h <- diff(x)
l <- length(x)
+
+ ### 20240127
+ if(l < 2) stop("Too few grid points for .primefun.")
xm <- (x[-l]+x[-1])/2
@@ -862,6 +865,8 @@
.csimpsum <- function(fx){
l <- length(fx)
+
+
l2 <- l%/%2
if (l%%2 == 0) {
fx <- c(fx[1:l2],(fx[l2]+fx[l2+1])/2,fx[(l2+1):l])
@@ -883,7 +888,9 @@
if (Cont){
mfun <- if (is.null (myPf)) approxfun else myPf
l <- length(x)
- if ((l%%2==0)&& is.null(myPf)){
+ ### 20240127
+ #if (l < 2) 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 +1012,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 +1055,7 @@
rm(pnew, qnew, dnew, rnew)
object
}
+
.logm.d <- function(e1){
supportnew <- log(e1 at support)
@@ -1071,6 +1080,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: pkg/distr/inst/NEWS
===================================================================
--- pkg/distr/inst/NEWS 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/inst/NEWS 2024-01-28 17:33:31 UTC (rev 1422)
@@ -10,10 +10,24 @@
##############
v 2.9.3
##############
-bug fixes:
-+ fixed a glitch in "+"("DiscreteDistribution","DiscreteDistribution") as spotted by christoph.dalitz at hs-niederrhein.de
+bug fixes
++ detected by Christoph Dalitz <christoph.dalitz at hs-niederrhein.de>
+ when multiplying DiscreteDistributions, the positive and negative parts of
+ which are Dirac Distributions, .finSupport was not returned of length 2
+ (as needed),
++ fixed a glitch in "+"("DiscreteDistribution","DiscreteDistribution") as
+ spotted by christoph.dalitz at hs-niederrhein.de
++ fixed some documentation glitches in internal .Rd files as noted in a mail
+ 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
##############
Modified: pkg/distr/man/0distr-package.Rd
===================================================================
--- pkg/distr/man/0distr-package.Rd 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/man/0distr-package.Rd 2024-01-28 17:33:31 UTC (rev 1422)
@@ -44,8 +44,8 @@
\details{
\tabular{ll}{
Package: \tab distr \cr
-Version: \tab 2.9.1 \cr
-Date: \tab 2022-11-14 \cr
+Version: \tab 2.9.3 \cr
+Date: \tab 2024-01-27 \cr
Depends: \tab R(>= 3.4), methods, graphics, startupmsg, sfsmisc \cr
Suggests: \tab distrEx, svUnit (>= 0.7-11), knitr, distrMod, ROptEst \cr
Imports: \tab stats, grDevices, utils, MASS \cr
@@ -52,7 +52,7 @@
LazyLoad: \tab yes \cr
License: \tab LGPL-3 \cr
URL: \tab https://distr.r-forge.r-project.org/\cr
-VCS/SVNRevision: \tab 1395 \cr
+VCS/SVNRevision: \tab 1422 \cr
}}
\section{Classes}{
Distribution classes have a slot \code{param} the class of which
Modified: pkg/distr/tests/Examples/distr-Ex.Rout.save
===================================================================
--- pkg/distr/tests/Examples/distr-Ex.Rout.save 2023-12-19 07:59:01 UTC (rev 1421)
+++ pkg/distr/tests/Examples/distr-Ex.Rout.save 2024-01-28 17:33:31 UTC (rev 1422)
@@ -1,7 +1,7 @@
-R version 4.1.2 Patched (2022-01-17 r81511) -- "Bird Hippie"
-Copyright (C) 2022 The R Foundation for Statistical Computing
-Platform: i386-w64-mingw32/i386 (32-bit)
+R Under development (unstable) (2024-01-25 r85826 ucrt) -- "Unsuffered Consequences"
+Copyright (C) 2024 The R Foundation for Statistical Computing
+Platform: x86_64-w64-mingw32/x64
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
@@ -30,7 +30,7 @@
Loading required package: sfsmisc
:distr> Object Oriented Implementation of Distributions (version
-:distr> 2.9.2)
+:distr> 2.9.3)
:distr>
:distr> Attention: Arithmetics on distribution objects are
:distr> understood as operations on corresponding random variables
@@ -2006,8 +2006,10 @@
> # squared standard normal distribution
> ## IGNORE_RDIFF_BEGIN
> x$dfun(4)
-[1] 0.0254851
+[1] 0.02548597
> RtoDPQ(r = rn2, e = 5, n = 1024) # for a better result
+Warning in .makeDNew(dxy$x, dxy$y, standM = "int") :
+ 'integrate()' threw an error ---result may be inaccurate.
$dfun
function(x, log = FALSE)
{if (log)
@@ -2014,8 +2016,8 @@
d0 <- log(df1(x))-log(stand)
else d0 <- df1(x) / stand
return (d0)}
-<bytecode: 0x09c2ef58>
-<environment: 0x0f6c8ee0>
+<bytecode: 0x00000151e3e59ca8>
+<environment: 0x00000151ed43d9a8>
$pfun
function (q, lower.tail = TRUE, log.p = FALSE)
@@ -2030,7 +2032,7 @@
else p0/nm
return(p0)
}
-<environment: 0x06fd13f0>
+<environment: 0x00000151ea9a1628>
$qfun
function (p, lower.tail = TRUE, log.p = FALSE)
@@ -2048,7 +2050,7 @@
else q.l0(1 - p01)
return(as.numeric(q0))
}
-<environment: 0x0afadf58>
+<environment: 0x00000151e625e970>
> ## IGNORE_RDIFF_END
> rp2 <- function(n){rpois(n, lambda = 1)^2}
@@ -2079,8 +2081,10 @@
> # squared standard normal distribution
> ## IGNORE_RDIFF_BEGIN
> x$dfun(4)
-[1] 0.0254851
+[1] 0.02548597
> RtoDPQ(r = rn2, e = 5, n = 1024) # for a better result
+Warning in .makeDNew(dxy$x, dxy$y, standM = "int") :
+ 'integrate()' threw an error ---result may be inaccurate.
$dfun
function(x, log = FALSE)
{if (log)
@@ -2087,8 +2091,8 @@
d0 <- log(df1(x))-log(stand)
else d0 <- df1(x) / stand
return (d0)}
-<bytecode: 0x09c2ef58>
-<environment: 0x0a602690>
+<bytecode: 0x00000151e3e59ca8>
+<environment: 0x00000151eef26f10>
$pfun
function (q, lower.tail = TRUE, log.p = FALSE)
@@ -2103,7 +2107,7 @@
else p0/nm
return(p0)
}
-<environment: 0x0a49bf18>
+<environment: 0x00000151e7cbb740>
$qfun
function (p, lower.tail = TRUE, log.p = FALSE)
@@ -2121,7 +2125,7 @@
else q.l0(1 - p01)
return(as.numeric(q0))
}
-<environment: 0x0a483368>
+<environment: 0x00000151e7c87b68>
> ## IGNORE_RDIFF_END
> rp2 <- function(n){rpois(n, lambda = 1)^2}
@@ -3625,11 +3629,11 @@
sim.left sim.right pw.left pw.right
[1,] 0.00282976 1.90952 0.0323441 1.04733
[2,] 0.00282976 1.94981 0.0323440 1.04733
- [3,] 0.00282976 2.03254 0.0323440 1.04733
+ [3,] 0.00282976 2.03254 0.0323441 1.04733
[4,] 0.00282976 2.22519 0.2156880 1.41067
[5,] 0.00282976 2.70502 0.7135654 2.16947
[6,] 0.00282976 2.71956 0.7135654 2.16947
- [7,] 0.00282976 3.02067 1.0115330 2.60787
+ [7,] 0.00282976 3.02067 1.0115331 2.60787
[8,] 0.00282976 3.15281 1.0115330 2.60787
[9,] 0.20789178 3.28363 1.1570344 2.82255
[10,] 0.78261897 3.63713 1.4471670 3.25405
@@ -3648,11 +3652,11 @@
[23,] 3.22446707 10.17629 3.5391176 6.67894
[24,] 3.43239404 14.95072 3.7815571 7.13538
[25,] 3.75255614 33.37684 4.3395390 8.26585
-[26,] 3.76891063 33.37684 4.3395390 8.26585
+[26,] 3.76891063 33.37684 4.3395389 8.26585
[27,] 4.23622865 33.37684 5.0503475 9.93760
[28,] 4.29137291 33.37684 5.0503475 9.93760
[29,] 4.30493804 33.37684 5.0503475 9.93760
-[30,] 4.68094638 33.37684 5.5034154 11.21826
+[30,] 4.68094638 33.37684 5.5034155 11.21826
$err
sim pw
@@ -3806,13 +3810,13 @@
> ## IGNORE_RDIFF_BEGIN
> system.time(r(F)(10^6))
user system elapsed
- 0.38 0.00 0.37
+ 0.31 0.01 0.33
> ## IGNORE_RDIFF_END
> simplifyr(F, size = 10^6)
> ## IGNORE_RDIFF_BEGIN
> system.time(r(F)(10^6))
user system elapsed
- 0.13 0.00 0.13
+ 0.11 0.00 0.11
> ## IGNORE_RDIFF_END
>
>
@@ -3849,7 +3853,7 @@
> cleanEx()
> options(digits = 7L)
> base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed: 25.75 2.3 29.29 NA NA
+Time elapsed: 25.53 1.97 28.05 NA NA
> grDevices::dev.off()
pdf
19
More information about the Distr-commits
mailing list