[Robast-commits] r1191 - in pkg/RobExtremes: R tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 2 19:11:26 CET 2019
Author: ruckdeschel
Date: 2019-03-02 19:11:25 +0100 (Sat, 02 Mar 2019)
New Revision: 1191
Modified:
pkg/RobExtremes/R/Expectation.R
pkg/RobExtremes/R/makeIC.R
pkg/RobExtremes/tests/Examples/RobExtremes-Ex_i386.Rout.save
pkg/RobExtremes/tests/Examples/RobExtremes-Ex_x64.Rout.save
Log:
[RobExtremes] trunk: some minor leftovers from an imperfect merge: had an old Expectation.R and forgot arg ... in makeIC.R
Modified: pkg/RobExtremes/R/Expectation.R
===================================================================
--- pkg/RobExtremes/R/Expectation.R 2019-03-02 16:17:26 UTC (rev 1190)
+++ pkg/RobExtremes/R/Expectation.R 2019-03-02 18:11:25 UTC (rev 1191)
@@ -1,44 +1,53 @@
+## copied form distrEx from distrEx 2.8.0 and branch 1.2.0 on
-setMethod("E", signature(object = "Pareto",
- fun = "missing",
+## .qtlIntegrate is moved from RobExtremes (slightly modified) to distrEx
+# as of versions distrEx 2.8.0 and RobExtremes 1.2.0
+
+
+setMethod("E", signature(object = "Pareto",
+ fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
if(!is.null(low)) if(low <= Min(object)) low <- NULL
a <- shape(object); b <- Min(object)
if(is.null(low) && is.null(upp)){
if(a<=1) return(Inf)
else return(b*a/(a-1))
- }
+ }
else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
+ return(E(object=object,fun=function(x)x, low=low, upp=upp, ...,
+ diagnostic = diagnostic))
})
### source http://mathworld.wolfram.com/ParetoDistribution.html
-setMethod("E", signature(object = "Gumbel",
- fun = "missing",
+setMethod("E", signature(object = "Gumbel",
+ fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){a <- loc(object); b <- scale(object)
+ function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ a <- loc(object); b <- scale(object)
if(is.null(low) && is.null(upp))
return(a- EULERMASCHERONICONSTANT * b)
else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
+ return(E(object=object,fun=function(x)x, low=low, upp=upp, ...,
+ diagnostic = diagnostic))
})
## http://mathworld.wolfram.com/GumbelDistribution.html
-setMethod("E", signature(object = "GPareto",
- fun = "missing",
+setMethod("E", signature(object = "GPareto",
+ fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
if(!is.null(low)) if(low <= Min(object)) low <- NULL
k <- shape(object); s <- scale(object); mu <- loc(object)
if(is.null(low) && is.null(upp)){
if(k>=1) return(Inf)
else return(mu+s/(1-k))
- }
+ }
else
- return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...))
+ return(E(object=object,fun=function(x)x, low=low, upp=upp, ...,
+ diagnostic = diagnostic))
})
### source http://en.wikipedia.org/wiki/Pareto_distribution
@@ -50,58 +59,20 @@
rel.tol= getdistrExOption("ErelativeTolerance"),
lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
- IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...
- ){
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...,
+ diagnostic = FALSE){
- dots <- list(...)
- dots.withoutUseApply <- dots
- useApply <- TRUE
- if(!is.null(dots$useApply)) useApply <- dots$useApply
+ dots <- list(...)
+ dotsI <- .filterEargs(dots)
+ dotsFun <- .filterFunargs(dots,fun)
+ funwD <- function(x) do.call(fun, c(list(x=x),dotsFun))
- dots.withoutUseApply$useApply <- NULL
- dots.withoutUseApply$stop.on.error <- NULL
-
- integrand <- function(x, dfun, ...){ di <- dim(x)
- y <- q.l(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 <- -Inf
- if(is.null(upp)) upp <- Inf
-
- Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile,
- upperTruncQuantile, IQR.fac)
- low <- p(object)(Ib["low"])
- upp <- p(object)(Ib["upp"])
- if(is.nan(low)) low <- 0
- if(is.nan(upp)) upp <- 1
-
- if(upp < 0.98){
- int <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = low,
- upper = upp,
- rel.tol = rel.tol, stop.on.error = FALSE,
- distr = object, dfun = dunif), dots.withoutUseApply))
- }else{
- int1 <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = low,
- upper = 0.98,
- rel.tol = rel.tol, stop.on.error = FALSE,
- distr = object, dfun = dunif), dots.withoutUseApply))
- int2 <- do.call(distrExIntegrate, c(list(f = integrand,
- lower = 0.98,
- upper = upp,
- rel.tol = rel.tol, stop.on.error = FALSE,
- distr = object, dfun = dunif), dots.withoutUseApply))
- int <- int1+int2
- }
-
- return(int)
-
+ do.call(.qtlIntegrate, c(list(object = object, fun = funwD, low = low, upp = upp,
+ rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile,
+ upperTruncQuantile = upperTruncQuantile,
+ IQR.fac = IQR.fac, ...,
+ .withLeftTail = FALSE, .withRightTail = TRUE,
+ diagnostic = diagnostic),dotsI))
})
setMethod("E", signature(object = "GPareto",
@@ -111,11 +82,11 @@
rel.tol= getdistrExOption("ErelativeTolerance"),
lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"),
upperTruncQuantile = getdistrExOption("EupperTruncQuantile"),
- IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...
- ){
+ IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...,
+ diagnostic = FALSE){
dots <- list(...)
- dots.withoutUseApply <- dots
+ dots.withoutUseApply <- .filterEargs(dots)
useApply <- TRUE
if(!is.null(dots$useApply)) useApply <- dots$useApply
dots.withoutUseApply$useApply <- NULL
@@ -140,24 +111,26 @@
lower = low,
upper = upp,
rel.tol = rel.tol,
- distr = object, dfun = d(object)), dots.withoutUseApply)))
+ distr = object, dfun = d(object)), dots.withoutUseApply,
+ diagnostic = diagnostic)))
})
setMethod("E", signature(object = "GEV",
- fun = "missing",
+ fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
if(!is.null(low)) if(low <= Min(object)) low <- NULL
xi <- shape(object); sigma <- scale(object); mu <- loc(object)
if(is.null(low) && is.null(upp)){
if (xi==0) return(mu+sigma*EULERMASCHERONICONSTANT)
else if(xi>=1) return(Inf)
else return(mu+sigma*(gamma(1-xi)-1)/xi)
- }
+ }
else
- return(E(object, low=low, upp=upp, fun = function(x)x, ...))
+ return(E(object, low=low, upp=upp, fun = function(x)x, ...,
+ diagnostic = diagnostic))
})
setMethod("E", signature(object = "GEV", fun = "function", cond = "missing"),
@@ -165,12 +138,14 @@
signature(object = "DistributionsIntegratingByQuantiles",
fun = "function", cond = "missing")))
-setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"),
- getMethod("E",
- signature(object = "DistributionsIntegratingByQuantiles",
- fun = "function", cond = "missing")))
+## these routines are moved back to package distrEx from distrEx 2.8.0 / RobExtremes 1.2.0 on
-setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"),
- getMethod("E",
- signature(object = "DistributionsIntegratingByQuantiles",
- fun = "function", cond = "missing")))
+#setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"),
+# getMethod("E",
+# signature(object = "DistributionsIntegratingByQuantiles",
+# fun = "function", cond = "missing")))
+
+#setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"),
+# getMethod("E",
+# signature(object = "DistributionsIntegratingByQuantiles",
+# fun = "function", cond = "missing")))
Modified: pkg/RobExtremes/R/makeIC.R
===================================================================
--- pkg/RobExtremes/R/makeIC.R 2019-03-02 16:17:26 UTC (rev 1190)
+++ pkg/RobExtremes/R/makeIC.R 2019-03-02 18:11:25 UTC (rev 1191)
@@ -1,4 +1,4 @@
-..makeIC.qtl <- function (IC, L2Fam){
+..makeIC.qtl <- function (IC, L2Fam,...){
mc <- match.call()
mcl <- as.list(mc)[-1]
mcl$IC <- IC
Modified: pkg/RobExtremes/tests/Examples/RobExtremes-Ex_i386.Rout.save
===================================================================
--- pkg/RobExtremes/tests/Examples/RobExtremes-Ex_i386.Rout.save 2019-03-02 16:17:26 UTC (rev 1190)
+++ pkg/RobExtremes/tests/Examples/RobExtremes-Ex_i386.Rout.save 2019-03-02 18:11:25 UTC (rev 1191)
@@ -308,8 +308,8 @@
loc: 0
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x18f5f030>
-<environment: 0x18f63a10>
+<bytecode: 0x18f35310>
+<environment: 0x18f377a0>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -364,8 +364,8 @@
shape: 0.5
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x13080b30>
-<environment: 0x13083780>
+<bytecode: 0x130564e0>
+<environment: 0x130581a0>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -545,8 +545,8 @@
loc: 0
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x18f5f030>
-<environment: 0x1016ecb8>
+<bytecode: 0x18f35310>
+<environment: 0x10150d58>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -757,7 +757,7 @@
{
LogDeriv(x - c(loc = 0))
}
-<environment: 0x12cae4e0>
+<environment: 0x12c820c0>
> checkL2deriv(G1)
precision of centering: 1.51181e-06
@@ -1327,12 +1327,12 @@
> system.time(print(Sn(GPareto(shape=0.5,scale=2))))
[1] 1.519379
user system elapsed
- 0.42 0.16 0.59
+ 0.36 0.23 0.59
> ## No test:
> system.time(print(Sn(as(GPareto(shape=0.5,scale=2),"AbscontDistribution"))))
[1] 1.522578
user system elapsed
- 0.52 0.00 0.52
+ 0.67 0.00 0.67
> ## End(No test)
>
>
@@ -1364,8 +1364,8 @@
shape: 0.5
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x18f5f030>
-<environment: 0x12ca73a0>
+<bytecode: 0x18f35310>
+<environment: 0x12c81e60>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -1747,7 +1747,7 @@
> cleanEx()
> options(digits = 7L)
> base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed: 23.72 1.43 26.02 NA NA
+Time elapsed: 27.42 1.58 29.83 NA NA
> grDevices::dev.off()
null device
1
Modified: pkg/RobExtremes/tests/Examples/RobExtremes-Ex_x64.Rout.save
===================================================================
--- pkg/RobExtremes/tests/Examples/RobExtremes-Ex_x64.Rout.save 2019-03-02 16:17:26 UTC (rev 1190)
+++ pkg/RobExtremes/tests/Examples/RobExtremes-Ex_x64.Rout.save 2019-03-02 18:11:25 UTC (rev 1191)
@@ -308,8 +308,8 @@
loc: 0
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x000000001a57d7b0>
-<environment: 0x000000001a57a038>
+<bytecode: 0x000000001a56e738>
+<environment: 0x000000001a563d98>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -364,8 +364,8 @@
shape: 0.5
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x000000001f82fb00>
-<environment: 0x000000001f833ec8>
+<bytecode: 0x000000001f81a3a8>
+<environment: 0x000000001f81e788>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -545,8 +545,8 @@
loc: 0
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x000000001a57d7b0>
-<environment: 0x000000001c79e528>
+<bytecode: 0x000000001a56e738>
+<environment: 0x000000001c782e50>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -757,7 +757,7 @@
{
LogDeriv(x - c(loc = 0))
}
-<environment: 0x000000001f8890f8>
+<environment: 0x000000001f8756f0>
> checkL2deriv(G1)
precision of centering: 1.51181e-06
@@ -1327,12 +1327,12 @@
> system.time(print(Sn(GPareto(shape=0.5,scale=2))))
[1] 1.519379
user system elapsed
- 0.32 0.07 0.41
+ 0.34 0.15 0.50
> ## No test:
> system.time(print(Sn(as(GPareto(shape=0.5,scale=2),"AbscontDistribution"))))
[1] 1.522578
user system elapsed
- 0.75 0.00 0.75
+ 0.85 0.00 0.90
> ## End(No test)
>
>
@@ -1364,8 +1364,8 @@
shape: 0.5
trafo:
function(x){ list(fval = tau(x), mat = Dtau(x)) }
-<bytecode: 0x000000001a57d7b0>
-<environment: 0x000000001d241a68>
+<bytecode: 0x000000001a56e738>
+<environment: 0x000000001d2301d0>
Shape parameter must not be negative.
> FisherInfo(G1)
An object of class "PosSemDefSymmMatrix"
@@ -1747,7 +1747,7 @@
> cleanEx()
> options(digits = 7L)
> base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed: 24.52 1.43 26.81 NA NA
+Time elapsed: 30.23 1.82 33.38 NA NA
> grDevices::dev.off()
null device
1
More information about the Robast-commits
mailing list