[Distr-commits] r1316 - branches/distr-2.8/pkg/distr/R branches/distr-2.8/pkg/distr/inst branches/distr-2.9/pkg/distr/R branches/distr-2.9/pkg/distr/inst pkg/distr/R pkg/distr/inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Mar 11 20:38:29 CET 2019
Author: ruckdeschel
Date: 2019-03-11 20:38:28 +0100 (Mon, 11 Mar 2019)
New Revision: 1316
Modified:
branches/distr-2.8/pkg/distr/R/internalUtils.R
branches/distr-2.8/pkg/distr/inst/NEWS
branches/distr-2.9/pkg/distr/R/internalUtils.R
branches/distr-2.9/pkg/distr/inst/NEWS
pkg/distr/R/internalUtils.R
pkg/distr/inst/NEWS
Log:
[distr] trunk & branches 2.8 & 2.9
+ .modifyqgaps can now digest args pfun and qfun with or without arguments log.p and lower.tail
Modified: branches/distr-2.8/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/internalUtils.R 2019-03-11 15:33:22 UTC (rev 1315)
+++ branches/distr-2.8/pkg/distr/R/internalUtils.R 2019-03-11 19:38:28 UTC (rev 1316)
@@ -1177,8 +1177,20 @@
gaps <- gaps[finit,,drop=FALSE]
# print(gaps)
## p-level of constancy region
- lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
- lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+
+ if(.inArgs("log.p", pfun)){
+ lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+ else
+ lp.gaps.l <- 1-matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ }else{
+ lp.gaps <- log(matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- log(matrix(pfun(gaps,lower.tail = FALSE),nrow=nrow(gaps),ncol=2))
+ else
+ lp.gaps.l <- log1p(-matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ }
# print(lp.gaps)
# print(lp.gaps.l)
@@ -1190,8 +1202,26 @@
## which stores the unmodified quantile function
## in the first modification round ..q0fun will not yet exist
## in this situation use qfun instead
+ qfunN <- qfun
+ if(!.inArgs("log.p", qfun) || !.inArgs("lower.tail", qfun)){
+ qfunN <- function(p, lower.tail = TRUE, log.p = FALSE){
+ if(.inArgs("lower.tail",qfun)) if(log.p) p <- exp(p)
+ if(.inArgs("log.p", qfun)){
+ p1 <- if(log.p) exp(p) else p
+ qval <- if(lower.tail) qfun(p, log.p) else qfun(1-p1, log.p=FALSE)
+ }else{
+ if(!.inArgs("lower.tail",qfun)){
+ qval <- if(lower.tail) qfun(p) else qfun(1-p)
+ }else{
+ qval <- qfun(p,lower.tail)
+ }
+ }
+ return(qval)
+ }
+ }
- qfunE <- environment(qfun)
+
+ qfunE <- environment(qfunN)
qnew <- function(p, lower.tail = TRUE, log.p = FALSE) {}
qnewE <- environment(qnew) <- new.env()
body(qnew) <- substitute({
@@ -1215,7 +1245,7 @@
}
}
return(q0)
- },list(qfunE. = qfunE, qfun.=qfun, lp.gaps.=lp.gaps,
+ },list(qfunE. = qfunE, qfun.=qfunN, lp.gaps.=lp.gaps,
lp.gaps.l. = lp.gaps.l[,2:1,drop=FALSE],
lrpmatch. = lrpmatch, gaps. = gaps, ..isEqual = .isEqual)
)
Modified: branches/distr-2.8/pkg/distr/inst/NEWS
===================================================================
--- branches/distr-2.8/pkg/distr/inst/NEWS 2019-03-11 15:33:22 UTC (rev 1315)
+++ branches/distr-2.8/pkg/distr/inst/NEWS 2019-03-11 19:38:28 UTC (rev 1316)
@@ -50,6 +50,7 @@
(if existant in the env() of q(obj)) to revert the gaps modification, and any gaps modification, instead of starting
from q(obj) starts with ..q0fun (if this exists); otherwise, i.e., if ..q0fun does not exist, it uses q(obj) and
afterwords stores the old q(obj) as ..q0fun ...
++ .modifyqgaps can now digest args pfun and qfun with or without arguments log.p and lower.tail
##############
v 2.7
Modified: branches/distr-2.9/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.9/pkg/distr/R/internalUtils.R 2019-03-11 15:33:22 UTC (rev 1315)
+++ branches/distr-2.9/pkg/distr/R/internalUtils.R 2019-03-11 19:38:28 UTC (rev 1316)
@@ -1177,8 +1177,20 @@
gaps <- gaps[finit,,drop=FALSE]
# print(gaps)
## p-level of constancy region
- lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
- lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+
+ if(.inArgs("log.p", pfun)){
+ lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+ else
+ lp.gaps.l <- 1-matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ }else{
+ lp.gaps <- log(matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- log(matrix(pfun(gaps,lower.tail = FALSE),nrow=nrow(gaps),ncol=2))
+ else
+ lp.gaps.l <- log1p(-matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ }
# print(lp.gaps)
# print(lp.gaps.l)
@@ -1190,8 +1202,26 @@
## which stores the unmodified quantile function
## in the first modification round ..q0fun will not yet exist
## in this situation use qfun instead
+ qfunN <- qfun
+ if(!.inArgs("log.p", qfun) || !.inArgs("lower.tail", qfun)){
+ qfunN <- function(p, lower.tail = TRUE, log.p = FALSE){
+ if(.inArgs("lower.tail",qfun)) if(log.p) p <- exp(p)
+ if(.inArgs("log.p", qfun)){
+ p1 <- if(log.p) exp(p) else p
+ qval <- if(lower.tail) qfun(p, log.p) else qfun(1-p1, log.p=FALSE)
+ }else{
+ if(!.inArgs("lower.tail",qfun)){
+ qval <- if(lower.tail) qfun(p) else qfun(1-p)
+ }else{
+ qval <- qfun(p,lower.tail)
+ }
+ }
+ return(qval)
+ }
+ }
- qfunE <- environment(qfun)
+
+ qfunE <- environment(qfunN)
qnew <- function(p, lower.tail = TRUE, log.p = FALSE) {}
qnewE <- environment(qnew) <- new.env()
body(qnew) <- substitute({
@@ -1215,7 +1245,7 @@
}
}
return(q0)
- },list(qfunE. = qfunE, qfun.=qfun, lp.gaps.=lp.gaps,
+ },list(qfunE. = qfunE, qfun.=qfunN, lp.gaps.=lp.gaps,
lp.gaps.l. = lp.gaps.l[,2:1,drop=FALSE],
lrpmatch. = lrpmatch, gaps. = gaps, ..isEqual = .isEqual)
)
Modified: branches/distr-2.9/pkg/distr/inst/NEWS
===================================================================
--- branches/distr-2.9/pkg/distr/inst/NEWS 2019-03-11 15:33:22 UTC (rev 1315)
+++ branches/distr-2.9/pkg/distr/inst/NEWS 2019-03-11 19:38:28 UTC (rev 1316)
@@ -50,6 +50,7 @@
(if existant in the env() of q(obj)) to revert the gaps modification, and any gaps modification, instead of starting
from q(obj) starts with ..q0fun (if this exists); otherwise, i.e., if ..q0fun does not exist, it uses q(obj) and
afterwords stores the old q(obj) as ..q0fun ...
++ .modifyqgaps can now digest args pfun and qfun with or without arguments log.p and lower.tail
##############
v 2.7
Modified: pkg/distr/R/internalUtils.R
===================================================================
--- pkg/distr/R/internalUtils.R 2019-03-11 15:33:22 UTC (rev 1315)
+++ pkg/distr/R/internalUtils.R 2019-03-11 19:38:28 UTC (rev 1316)
@@ -1177,8 +1177,20 @@
gaps <- gaps[finit,,drop=FALSE]
# print(gaps)
## p-level of constancy region
- lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
- lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+
+ if(.inArgs("log.p", pfun)){
+ lp.gaps <- matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- matrix(pfun(gaps,log.p=TRUE, lower.tail = FALSE),nrow=nrow(gaps),ncol=2)
+ else
+ lp.gaps.l <- 1-matrix(pfun(gaps,log.p=TRUE),nrow=nrow(gaps),ncol=2)
+ }else{
+ lp.gaps <- log(matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ if(.inArgs("lower.tail", pfun))
+ lp.gaps.l <- log(matrix(pfun(gaps,lower.tail = FALSE),nrow=nrow(gaps),ncol=2))
+ else
+ lp.gaps.l <- log1p(-matrix(pfun(gaps),nrow=nrow(gaps),ncol=2))
+ }
# print(lp.gaps)
# print(lp.gaps.l)
@@ -1190,8 +1202,26 @@
## which stores the unmodified quantile function
## in the first modification round ..q0fun will not yet exist
## in this situation use qfun instead
+ qfunN <- qfun
+ if(!.inArgs("log.p", qfun) || !.inArgs("lower.tail", qfun)){
+ qfunN <- function(p, lower.tail = TRUE, log.p = FALSE){
+ if(.inArgs("lower.tail",qfun)) if(log.p) p <- exp(p)
+ if(.inArgs("log.p", qfun)){
+ p1 <- if(log.p) exp(p) else p
+ qval <- if(lower.tail) qfun(p, log.p) else qfun(1-p1, log.p=FALSE)
+ }else{
+ if(!.inArgs("lower.tail",qfun)){
+ qval <- if(lower.tail) qfun(p) else qfun(1-p)
+ }else{
+ qval <- qfun(p,lower.tail)
+ }
+ }
+ return(qval)
+ }
+ }
- qfunE <- environment(qfun)
+
+ qfunE <- environment(qfunN)
qnew <- function(p, lower.tail = TRUE, log.p = FALSE) {}
qnewE <- environment(qnew) <- new.env()
body(qnew) <- substitute({
@@ -1215,7 +1245,7 @@
}
}
return(q0)
- },list(qfunE. = qfunE, qfun.=qfun, lp.gaps.=lp.gaps,
+ },list(qfunE. = qfunE, qfun.=qfunN, lp.gaps.=lp.gaps,
lp.gaps.l. = lp.gaps.l[,2:1,drop=FALSE],
lrpmatch. = lrpmatch, gaps. = gaps, ..isEqual = .isEqual)
)
Modified: pkg/distr/inst/NEWS
===================================================================
--- pkg/distr/inst/NEWS 2019-03-11 15:33:22 UTC (rev 1315)
+++ pkg/distr/inst/NEWS 2019-03-11 19:38:28 UTC (rev 1316)
@@ -34,14 +34,6 @@
+ in distr::solve only try base::solve if arg "a" has no dim or if it has then
if nrow(a)==nrow(b); otherwise directly use MASS::ginv
+ introduced particular liesInSupport methods for all specific abs.cont distributions in distr
-
-bug fixes
-+ fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ...
-+ Bernhard discovered a bug in devNew() -- it opened new devices even if option("newDevice"==FALSE)
-+ detected that the initialize method of Weibull lacked a .withArith argument to capture the scale structure
-+ unknown variable p in S4method to Minimum(absCont,absCont)
-
-under the hood:
+ in reaction to mail by B.Ripley Feb 20, 19/ explanation by T. Kalibera, that our code to
look into system.call() stack was buggy and failed in staged installation, we revised code to .modifyqgaps completely;
we now compute p(obj)(gaps) and check if any argument p of q(obj) falls within the gap range and then shift it to either
@@ -50,7 +42,15 @@
(if existant in the env() of q(obj)) to revert the gaps modification, and any gaps modification, instead of starting
from q(obj) starts with ..q0fun (if this exists); otherwise, i.e., if ..q0fun does not exist, it uses q(obj) and
afterwords stores the old q(obj) as ..q0fun ...
++ .modifyqgaps can now digest args pfun and qfun with or without arguments log.p and lower.tail
+
+bug fixes
++ fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ...
++ Bernhard discovered a bug in devNew() -- it opened new devices even if option("newDevice"==FALSE)
++ detected that the initialize method of Weibull lacked a .withArith argument to capture the scale structure
++ unknown variable p in S4method to Minimum(absCont,absCont)
+
##############
v 2.7
##############
More information about the Distr-commits
mailing list