[Distr-commits] r446 - branches/distr-2.2/pkg/distr/R branches/distr-2.2/pkg/distrEx/R pkg/distr/R pkg/distr/chm pkg/distrEx/R pkg/distrEx/chm pkg/distrEx/src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Mar 31 11:47:30 CEST 2009
Author: ruckdeschel
Date: 2009-03-31 11:47:30 +0200 (Tue, 31 Mar 2009)
New Revision: 446
Modified:
branches/distr-2.2/pkg/distr/R/AllInitialize.R
branches/distr-2.2/pkg/distr/R/setIsRelations.R
branches/distr-2.2/pkg/distrEx/R/AllClass.R
branches/distr-2.2/pkg/distrEx/R/AllInitialize.R
pkg/distr/R/AllInitialize.R
pkg/distr/R/setIsRelations.R
pkg/distr/chm/Distr.chm
pkg/distrEx/R/AllClass.R
pkg/distrEx/R/AllInitialize.R
pkg/distrEx/chm/distrEx.chm
pkg/distrEx/src/distrEx.dll
Log:
distr/distrEx:
fixed bug ->
Warnung in .local(.Object, ...) : you have to specify slot r at least
Error in function (classes, fdef, mtable) :
unable to find an inherited method for function "r", for signature "numeric"
Error : unable to load R code in package 'distrEx'
ERROR: lazy loading failed for package ?\226?\128?\152distrEx?\226?\128?\153
changed initialize methods for AbscontDistribution and DiscreteDistribution in distr;
distrEx: catch errors thrown by qgumbel and qpareto1 when args are not in (0,1)
--> corresp. q-methods now consistently return NaN.
Modified: branches/distr-2.2/pkg/distr/R/AllInitialize.R
===================================================================
--- branches/distr-2.2/pkg/distr/R/AllInitialize.R 2009-03-26 14:07:29 UTC (rev 445)
+++ branches/distr-2.2/pkg/distr/R/AllInitialize.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -72,6 +72,8 @@
) {
## don't use this if the call is new("AbscontDistribution")
LL <- length(sys.calls())
+ if(sys.calls()[[LL-3]] == "new(toDef)")
+ {return(.Object)}
if(sys.calls()[[LL-3]] == "new(\"AbscontDistribution\")")
{return(.Object)}
@@ -165,6 +167,8 @@
## don't use this if the call is new("DiscreteDistribution")
LL <- length(sys.calls())
+ if(sys.calls()[[LL-3]] == "new(toDef)")
+ {return(.Object)}
if(sys.calls()[[LL-3]] == "new(\"DiscreteDistribution\")")
{return(.Object)}
Modified: branches/distr-2.2/pkg/distr/R/setIsRelations.R
===================================================================
--- branches/distr-2.2/pkg/distr/R/setIsRelations.R 2009-03-26 14:07:29 UTC (rev 445)
+++ branches/distr-2.2/pkg/distr/R/setIsRelations.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -46,12 +46,14 @@
function(from){
if(!.is.vector.lattice(from at support))
return(from)
- else
- return(new("LatticeDistribution", r = from at r, d = from at d,
- q = from at q, p = from at p, support = from at support,
- lattice = .make.lattice.es.vector(from at support),
- .withArith = FALSE, .withSim = FALSE, img = from at img,
- param = from at param))
+ else{ to <- new("LatticeDistribution")
+ slotNames <- slotNames(from)
+ lst <- sapply(slotNames, function(x) slot(from,x))
+ names(lst) <- slotNames
+ lst$lattice <- .make.lattice.es.vector(from at support)
+ for (i in 1: length(lst))
+ slot(to, name = names(lst)[i]) <- lst[[i]]
+ return(to)}
})
#setIs("DiscreteDistribution", "LatticeDistribution",
# test = function(object) .is.vector.lattice(support(object)),
Modified: branches/distr-2.2/pkg/distrEx/R/AllClass.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/AllClass.R 2009-03-26 14:07:29 UTC (rev 445)
+++ branches/distr-2.2/pkg/distrEx/R/AllClass.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -106,18 +106,25 @@
if(log.p) return(log(p0)) else return(p0)
},
q = function(p, loc = 0, scale = 1, lower.tail = TRUE, log.p = FALSE){
- p <- if(log.p) exp(p) else p
- in01 <- (p>1 | p<0)
- i01 <- .isEqual01(p)
- i0 <- (i01 & p<1)
- i1 <- (i01 & p>0)
- ii01 <- .isEqual01(p) | in01
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
p0 <- p
- p0[ii01] <- 0.5
- q1 <- qgumbel(p0, loc = 0, scale = 1, ...)
- q[i0] <- if(lower.tail) -Inf else Inf
- q[i1] <- if(!lower.tail) -Inf else Inf
- q[in01] <- NaN
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qgumbel(p0, loc = 0, scale = 1,
+ lower.tail = lower.tail)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
},
img = new("Reals"),
param = new("GumbelParameter"),
@@ -172,9 +179,26 @@
lower.tail = lower.tail, log.p = log.p)
},
q = function(p, lower.tail = TRUE, log.p = FALSE ){
- qpareto1(p, shape = 1, min = 1,
- lower.tail = lower.tail, log.p = log.p)
- },
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
+ p0 <- p
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qpareto1(p0, shape = 1, min = 1,
+ lower.tail = lower.tail, log.p = log.p)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
+ },
param = new("ParetoParameter"),
img = new("Reals"),
.logExact = TRUE,
Modified: branches/distr-2.2/pkg/distrEx/R/AllInitialize.R
===================================================================
--- branches/distr-2.2/pkg/distrEx/R/AllInitialize.R 2009-03-26 14:07:29 UTC (rev 445)
+++ branches/distr-2.2/pkg/distrEx/R/AllInitialize.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -15,18 +15,18 @@
return(if(log.p) log(p1) else p1)},
list(loc1 = loc, scale1 = scale))
.Object at q <- function(p, loc = loc1, scale = scale1, lower.tail = TRUE, log.p = FALSE){}
- body(.Object at q) <- substitute({
+ body(.Object at q) <- substitute({
## P.R.: changed to vectorized form
- p <- if(log.p) exp(p) else p
+ p1 <- if(log.p) exp(p) else p
- in01 <- (p>1 | p<0)
- i01 <- .isEqual01(p)
- i0 <- (i01 & p<1)
- i1 <- (i01 & p>0)
- ii01 <- .isEqual01(p) | in01
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
p0 <- p
- p0[ii01] <- 0.5
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
q1 <- qgumbel(p0, loc = loc1, scale = scale1,
lower.tail = lower.tail)
@@ -66,11 +66,27 @@
lower.tail = lower.tail, log.p = log.p) },
list(shapeSub = shape, MinSub = Min)
)
- body(.Object at q) <- substitute(
- { qpareto1(p, shape = shapeSub, min = MinSub,
- lower.tail = lower.tail, log.p = log.p) },
- list(shapeSub = shape, MinSub = Min)
- )
+ body(.Object at q) <- substitute({
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
+ p0 <- p
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qpareto1(p0, shape = shapeSub, min = MinSub,
+ lower.tail = lower.tail, log.p = log.p)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
+ }, list(shapeSub = shape, MinSub = Min))
.Object at .withArith <- .withArith
.Object at .logExact <- TRUE
.Object at .lowerExact <- TRUE
Modified: pkg/distr/R/AllInitialize.R
===================================================================
--- pkg/distr/R/AllInitialize.R 2009-03-26 14:07:29 UTC (rev 445)
+++ pkg/distr/R/AllInitialize.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -73,6 +73,8 @@
LL <- length(sys.calls())
if(sys.calls()[[LL-3]] == "new(\"AbscontDistribution\")")
{return(.Object)}
+ if(sys.calls()[[LL-3]] == "new(toDef)")
+ {return(.Object)}
if(is.null(r))
warning("you have to specify slot r at least")
@@ -160,6 +162,8 @@
## don't use this if the call is new("DiscreteDistribution")
LL <- length(sys.calls())
+ if(sys.calls()[[LL-3]] == "new(toDef)")
+ {return(.Object)}
if(sys.calls()[[LL-3]] == "new(\"DiscreteDistribution\")")
{return(.Object)}
Modified: pkg/distr/R/setIsRelations.R
===================================================================
--- pkg/distr/R/setIsRelations.R 2009-03-26 14:07:29 UTC (rev 445)
+++ pkg/distr/R/setIsRelations.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -51,7 +51,8 @@
q = from at q, p = from at p, support = from at support,
lattice = .make.lattice.es.vector(from at support),
.withArith = FALSE, .withSim = FALSE, img = from at img,
- param = from at param))
+ param = from at param,.lowerExact = .lowerExact(from),
+ .logExact = .logExact(from)))
})
#setIs("DiscreteDistribution", "LatticeDistribution",
# test = function(object) .is.vector.lattice(support(object)),
Modified: pkg/distr/chm/Distr.chm
===================================================================
(Binary files differ)
Modified: pkg/distrEx/R/AllClass.R
===================================================================
--- pkg/distrEx/R/AllClass.R 2009-03-26 14:07:29 UTC (rev 445)
+++ pkg/distrEx/R/AllClass.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -100,27 +100,36 @@
# Gumbel distribution
setClass("Gumbel",
prototype = prototype(r = function(n){ rgumbel(n, loc = 0, scale = 1) },
- d = function(x, log){ dgumbel(x, loc = 0, scale = 1, log = FALSE) },
+ d = function(x, log){dgumbel(x, loc = 0, scale = 1, log = FALSE)},
p = function(q, lower.tail = TRUE, log.p = FALSE){
p0 <- pgumbel(q, loc = 0, scale = 1, lower.tail = lower.tail)
if(log.p) return(log(p0)) else return(p0)
},
q = function(p, loc = 0, scale = 1, lower.tail = TRUE, log.p = FALSE){
- p <- if(log.p) exp(p) else p
- in01 <- (p>1 | p<0)
- i01 <- .isEqual01(p)
- i0 <- (i01 & p<1)
- i1 <- (i01 & p>0)
- ii01 <- .isEqual01(p) | in01
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
p0 <- p
- p0[ii01] <- 0.5
- q1 <- qgumbel(p0, loc = 0, scale = 1, ...)
- q[i0] <- if(lower.tail) -Inf else Inf
- q[i1] <- if(!lower.tail) -Inf else Inf
- q[in01] <- NaN
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qgumbel(p0, loc = 0, scale = 1,
+ lower.tail = lower.tail)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
},
img = new("Reals"),
param = new("GumbelParameter"),
+ .withArith = FALSE,
+ .withSim = FALSE,
.logExact = FALSE,
.lowerExact = TRUE),
contains = "AbscontDistribution")
@@ -172,11 +181,30 @@
lower.tail = lower.tail, log.p = log.p)
},
q = function(p, lower.tail = TRUE, log.p = FALSE ){
- qpareto1(p, shape = 1, min = 1,
- lower.tail = lower.tail, log.p = log.p)
- },
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
+ p0 <- p
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qpareto1(p0, shape = 1, min = 1,
+ lower.tail = lower.tail, log.p = log.p)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
+ },
param = new("ParetoParameter"),
img = new("Reals"),
+ .withArith = FALSE,
+ .withSim = FALSE,
.logExact = TRUE,
.lowerExact = TRUE),
contains = "AbscontDistribution"
Modified: pkg/distrEx/R/AllInitialize.R
===================================================================
--- pkg/distrEx/R/AllInitialize.R 2009-03-26 14:07:29 UTC (rev 445)
+++ pkg/distrEx/R/AllInitialize.R 2009-03-31 09:47:30 UTC (rev 446)
@@ -15,18 +15,18 @@
return(if(log.p) log(p1) else p1)},
list(loc1 = loc, scale1 = scale))
.Object at q <- function(p, loc = loc1, scale = scale1, lower.tail = TRUE, log.p = FALSE){}
- body(.Object at q) <- substitute({
+ body(.Object at q) <- substitute({
## P.R.: changed to vectorized form
- p <- if(log.p) exp(p) else p
+ p1 <- if(log.p) exp(p) else p
- in01 <- (p>1 | p<0)
- i01 <- .isEqual01(p)
- i0 <- (i01 & p<1)
- i1 <- (i01 & p>0)
- ii01 <- .isEqual01(p) | in01
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
p0 <- p
- p0[ii01] <- 0.5
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
q1 <- qgumbel(p0, loc = loc1, scale = scale1,
lower.tail = lower.tail)
@@ -45,7 +45,7 @@
## Class: Pareto distribution
setMethod("initialize", "Pareto",
- function(.Object, shape = 1, Min = 1, .withArith = FALSE) {
+ function(.Object, shape = 1, Min = 1) {
.Object at img <- new("Reals")
.Object at param <- new("ParetoParameter", shape = shape, Min = Min)
.Object at r <- function(n){}
@@ -66,12 +66,30 @@
lower.tail = lower.tail, log.p = log.p) },
list(shapeSub = shape, MinSub = Min)
)
- body(.Object at q) <- substitute(
- { qpareto1(p, shape = shapeSub, min = MinSub,
- lower.tail = lower.tail, log.p = log.p) },
- list(shapeSub = shape, MinSub = Min)
- )
- .Object at .withArith <- .withArith
+ body(.Object at q) <- substitute({
+ ## P.R.: changed to vectorized form
+ p1 <- if(log.p) exp(p) else p
+
+ in01 <- (p1>1 | p1<0)
+ i01 <- .isEqual01(p1)
+ i0 <- (i01 & p1<1)
+ i1 <- (i01 & p1>0)
+ ii01 <- .isEqual01(p1) | in01
+
+ p0 <- p
+ p0[ii01] <- if(log.p) log(0.5) else 0.5
+
+ q1 <- qpareto1(p0, shape = shapeSub, min = MinSub,
+ lower.tail = lower.tail, log.p = log.p)
+ q1[i0] <- if(lower.tail) -Inf else Inf
+ q1[i1] <- if(!lower.tail) -Inf else Inf
+ q1[in01] <- NaN
+
+ return(q1)
+ }, list(shapeSub = shape, MinSub = Min))
+
+ .Object at .withSim <- FALSE
+ .Object at .withArith <- FALSE
.Object at .logExact <- TRUE
.Object at .lowerExact <- TRUE
.Object
Modified: pkg/distrEx/chm/distrEx.chm
===================================================================
(Binary files differ)
Modified: pkg/distrEx/src/distrEx.dll
===================================================================
(Binary files differ)
More information about the Distr-commits
mailing list