[Distr-commits] r558 - branches/distr-2.2/pkg/distrEx/R branches/distr-2.2/pkg/distrEx/chm branches/distr-2.2/pkg/utils pkg/distrEx/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Aug 28 14:27:51 CEST 2009
Author: ruckdeschel
Date: 2009-08-28 14:27:50 +0200 (Fri, 28 Aug 2009)
New Revision: 558
Modified:
branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
branches/distr-2.2/pkg/distrEx/R/Expectation.R
branches/distr-2.2/pkg/distrEx/chm/distrEx.chm
branches/distr-2.2/pkg/utils/ladealles.R
pkg/distrEx/R/ClippedMoments.R
pkg/distrEx/R/Expectation.R
Log:
some embarrassing errors in expectation methods (with upper & lower bounds) as well as in m1df, m2df methods
Modified: branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-08-27 19:44:01 UTC (rev 557)
+++ branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-08-28 12:27:50 UTC (rev 558)
@@ -39,6 +39,7 @@
mc$useApply <- FALSE
mc$upper <- NULL
mc$object <- object
+ mc$upp <- upper
mc$lowerTruncQuantile <- lowerTruncQuantile
mc$rel.tol <- rel.tol
return(do.call("E", args=mc ))
@@ -162,8 +163,8 @@
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, ...)
@@ -175,9 +176,9 @@
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, ...)
Modified: branches/distr-2.2/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/Expectation.R 2009-08-27 19:44:01 UTC (rev 557)
+++ branches/distr-2.2/pkg/distrEx/R/Expectation.R 2009-08-28 12:27:50 UTC (rev 558)
@@ -47,7 +47,8 @@
upperTruncQuantile, IQR.fac)
low <- Ib["low"]
upp <- Ib["upp"]
-
+ if(upp<low) return(0)
+
return(distrExIntegrate(f = integrand,
lower = low,
upper = upp,
@@ -84,12 +85,16 @@
return(SymmCenter(Symmetry(object)))
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
- if(object at a >= 0)
- object at a * E(object at X0, low = object at a*low,
- upp = object at a*upp, ...) + object at b
- else
- object at a * E(object at X0, low = object at a*upp,
- upp = object at a*low, ...) + object at b
+ if(upp<low) return(0)
+ if(object at a >= 0){
+ return(object at a * E(object at X0, low = (low-object at b)/object at a,
+ upp = (upp-object at b)/object at a, ...) +
+ object at b * (p(object)(upp)-p.l(object)(low)))
+ }else{
+ return(object at a * E(object at X0, low = (upp-object at b)/object at a,
+ upp = (low-object at b)/object at a, ...) +
+ object at b * (p(object)(upp)-p.l(object)(low)))
+ }
})
setMethod("E", signature(object = "AffLinAbscontDistribution",
@@ -415,7 +420,7 @@
if(upp == Inf) return(mean(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
mean(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -451,7 +456,7 @@
if(upp == Inf) return(size(object)*prob(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
size(object)*prob(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -498,7 +503,7 @@
if(upp == Inf) return(df(object)+ncp(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
df(object)+ncp(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -546,7 +551,7 @@
if(upp == Inf) return(1/rate(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
1/rate(object) else m1df(object, upper = upp, ...)
return(E2-E1)
Modified: branches/distr-2.2/pkg/distrEx/chm/distrEx.chm
===================================================================
(Binary files differ)
Modified: branches/distr-2.2/pkg/utils/ladealles.R
===================================================================
--- branches/distr-2.2/pkg/utils/ladealles.R 2009-08-27 19:44:01 UTC (rev 557)
+++ branches/distr-2.2/pkg/utils/ladealles.R 2009-08-28 12:27:50 UTC (rev 558)
@@ -8,5 +8,5 @@
#ladeall(DIR="distr", develDir = "C:/rtest/distr/branches/distr-2.1/pkg")
#ladeall(DIR="distrEx", develDir = "C:/rtest/distr/pkg")
-ladeall(DIR="ROptEst", develDir = "C:/rtest/robast/pkg")
+ladeall(DIR="ROptEst", develDir = "C:/rtest/robast/branches/robast-0.7/pkg")
Modified: pkg/distrEx/R/ClippedMoments.R
===================================================================
--- pkg/distrEx/R/ClippedMoments.R 2009-08-27 19:44:01 UTC (rev 557)
+++ pkg/distrEx/R/ClippedMoments.R 2009-08-28 12:27:50 UTC (rev 558)
@@ -38,6 +38,7 @@
mc <- as.list(mc)[-1]
mc$useApply <- FALSE
mc$upper <- NULL
+ mc$upp <- upper
mc$object <- object
mc$lowerTruncQuantile <- lowerTruncQuantile
mc$rel.tol <- rel.tol
@@ -162,8 +163,8 @@
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, ...)
@@ -175,9 +176,9 @@
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, ...)
Modified: pkg/distrEx/R/Expectation.R
===================================================================
--- pkg/distrEx/R/Expectation.R 2009-08-27 19:44:01 UTC (rev 557)
+++ pkg/distrEx/R/Expectation.R 2009-08-28 12:27:50 UTC (rev 558)
@@ -43,7 +43,7 @@
upperTruncQuantile, IQR.fac)
low <- Ib["low"]
upp <- Ib["upp"]
-
+ if(upp<low) return(0)
return(distrExIntegrate(f = integrand,
lower = low,
upper = upp,
@@ -70,18 +70,22 @@
cond = "missing")))
-setMethod("E", signature(object = "AffLinDistribution",
- fun = "missing",
+setMethod("E", signature(object = "AffLinDistribution",
+ fun = "missing",
cond = "missing"),
function(object, low = NULL, upp = NULL, ...){
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
- if(object at a >= 0)
- object at a * E(object at X0, low = object at a*low,
- upp = object at a*upp, ...) + object at b
- else
- object at a * E(object at X0, low = object at a*upp,
- upp = object at a*low, ...) + object at b
+ if(upp<low) return(0)
+ if(object at a >= 0){
+ return(object at a * E(object at X0, low = object at a*low,
+ upp = object at a*upp, ...) +
+ object at b * (p(object)(upp)-p.l(object)(low)))
+ }else{
+ return(object at a * E(object at X0, low = object at a*upp,
+ upp = object at a*low, ...) +
+ object at b * (p(object)(upp)-p.l(object)(low)))
+ }
})
setMethod("E", signature(object = "AffLinAbscontDistribution",
@@ -405,7 +409,7 @@
if(upp == Inf) return(mean(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
mean(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -440,7 +444,7 @@
if(upp == Inf) return(size(object)*prob(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
size(object)*prob(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -483,7 +487,7 @@
if(upp == Inf) return(df(object)+ncp(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
df(object)+ncp(object) else m1df(object, upper = upp, ...)
return(E2-E1)
@@ -528,7 +532,7 @@
if(upp == Inf) return(1/rate(object))
else return(m1df(object, upper = upp, ...))
}else{
- E1 <- -m1df(object, upper = low, ...)
+ E1 <- m1df(object, upper = low, ...)
E2 <- if(upp == Inf)
1/rate(object) else m1df(object, upper = upp, ...)
return(E2-E1)
More information about the Distr-commits
mailing list