[Distr-commits] r430 - branches/distr-2.2/pkg/distrEx/R branches/distr-2.2/pkg/distrEx/man pkg/distrEx/R pkg/distrEx/chm pkg/distrEx/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Mar 23 14:49:23 CET 2009
Author: ruckdeschel
Date: 2009-03-23 14:49:20 +0100 (Mon, 23 Mar 2009)
New Revision: 430
Added:
branches/distr-2.2/pkg/distrEx/man/distrExConstants.Rd
Modified:
branches/distr-2.2/pkg/distrEx/R/AllGeneric.R
branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
branches/distr-2.2/pkg/distrEx/R/Expectation.R
branches/distr-2.2/pkg/distrEx/man/E.Rd
branches/distr-2.2/pkg/distrEx/man/m1df.Rd
branches/distr-2.2/pkg/distrEx/man/m2df.Rd
pkg/distrEx/R/AllGeneric.R
pkg/distrEx/R/ClippedMoments.R
pkg/distrEx/R/Expectation.R
pkg/distrEx/chm/00Index.html
pkg/distrEx/chm/E.html
pkg/distrEx/chm/distrEx.chm
pkg/distrEx/chm/distrEx.toc
pkg/distrEx/chm/m1df.html
pkg/distrEx/chm/m2df.html
pkg/distrEx/man/E.Rd
pkg/distrEx/man/m1df.Rd
pkg/distrEx/man/m2df.Rd
Log:
+ forgot to commit branches/distr-2.2/pkg/distrEx/man/distrExConstants.Rd
+ m1df, m2df gain ... argument to be able to pass on accuracy arguments to E();
+ m1df, m2df can now digest cond, fun arguments...
+ particular m1df versions (for Binom, Norm, Chisq, Exp, Pois)
are used in E(object, [fun, cond, ] low=.., upp=.., ...) calls
Modified: branches/distr-2.2/pkg/distrEx/R/AllGeneric.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/AllGeneric.R 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/R/AllGeneric.R 2009-03-23 13:49:20 UTC (rev 430)
@@ -151,10 +151,10 @@
}
if(!isGeneric("m1df")){
- setGeneric("m1df", function(object, upper) standardGeneric("m1df"))
+ setGeneric("m1df", function(object, upper, ...) standardGeneric("m1df"))
}
if(!isGeneric("m2df")){
- setGeneric("m2df", function(object, upper) standardGeneric("m2df"))
+ setGeneric("m2df", function(object, upper, ...) standardGeneric("m2df"))
}
#if(!isGeneric("illustrateCLT")){
Modified: branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-03-23 13:49:20 UTC (rev 430)
@@ -2,72 +2,96 @@
## Clipped first and second moments
###############################################################################
setMethod("m1df", "UnivariateDistribution",
- function(object, upper){
- x <- r(object)(.distrExOptions$MCIterations)
- return(mean(x*(x<=upper)))
+ function(object, upper, ...){
+ return(E(object, upp=upper,...))
})
setMethod("m2df", "UnivariateDistribution",
- function(object, upper){
- x <- r(object)(.distrExOptions$MCIterations)
- return(mean(x^2*(x<=upper)))
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc1 <- mc
+ fun0 <- if(is.null(mc$fun))
+ function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
+ mc$fun <- fun0
+ mc$upper <- NULL
+ mc$upp <- upper
+ return(do.call("E", args=mc ))
})
-setMethod("m1df", "AbscontDistribution",
- function(object, upper){
- integrandm1 <- function(x, dfun){ x * dfun(x) }
- return(distrExIntegrate(integrandm1, lower = q(object)(.distrExOptions$m1dfLowerTruncQuantile),
- rel.tol = .distrExOptions$m1dfRelativeTolerance, upper = upper, dfun = d(object),
- distr = object))
- })
-setMethod("m2df", "AbscontDistribution",
- function(object, upper){
- integrandm2 <- function(x, dfun){ x^2 * dfun(x) }
- return(distrExIntegrate(integrandm2, lower = q(object)(.distrExOptions$m2dfLowerTruncQuantile),
- rel.tol = .distrExOptions$m2dfRelativeTolerance, upper = upper, dfun = d(object),
- distr = object))
- })
-setMethod("m1df", "DiscreteDistribution",
- function(object, upper){
- supp <- support(object)
- supp <- supp[supp <= upper]
- dfun <- d(object)
- return(sum(supp * dfun(supp)))
- })
-setMethod("m2df", "DiscreteDistribution",
- function(object, upper){
- supp <- support(object)
- supp <- supp[supp <= upper]
- dfun <- d(object)
- return(sum(supp^2 * dfun(supp)))
- })
+#setMethod("m1df", "AbscontDistribution",
+# function(object, upper, ...){
+# integrandm1 <- function(x, dfun){ x * dfun(x) }
+# return(distrExIntegrate(integrandm1, lower = q(object)(.distrExOptions$m1dfLowerTruncQuantile),
+# rel.tol = .distrExOptions$m1dfRelativeTolerance, upper = upper, dfun = d(object),
+# distr = object))
+# })
+#setMethod("m2df", "AbscontDistribution",
+# function(object, upper, ...){
+# integrandm2 <- function(x, dfun){ x^2 * dfun(x) }
+# return(distrExIntegrate(integrandm2, lower = q(object)(.distrExOptions$m2dfLowerTruncQuantile),
+# rel.tol = .distrExOptions$m2dfRelativeTolerance, upper = upper, dfun = d(object),
+# distr = object))
+# })
+#setMethod("m1df", "DiscreteDistribution",
+# function(object, upper, ...){
+# supp <- support(object)
+# supp <- supp[supp <= upper]
+# dfun <- d(object)
+# return(sum(supp * dfun(supp)))
+# })
+#setMethod("m2df", "DiscreteDistribution",
+# function(object, upper, ...){
+# supp <- support(object)
+# supp <- supp[supp <= upper]
+# dfun <- d(object)
+# return(sum(supp^2 * dfun(supp)))
+# })
+
setMethod("m1df", "Binom",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond))
return(prob(object)*size(object)*pbinom(upper-1, prob = prob(object),
size = size(object)-1))
+ else m1df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
+
setMethod("m2df", "Binom",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
n <- size(object)
p <- prob(object)
return(n*p*(pbinom(upper-1, prob = p, size = n-1)
+ p*(n-1)*pbinom(upper-2, prob = p, size = n-2)))
+ }else m2df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m1df", "Pois",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
return(lambda(object)*ppois(upper-1, lambda = lambda(object)))
+ }else m1df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m2df", "Pois",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
lam <- lambda(object)
return(lam*(ppois(upper-1, lambda = lam) + lam*ppois(upper-2, lambda = lam)))
+ }else m2df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m1df", "Norm",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
return(mu*pnorm((upper-mu)/std) - std*dnorm((upper-mu)/std))
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Norm",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
if(abs(pnorm((upper-mu)/std)-1) > .Machine$double.eps)
@@ -75,61 +99,84 @@
- std*(upper + mu)*dnorm((upper-mu)/std))
else
return(mu^2+std^2)
- })
+ }else m2df(as(object,"AbscontDistribution"), upper = upper, ...)
+ })
setMethod("m1df", "Exp",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
- if(abs(pexp(lam*upper)-1) > .Machine$double.eps)
- return(pexp(lam*upper)/lam - upper*exp(-lam*upper))
+ if(abs(pexp(lam*upper, ...)-1) > .Machine$double.eps)
+ return(pexp(lam*upper, ...)/lam - upper*exp(-lam*upper, ...))
else
return(1/lam)
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Exp",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
- if(abs(pexp(lam*upper)-1) > .Machine$double.eps)
- return(2*pexp(lam*upper)/lam^2
- - (upper + 2/lam)*upper*exp(-lam*upper))
+ if(abs(pexp(lam*upper, ...)-1) > .Machine$double.eps)
+ return(2*pexp(lam*upper, ...)/lam^2
+ - (upper + 2/lam)*upper*exp(-lam*upper, ...))
else
return(2/lam^2)
+ }else m2df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m1df", "Chisq",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
+ dfr <- df(object)
if(ncp != 0)
- if(abs(p(object)(upper)-1) > .Machine$double.eps)
- return(m1df(as(object, "AbscontDistribution"), upper))
+ if(abs(p(object)(upper, ...)-1) > .Machine$double.eps)
+ return(m1df(as(object, "AbscontDistribution"), upper = upper, ...))
else
return(dfr + ncp)
- dfr <- df(object)
return(dfr*pchisq(upper, df = (dfr+2)))
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Chisq",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
- if(ncp != 0)
- if(abs(p(object)(upper)-1) > .Machine$double.eps)
- return(m2df(as(object, "AbscontDistribution"), upper))
+ dfr <- df(object)
+ if(ncp != 0){
+ if(abs(p(object)(upper, ...)-1) > .Machine$double.eps)
+ return(m2df(as(object, "AbscontDistribution"),
+ upper = upper, ...))
else
return(dfr^2 + 2*dfr*(ncp+1) + ncp*(ncp + 4))
- dfr <- df(object)
+ }
return(dfr*(dfr+2)*pchisq(upper, df = (dfr+4)))
+ }else m2df(as(object,"AbscontDistribution"), upper = upper, ...)
})
+#setMethod("m1df", "LatticeDistribution",
+# function(object, upper, ...){
+# getMethod("m1df", "DiscreteDistribution")(
+# as(object, "DiscreteDistribution"), upper, ...)
+# })
+#setMethod("m2df", "LatticeDistribution",
+# function(object, upper, ...){
+# getMethod("m2df", "DiscreteDistribution")(
+# as(object, "DiscreteDistribution"), upper, ...)
+# })
setMethod("m1df", "LatticeDistribution",
- function(object, upper){
- getMethod("m1df", "DiscreteDistribution")(
- as(object, "DiscreteDistribution"), upper)
+ function(object, upper, ...){
+ E(as(object, "DiscreteDistribution"), upp = upper, ...)
})
setMethod("m2df", "LatticeDistribution",
- function(object, upper){
- getMethod("m2df", "DiscreteDistribution")(
- as(object, "DiscreteDistribution"), upper)
+ function(object, upper, ...){
+ E(as(object, "DiscreteDistribution"), fun=function(x)x^2, upp = upper, ...)
})
setMethod("m1df", "AffLinDistribution",
- function(object, upper){
+ function(object, upper, ...){
a <- object at a
b <- object at b
if(a>0)
Modified: branches/distr-2.2/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/Expectation.R 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/R/Expectation.R 2009-03-23 13:49:20 UTC (rev 430)
@@ -391,9 +391,20 @@
function(object, low = NULL, upp = NULL,...){
if(is.null(low) && is.null(upp))
return(mean(object))
- else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
- })
+ else{
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+ if(low == -Inf){
+ if(upp == Inf) return(mean(object))
+ else return(m1df(object, upper = upp, ...))
+ }else{
+ E1 <- -m1df(object, upper = low, ...)
+ E2 <- if(upp == Inf)
+ mean(object) else m1df(object, upper = upp, ...)
+ return(E2-E1)
+ }
+ }
+ })
setMethod("E", signature(object = "Beta",
fun = "missing",
@@ -415,9 +426,20 @@
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
if(is.null(low) && is.null(upp))
return(size(object)*prob(object))
- else
- return(E(as(object,"DiscreteDistribution"), low, up, ...))
- })
+ else{
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+ if(low == -Inf){
+ if(upp == Inf) return(size(object)*prob(object))
+ else return(m1df(object, upper = upp, ...))
+ }else{
+ E1 <- -m1df(object, upper = low, ...)
+ E2 <- if(upp == Inf)
+ size(object)*prob(object) else m1df(object, upper = upp, ...)
+ return(E2-E1)
+ }
+ }
+ })
setMethod("E", signature(object = "Cauchy",
fun = "missing",
@@ -425,9 +447,21 @@
function(object, low = NULL, upp = NULL, ...){
if(is.null(low) && is.null(upp))
return(NA)
- else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
- })
+ else{
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+ if(low == -Inf){
+ if(upp == Inf) return(NA)
+ else return(-Inf)
+ }else{
+ E1 <- -m1df(object, upper = low, ...)
+ E2 <- if(upp == Inf)
+ Inf else m1df(object, upper = upp, ...)
+ return(E2-E1)
+ }
+ }
+# return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
+ })
setMethod("E", signature(object = "Chisq",
fun = "missing",
@@ -436,9 +470,20 @@
if(!is.null(low)) if(low <= 0) low <- NULL
if(is.null(low) && is.null(upp))
return(df(object)+ncp(object))
- else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
- })
+ else{
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+ if(low == -Inf){
+ if(upp == Inf) return(df(object)+ncp(object))
+ else return(m1df(object, upper = upp, ...))
+ }else{
+ E1 <- -m1df(object, upper = low, ...)
+ E2 <- if(upp == Inf)
+ df(object)+ncp(object) else m1df(object, upper = upp, ...)
+ return(E2-E1)
+ }
+ }
+ })
setMethod("E", signature(object = "Dirac",
fun = "missing",
@@ -470,9 +515,20 @@
if(!is.null(low)) if(low <= 0) low <- NULL
if(is.null(low) && is.null(upp))
return(1/rate(object))
- else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
- })
+ else{
+ if(is.null(low)) low <- -Inf
+ if(is.null(upp)) upp <- Inf
+ if(low == -Inf){
+ if(upp == Inf) return(1/rate(object))
+ else return(m1df(object, upper = upp, ...))
+ }else{
+ E1 <- -m1df(object, upper = low, ...)
+ E2 <- if(upp == Inf)
+ 1/rate(object) else m1df(object, upper = upp, ...)
+ return(E2-E1)
+ }
+ }
+ })
setMethod("E", signature(object = "Fd",
@@ -510,7 +566,7 @@
if(is.null(low) && is.null(upp))
return(1/ prob(object) -1)
else
- return(E(as(object,"DiscreteDistribution"), low, up, ...))
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
})
setMethod("E", signature(object = "Hyper",
@@ -522,7 +578,7 @@
if(is.null(low) && is.null(upp))
return(k(object)*m(object)/(m(object)+n(object)))
else
- return(E(as(object,"DiscreteDistribution"), low, up, ...))
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
})
setMethod("E", signature(object = "Logis",
@@ -555,7 +611,7 @@
if(is.null(low) && is.null(upp))
return(size(object)*(1-prob(object))/prob(object))
else
- return(E(as(object,"DiscreteDistribution"), low, up, ...))
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
})
setMethod("E", signature(object = "Pois",
@@ -567,7 +623,7 @@
if(is.null(low) && is.null(upp))
return(lambda(object))
else
- return(E(as(object,"DiscreteDistribution"), low, up, ...))
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
})
setMethod("E", signature(object = "Td",
Modified: branches/distr-2.2/pkg/distrEx/man/E.Rd
===================================================================
--- branches/distr-2.2/pkg/distrEx/man/E.Rd 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/man/E.Rd 2009-03-23 13:49:20 UTC (rev 430)
@@ -191,7 +191,14 @@
\item{withCond}{ logical: is \code{cond} in the argument list of \code{fun}. }
}
\details{The precision of the computations can be controlled via
- certain global options; cf. \code{\link{distrExOptions}}. }
+ certain global options; cf. \code{\link{distrExOptions}}.
+ Also note that arguments \code{low} and \code{upp} should be given as
+ named arguments in order to prevent them to be matched by arguments
+ \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.}
+
\value{
The (conditional) expectation is computed.
}
@@ -389,6 +396,22 @@
E(D1, function(x, cond){cond*x^2}, cond = 2, withCond = TRUE, useApply = FALSE)
E(Norm(mean=2), function(x){2*x^2})
+E(as(Norm(mean=2),"AbscontDistribution"))
+### somewhat less accurate:
+E(as(Norm(mean=2),"AbscontDistribution"),
+ lowerTruncQuantil=1e-4,upperTruncQuantil=1e-4, IQR.fac= 4)
+### even less accurate:
+E(as(Norm(mean=2),"AbscontDistribution"),
+ lowerTruncQuantil=1e-2,upperTruncQuantil=1e-2, IQR.fac= 4)
+### no good idea, but just as an example:
+E(as(Norm(mean=2),"AbscontDistribution"),
+ lowerTruncQuantil=1e-2,upperTruncQuantil=1e-2, IQR.fac= .1)
+
+### truncation of integration range; see also m1df...
+E(Norm(mean=2), low=2,upp=4)
+
+E(Cauchy())
+E(Cauchy(),upp=3,low=-2)
# some Lebesgue decomposed distribution
mymix <- UnivarLebDecDistribution(acPart = Norm(), discretePart = Binom(4,.4),
acWeight = 0.4)
Added: branches/distr-2.2/pkg/distrEx/man/distrExConstants.Rd
===================================================================
--- branches/distr-2.2/pkg/distrEx/man/distrExConstants.Rd (rev 0)
+++ branches/distr-2.2/pkg/distrEx/man/distrExConstants.Rd 2009-03-23 13:49:20 UTC (rev 430)
@@ -0,0 +1,34 @@
+\name{distrExConstants}
+\alias{EULERMASCHERONICONSTANT}
+\alias{APERYCONSTANT}
+\encoding{latin1}
+\title{Built-in Constants in package distrEx}
+\description{
+ Constants built into \pkg{distrEx}.
+}
+\usage{
+EULERMASCHERONICONSTANT
+APERYCONSTANT
+}
+\details{
+ \pkg{distrEx} has a small number of built-in constants.
+
+ The following constants are available:
+ \itemize{
+ \item \code{EULERMASCHERONICONSTANT}: the Euler Mascheroni constant
+ \deqn{\gamma=-\Gamma'(1)}{gamma=-digamma(1)}
+ given in \url{http://mathworld.wolfram.com/Euler-MascheroniConstant.html} (48);
+ \item \code{APERYCONSTANT}: the \enc{Apéry}{Apery} constant
+ \deqn{\zeta(3)= \frac{5}{2} (\sum_{k\ge 1}\frac{(-1)^{k-1}}{k^3 {2k\choose k}})}%
+ {zeta(3)=5/2 sum_{k>=0} (-1)^(k-1)/(k^3 * choose(2k,k))}
+ as given in \url{http://mathworld.wolfram.com/AperysConstant.html}, equation (8);
+ }
+
+ These are implemented as variables in the \pkg{distrEx} name space taking
+ appropriate values.
+}
+\examples{
+EULERMASCHERONICONSTANT
+APERYCONSTANT
+}
+\keyword{sysdata}
Modified: branches/distr-2.2/pkg/distrEx/man/m1df.Rd
===================================================================
--- branches/distr-2.2/pkg/distrEx/man/m1df.Rd 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/man/m1df.Rd 2009-03-23 13:49:20 UTC (rev 430)
@@ -2,8 +2,8 @@
\alias{m1df}
\alias{m1df-methods}
\alias{m1df,UnivariateDistribution-method}
-\alias{m1df,AbscontDistribution-method}
-\alias{m1df,DiscreteDistribution-method}
+%\alias{m1df,AbscontDistribution-method}
+%\alias{m1df,DiscreteDistribution-method}
\alias{m1df,LatticeDistribution-method}
\alias{m1df,AffLinDistribution-method}
\alias{m1df,Binom-method}
@@ -18,11 +18,12 @@
The moments are clipped at \code{upper}.
}
\usage{
-m1df(object, upper)
+m1df(object, upper, ...)
}
\arguments{
\item{object}{ object of class \code{"Distribution"} }
\item{upper}{ clipping bound }
+ \item{\dots}{ additional arguments to \code{E} }
}
\details{The precision of the computations can be controlled via
certain global options; cf. \code{\link{distrExOptions}}. }
@@ -31,17 +32,20 @@
}
\section{Methods}{
\describe{
- \item{object = "UnivariateDistribution":}{ clipped first moment
- for univariate distributions which is computed using crude
- Monte-Carlo integration. }
+ \item{object = "UnivariateDistribution":}{%
+ % clipped first moment
+ % for univariate distributions which is computed using crude
+ % Monte-Carlo integration.
+ uses call \code{E(object, upp=upper, ...)}.
+ }
- \item{object = "AbscontDistribution":}{ clipped first moment
- for absolutely continuous univariate distributions which
- is computed using \code{distrExIntegrate}. }
+% \item{object = "AbscontDistribution":}{ clipped first moment
+% for absolutely continuous univariate distributions which
+% is computed using \code{distrExIntegrate}. }
- \item{object = "DiscreteDistribution":}{ clipped first moment
- for discrete univariate distributions which is computed
- using \code{support} and \code{sum}. }
+% \item{object = "DiscreteDistribution":}{ clipped first moment
+% for discrete univariate distributions which is computed
+% using \code{support} and \code{sum}. }
\item{object = "Binom":}{ clipped first moment
for Binomial distributions which is computed using \code{pbinom}. }
@@ -70,6 +74,7 @@
# Poisson distribution
P1 <- Pois(lambda=2)
m1df(P1, 3)
+m1df(P1, 3, fun = function(x)sin(x))
# absolutely continuous distribution
D1 <- Norm() + Exp() # convolution
Modified: branches/distr-2.2/pkg/distrEx/man/m2df.Rd
===================================================================
--- branches/distr-2.2/pkg/distrEx/man/m2df.Rd 2009-03-23 06:04:32 UTC (rev 429)
+++ branches/distr-2.2/pkg/distrEx/man/m2df.Rd 2009-03-23 13:49:20 UTC (rev 430)
@@ -17,11 +17,12 @@
The moments are clipped at \code{upper}.
}
\usage{
-m2df(object, upper)
+m2df(object, upper, ...)
}
\arguments{
\item{object}{ object of class \code{"Distribution"} }
\item{upper}{ clipping bound }
+ \item{\dots}{ additional arguments to \code{E} }
}
\details{The precision of the computations can be controlled via
certain global options; cf. \code{\link{distrExOptions}}. }
@@ -30,9 +31,12 @@
}
\section{Methods}{
\describe{
- \item{object = "UnivariateDistribution":}{ clipped first moment
- for univariate distributions which is computed using
- crude Monte-Carlo integration. }
+ \item{object = "UnivariateDistribution":}{ %
+ %clipped first moment
+ %for univariate distributions which is computed using
+ %crude Monte-Carlo integration.
+ uses call \code{E(object, upp=upper, fun = function, ...)}.
+ }
\item{object = "AbscontDistribution":}{ clipped first moment
for absolutely continuous univariate distributions which is
@@ -69,6 +73,7 @@
# Poisson distribution
P1 <- Pois(lambda=2)
m2df(P1, 3)
+m2df(P1, 3, fun = function(x)sin(x))
# absolutely continuous distribution
D1 <- Norm() + Exp() # convolution
Modified: pkg/distrEx/R/AllGeneric.R
===================================================================
--- pkg/distrEx/R/AllGeneric.R 2009-03-23 06:04:32 UTC (rev 429)
+++ pkg/distrEx/R/AllGeneric.R 2009-03-23 13:49:20 UTC (rev 430)
@@ -151,10 +151,10 @@
}
if(!isGeneric("m1df")){
- setGeneric("m1df", function(object, upper) standardGeneric("m1df"))
+ setGeneric("m1df", function(object, upper, ...) standardGeneric("m1df"))
}
if(!isGeneric("m2df")){
- setGeneric("m2df", function(object, upper) standardGeneric("m2df"))
+ setGeneric("m2df", function(object, upper, ...) standardGeneric("m2df"))
}
#if(!isGeneric("illustrateCLT")){
Modified: pkg/distrEx/R/ClippedMoments.R
===================================================================
--- pkg/distrEx/R/ClippedMoments.R 2009-03-23 06:04:32 UTC (rev 429)
+++ pkg/distrEx/R/ClippedMoments.R 2009-03-23 13:49:20 UTC (rev 430)
@@ -2,72 +2,96 @@
## Clipped first and second moments
###############################################################################
setMethod("m1df", "UnivariateDistribution",
- function(object, upper){
- x <- r(object)(.distrExOptions$MCIterations)
- return(mean(x*(x<=upper)))
+ function(object, upper, ...){
+ return(E(object, upp=upper,...))
})
setMethod("m2df", "UnivariateDistribution",
- function(object, upper){
- x <- r(object)(.distrExOptions$MCIterations)
- return(mean(x^2*(x<=upper)))
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc1 <- mc
+ fun0 <- if(is.null(mc$fun))
+ function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
+ mc$fun <- fun0
+ mc$upper <- NULL
+ mc$upp <- upper
+ return(do.call("E", args=mc ))
})
-setMethod("m1df", "AbscontDistribution",
- function(object, upper){
- integrandm1 <- function(x, dfun){ x * dfun(x) }
- return(distrExIntegrate(integrandm1, lower = q(object)(.distrExOptions$m1dfLowerTruncQuantile),
- rel.tol = .distrExOptions$m1dfRelativeTolerance, upper = upper, dfun = d(object),
- distr = object))
- })
-setMethod("m2df", "AbscontDistribution",
- function(object, upper){
- integrandm2 <- function(x, dfun){ x^2 * dfun(x) }
- return(distrExIntegrate(integrandm2, lower = q(object)(.distrExOptions$m2dfLowerTruncQuantile),
- rel.tol = .distrExOptions$m2dfRelativeTolerance, upper = upper, dfun = d(object),
- distr = object))
- })
-setMethod("m1df", "DiscreteDistribution",
- function(object, upper){
- supp <- support(object)
- supp <- supp[supp <= upper]
- dfun <- d(object)
- return(sum(supp * dfun(supp)))
- })
-setMethod("m2df", "DiscreteDistribution",
- function(object, upper){
- supp <- support(object)
- supp <- supp[supp <= upper]
- dfun <- d(object)
- return(sum(supp^2 * dfun(supp)))
- })
+#setMethod("m1df", "AbscontDistribution",
+# function(object, upper, ...){
+# integrandm1 <- function(x, dfun){ x * dfun(x) }
+# return(distrExIntegrate(integrandm1, lower = q(object)(.distrExOptions$m1dfLowerTruncQuantile),
+# rel.tol = .distrExOptions$m1dfRelativeTolerance, upper = upper, dfun = d(object),
+# distr = object))
+# })
+#setMethod("m2df", "AbscontDistribution",
+# function(object, upper, ...){
+# integrandm2 <- function(x, dfun){ x^2 * dfun(x) }
+# return(distrExIntegrate(integrandm2, lower = q(object)(.distrExOptions$m2dfLowerTruncQuantile),
+# rel.tol = .distrExOptions$m2dfRelativeTolerance, upper = upper, dfun = d(object),
+# distr = object))
+# })
+#setMethod("m1df", "DiscreteDistribution",
+# function(object, upper, ...){
+# supp <- support(object)
+# supp <- supp[supp <= upper]
+# dfun <- d(object)
+# return(sum(supp * dfun(supp)))
+# })
+#setMethod("m2df", "DiscreteDistribution",
+# function(object, upper, ...){
+# supp <- support(object)
+# supp <- supp[supp <= upper]
+# dfun <- d(object)
+# return(sum(supp^2 * dfun(supp)))
+# })
+
setMethod("m1df", "Binom",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond))
return(prob(object)*size(object)*pbinom(upper-1, prob = prob(object),
size = size(object)-1))
+ else m1df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
+
setMethod("m2df", "Binom",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
n <- size(object)
p <- prob(object)
return(n*p*(pbinom(upper-1, prob = p, size = n-1)
+ p*(n-1)*pbinom(upper-2, prob = p, size = n-2)))
+ }else m2df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m1df", "Pois",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
return(lambda(object)*ppois(upper-1, lambda = lambda(object)))
+ }else m1df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m2df", "Pois",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
lam <- lambda(object)
return(lam*(ppois(upper-1, lambda = lam) + lam*ppois(upper-2, lambda = lam)))
+ }else m2df(as(object,"DiscreteDistribution"), upper = upper, ...)
})
setMethod("m1df", "Norm",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
return(mu*pnorm((upper-mu)/std) - std*dnorm((upper-mu)/std))
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Norm",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
if(abs(pnorm((upper-mu)/std)-1) > .Machine$double.eps)
@@ -75,61 +99,84 @@
- std*(upper + mu)*dnorm((upper-mu)/std))
else
return(mu^2+std^2)
- })
+ }else m2df(as(object,"AbscontDistribution"), upper = upper, ...)
+ })
setMethod("m1df", "Exp",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
- if(abs(pexp(lam*upper)-1) > .Machine$double.eps)
- return(pexp(lam*upper)/lam - upper*exp(-lam*upper))
+ if(abs(pexp(lam*upper, ...)-1) > .Machine$double.eps)
+ return(pexp(lam*upper, ...)/lam - upper*exp(-lam*upper, ...))
else
return(1/lam)
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Exp",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
- if(abs(pexp(lam*upper)-1) > .Machine$double.eps)
- return(2*pexp(lam*upper)/lam^2
- - (upper + 2/lam)*upper*exp(-lam*upper))
+ if(abs(pexp(lam*upper, ...)-1) > .Machine$double.eps)
+ return(2*pexp(lam*upper, ...)/lam^2
+ - (upper + 2/lam)*upper*exp(-lam*upper, ...))
else
return(2/lam^2)
+ }else m2df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m1df", "Chisq",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
+ dfr <- df(object)
if(ncp != 0)
- if(abs(p(object)(upper)-1) > .Machine$double.eps)
- return(m1df(as(object, "AbscontDistribution"), upper))
+ if(abs(p(object)(upper, ...)-1) > .Machine$double.eps)
+ return(m1df(as(object, "AbscontDistribution"), upper = upper, ...))
else
return(dfr + ncp)
- dfr <- df(object)
return(dfr*pchisq(upper, df = (dfr+2)))
+ }else m1df(as(object,"AbscontDistribution"), upper = upper, ...)
})
setMethod("m2df", "Chisq",
- function(object, upper){
+ function(object, upper, ...){
+ mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
- if(ncp != 0)
- if(abs(p(object)(upper)-1) > .Machine$double.eps)
- return(m2df(as(object, "AbscontDistribution"), upper))
+ dfr <- df(object)
+ if(ncp != 0){
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 430
More information about the Distr-commits
mailing list