[Distr-commits] r675 - branches/distr-2.3/pkg/distrEx/R

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

Author: horbenko
Date: 2010-08-26 14:48:48 +0200 (Thu, 26 Aug 2010)
New Revision: 675

Modified:
   branches/distr-2.3/pkg/distrEx/R/Expectation.R
   branches/distr-2.3/pkg/distrEx/R/Functionals.R
Log:
Klein fehler behoben f?\195?\188r xi = 0 in Functionals.R und Expecation. R von GEV

Modified: branches/distr-2.3/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.3/pkg/distrEx/R/Expectation.R	2010-07-23 21:44:25 UTC (rev 674)
+++ branches/distr-2.3/pkg/distrEx/R/Expectation.R	2010-08-26 12:48:48 UTC (rev 675)
@@ -14,6 +14,7 @@
         return(c(low=low,upp=upp)) 
 }
 
+       
 ## Integration of functions
 setMethod("E", signature(object = "UnivariateDistribution", 
                          fun = "missing", 
@@ -869,35 +870,30 @@
              ){
 
         dots <- list(...)
+
         dots.withoutUseApply <- dots
         useApply <- TRUE
         if(!is.null(dots$useApply)) useApply <- dots$useApply
         dots.withoutUseApply$useApply <- NULL
-        integrand <- function(x, dfun, ...){   di <- dim(x)
-                                               y <- q(object)(x)##quantile transformation
-                                               if(useApply){
-                                                    funy <- sapply(y,fun, ...)
-                                                    dim(y) <- di
-                                                    dim(funy) <- di
-                                               }else funy <- fun(y,...)
+
+        integrand <- function(x, dfun, ...){di <- dim(x)
+                                            y <- q(object)(x)##quantile transformation
+                                            if(useApply){
+                                               funy <- sapply(y,fun, ...)
+                                               dim(y) <- di
+                                               dim(funy) <- di
+                                             }else funy <- fun(y,...)
                                         return(funy) }
 
-#         if(is.null(low)) low <- 0
-#         if(is.null(upp)) upp <- 1
-# 
-#         Ib <- .getIntbounds(object, low, upp, #lowerTruncQuantile,
-#               upperTruncQuantile, IQR.fac)
-#         low <- if(Ib["low"]<=0) -Inf else log(Ib["low"])
-#         upp <- log(Ib["upp"])
-         
-         low <- 0
-         upp <- 1
-        return(do.call(distrExIntegrate, c(list(f = integrand,
-                    lower = low,
-                    upper = upp,
-                    rel.tol = rel.tol,
-                    distr = object, dfun = d(object)), dots.withoutUseApply)))
+        if(is.null(low)) low <- 0
+        if(is.null(upp)) upp <- 1
 
+        Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile,
+              upperTruncQuantile, IQR.fac)
+        
+        return(do.call(distrExIntegrate, c(list(f = integrand,lower = low,
+upper = upp,rel.tol = rel.tol,distr = object, dfun = d(object)),dots.withoutUseApply)))
+
     })
 
 

Modified: branches/distr-2.3/pkg/distrEx/R/Functionals.R
===================================================================
--- branches/distr-2.3/pkg/distrEx/R/Functionals.R	2010-07-23 21:44:25 UTC (rev 674)
+++ branches/distr-2.3/pkg/distrEx/R/Functionals.R	2010-08-26 12:48:48 UTC (rev 675)
@@ -592,7 +592,8 @@
     })
 setMethod("median", signature(x = "GEV"),
     function(x) {xi <- shape(x); mu <- loc(x); sigma <- scale(x)
-              return(mu + sigma*(log(2)^(-xi)-1)/xi)
+              if (xi != 0) return(mu + sigma*(log(2)^(-xi)-1)/xi)
+              else return(mu-sigma*log(log(2)))
     })
 
 #################################################################
@@ -641,7 +642,8 @@
     })
 setMethod("IQR", signature(x = "GEV"),
     function(x) {xi <- shape(x); sigma<- scale(x)
-              return(sigma*((log(4/3))^(-xi)-(log(4))^(-xi))/xi)
+             if (xi != 0) return(sigma*((log(4/3))^(-xi)-(log(4))^(-xi))/xi)
+             else return(sigma*(log(log(4))-log(log(4/3))))
     })
 #################################################################
 # some exact mads