[Distr-commits] r196 - branches/distr-2.0/pkg/distrEx/R pkg/distrEx/R

[noreply at r-forge.r-project.org]

Author: ruckdeschel
Date: 2008-07-24 17:28:49 +0200 (Thu, 24 Jul 2008)
New Revision: 196

Modified:
   branches/distr-2.0/pkg/distrEx/R/AllClass.R
   branches/distr-2.0/pkg/distrEx/R/AllInitialize.R
   pkg/distrEx/R/AllClass.R
   pkg/distrEx/R/AllInitialize.R
Log:
changed Matthias' qgumbel to a form which can digest vectorized input

Modified: branches/distr-2.0/pkg/distrEx/R/AllClass.R
===================================================================
--- branches/distr-2.0/pkg/distrEx/R/AllClass.R	2008-07-24 14:02:30 UTC (rev 195)
+++ branches/distr-2.0/pkg/distrEx/R/AllClass.R	2008-07-24 15:28:49 UTC (rev 196)
@@ -1,3 +1,5 @@
+.isEqual01 <- distr:::.isEqual01 ## for faster access due to local caching in package namespace
+
 .onLoad <- function(lib, pkg){
     require("methods", character = TRUE, quietly = TRUE)
 }

Modified: branches/distr-2.0/pkg/distrEx/R/AllInitialize.R
===================================================================
--- branches/distr-2.0/pkg/distrEx/R/AllInitialize.R	2008-07-24 14:02:30 UTC (rev 195)
+++ branches/distr-2.0/pkg/distrEx/R/AllInitialize.R	2008-07-24 15:28:49 UTC (rev 196)
@@ -14,14 +14,23 @@
         body(.Object at p) <- substitute({ pgumbel(q, loc = loc1, scale = scale1, ...) },
                                      list(loc1 = loc, scale1 = scale))
         .Object at q <- function(p, ...){ 
-                        if(p == 0) return(-Inf)
-                        if(p == 1) return(Inf)
-                        qgumbel(p, loc = loc1, scale = scale1, ...) 
+                        ## P.R.: changed to vectorized form 
+                        p0 <- p
+                        p0[.isEqual01(p)] <- 0.5
+                        q0 <- qgumbel(p0, loc = loc1, scale = scale1, ...)
+                        q0[.isEqual01(p)] <- sign([.isEqual01(p)]-0.5)*Inf
+                        return(q0)  
                      }
-        body(.Object at q) <- substitute({ if(p == 0) return(-Inf)
-                                        if(p == 1) return(Inf)
-                                        qgumbel(p, loc = loc1, scale = scale1, ...) },
-                                     list(loc1 = loc, scale1 = scale))
+        body(.Object at q) <- substitute({                         
+                              ## P.R.: changed to vectorized form 
+                              p0 <- p
+                              p0[.isEqual01(p)] <- 0.5
+                              q0 <- qgumbel(p0, loc = loc1, 
+                                            scale = scale1, ...)
+                              q0[.isEqual01(p)] <- sign([.isEqual01(p)]-0.5)*Inf
+                              return(q0)  
+                               },
+                              list(loc1 = loc, scale1 = scale))
         .Object at .withSim   <- FALSE
         .Object at .withArith <- FALSE
         .Object

Modified: pkg/distrEx/R/AllClass.R
===================================================================
--- pkg/distrEx/R/AllClass.R	2008-07-24 14:02:30 UTC (rev 195)
+++ pkg/distrEx/R/AllClass.R	2008-07-24 15:28:49 UTC (rev 196)
@@ -1,3 +1,5 @@
+.isEqual01 <- distr:::.isEqual01 ## for faster access due to local caching in package namespace
+
 .onLoad <- function(lib, pkg){
     require("methods", character = TRUE, quietly = TRUE)
 }
@@ -104,8 +106,8 @@
 setClass("Gumbel", 
             prototype = prototype(r = function(n){ rgumbel(n, loc = 0, scale = 1) },
                                   d = function(x, ...){ dgumbel(x, loc = 0, scale = 1, ...) },
-                                  p = function(x, ...){ pgumbel(x, loc = 0, scale = 1, ...) },
-                                  q = function(x, ...){ qgumbel(x, loc = 0, scale = 1, ...) },
+                                  p = function(q, ...){ pgumbel(q, loc = 0, scale = 1, ...) },
+                                  q = function(p, ...){ qgumbel(p, loc = 0, scale = 1, ...) },
                                   img = new("Reals"),
                                   param = new("GumbelParameter"),
                                   .withArith = FALSE,

Modified: pkg/distrEx/R/AllInitialize.R
===================================================================
--- pkg/distrEx/R/AllInitialize.R	2008-07-24 14:02:30 UTC (rev 195)
+++ pkg/distrEx/R/AllInitialize.R	2008-07-24 15:28:49 UTC (rev 196)
@@ -10,18 +10,27 @@
         .Object at d <- function(x, ...){ dgumbel(x, loc = loc1, scale = scale1, ...) }
         body(.Object at d) <- substitute({ dgumbel(x, loc = loc1, scale = scale1, ...) },
                                      list(loc1 = loc, scale1 = scale))
-        .Object at p <- function(x, ...){ pgumbel(x, loc = loc1, scale = scale1, ...) }
-        body(.Object at p) <- substitute({ pgumbel(x, loc = loc1, scale = scale1, ...) },
+        .Object at p <- function(q, ...){ pgumbel(q, loc = loc1, scale = scale1, ...) }
+        body(.Object at p) <- substitute({ pgumbel(q, loc = loc1, scale = scale1, ...) },
                                      list(loc1 = loc, scale1 = scale))
-        .Object at q <- function(x, ...){ 
-                        if(x == 0) return(-Inf)
-                        if(x == 1) return(Inf)
-                        qgumbel(x, loc = loc1, scale = scale1, ...) 
+        .Object at q <- function(p, ...){ 
+                        ## P.R.: changed to vectorized form 
+                        p0 <- p
+                        p0[.isEqual01(p)] <- 0.5
+                        q0 <- qgumbel(p0, loc = loc1, scale = scale1, ...)
+                        q0[.isEqual01(p)] <- sign([.isEqual01(p)]-0.5)*Inf
+                        return(q0)  
                      }
-        body(.Object at q) <- substitute({ if(x == 0) return(-Inf)
-                                        if(x == 1) return(Inf)
-                                        qgumbel(x, loc = loc1, scale = scale1, ...) },
-                                     list(loc1 = loc, scale1 = scale))
+        body(.Object at q) <- substitute({                         
+                              ## P.R.: changed to vectorized form 
+                              p0 <- p
+                              p0[.isEqual01(p)] <- 0.5
+                              q0 <- qgumbel(p0, loc = loc1, 
+                                            scale = scale1, ...)
+                              q0[.isEqual01(p)] <- sign([.isEqual01(p)]-0.5)*Inf
+                              return(q0)  
+                               },
+                              list(loc1 = loc, scale1 = scale))
         .Object at .withSim   <- FALSE
         .Object at .withArith <- FALSE
         .Object