[Distr-commits] r1279 - in branches/distr-2.8/pkg/distrEx: R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Aug 16 10:00:51 CEST 2018
Author: ruckdeschel
Date: 2018-08-16 10:00:48 +0200 (Thu, 16 Aug 2018)
New Revision: 1279
Modified:
branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R
branches/distr-2.8/pkg/distrEx/R/sysdata.rda
branches/distr-2.8/pkg/distrEx/inst/NEWS
Log:
[distrEx] branch 2.8
+ .qtlIntegrate now uses smaller values for args subdivisions and order
in case partitioning into left/middle/right is used: they are multiplied
by factors fac.L/fac.R/fac.M according to
if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8}
if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8}
if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8}
if(!.withRightTail && !.withLeftTail){fac.M <- 1.0}
=> so at order 5000 we come up with orders in L/M/R of 500 / 4000 / 500
instead of 5000 / 5000 / 5000
+ additional .AW-grid values into sysdata.rda for orders
50, 400, 800, 4000, 8000, 40000, 80000
as these grid values are needed in the partitioned integration in
.qtlIntegrate
+ in addition grid value 100000 so far was not used as it is parsed to
.AW.1e5 instead to .AW.100000
+ code to produce the grid values .AW.xxx in sysdata.rda is now contained
in distrExIntegrate.R in an if(FALSE) { <block> }
extended NEWS on filtering to ::
+ introduced filter functions to warrant some safety that only those args from
"..." become arguments of the integrand, of distrExIntegrate, of E(),
of integrate, of GLIntegrate, of quantiles and IQR, which are within
the formals of the respective function...
as a consequence:
* functions with more than one formal argument have to have named
arguments, as these are then attached internally by name in wrapper functions;
CAVEAT: integrands of form function(x, ...) will no longer get their arguments
right -- this is intentional to safeguard against passing arguments to the
integrand that it cannot digest;
* For a call like E(distr, fun = myfun, ...), it is advisable to do something like
dotsFun <- .filterFunargs(list(...), myfun)
funwD <- function(x) do.call(fun,c(list(x), dotsFun))
dotsInt <- .filterEargs(list(...))
do.call(E, c(list(object = distr, fun = funwd), dotsInt))
to be on the safe side that both E() and myfun() obtain the correct
parts of "..."
Calls with E(distr, fun=myfun, cond = mycond, withCond = TRUE)
are automatically treated in a way s.t. they do not break existing code,
i.e., in case of random variables, argument "cond" is suitably attached
to argument "x" of the Map of the random variable -- something like c(x,cond)
Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-15 19:58:21 UTC (rev 1278)
+++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-16 08:00:48 UTC (rev 1279)
@@ -24,7 +24,6 @@
integrand <- function(x){ y <- ql(x)##quantile transformation
if(useApply){
funy <- sapply(y,funwD)
- # dim(y) <- di
dim(funy) <- dim(x)
}else funy <- fun(y)
return(funy) }
@@ -44,14 +43,23 @@
low.m <- low
upp.m <- upp
+ .order <- if(!is.null(dots$order)) dots$order else .distrExOptions$GLIntegrateOrder
+ .subdivisions <- if(!is.null(dots$subdivisions)) dots$subdivisions else 100
+ dots.withoutUseApply$order <- dots.withoutUseApply$subdivisions <- NULL
+
+ if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8}
+ if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8}
+ if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8}
+ if(!.withRightTail && !.withLeftTail){fac.M <- 1.0}
+
if(diagnostic) diagn <- list(call = mc)
if(.withRightTail){
upp.m <- min(upp,0.98)
if(upp>0.98){
intV.u <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = max(0.98,low),
- upper = upp,
+ lower = max(0.98,low), upper = upp,
+ order = fac.R * .order, subdivisions = fac.R * .subdivisions,
rel.tol = rel.tol, stop.on.error = FALSE,
distr = object, dfun = dunif, diagnostic = diagnostic), dots.withoutUseApply))
if(diagnostic) diagn$rightTail <- attr(intV.u,"diagnostic")
@@ -61,16 +69,16 @@
low.m <- max(low,0.02)
if(low<0.02){
intV.l <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = low,
- upper = min(0.02, upp),
+ lower = low, upper = min(0.02, upp),
+ order = fac.L * .order, subdivisions = fac.L * .subdivisions,
rel.tol = rel.tol, stop.on.error = FALSE,
distr = object, dfun = dunif), dots.withoutUseApply))
if(diagnostic) diagn$leftTail <- attr(intV.l,"diagnostic")
}
}
intV.m <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = low.m,
- upper = upp.m,
+ lower = low.m, upper = upp.m,
+ order = fac.M * .order, subdivisions = fac.M * .subdivisions,
rel.tol = rel.tol, stop.on.error = FALSE,
distr = object, dfun = dunif), dots.withoutUseApply))
if(diagnostic) diagn$main <- attr(intV.m,"diagnostic")
Modified: branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-15 19:58:21 UTC (rev 1278)
+++ branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-16 08:00:48 UTC (rev 1279)
@@ -55,8 +55,61 @@
}
+if(FALSE){
+# code to produce the AW values stored in the namespace of distrEx
+##
+
+## timing code borrowed from base::system.time
+
+ ppt <- function(y) {
+ if (!is.na(y[4L]))
+ y[1L] <- y[1L] + y[4L]
+ if (!is.na(y[5L]))
+ y[2L] <- y[2L] + y[5L]
+ paste(formatC(y[1L:3L]), collapse = " ")
+ }
+
+
+
+todo <- c(50, 100, 400, 500, 800, 1000, 4000, 5000, 8000, 10000, 40000, 50000, 80000, 100000)
+l <- length(todo)
+nE <- new.env()
+svncheckout <- "C:/rtest/distr"
+pkg <- file.path(svncheckout, "branches/distr-2.8/pkg/distrEx")
+sysdataFilename <- file.path(pkg, "R/sysdata.rda")
+load(sysdataFilename,envir=nE)
+
+gc()
+starttime <- proc.time()
+on.exit(message("Timing stopped at: ", ppt(proc.time() - starttime)))
+
+lasttime <- starttime
+for(gridsize.i in seq(todo)){
+ cat("Gridpoint i =", gridsize.i, ", order = ", todo[gridsize.i],", time needed: ")
+ res <- distrEx:::.GLaw(todo[gridsize.i])
+ newtime <- proc.time()
+ timN <- structure(newtime - lasttime, class = "proc_time")
+ lasttime <- newtime
+ cat(paste(round(timN,3)), "\n")
+ nam <- paste(".AW",as.character(todo[gridsize.i]), sep = ".")
+ assign(x=nam, value=res, envir=nE)
+}
+
+ timN <- structure(proc.time() - starttime, class = "proc_time")
+ cat("Time altogether:", paste(round(timN,3)), "\n")
+
+rm(".AW.100000", envir=nE)
+what <- ls(all=TRUE, env=nE)
+for(item in what) {cat(item, ":\n");print(object.size(get(item, envir=nE)))}
+on.exit()
+
+save(list=what,file=sysdataFilename,envir=nE)
+rm(nE)
+}
+
GLIntegrate <- function(f, lower, upper, order = 500, ...){
- if(order %in% c(100, 500, 1000, 5000, 10000, 50000, 100000))
+ if(order %in% c(50, 100, 400, 500, 800, 1000, 4000, 5000, 8000, 10000,
+ 40000, 50000, 80000, 100000))
AW <- getFromNamespace(paste(".AW", as.character(order),
sep = "."), ns = "distrEx")
else
Modified: branches/distr-2.8/pkg/distrEx/R/sysdata.rda
===================================================================
(Binary files differ)
Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS
===================================================================
--- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-15 19:58:21 UTC (rev 1278)
+++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-16 08:00:48 UTC (rev 1279)
@@ -38,7 +38,44 @@
"..." become arguments of the integrand, of distrExIntegrate, of E(),
of integrate, of GLIntegrate, of quantiles and IQR, which are within
the formals of the respective function...
-
+ as a consequence:
+ * functions with more than one formal argument have to have named
+ arguments, as these are then attached internally by name in wrapper functions;
+ CAVEAT: integrands of form function(x, ...) will no longer get their arguments
+ right -- this is intentional to safeguard against passing arguments to the
+ integrand that it cannot digest;
+ * For a call like E(distr, fun = myfun, ...), it is advisable to do something like
+
+ dotsFun <- .filterFunargs(list(...), myfun)
+ funwD <- function(x) do.call(fun,c(list(x), dotsFun))
+ dotsInt <- .filterEargs(list(...))
+ do.call(E, c(list(object = distr, fun = funwd), dotsInt))
+
+ to be on the safe side that both E() and myfun() obtain the correct
+ parts of "..."
+
+ Calls with E(distr, fun=myfun, cond = mycond, withCond = TRUE)
+ are automatically treated in a way s.t. they do not break existing code,
+ i.e., in case of random variables, argument "cond" is suitably attached
+ to argument "x" of the Map of the random variable -- something like c(x,cond)
+
++ .qtlIntegrate now uses smaller values for args subdivisions and order
+ in case partitioning into left/middle/right is used: they are multiplied
+ by factors fac.L/fac.R/fac.M according to
+ if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8}
+ if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8}
+ if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8}
+ if(!.withRightTail && !.withLeftTail){fac.M <- 1.0}
+ => so at order 5000 we come up with orders in L/M/R of 500 / 4000 / 500
+ instead of 5000 / 5000 / 5000
++ additional .AW-grid values into sysdata.rda for orders
+ 50, 400, 800, 4000, 8000, 40000, 80000
+ as these grid values are needed in the partitioned integration in
+ .qtlIntegrate
++ in addition grid value 100000 so far was not used as it is parsed to
+ .AW.1e5 instead to .AW.100000
++ code to produce the grid values .AW.xxx in sysdata.rda is now contained
+ in distrExIntegrate.R in an if(FALSE) { <block> }
##############
v 2.7
##############
More information about the Distr-commits
mailing list