[Distr-commits] r1241 - in branches/distr-2.8/pkg/distrEx: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Aug 5 17:46:35 CEST 2018
Author: ruckdeschel
Date: 2018-08-05 17:46:35 +0200 (Sun, 05 Aug 2018)
New Revision: 1241
Added:
branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
Modified:
branches/distr-2.8/pkg/distrEx/NAMESPACE
branches/distr-2.8/pkg/distrEx/R/Expectation.R
branches/distr-2.8/pkg/distrEx/inst/NEWS
branches/distr-2.8/pkg/distrEx/man/E.Rd
Log:
[distrEx] branch 2.8:
+ introduce exported helper function .qtlIntegrate to achieve this
(is reused in RobExtremes for the GEV methods there)
+ cleaned .Rd file E.Rd: It contained still some references to methods
for extreme value distributions which are now in RobExtremes
and some old mail reference peter.ruckdeschel at uni-bayreuth.de
Modified: branches/distr-2.8/pkg/distrEx/NAMESPACE
===================================================================
--- branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-04 14:01:53 UTC (rev 1240)
+++ branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-05 15:46:35 UTC (rev 1241)
@@ -1,7 +1,7 @@
useDynLib("distrEx", .registration = TRUE, .fixes = "C_")
importFrom("stats", "dnorm", "integrate", "optimize", "pbinom",
"pchisq", "pexp", "pnorm", "ppois", "qcauchy", "qnorm",
- "uniroot")
+ "uniroot", "dunif")
importFrom("utils", "getFromNamespace")
import("methods")
import("distr")
@@ -53,4 +53,4 @@
"distrExMASK", "distrExoptions", "distrExMOVED")
export("make01","PrognCondDistribution",
"PrognCondition")
-export(".getIntbounds")
+export(".getIntbounds", ".qtlIntegrate")
Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-04 14:01:53 UTC (rev 1240)
+++ branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-05 15:46:35 UTC (rev 1241)
@@ -591,49 +591,52 @@
### source https://mathworld.wolfram.com/GammaDistribution.html
-setMethod("E", signature(object = "Gammad",
- fun = "function",
- cond = "missing"),
- function(object, fun, low = NULL, upp = NULL,
- rel.tol= getdistrExOption("ErelativeTolerance"),
- lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
- upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
- IQR.fac = getdistrExOption("IQR.fac"), ...
- ){
+## replaced by quantile method in file GammaWeibullExpectation.R from distrEx 2.8.0
+# on
+#
+#setMethod("E", signature(object = "Gammad",
+# fun = "function",
+# cond = "missing"),
+# function(object, fun, low = NULL, upp = NULL,
+# rel.tol= getdistrExOption("ErelativeTolerance"),
+# lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+# upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+# IQR.fac = getdistrExOption("IQR.fac"), ...
+# ){
+#
+# dots <- list(...)
+# dots.withoutUseApply <- dots
+# useApply <- TRUE
+# if(!is.null(dots$useApply)) useApply <- dots$useApply
+# dots.withoutUseApply$useApply <- NULL
+# integrand <- function(x, dfun, ...){ di <- dim(x)
+# y <- exp(x)
+# if(useApply){
+# funy <- sapply(y,fun, ...)
+# dim(y) <- di
+# dim(funy) <- di
+# }else funy <- fun(y,...)
+# return(funy * y * dfun(y)) }
+#
+# if(is.null(low)) low <- -Inf
+# if(is.null(upp)) upp <- Inf
+#
+# Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile,
+# upperTruncQuantile, IQR.fac)
+# low <- if(Ib["low"]<=0) -Inf else log(Ib["low"])
+# upp <- log(Ib["upp"])
+#
+# return(do.call(distrExIntegrate, c(list(f = integrand,
+# lower = low,
+# upper = upp,
+# rel.tol = rel.tol,
+# distr = object, dfun = d(object)), dots.withoutUseApply)))
+#
+# })
- dots <- list(...)
- dots.withoutUseApply <- dots
- useApply <- TRUE
- if(!is.null(dots$useApply)) useApply <- dots$useApply
- dots.withoutUseApply$useApply <- NULL
- integrand <- function(x, dfun, ...){ di <- dim(x)
- y <- exp(x)
- if(useApply){
- funy <- sapply(y,fun, ...)
- dim(y) <- di
- dim(funy) <- di
- }else funy <- fun(y,...)
- return(funy * y * dfun(y)) }
- if(is.null(low)) low <- -Inf
- if(is.null(upp)) upp <- Inf
-
- Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile,
- upperTruncQuantile, IQR.fac)
- low <- if(Ib["low"]<=0) -Inf else log(Ib["low"])
- upp <- log(Ib["upp"])
-
- return(do.call(distrExIntegrate, c(list(f = integrand,
- lower = low,
- upper = upp,
- rel.tol = rel.tol,
- distr = object, dfun = d(object)), dots.withoutUseApply)))
-
- })
-
-
-setMethod("E", signature(object = "Geom",
- fun = "missing",
+setMethod("E", signature(object = "Geom",
+ fun = "missing",
cond = "missing"),
function(object, low = NULL, upp = NULL, ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
Added: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R (rev 0)
+++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-05 15:46:35 UTC (rev 1241)
@@ -0,0 +1,100 @@
+## taken from RobExtremes (slightly modified) as of version 2.8.0
+
+.qtlIntegrate <- function(object, fun, low = NULL, upp = NULL,
+ rel.tol= getdistrExOption("ErelativeTolerance"),
+ lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...,
+ .withLeftTail = FALSE, .withRightTail = FALSE
+ ){
+
+ dots <- list(...)
+ dots.withoutUseApply <- dots
+ useApply <- TRUE
+ if(!is.null(dots$useApply)) useApply <- dots$useApply
+
+ dots.withoutUseApply$useApply <- NULL
+ dots.withoutUseApply$stop.on.error <- NULL
+
+ integrand <- function(x, dfun, ...){ di <- dim(x)
+ y <- q.l(object)(x)##quantile transformation
+ if(useApply){
+ funy <- sapply(y,fun, ...)
+ dim(y) <- di
+ dim(funy) <- di
+ }else funy <- fun(y,...)
+ return(funy) }
+
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+
+ Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile,
+ upperTruncQuantile, IQR.fac)
+ low <- p(object)(Ib["low"])
+ upp <- p(object)(Ib["upp"])
+ if(is.nan(low)) low <- 0
+ if(is.nan(upp)) upp <- 1
+
+ intV.l <- intV.u <- 0
+ low.m <- low
+ upp.m <- upp
+
+ if(.withRightTail){
+ upp.m <- min(upp,0.98)
+ if(upp>0.98){
+ intV.u <- do.call(distrExIntegrate, c(list(f = integrand,
+ lower = 0.98,
+ upper = upp,
+ rel.tol = rel.tol, stop.on.error = FALSE,
+ distr = object, dfun = dunif), dots.withoutUseApply))
+ }
+ }
+ if(.withLeftTail){
+ low.m <- max(low,0.02)
+ if(low<0.02){
+ intV.l <- do.call(distrExIntegrate, c(list(f = integrand,
+ lower = low,
+ upper = 0.02,
+ rel.tol = rel.tol, stop.on.error = FALSE,
+ distr = object, dfun = dunif), dots.withoutUseApply))
+ }
+ }
+ intV.m <- do.call(distrExIntegrate, c(list(f = integrand,
+ lower = low.m,
+ upper = upp.m,
+ rel.tol = rel.tol, stop.on.error = FALSE,
+ distr = object, dfun = dunif), dots.withoutUseApply))
+
+ int <- intV.l+intV.m+intV.u
+
+ return(int)
+
+ }
+
+setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"),
+ function(object, fun, low = NULL, upp = NULL,
+ rel.tol= getdistrExOption("ErelativeTolerance"),
+ lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...
+ ){
+ .qtlIntegrate(object = object, fun = fun, low = low, upp = upp,
+ rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile,
+ upperTruncQuantile = upperTruncQuantile,
+ IQR.fac = IQR.fac, ...,
+ .withLeftTail = FALSE, .withRightTail = TRUE)
+ })
+
+setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"),
+ function(object, fun, low = NULL, upp = NULL,
+ rel.tol= getdistrExOption("ErelativeTolerance"),
+ lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...
+ ){
+ .qtlIntegrate(object = object, fun = fun, low = low, upp = upp,
+ rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile,
+ upperTruncQuantile = upperTruncQuantile,
+ IQR.fac = IQR.fac, ...,
+ .withLeftTail = TRUE, .withRightTail = TRUE)
+ })
Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS
===================================================================
--- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-04 14:01:53 UTC (rev 1240)
+++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-05 15:46:35 UTC (rev 1241)
@@ -14,6 +14,15 @@
user-visible CHANGES:
+ DESCRIPTION tag SVNRevision changed to VCS/SVNRevision
+under the hood:
++ moved quantile integration methods for expectation for Weibull and
+ Gamma distribution from pkg RobExtremes to distrEx
++ introduce exported helper function .qtlIntegrate to achieve this
+ (is reused in RobExtremes for the GEV methods there)
++ cleaned .Rd file E.Rd: It contained still some references to methods
+ for extreme value distributions which are now in RobExtremes
+ and some old mail reference peter.ruckdeschel at uni-bayreuth.de
+
##############
v 2.7
##############
Modified: branches/distr-2.8/pkg/distrEx/man/E.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-04 14:01:53 UTC (rev 1240)
+++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-05 15:46:35 UTC (rev 1241)
@@ -44,23 +44,25 @@
\alias{E,Exp,missing,missing-method}
\alias{E,Fd,missing,missing-method}
\alias{E,Gammad,missing,missing-method}
-\alias{E,Gammad,function,missing-method}
\alias{E,Geom,missing,missing-method}
\alias{E,Gumbel,missing,missing-method}
-\alias{E,GPareto,missing,missing-method}
-\alias{E,GPareto,function,missing-method}
-\alias{E,GEV,missing,missing-method}
-\alias{E,GEV,function,missing-method}
+%\alias{E,GPareto,missing,missing-method}
+%\alias{E,GPareto,function,missing-method}
+%\alias{E,GEV,missing,missing-method}
+%\alias{E,GEV,function,missing-method}
\alias{E,Hyper,missing,missing-method}
\alias{E,Logis,missing,missing-method}
\alias{E,Lnorm,missing,missing-method}
\alias{E,Nbinom,missing,missing-method}
\alias{E,Norm,missing,missing-method}
-\alias{E,Pareto,missing,missing-method}
+%\alias{E,Pareto,missing,missing-method}
\alias{E,Pois,missing,missing-method}
\alias{E,Td,missing,missing-method}
\alias{E,Unif,missing,missing-method}
\alias{E,Weibull,missing,missing-method}
+\alias{E,Gammad,function,missing-method}
+\alias{E,Weibull,function,missing-method}
+\alias{.qtlIntegrate}
\title{Generic Function for the Computation of (Conditional) Expectations}
\description{
@@ -202,26 +204,36 @@
rel.tol = getdistrExOption("ErelativeTolerance"),
lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
- IQR.fac = getdistrExOption("IQR.fac"), ...)
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...)
\S4method{E}{Geom,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Gumbel,missing,missing}(object, low = NULL, upp = NULL, ...)
-\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ...)
-\S4method{E}{GPareto,function,missing}(object, fun, low = NULL, upp = NULL,
- rel.tol = getdistrExOption("ErelativeTolerance"),
- lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
- upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
- IQR.fac = max(10000, getdistrExOption("IQR.fac")), ...)
+%\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ...)
+%\S4method{E}{GPareto,function,missing}(object, fun, low = NULL, upp = NULL,
+% rel.tol = getdistrExOption("ErelativeTolerance"),
+% lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+% upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+% IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...)
\S4method{E}{Hyper,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Logis,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Lnorm,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Nbinom,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Norm,missing,missing}(object, low = NULL, upp = NULL, ...)
-\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ...)
+%\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Pois,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Unif,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Td,missing,missing}(object, low = NULL, upp = NULL, ...)
\S4method{E}{Weibull,missing,missing}(object, low = NULL, upp = NULL, ...)
-
+\S4method{E}{Weibull,function,missing}(object, fun, low = NULL, upp = NULL,
+ rel.tol = getdistrExOption("ErelativeTolerance"),
+ lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...)
+.qtlIntegrate(object, fun, low = NULL, upp = NULL,
+ rel.tol= getdistrExOption("ErelativeTolerance"),
+ lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
+ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...,
+ .withLeftTail = FALSE, .withRightTail = FALSE)
}
\arguments{
\item{object}{ object of class \code{"Distribution"}}
@@ -241,6 +253,10 @@
\item{useApply}{ logical: should \code{sapply}, respectively \code{apply}
be used to evaluate \code{fun}. }
\item{withCond}{ logical: is \code{cond} in the argument list of \code{fun}. }
+ \item{.withLeftTail}{ logical: should left tail (falling into quantile range [0,0.02])
+ be computed separately to enhance accuracy? }
+ \item{.withRightTail}{ logical: should right tail (falling into quantile range [0.98,1])
+ be computed separately to enhance accuracy? }
}
\details{The precision of the computations can be controlled via
certain global options; cf. \code{\link{distrExOptions}}.
@@ -249,8 +265,16 @@
\code{fun} or \code{cond}. Also the result, when arguments
\code{low} or \code{upp} is given, is the \emph{unconditional value} of the
expectation; no conditioning with respect to \code{low <= object <= upp}
- is done.}
+ is done.
+ For the Gamma and Weibull distribution for integration with missing argument
+ \code{cond} but given argument \code{fun}, we use integration on [0,1]
+ (i.e, via the respective probability transformation). This done via helper
+ function \code{.qtlIntegrate}, where both arguments \code{.withLeftTail}
+ and \code{.withRightTail} are \code{TRUE} for the Gamma distribution,
+ and only \code{.withRightTail} ist \code{TRUE} for the Weibull distribution.
+ }
+
\value{
The (conditional) expectation is computed.
}
@@ -401,15 +425,16 @@
\item{object = "Gammad", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
\item{object = "Gammad", fun = "function", cond = "missing":}{
- use substitution method (y := log(x)) for numerical integration.}
+ use integration over the quantile range for numerical integration
+ via helper function \code{.qtlIntegrate}.}
\item{object = "Geom", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
\item{object = "Gumbel", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
- \item{object = "GPareto", fun = "missing", cond = "missing":}{
- exact evaluation using explicit expressions.}
- \item{object = "GPareto", fun = "function", cond = "missing":}{
- use substitution method (y := log(x)) for numerical integration.}
+% \item{object = "GPareto", fun = "missing", cond = "missing":}{
+% exact evaluation using explicit expressions.}
+% \item{object = "GPareto", fun = "function", cond = "missing":}{
+% use substitution method (y := log(x)) for numerical integration.}
\item{object = "Hyper", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
\item{object = "Logis", fun = "missing", cond = "missing":}{
@@ -420,8 +445,8 @@
exact evaluation using explicit expressions.}
\item{object = "Norm", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
- \item{object = "Pareto", fun = "missing", cond = "missing":}{
- exact evaluation using explicit expressions.}
+% \item{object = "Pareto", fun = "missing", cond = "missing":}{
+% exact evaluation using explicit expressions.}
\item{object = "Pois", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
\item{object = "Unif", fun = "missing", cond = "missing":}{
@@ -430,9 +455,12 @@
exact evaluation using explicit expressions.}
\item{object = "Weibull", fun = "missing", cond = "missing":}{
exact evaluation using explicit expressions.}
+ \item{object = "Weibull", fun = "function", cond = "missing":}{
+ use integration over the quantile range for numerical integration
+ via helper function \code{.qtlIntegrate}.}
}}
%\references{ ~put references to the literature/web site here ~ }
-\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-bayreuth.de}}
+\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de}}
%\note{ ~~further notes~~ }
\seealso{\code{\link{distrExIntegrate}}, \code{\link{m1df}}, \code{\link{m2df}},
\code{\link[distr]{Distribution-class}}}
More information about the Distr-commits
mailing list