[Robast-commits] r1186 - in pkg/RobExtremes: . R inst inst/scripts man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 2 17:06:31 CET 2019
Author: ruckdeschel
Date: 2019-03-02 17:06:30 +0100 (Sat, 02 Mar 2019)
New Revision: 1186
Modified:
pkg/RobExtremes/DESCRIPTION
pkg/RobExtremes/NAMESPACE
pkg/RobExtremes/R/AllClass.R
pkg/RobExtremes/R/AllShow.R
pkg/RobExtremes/R/GEV.R
pkg/RobExtremes/R/GPareto.R
pkg/RobExtremes/R/Gumbel.R
pkg/RobExtremes/R/Pareto.R
pkg/RobExtremes/R/asvarMedkMAD.R
pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R
pkg/RobExtremes/R/getStartIC.R
pkg/RobExtremes/R/getStartICPareto.R
pkg/RobExtremes/R/gevgpddiag.R
pkg/RobExtremes/R/internal-getpsi.R
pkg/RobExtremes/R/startEstGEV.R
pkg/RobExtremes/inst/NEWS
pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
pkg/RobExtremes/man/0RobExtremes-package.Rd
pkg/RobExtremes/man/E.Rd
pkg/RobExtremes/man/GEV-class.Rd
pkg/RobExtremes/man/GEVFamily.Rd
pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
pkg/RobExtremes/man/GPareto-class.Rd
pkg/RobExtremes/man/Gumbel-class.Rd
pkg/RobExtremes/man/Pareto-class.Rd
pkg/RobExtremes/man/internal-interpolate.Rd
pkg/RobExtremes/man/internal-methods.Rd
pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd
Log:
preparation for release of 1.2: merged back RobExtremes from branch 1.2 to trunk
Modified: pkg/RobExtremes/DESCRIPTION
===================================================================
--- pkg/RobExtremes/DESCRIPTION 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/DESCRIPTION 2019-03-02 16:06:30 UTC (rev 1186)
@@ -1,13 +1,14 @@
Package: RobExtremes
-Version: 1.1.0
-Date: 2018-08-03
+Version: 1.2.0
+Date: 2019-03-01
Title: Optimally Robust Estimation for Extreme Value Distributions
Description: Optimally robust estimation for extreme value distributions using S4 classes and
methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and
'ROptEst').
-Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd
-Suggests: RUnit (>= 0.4.26), ismev (>= 1.39)
-Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar
+Depends: R(>= 2.14.0), methods, distrMod(>= 2.8.0), ROptEst(>= 1.2.0), robustbase, evd
+Suggests: RUnit(>= 0.4.26), ismev(>= 1.39)
+Enhances: fitdistrplus(>= 1.0-9)
+Imports: RobAStRDA, distr, distrEx(>= 2.8.0), RandVar, RobAStBase(>= 1.2.0), startupmsg, actuar
Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl",
role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"),
person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of
@@ -26,4 +27,4 @@
URL: http://robast.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-VCS/SVNRevision: 1091
+VCS/SVNRevision: 1178
Modified: pkg/RobExtremes/NAMESPACE
===================================================================
--- pkg/RobExtremes/NAMESPACE 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/NAMESPACE 2019-03-02 16:06:30 UTC (rev 1186)
@@ -32,7 +32,10 @@
exportClasses("GPDEstimate","GPDMCEstimate","GPDLDEstimate",
"GPDkStepEstimate","GEVEstimate","GEVLDEstimate",
"GEVkStepEstimate","GEVMCEstimate",
- "GPDORobEstimate","GEVORobEstimate")
+ "GPDORobEstimate","GEVORobEstimate",
+ GEVCvMMD.ALEstimate,GEVML.ALEstimate,
+ GPDCvMMD.ALEstimate,GPDML.ALEstimate)
+
exportMethods("initialize", "show", "rescaleFunction")
exportMethods("loc", "loc<-", "kMAD", "Sn", "Qn")
exportMethods("validParameter",
@@ -45,10 +48,10 @@
exportMethods(".checkEstClassForParamFamily")
exportMethods("locscaleshapename","locscalename","scaleshapename",
"locationname","scalename","shapename","locscaleshapename<-")
-exportMethods("modifyModel", "getStartIC")
+exportMethods("modifyModel", "getStartIC", "coerce")
exportMethods("moveL2Fam2RefParam",
"moveICBackFromRefParam")
-exportMethods("checkIC", "makeIC")
+exportMethods("checkIC", "makeIC", "liesInSupport")
export("EULERMASCHERONICONSTANT","APERYCONSTANT")
export("getCVaR", "getVaR", "getEL")
export("Gumbel", "Pareto", "GPareto", "GEV")
Modified: pkg/RobExtremes/R/AllClass.R
===================================================================
--- pkg/RobExtremes/R/AllClass.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/AllClass.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -284,13 +284,22 @@
setOldClass("gev.fit")
setOldClass("gpd.fit")
+
setClass("GPDEstimate", contains="Estimate")
setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate"))
+setClass("GPDML.ALEstimate", contains=c("ML.ALEstimate", "GPDEstimate"))
+setClass("GPDCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GPDEstimate"))
setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate"))
setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate"))
setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate"))
+setClass("GPDMDEstimate", contains=c("MDEstimate", "GPDEstimate"))
+
setClass("GEVEstimate", contains="Estimate")
setClass("GEVLDEstimate", contains=c("LDEstimate", "GEVEstimate"))
setClass("GEVkStepEstimate", contains=c("kStepEstimate", "GEVEstimate"))
setClass("GEVORobEstimate", contains=c("ORobEstimate", "GEVkStepEstimate"))
setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate"))
+setClass("GEVML.ALEstimate", contains=c("ML.ALEstimate", "GEVEstimate"))
+setClass("GEVCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GEVEstimate"))
+setClass("GEVMDEstimate", contains=c("MDEstimate", "GEVEstimate"))
+
Modified: pkg/RobExtremes/R/AllShow.R
===================================================================
--- pkg/RobExtremes/R/AllShow.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/AllShow.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -2,7 +2,7 @@
setMethod("show", "LDEstimate",
function(object){
digits <- getOption("digits")
- show(as(object,"Estimate"))
+ getMethod("show","Estimate")(object)
if(getdistrModOption("show.details")!="minimal"){
cat("Location:", object at location, "\n")
cat("Dispersion:", object at dispersion, "\n")
Modified: pkg/RobExtremes/R/GEV.R
===================================================================
--- pkg/RobExtremes/R/GEV.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/GEV.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -33,7 +33,6 @@
scale(x at param))
setMethod("shape", "GEV", function(object) shape(object at param))
-
## wrapped replace methods
setMethod("loc<-", "GEV", function(object, value)
new("GEV", loc = value, scale = scale(object), shape = shape(object)))
@@ -58,6 +57,14 @@
else return(TRUE)
})
+setMethod("liesInSupport", signature(object = "GEV",
+ x = "numeric"),
+ function(object, x, checkFin = TRUE){
+ loc=loc(object); scale=scale(object); shape=shape(object)
+ if(shape>0) return(is.finite(x)&(x>= loc-scale/shape))
+ if(shape<0) return(is.finite(x)&(x<= loc-scale/shape))
+ if(abs(shape)<1e-8) return(is.finite(x))})
+
## generating function
GEV <- function(loc = 0, scale = 1, shape = 0, location = loc){
if(!missing(loc)&&!missing(location))
Modified: pkg/RobExtremes/R/GPareto.R
===================================================================
--- pkg/RobExtremes/R/GPareto.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/GPareto.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -58,6 +58,13 @@
else return(TRUE)
})
+setMethod("liesInSupport", signature(object = "GPareto",
+ x = "numeric"),
+ function(object, x, checkFin = TRUE){
+ loc=loc(object); scale=scale(object); shape=shape(object)
+ if(shape>=0) return(is.finite(x)&(x>= loc))
+ if(shape<0) return(is.finite(x)&(x<= loc-scale/shape)&(x>=loc))})
+
## generating function
GPareto <- function(loc = 0, scale = 1, shape = 0, location = loc){
if(!missing(loc)&&!missing(location))
Modified: pkg/RobExtremes/R/Gumbel.R
===================================================================
--- pkg/RobExtremes/R/Gumbel.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/Gumbel.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -9,6 +9,9 @@
setReplaceMethod("scale", "GumbelParameter",
function(object, value){ object at scale <- value; object})
+setMethod("liesInSupport", signature(object = "Gumbel",
+ x = "numeric"),
+ function(object, x, checkFin = TRUE){is.finite(x)})
## generating function
Gumbel <- function(loc = 0, scale = 1){ new("Gumbel", loc = loc, scale = scale) }
Modified: pkg/RobExtremes/R/Pareto.R
===================================================================
--- pkg/RobExtremes/R/Pareto.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/Pareto.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -36,6 +36,10 @@
else return(TRUE)
})
+setMethod("liesInSupport", signature(object = "Pareto",
+ x = "numeric"),
+ function(object, x, checkFin = TRUE){is.finite(x)&(x>=0)})
+
################################
## .Object at img <- new("Naturals")
Modified: pkg/RobExtremes/R/asvarMedkMAD.R
===================================================================
--- pkg/RobExtremes/R/asvarMedkMAD.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/asvarMedkMAD.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -54,7 +54,7 @@
D1 <- matrix(c(dG1_beta,dG2_beta,dG1_xi,dG2_xi),2,2)
D2 <- matrix(c(dG1_M,dG2_M,dG1_m,dG2_m),2,2)
- D <- -solve(D1)%*%D2
+ D <- - distr::solve(D1)%*%D2
}else{
psi_med <- function(x) (0.5-(x<=m))/dm
psi_kMad <- function(x){
@@ -71,7 +71,7 @@
E12 <- E(distribution(model),fun=function(x) psi_kMad(x) * L_xi.f(x))
E21 <- E(distribution(model),fun=function(x) psi_med(x) * L_beta.f(x))
E22 <- E(distribution(model),fun=function(x) psi_med(x) * L_xi.f(x))
- D <- solve(matrix(c(E11,E21,E12,E22),2,2))
+ D <- distr::solve(matrix(c(E11,E21,E12,E22),2,2))
}
ASV_Med <- PosSemDefSymmMatrix(D %*% V %*% t(D))
Modified: pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R
===================================================================
--- pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -1,3 +1,12 @@
+.castToALE <- function(PFam, estimator, toclass){
+ fromSlotNames <- slotNames(class(estimator))
+ to <- new(toclass)
+ for(item in fromSlotNames) slot(to, item) <- slot(estimator,item)
+ to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator))
+ return(to)
+}
+
+
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GParetoFamily",estimator="Estimate"),
function(PFam, estimator) as(estimator,"GPDEstimate"))
@@ -14,6 +23,17 @@
signature=signature(PFam="GParetoFamily",estimator="MCEstimate"),
function(PFam, estimator) as(estimator,"GPDMCEstimate"))
setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GParetoFamily",estimator="MDEstimate"),
+ function(PFam, estimator) as(estimator,"GPDMDEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GParetoFamily",estimator="MLEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GPDML.ALEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GParetoFamily",estimator="CvMMDEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate"))
+
+
+setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamily",estimator="Estimate"),
function(PFam, estimator) as(estimator,"GEVEstimate"))
setMethod(".checkEstClassForParamFamily",
@@ -29,6 +49,17 @@
signature=signature(PFam="GEVFamily",estimator="MCEstimate"),
function(PFam, estimator) as(estimator,"GEVMCEstimate"))
setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamily",estimator="MDEstimate"),
+ function(PFam, estimator) as(estimator,"GEVMDEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamily",estimator="MLEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamily",estimator="CvMMDEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GEVCvMMD.ALEstimate"))
+
+
+setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamilyMuUnknown",estimator="Estimate"),
function(PFam, estimator) as(estimator,"GEVEstimate"))
setMethod(".checkEstClassForParamFamily",
@@ -43,3 +74,12 @@
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"),
function(PFam, estimator) as(estimator,"GEVMCEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamilyMuUnknown",estimator="MDEstimate"),
+ function(PFam, estimator) as(estimator,"GEVMDEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamilyMuUnknown",estimator="MLEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate"))
+setMethod(".checkEstClassForParamFamily",
+ signature=signature(PFam="GEVFamilyMuUnknown",estimator="CvMMDEstimate"),
+ function(PFam,estimator) .castToALE(PFam, estimator, "GEVCvMMD.ALEstimate") )
Modified: pkg/RobExtremes/R/getStartIC.R
===================================================================
--- pkg/RobExtremes/R/getStartIC.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/getStartIC.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -26,48 +26,36 @@
if(length(nsng)){
if(gridn %in% nsng){
interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
- if(withMakeIC){
- .modifyIC0 <- function(L2Fam, IC){
+ rm(famg, nsng, gridn)
+ .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC))
+ return(.getPsi(para, interpolfct, L2Fam, type(risk)))
else{
IC0 <- do.call(getStartIC, as.list(mc[-1]),
envir=parent.frame(2))
- IC0 <- makeIC(IC0, L2Fam)
return(IC0)
}
- }
- }else{
- .modifyIC0 <- function(L2Fam, IC){
- para <- param(L2Fam)
- if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC))
- else{
- IC0 <- do.call(getStartIC, as.list(mc[-1]),
- envir=parent.frame(2))
- return(IC0)
- }
- }
}
- if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
-
- .modifyIC <- function(L2Fam,IC){
+ .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){
psi.0 <- .modifyIC0(L2Fam,IC)
psi.0 at modifyIC <- .modifyIC
+ if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...)
return(psi.0)
}
- if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
if(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC)
+ IC0 <- .getPsi(param1, interpolfct, model, type(risk))
IC0 at modifyIC <- .modifyIC
+ if(withMakeIC) IC0 <- makeIC(IC0, model, ...)
return(IC0)
}
+ rm(mc)
}
}
+ rm(famg, nsng,gridn)
IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))
- if(withMakeIC) IC <- makeIC(IC,model)
+ if(withMakeIC) IC <- makeIC(IC,model,...)
return(IC)
})
@@ -79,7 +67,6 @@
mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
mc$neighbor <- ContNeighborhood(radius=0.5)
-
gridn <- gsub("\\.","",type(risk))
nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="")
@@ -91,52 +78,39 @@
shnam <- locscshnm["shape"]
nsng <- character(0)
famg <- try(getFromNamespace(nam, ns = "RobAStRDA"), silent=TRUE)
- #sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE)
if(!is(famg,"try-error")) nsng <- names(famg)
if(length(nsng)){
if(gridn %in% nsng){
interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
- if(withMakeIC){
- .modifyIC0 <- function(L2Fam, IC){
+ rm(famg, nsng, gridn)
+ .modifyIC0 <- function(L2Fam, IC){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), withMakeIC))
+ return(.getPsi.wL(para, interpolfct, L2Fam, type(risk)))
else{
IC0 <- do.call(getStartIC, as.list(mc[-1]),
envir=parent.frame(2))
- IC0 <- makeIC(IC0, L2Fam)
return(IC0)
}
- }
- }else{
- .modifyIC0 <- function(L2Fam, IC){
- para <- param(L2Fam)
- if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), withMakeIC))
- else{
- IC0 <- do.call(getStartIC, as.list(mc[-1]),
- envir=parent.frame(2))
- return(IC0)
- }
- }
}
- if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
- .modifyIC <- function(L2Fam,IC){
+ .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){
psi.0 <- .modifyIC0(L2Fam,IC)
psi.0 at modifyIC <- .modifyIC
+ if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...)
return(psi.0)
}
- if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
if(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk), withMakeIC)
+ IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk))
IC0 at modifyIC <- .modifyIC
+ if(withMakeIC) IC0 <- makeIC(IC0, model, ...)
return(IC0)
}
}
}
+ rm(famg, nsng,gridn)
IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))
- if(withMakeIC) IC <- makeIC(IC,model)
+ if(withMakeIC) IC <- makeIC(IC,model,...)
return(IC)
})
Modified: pkg/RobExtremes/R/getStartICPareto.R
===================================================================
--- pkg/RobExtremes/R/getStartICPareto.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/getStartICPareto.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -5,21 +5,21 @@
xi <- main(param1)
.modifyIC0 <- function(L2Fam, IC){
xi0 <- main(param(L2Fam))
- return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC))
+ return(.getPsi.P(xi0, L2Fam, type(risk)))
}
- attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
- .modifyIC <- function(L2Fam,IC){
+ .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){
psi.0 <- .modifyIC0(L2Fam,IC)
psi.0 at modifyIC <- .modifyIC
+ if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...)
return(psi.0)
}
- attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
- IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC)
+ IC0 <- .getPsi.P(xi, model, type(risk))
IC0 at modifyIC <- .modifyIC
+ if(withMakeIC) IC0 <- makeIC(IC0, model, ...)
return(IC0)
})
-.getPsi.P <- function(xi, L2Fam, type, withMakeIC){
+.getPsi.P <- function(xi, L2Fam, type){
## the respective LMs have been computed ahead of time
## and stored in sysdata.rda of this package
## the code for this computation is in AddMaterial/getLMPareto.R
@@ -63,13 +63,16 @@
}else weight(w) <- minbiasweight(w, neighbor = nb, biastype = biast,
normW = normt)
+ Risk <- list(asBias = list(value = b, biastype = biast,
+ normtype = normt,
+ neighbortype = class(nb)))
+
res <- list(a = a, A = A, b = b, d = 0*a,
normtype = normt, biastype = biast, w = w,
- info = c("optIC", ICT), risk = list(),
+ info = c("optIC", ICT), risk = Risk,
modifyIC = NULL)
IC <- generateIC(nb, L2Fam, res)
- if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: pkg/RobExtremes/R/gevgpddiag.R
===================================================================
--- pkg/RobExtremes/R/gevgpddiag.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/gevgpddiag.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -74,7 +74,7 @@
es.call <- z at estimate.call
nm.call <- names(es.call)
if("pIC" %in% names(getSlots(class(z)))){
- PFam0 <- eval(z at pIC@CallL2Fam)
+ PFam0 <- eval(pIC(z)@CallL2Fam)
}else{
PFam <- NULL
if("ParamFamily" %in% nm.call)
Modified: pkg/RobExtremes/R/internal-getpsi.R
===================================================================
--- pkg/RobExtremes/R/internal-getpsi.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/internal-getpsi.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -2,7 +2,7 @@
xi <- main(param)[nam]
return(is.na(fct[[1]](xi)))
}
-.getPsi <- function(param, fct, L2Fam , type, withMakeIC = FALSE){
+.getPsi <- function(param, fct, L2Fam , type){
scshnm <- scaleshapename(L2Fam)
shnam <- scshnm["shape"]
@@ -29,7 +29,7 @@
ai <- Ai %*% zi
Am <- (Ai+Aa)/2; Ai <- Aa <- Am
am <- (ai+aa)/2; ai <- aa <- am
- zi <- solve(Ai,ai)
+ zi <- distr::solve(Ai,ai)
}
a <- c(.dbeta%*%aa)
aw <- c(.dbeta1%*%zi)
@@ -53,20 +53,22 @@
normW = normt)
}else weight(w) <- minbiasweight(w, neighbor = nb, biastype = biast,
normW = normt)
+ Risk <- list(asBias = list(value = b, biastype = biast,
+ normtype = normt,
+ neighbortype = class(nb)))
res <- list(a = a, A = A, b = b, d = 0*a,
normtype = normt, biastype = biast, w = w,
- info = c("optIC", ICT), risk = list(),
+ info = c("optIC", ICT), risk = Risk,
modifyIC = NULL)
IC <- generateIC(nb, L2Fam, res)
- if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
-.getPsi.wL <- function(param, fct, L2Fam , type, withMakeIC = FALSE){
+.getPsi.wL <- function(param, fct, L2Fam , type){
scshnm <- scaleshapename(L2Fam)
shnam <- scshnm["shape"]
@@ -96,7 +98,7 @@
ai <- Ai %*% zi
Am <- (Ai+Aa)/2; Ai <- Aa <- Am
am <- (ai+aa)/2; ai <- aa <- am
- zi <- solve(Ai,ai)
+ zi <- distr::solve(Ai,ai)
}
a <- c(.dbeta%*%aa)
aw <- c(.dbeta1%*%zi)
@@ -121,14 +123,17 @@
}else weight(w) <- minbiasweight(w, neighbor = nb, biastype = biast,
normW = normt)
+ Risk <- list(asBias = list(value = b, biastype = biast,
+ normtype = normt,
+ neighbortype = class(nb)))
+
res <- list(a = a, A = A, b = b, d = 0*a,
normtype = normt, biastype = biast, w = w,
- info = c("optIC", ICT), risk = list(),
+ info = c("optIC", ICT), risk = Risk,
modifyIC = NULL)
IC <- generateIC(nb, L2Fam, res)
- if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- pkg/RobExtremes/R/startEstGEV.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/R/startEstGEV.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -30,14 +30,15 @@
names(e0) <- c("scale","shape")
return(e0)
}
- mygev <- GEVFamily(loc=0,scale=e0[1],shape=e0[2], withPos=withPos,
+ mygev <- GEVFamily(loc=0,scale=e0[1],shape=e0[2],
+ withPos=withPos,
start0Est = fu, ..withWarningGEV=FALSE)
mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=e0[1],"shape"=e0[2])),silent=TRUE)
if(!is(mde0,"try-error")){
es <- estimate(mde0)
crit1 <- criterion(mde0)
if(.issueIntermediateParams){
- cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), , " ")
+ cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), "\n")
}
if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
validi <- 1
@@ -114,8 +115,8 @@
}
}
}
- names(es) <- c("scale","shape")
- return(es)
+ names(es0) <- c("scale","shape")
+ return(es0)
}
.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7,
Modified: pkg/RobExtremes/inst/NEWS
===================================================================
--- pkg/RobExtremes/inst/NEWS 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/inst/NEWS 2019-03-02 16:06:30 UTC (rev 1186)
@@ -8,6 +8,44 @@
information)
#######################################
+version 1.2
+#######################################
+
+user-visible CHANGES:
++ return object of roptest (with interpolRisks) now contains information on its bias,
+ so can, e.g., be used in confint with accounting for possible bias
+
+bugfixes:
++ Bernhard discovered a bug in ".checkEstClassForParamFamily" for GEV (was GPD instead of GEV)
++ there were no classes [GPD/GEV]MDEstimate -> fixed now
+
+under the hood
++ moved quantile integration methods for expectation for Weibull and
+ Gamma distribution to pkg distrEx (>= 2.8.0)
++ in asvarMedkMAD we now use distr::solve
++ made a helper function .qtlIntegrate out of existing code in
+ RobExtremes 1.1.0 and moved it to distrEx where it is exported
+ from version 2.8.0; it is reused in RobExtremes for the GEV methods
++ as with the interpolating - getStartIC methods in ROptEst,
+ the makeIC-task is removed from the inner .modifyIC.0 function and
+ delegated to the outer .modifyIC , so .getPsi, getPsi.wL, and
+ .getPsi.P loose their argument withMakeIC
++ in the getStartIC methods for interpolRisks, we now produce slots modifyIC with argument
+ withMakeIC (as before) and with "..." to pass on arguments to E() (e.g., when makeIC is called)
++ the timings are now about ~ 2s per estimator for GEV and GPD and check/makeIC are much faster
++ script updated
++ the makeIC methods for GPD/GEV... also gain an "..." argument
++ fixed minor issues in scripts/RobFitsAtRealData.R
++ expectation E() of Pareto, GPD, and GEV gain argument diagnostic and use dot-filtering (like in distrEx)
++ minor bugfixes in .getBetaXiGEW
++ new S4 classes
+ "GPDML.ALEstimate", "GPDCvMMD.ALEstimate", and "GEVML.ALEstimate", "GEVCvMMD.ALEstimate"
+ deleted classes "GPDMCALEstimate", "GEVMCALEstimate" as not every MCE is an ALE -> this gave misleading error messages
++ warning/caveat in the help to GEVFamily/GEVFamilyMuUnknown as to the accuracy of PickandsEstimator for GEV
++ introduced particular liesInSupport methods for Gumbel, Pareto, GPareto, and GEV
+
+
+#######################################
version 1.1
#######################################
@@ -76,7 +114,7 @@
realized in startEstGEV.R : a CvM-MDE with xi varying on a grid...
+ provide wrapper for ismev-diagnostics ie gev.diag, gev.prof, gev.profxi,
gpd.diag, gpd.prof, gpd.profxi
-
+
GENERAL ENHANCEMENTS:
under the hood:
Modified: pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
===================================================================
--- pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2019-03-02 16:06:30 UTC (rev 1186)
@@ -7,8 +7,8 @@
require(fitdistrplus) ## for dataset groundbeef
-help(package="RobExtremes")
-help("RobExtremes-package")
+#help(package="RobExtremes")
+#help("RobExtremes-package")
#----------------------------------------
## data sets
@@ -46,6 +46,17 @@
system.time(MBRi <- MBREstimator(portpiriei, GEVFam))
## synonymous to
## system.time(MBRi0 <- roptest(portpiriei, GEVFam,risk=MBRRisk()))
+
+## some diagnostics as to timings and integrations:
+system.time(MBRiD <- MBREstimator(portpiriei, GEVFam, diagnostic = TRUE))
+showDiagnostic(MBRiD)
+timings(MBRiD)
+kStepTimings(MBRiD)
+(int.times <- getDiagnostic(MBRiD, what="time"))
+
+IC <- pIC(MBRiD)
+es <- checkIC(IC,diagnostic = TRUE)
+
system.time(RMXi <- RMXEstimator(portpiriei, GEVFam))
## synonymous to
## system.time(RMXi <- roptest(portpiriei, GEVFam,risk=RMXRRisk()))
@@ -53,9 +64,20 @@
## little to the situation where we enforce IC conditions
checkIC(pIC(RMXi))
system.time(RMXiw <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE))
-checkIC(pIC(RMXiw))
+checkIC(pIC(RMXiw), forceContICMethod = TRUE)
+## uses contIC 0 - 1 standardization...
+## for a moment remove this method
+oldM <- getMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"))
+removeMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"))
+system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE))
+checkIC(pIC(RMXiw2))
+setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),oldM)
+erg <- getMethod("checkIC", signature(IC = "IC", L2Fam = "missing"))(pIC(RMXiw2),
+ out=TRUE, diagnostic=TRUE)
+
estimate(RMXi)
estimate(RMXiw)
+estimate(RMXiw2)
## our output:
mlEi
@@ -69,8 +91,6 @@
estimate(MBRi)
estimate(RMXi)
estimate(RMXiw)
-### where do the robust estimators spend their time?
-attr(MBRi, "timings")
## our return values can be plugged into ismev-diagnostics:
devNew()
@@ -164,13 +184,9 @@
gev.profxi(mlEc, -0.3, 0.3)
## diagnostics from pkg 'distrMod'/'RobAStBase'
-devNew()
qqplot(portpiriec,MBRc)
-devNew()
qqplot(portpiriec,MBRc,ylim=c(3.5,5))
-devNew()
returnlevelplot(portpiriec,MBRc)
-devNew()
returnlevelplot(portpiriec,MBRc,ylim=c(3.5,5))
## here the MBR-IC looks as follows
@@ -237,48 +253,33 @@
devNew()
plot(pIC(MBR2c))
-devNew()
qqplot(rainc,MBR2c)
-devNew()
qqplot(rainc,MBR2c,ylim=c(5,100))
-devNew()
qqplot(rainc,MBR2c,xlim=c(5,100),ylim=c(5,100),log="xy")
-devNew()
qqplot(rainc,MBR2c,xlim=c(5,100),ylim=c(5,100),log="xy",
cex.pts=2,col.pts="blue",with.lab=TRUE,cex.lbs=.9,which.Order=1:3)
-devNew()
returnlevelplot(raini,MBR2i,MaxOrPot="POT",threshold=0)
-devNew()
returnlevelplot(raini,MBR2i,MaxOrPot="POT",threshold=0, withLab=TRUE, cex.lbl=0.8)
-devNew()
returnlevelplot(rainc,MBR2c,MaxOrPot="POT",threshold=0)
-devNew()
returnlevelplot(rainc,MBR2c,ylim=c(10,100),MaxOrPot="POT",threshold=0)
#
L2F <- eval(MBR2c at pIC@CallL2Fam)
dI2c <- L2F at distribution
-devNew()
qqplot(rainc,dI2c)
rainc.10 <- rainc-10
-devNew()
qqplot(rainc.10,dI2c-10)
-devNew()
returnlevelplot(rainc.10,dI2c-10,MaxOrPot="POT",threshold=0)
## wrong data set
dI2i <- distribution(eval(MBR2i at pIC@CallL2Fam))
loc(dI2i) <- 0
-devNew()
qqplot(portpiriei-10,dI2i)
-devNew()
qqplot(portpiriec,MBR2c)
### all points are red
## right data set
-devNew()
qqplot(raini-10,dI2i)
-devNew()
qqplot(rainc,MBR2c)
@@ -291,11 +292,8 @@
PM <- ParetoFamily(Min=2)
mlE3i <- MLEstimator(x,PM)
mlE3c <- MLEstimator(xc,PM)
-devNew()
qqplot(x, mlE3i, log="xy")
-devNew()
qqplot(xc, mlE3c, log="xy")
-devNew()
returnlevelplot(x, mlE3i, MaxOrPOT="POT",ylim=c(1,1e5),log="y")
system.time(MBR3i <- MBREstimator(x, PM))
@@ -339,9 +337,7 @@
plot(pIC(MBR4i))
devNew()
plot(pIC(RMX4i))
-devNew()
qqplot(grbsi, RMX4i)
-devNew()
qqplot(grbsc, RMX4c, log="xy")
#######################################################
@@ -350,13 +346,13 @@
GF <- GammaFamily()
system.time(mlE5i <- MLEstimator(grbsi, GF))
-system.time(OMS5i <- MBREstimator(grbsi, GF))
-system.time(RMX5i <- OMSEstimator(grbsi, GF))
-system.time(MBR5i <- RMXEstimator(grbsi, GF))
+system.time(MBR5i <- MBREstimator(grbsi, GF))
+system.time(OMS5i <- OMSEstimator(grbsi, GF))
+system.time(RMX5i <- RMXEstimator(grbsi, GF))
system.time(mlE5c <- MLEstimator(grbsc, GF))
-system.time(OMS5c <- MBREstimator(grbsc, GF))
-system.time(RMX5c <- OMSEstimator(grbsc, GF))
-system.time(MBR5c <- RMXEstimator(grbsc, GF))
+system.time(MBR5c <- MBREstimator(grbsc, GF))
+system.time(OMS5c <- OMSEstimator(grbsc, GF))
+system.time(RMX5c <- RMXEstimator(grbsc, GF))
estimate(mlE5i)
estimate(RMX5i)
estimate(OMS5i)
@@ -371,7 +367,5 @@
plot(pIC(RMX5i))
devNew()
plot(pIC(MBR5i))
-devNew()
qqplot(grbsi, RMX5i)
-devNew()
qqplot(grbsc, RMX5c, log="xy")
Modified: pkg/RobExtremes/man/0RobExtremes-package.Rd
===================================================================
--- pkg/RobExtremes/man/0RobExtremes-package.Rd 2019-03-02 16:06:02 UTC (rev 1185)
+++ pkg/RobExtremes/man/0RobExtremes-package.Rd 2019-03-02 16:06:30 UTC (rev 1186)
@@ -102,8 +102,8 @@
\details{
\tabular{ll}{
Package: \tab RobExtremes \cr
-Version: \tab 1.1.0 \cr
-Date: \tab 2018-08-03 \cr
+Version: \tab 1.2.0 \cr
+Date: \tab 2019-03-01 \cr
Title: \tab Optimally Robust Estimation for Extreme Value Distributions\cr
Description: \tab Optimally robust estimation for extreme value distributions
using S4 classes and methods \cr
@@ -130,7 +130,7 @@
License: \tab LGPL-3 \cr
URL: \tab http://robast.r-forge.r-project.org/\cr
Encoding: \tab latin1 \cr
-VCS/SVNRevision: \tab 1091 \cr
+VCS/SVNRevision: \tab 1178 \cr
}
}
Modified: pkg/RobExtremes/man/E.Rd
===================================================================
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1186
More information about the Robast-commits
mailing list