[Distr-commits] r453 - branches/distr-2.2/pkg/distr/R branches/distr-2.2/pkg/distrEx/R branches/distr-2.2/pkg/utils pkg/SweaveListingUtils/chm pkg/distr/R pkg/distr/chm pkg/distrEx/R pkg/distrEx/chm pkg/distrMod/chm pkg/utils
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 8 12:44:33 CEST 2009
Author: ruckdeschel
Date: 2009-04-08 12:44:33 +0200 (Wed, 08 Apr 2009)
New Revision: 453
Modified:
branches/distr-2.2/pkg/distr/R/UtilitiesDistributions.R
branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
branches/distr-2.2/pkg/utils/ladealles.R
pkg/SweaveListingUtils/chm/SweaveListingUtils.chm
pkg/distr/R/UtilitiesDistributions.R
pkg/distr/chm/Distr.chm
pkg/distrEx/R/ClippedMoments.R
pkg/distrEx/chm/distrEx.chm
pkg/distrMod/chm/distrMod.chm
pkg/utils/ladealles.R
Log:
bug fix on Matthias' mail Apr07-09:
+in folder utils: ladealles.R now loads both .r and .R files
+RtoDPQ.LC now correctly sets .withArith, .withSim slots in discretePart and .logExact, .lowerExact in both discretePart and acPart
+fix for the bug in distrEx: m2df now only uses mc <- match.call() instead of mc <- match.call(call = sys.call(sys.parent(1)))
(do not completely understand why:
there is method dispatch, though, as in plot(), where sys.call(sys.parent(1))
is needed, but here match.call() does it... )
Modified: branches/distr-2.2/pkg/distr/R/UtilitiesDistributions.R
===================================================================
--- branches/distr-2.2/pkg/distr/R/UtilitiesDistributions.R 2009-04-07 05:35:49 UTC (rev 452)
+++ branches/distr-2.2/pkg/distr/R/UtilitiesDistributions.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -88,7 +88,9 @@
{hasDis <- TRUE
zz.nr <- zz[! zz %in% zz.replic]
d.r <- zz.T1/sum(zz.T1)
- f.d <- DiscreteDistribution(supp = zz.replic, prob = d.r)
+ f.d <- DiscreteDistribution(supp = zz.replic, prob = d.r,
+ .withSim = TRUE, .withArith = TRUE,
+ .lowerExact = FALSE, .logExact = FALSE)
rm(d.r,zz.replic,zz.T1)
}
rm(zz)
@@ -108,7 +110,7 @@
rm(px.l, px.u, dxy, pf0)
f.c <- AbscontDistribution( r= function(n) qcfun(runif(n)),
d=dcfun, p = pcfun, q = qcfun, .withSim = TRUE,
- .withArith = TRUE)
+ .withArith = TRUE, .lowerExact = FALSE, .logExact = FALSE)
}
else f.c <-Norm()
UnivarLebDecDistribution(discretePart = f.d, acPart = f.c,
Modified: branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-04-07 05:35:49 UTC (rev 452)
+++ branches/distr-2.2/pkg/distrEx/R/ClippedMoments.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -7,7 +7,8 @@
})
setMethod("m2df", "UnivariateDistribution",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
@@ -27,7 +28,8 @@
function(object, upper,
lowerTruncQuantile = getdistrExOption("m2dfLowerTruncQuantile"),
rel.tol = getdistrExOption("m2dfRelativeTolerance"), ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
@@ -69,7 +71,8 @@
setMethod("m1df", "Binom",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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))
@@ -78,7 +81,8 @@
setMethod("m2df", "Binom",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
n <- size(object)
p <- prob(object)
@@ -88,14 +92,16 @@
})
setMethod("m1df", "Pois",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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)))
@@ -103,7 +109,8 @@
})
setMethod("m1df", "Norm",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
@@ -112,7 +119,8 @@
})
setMethod("m2df", "Norm",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
@@ -125,7 +133,8 @@
})
setMethod("m1df", "Exp",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
@@ -137,7 +146,8 @@
})
setMethod("m2df", "Exp",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
@@ -150,7 +160,8 @@
})
setMethod("m1df", "Chisq",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
dfr <- df(object)
@@ -164,7 +175,8 @@
})
setMethod("m2df", "Chisq",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
dfr <- df(object)
@@ -195,7 +207,8 @@
setMethod("m2df", "LatticeDistribution",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
Modified: branches/distr-2.2/pkg/utils/ladealles.R
===================================================================
--- branches/distr-2.2/pkg/utils/ladealles.R 2009-04-07 05:35:49 UTC (rev 452)
+++ branches/distr-2.2/pkg/utils/ladealles.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -2,9 +2,11 @@
od <- getwd()
print(file.path(develDir,DIR, "R"))
setwd(file.path(develDir,DIR, "R"))
- lapply(grep(paste(pattern,".R$",sep="",collapse=""),dir(),value=T),function(...) {print(...);source(...)})
+ lapply(grep(paste(pattern,".(r|R)$",sep="",collapse=""),dir(),value=T),function(...) {print(...);source(...)})
setwd(od)
}
-ladeall(DIR="distr", develDir = "C:/rtest/distr/branches/distr-2.1/pkg")
+#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")
Modified: pkg/SweaveListingUtils/chm/SweaveListingUtils.chm
===================================================================
(Binary files differ)
Modified: pkg/distr/R/UtilitiesDistributions.R
===================================================================
--- pkg/distr/R/UtilitiesDistributions.R 2009-04-07 05:35:49 UTC (rev 452)
+++ pkg/distr/R/UtilitiesDistributions.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -88,7 +88,9 @@
{hasDis <- TRUE
zz.nr <- zz[! zz %in% zz.replic]
d.r <- zz.T1/sum(zz.T1)
- f.d <- DiscreteDistribution(supp = zz.replic, prob = d.r)
+ f.d <- DiscreteDistribution(supp = zz.replic, prob = d.r,
+ .withSim = TRUE, .withArith = TRUE,
+ .lowerExact = FALSE, .logExact = FALSE)
rm(d.r,zz.replic,zz.T1)
}
rm(zz)
@@ -108,7 +110,7 @@
rm(px.l, px.u, dxy, pf0)
f.c <- AbscontDistribution( r= function(n) qcfun(runif(n)),
d=dcfun, p = pcfun, q = qcfun, .withSim = TRUE,
- .withArith = TRUE)
+ .withArith = TRUE, .lowerExact = FALSE, .logExact = FALSE)
}
else f.c <-Norm()
UnivarLebDecDistribution(discretePart = f.d, acPart = f.c,
Modified: pkg/distr/chm/Distr.chm
===================================================================
(Binary files differ)
Modified: pkg/distrEx/R/ClippedMoments.R
===================================================================
--- pkg/distrEx/R/ClippedMoments.R 2009-04-07 05:35:49 UTC (rev 452)
+++ pkg/distrEx/R/ClippedMoments.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -7,7 +7,8 @@
})
setMethod("m2df", "UnivariateDistribution",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
@@ -27,7 +28,8 @@
function(object, upper,
lowerTruncQuantile = getdistrExOption("m2dfLowerTruncQuantile"),
rel.tol = getdistrExOption("m2dfRelativeTolerance"), ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
@@ -69,7 +71,8 @@
setMethod("m1df", "Binom",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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))
@@ -78,7 +81,8 @@
setMethod("m2df", "Binom",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
n <- size(object)
p <- prob(object)
@@ -88,14 +92,16 @@
})
setMethod("m1df", "Pois",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-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)))
@@ -103,7 +109,8 @@
})
setMethod("m1df", "Norm",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
@@ -112,7 +119,8 @@
})
setMethod("m2df", "Norm",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
mu <- mean(object)
std <- sd(object)
@@ -125,7 +133,8 @@
})
setMethod("m1df", "Exp",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
@@ -137,7 +146,8 @@
})
setMethod("m2df", "Exp",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
if(upper <= 0) return(0)
lam <- rate(object)
@@ -150,7 +160,8 @@
})
setMethod("m1df", "Chisq",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
dfr <- df(object)
@@ -164,7 +175,8 @@
})
setMethod("m2df", "Chisq",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
if(is.null(mc$fun) && is.null(mc$cond)){
ncp <- ncp(object)
dfr <- df(object)
@@ -195,7 +207,8 @@
setMethod("m2df", "LatticeDistribution",
function(object, upper, ...){
- mc <- as.list(match.call(call = sys.call(sys.parent(1))))[-1]
+ mc <- match.call()
+ mc <- as.list(mc)[-1]
mc1 <- mc
fun0 <- if(is.null(mc$fun))
function(x)x^2 else function(x) (eval(mc1$fun)(x))^2
Modified: pkg/distrEx/chm/distrEx.chm
===================================================================
(Binary files differ)
Modified: pkg/distrMod/chm/distrMod.chm
===================================================================
(Binary files differ)
Modified: pkg/utils/ladealles.R
===================================================================
--- pkg/utils/ladealles.R 2009-04-07 05:35:49 UTC (rev 452)
+++ pkg/utils/ladealles.R 2009-04-08 10:44:33 UTC (rev 453)
@@ -2,9 +2,11 @@
od <- getwd()
print(file.path(develDir,DIR, "R"))
setwd(file.path(develDir,DIR, "R"))
- lapply(grep(paste(pattern,".R$",sep="",collapse=""),dir(),value=T),function(...) {print(...);source(...)})
+ lapply(grep(paste(pattern,".(r|R)$",sep="",collapse=""),dir(),value=T),function(...) {print(...);source(...)})
setwd(od)
}
-ladeall(DIR="distr", develDir = "C:/rtest/distr/branches/distr-2.1/pkg")
+#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")
More information about the Distr-commits
mailing list