[Distr-commits] r1292 - branches/distr-2.8/pkg/distr/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Feb 27 16:28:53 CET 2019
Author: ruckdeschel
Date: 2019-02-27 16:28:53 +0100 (Wed, 27 Feb 2019)
New Revision: 1292
Modified:
branches/distr-2.8/pkg/distr/R/ContDistribution.R
branches/distr-2.8/pkg/distr/R/MinMaximum.R
branches/distr-2.8/pkg/distr/R/UnivarMixingDistribution.R
branches/distr-2.8/pkg/distr/R/internalUtils.R
branches/distr-2.8/pkg/distr/R/internalUtils_LCD.R
Log:
[distr] branch 2.8:
revealed in mail by B.Ripley Feb 20, 19:
"Staged installation is to be a new feature of R 3.6.0: it is not yet the default in R-devel but it is scheduled to become so on Mar 1. To turn
it on before then, set environment variable R_INSTALL_STAGED=true : this has been done for the fedora-clang results on CRAN."
Later on T. Kalibera spotted that the culprit was .qmodifygaps in internalUtils --- "...
it seems that during preparation for lazy loading, the current call stack is captured and ends up serialized into the R package. This
happens inside distr package, in function .modifyqgaps, in file internalUtils.R
syC <- paste(sys.calls())
The call stack includes the name of the temporary installation directory.
... " That code was shaky anyway so a complete rewrite was done;
Essentially what we do now is: we compute p(obj)(gaps) and check if any argument p of q(obj) falls within the gap range and then shift it to either the left or right endpoint of the gap acc. to args lower.tail and leftright. To avoid redoing this whenever slot gaps is changed, we store the unmodified q(obj) function in an internal variable ..q0fun which can also be used (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 it uses q(obj) and afterwords stores the old q(obj) as ..q0fun...
In this code we also spotted an error in Minimum(absCont,absCont) ...
Modified: branches/distr-2.8/pkg/distr/R/ContDistribution.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/ContDistribution.R 2019-02-22 15:52:46 UTC (rev 1291)
+++ branches/distr-2.8/pkg/distr/R/ContDistribution.R 2019-02-27 15:28:53 UTC (rev 1292)
@@ -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: branches/distr-2.8/pkg/distr/R/MinMaximum.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/MinMaximum.R 2019-02-22 15:52:46 UTC (rev 1291)
+++ branches/distr-2.8/pkg/distr/R/MinMaximum.R 2019-02-27 15:28:53 UTC (rev 1292)
@@ -19,7 +19,7 @@
p1 <- p(e1)(q, lower.tail = FALSE)
p2 <- p(e2)(q, lower.tail = FALSE)
p0 <- if(lower.tail) 1 - p1 * p2 else p1 * p2
- if (log.p) p0 <- log(p)
+ if (log.p) p0 <- log(p0)
return(p0)
}
Modified: branches/distr-2.8/pkg/distr/R/UnivarMixingDistribution.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/UnivarMixingDistribution.R 2019-02-22 15:52:46 UTC (rev 1291)
+++ branches/distr-2.8/pkg/distr/R/UnivarMixingDistribution.R 2019-02-27 15:28:53 UTC (rev 1292)
@@ -97,7 +97,7 @@
setMethod("q.r", signature(object = "UnivarMixingDistribution"),
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: branches/distr-2.8/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/internalUtils.R 2019-02-22 15:52:46 UTC (rev 1291)
+++ branches/distr-2.8/pkg/distr/R/internalUtils.R 2019-02-27 15:28:53 UTC (rev 1292)
@@ -1166,7 +1166,71 @@
# modify slot q for AbscontDistribution if there are gaps
#------------------------------------------------------------------------------
.modifyqgaps <- function(pfun, qfun, gaps, leftright = "left"){
+ ## no modification needed if gaps have no length
+
if(length(gaps)==0) return(qfun)
+ if(is.null(dim(gaps))) return(qfun)
+
+ finit <- apply(gaps, 1, function(x) all(is.finite(x)&is.numeric(x)))
+ if(sum(finit)==0) return(qfun)
+
+ 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)
+# print(lp.gaps)
+# print(lp.gaps.l)
+
+ ## are we heading for left or right continuous quantile fct?
+ lrpmatch <- pmatch(leftright, table = c("left","right"), nomatch = 1)
+
+ ## in order to avoid chaining of qgaps modifications:
+ ## place a variable ..q0fun into modified quantile function (after modification)
+ ## which stores the unmodified quantile function
+ ## in the first modification round ..q0fun will not yet exist
+ ## in this situation use qfun instead
+
+ qfunE <- environment(qfun)
+ qnew <- function(p, lower.tail = TRUE, log.p = FALSE) {}
+ qnewE <- environment(qnew) <- new.env()
+ body(qnew) <- substitute({
+ ## .q0fun is the (gaps-)unmodified quantile function
+ .q0fun <- if(exists("..q0fun", envir=qfunE.)){
+ get("..q0fun", envir=qfunE.) } else qfun.
+ q0 <- .q0fun(p, lower.tail = lower.tail, log.p = log.p)
+ ## the gaps-modification: find out which args p coincide
+ ## (numerically, on log scale) with gaps-plevels;
+ ## depending on "leftright" and lower.tail
+ ## set these return values to left or right endpoit of the gap
+ if(length(lp.gaps.)>0){
+ i0 <- seq(length=length(p))
+ lg <- round(3/2-(2*lower.tail-1)*(2*(lrpmatch.==1)-1)/2)
+ ## ==1 if(lower.tail&&leftright==1) or (!lower.tail&&leftright!=1)
+ ## and == 2 otherwise
+ lpgaps0 <- if(lg==1L) lp.gaps. else lp.gaps.l.
+ for(i in 1:nrow(lpgaps0)){
+ i0 <- (log(p)>=lpgaps0[i,1])&(log(p)<=lpgaps0[i,2])
+ if(length(i0)) q0[i0] <- gaps.[i,lg]
+ }
+ }
+ return(q0)
+ },list(qfunE. = qfunE, qfun.=qfun, lp.gaps.=lp.gaps,
+ lp.gaps.l. = lp.gaps.l[,2:1,drop=FALSE],
+ lrpmatch. = lrpmatch, gaps. = gaps, ..isEqual = .isEqual)
+ )
+ if(exists("..q0fun", envir=qfunE)){
+ .q0fun <- get("..q0fun", envir=qfunE)
+ assign("..q0fun", .q0fun, envir = qnewE)
+ }else{
+ assign("..q0fun", qfun, envir = qnewE)
+ }
+ return(qnew)
+}
+
+if(FALSE){ ## old code
+.modifyqgaps <- function(pfun, qfun, gaps, leftright = "left"){
+ if(length(gaps)==0) return(qfun)
p.gaps <- pfun(gaps[,1])
p.gaps.l <- pfun(gaps[,1], lower.tail = FALSE)
dP <- deparse(body(qfun))
@@ -1239,7 +1303,7 @@
}
return(qnew)
}
-
+}
#------------------------------------------------------------------------------
# issue warnings in show / print as to Arith or print
#------------------------------------------------------------------------------
Modified: branches/distr-2.8/pkg/distr/R/internalUtils_LCD.R
===================================================================
--- branches/distr-2.8/pkg/distr/R/internalUtils_LCD.R 2019-02-22 15:52:46 UTC (rev 1291)
+++ branches/distr-2.8/pkg/distr/R/internalUtils_LCD.R 2019-02-27 15:28:53 UTC (rev 1292)
@@ -175,9 +175,13 @@
px.l <- pnew(xseq, lower.tail = TRUE)
px.u <- pnew(xseq, lower.tail = FALSE)
qnew <- .makeQNew(xseq, px.l, px.u, TRUE, lo, up, Cont = Cont)
- if(!is.null(gaps))
+ if(!is.null(gaps)&&length(gaps)){
qnew <- .modifyqgaps(pfun = pnew, qfun = qnew, gaps = gaps,
leftright = leftright)
+ }else{
+ if(exists("..q0fun", envir=environment(qnew)))
+ qnew <- get("..q0fun", envir=environment(qnew))
+ }
return(qnew)
}
More information about the Distr-commits
mailing list