[Robast-commits] r1023 - in branches/robast-1.1/pkg/RobExtremes: R inst inst/scripts
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jul 22 19:42:52 CEST 2018
Author: ruckdeschel
Date: 2018-07-22 19:42:51 +0200 (Sun, 22 Jul 2018)
New Revision: 1023
Modified:
branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R
branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R
branches/robast-1.1/pkg/RobExtremes/R/internal-getpsi.R
branches/robast-1.1/pkg/RobExtremes/inst/NEWS
branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
Log:
[RobExtremes] branch 1.1 to gain speed, by default no longer use makeIC ...
Modified: branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-07-22 17:05:44 UTC (rev 1022)
+++ branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-07-22 17:42:51 UTC (rev 1023)
@@ -1,10 +1,15 @@
setMethod("getStartIC",signature(model = "L2ScaleShapeUnion", risk = "interpolRisk"),
function(model, risk, ...){
- mc <- match.call(expand.dots=TRUE)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
mc$neighbor <- ContNeighborhood(radius=0.5)
+ withMakeIC <- FALSE
+ if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC
+
gridn <- gsub("\\.","",type(risk))
nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="")
@@ -25,45 +30,62 @@
if(length(nsng)){
if(gridn %in% nsng){
interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
- .modifyIC0 <- function(L2Fam, IC){
+ if(withMakeIC){
+ .modifyIC0 <- function(L2Fam, IC){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi(para, interpolfct, L2Fam, type(risk)))
+ return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC))
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)
+ }
+ }
}
- attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
+ if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
.modifyIC <- function(L2Fam,IC){
psi.0 <- .modifyIC0(L2Fam,IC)
psi.0 at modifyIC <- .modifyIC
return(psi.0)
}
- attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
+ if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
if(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi(param1, interpolfct, model, type(risk))
+ IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC)
IC0 at modifyIC <- .modifyIC
return(IC0)
}
}
}
IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))
- IC <- makeIC(IC,model)
+ if(withMakeIC) IC <- makeIC(IC,model)
return(IC)
})
setMethod("getStartIC",signature(model = "L2LocScaleShapeUnion", risk = "interpolRisk"),
function(model, risk, ...){
- mc <- match.call(expand.dots=TRUE)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
mc$neighbor <- ContNeighborhood(radius=0.5)
+ withMakeIC <- FALSE
+
gridn <- gsub("\\.","",type(risk))
nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="")
@@ -80,34 +102,47 @@
if(length(nsng)){
if(gridn %in% nsng){
interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
- .modifyIC0 <- function(L2Fam, IC){
+ if(withMakeIC){
+ .modifyIC0 <- function(L2Fam, IC){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
- return(.getPsi.wL(para, interpolfct, L2Fam, type(risk)))
+ return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), withMakeIC))
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)
+ }
+ }
}
- attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
+ if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
.modifyIC <- function(L2Fam,IC){
psi.0 <- .modifyIC0(L2Fam,IC)
psi.0 at modifyIC <- .modifyIC
return(psi.0)
}
- attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
+ if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
if(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk))
+ IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk), withMakeIC)
IC0 at modifyIC <- .modifyIC
return(IC0)
}
}
}
IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))
- IC <- makeIC(IC,model)
+ if(withMakeIC) IC <- makeIC(IC,model)
return(IC)
})
Modified: branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R 2018-07-22 17:05:44 UTC (rev 1022)
+++ branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R 2018-07-22 17:42:51 UTC (rev 1023)
@@ -1,11 +1,18 @@
setMethod("getStartIC",signature(model = "ParetoFamily", risk = "interpolRisk"),
function(model, risk, ...){
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+
+ withMakeIC <- FALSE
+ if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC
+
param1 <- param(model)
xi <- main(param1)
.modifyIC0 <- function(L2Fam, IC){
xi0 <- main(param(L2Fam))
- return(.getPsi.P(xi0, L2Fam, type(risk)))
+ return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC))
}
attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE
.modifyIC <- function(L2Fam,IC){
@@ -14,12 +21,12 @@
return(psi.0)
}
attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE
- IC0 <- .getPsi.P(xi, model, type(risk))
+ IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC)
IC0 at modifyIC <- .modifyIC
return(IC0)
})
-.getPsi.P <- function(xi, L2Fam, type){
+.getPsi.P <- function(xi, L2Fam, type, withMakeIC){
## 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
@@ -70,6 +77,6 @@
IC <- generateIC(nb, L2Fam, res)
- IC <- makeIC(IC,L2Fam)
+ if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: branches/robast-1.1/pkg/RobExtremes/R/internal-getpsi.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/internal-getpsi.R 2018-07-22 17:05:44 UTC (rev 1022)
+++ branches/robast-1.1/pkg/RobExtremes/R/internal-getpsi.R 2018-07-22 17:42:51 UTC (rev 1023)
@@ -2,7 +2,7 @@
xi <- main(param)[nam]
return(is.na(fct[[1]](xi)))
}
-.getPsi <- function(param, fct, L2Fam , type){
+.getPsi <- function(param, fct, L2Fam , type, withMakeIC = FALSE){
scshnm <- scaleshapename(L2Fam)
shnam <- scshnm["shape"]
@@ -52,12 +52,12 @@
IC <- generateIC(nb, L2Fam, res)
- IC <- makeIC(IC,L2Fam)
+ if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
-.getPsi.wL <- function(param, fct, L2Fam , type){
+.getPsi.wL <- function(param, fct, L2Fam , type, withMakeIC = FALSE){
scshnm <- scaleshapename(L2Fam)
shnam <- scshnm["shape"]
@@ -109,7 +109,7 @@
IC <- generateIC(nb, L2Fam, res)
- IC <- makeIC(IC,L2Fam)
+ if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: branches/robast-1.1/pkg/RobExtremes/inst/NEWS
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/inst/NEWS 2018-07-22 17:05:44 UTC (rev 1022)
+++ branches/robast-1.1/pkg/RobExtremes/inst/NEWS 2018-07-22 17:42:51 UTC (rev 1023)
@@ -23,6 +23,7 @@
+ new script RobFitsAtRealData
+ GEVFamily, GParetoFamily and GEVFamilyMuUnknown gain argument withMDE (by default TRUE) which controls usage of MDEs at finding startPars
+ gev/gpddiag and friends (i.e. interface to ismev methods) now apply to return values of roptest
++ new argument withMakeIC to control when to use makeIC to enhance accuracy
minor changes:
+ new Rd files for now exported (formerly internal) intermediate classes
@@ -51,8 +52,7 @@
+ updated/prepared plotOutlyingness.R
+ fixed unit test suite for zero length
+ changed \dontrun in \donttest in examples
-+ wherever possible also use q.l internally instead of q to
- provide functionality in IRKernel
++ wherever possible also use q.l internally instead of q to provide functionality in IRKernel
+ in addition, now use slot locscaleshapename in generating function of GEVFamilyMuUnknown
+ new generics/methods for locationname, locscaleshapename(<-), scaleshapename, locscalename, shapename, scalename
+ use prefix evd:: to clarify which [p,d,q,r]gumbel to take
Modified: branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-07-22 17:05:44 UTC (rev 1022)
+++ branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-07-22 17:42:51 UTC (rev 1023)
@@ -25,10 +25,11 @@
MBRi
estimate(mlEi)
estimate(MBRi)
+attr(MBRi, "timings")
gev.diag(mlEi)
gev.diag(MBRi)
gev.prof(mlEi, m = 10, 4.1, 5)
-gev.profxi(mBRi, -0.3, 0.3)
+gev.profxi(MBRi, -0.3, 0.3)
plot(MBRi at pIC)
## contaminated:
@@ -95,11 +96,11 @@
gpd.prof(mlE2c, m = 10, 55, 77)
gpd.profxi(mlE2c, -0.02, 0.02)
plot(MBR2c at pIC)
-## to be fixed
+
qqplot(rainc,MBR2c)
qqplot(rainc,MBR2c,ylim=c(5,100))
qqplot(rainc,MBR2c,xlim=c(5,100),ylim=c(5,100),log="xy")
-## to be fixed
+
returnlevelplot(raini,MBR2i,MaxOrPot="POT",threshold=0)
returnlevelplot(rainc,MBR2c,MaxOrPot="POT",threshold=0)
returnlevelplot(rainc,MBR2c,ylim=c(10,100),MaxOrPot="POT",threshold=0)
@@ -114,5 +115,6 @@
returnlevelplot(rainc.10,dI2c-10,MaxOrPot="POT",threshold=0)
dI2i <- distribution(eval(MBR2i at pIC@CallL2Fam))
loc(dI2i) <- 0
+## wrong data set
qqplot(portpiriei-10,dI2i)
qqplot(portpiriec,MBR2c)
More information about the Robast-commits
mailing list