[Robast-commits] r1134 - in branches/robast-1.2/pkg/RobExtremes: R inst/scripts man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Aug 12 17:57:03 CEST 2018
Author: ruckdeschel
Date: 2018-08-12 17:57:02 +0200 (Sun, 12 Aug 2018)
New Revision: 1134
Modified:
branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R
branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R
branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R
branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R
branches/robast-1.2/pkg/RobExtremes/R/makeIC.R
branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd
Log:
[RobEstremes] branch 2.8
+ 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 asvarMedkMAD we now use distr::solve
+ in the getStartIC methods for interpolators, 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
+ makeIC also gains ... argument
Modified: branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -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: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -26,36 +26,36 @@
if(length(nsng)){
if(gridn %in% nsng){
interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
- rm(famg, nsgn, gridn)
+ 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 = withMakeIC))
+ return(.getPsi(para, interpolfct, L2Fam, type(risk)))
else{
IC0 <- do.call(getStartIC, as.list(mc[-1]),
envir=parent.frame(2))
- if(withMakeIC) IC0 <- makeIC(IC0, L2Fam)
return(IC0)
}
}
- .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){
- psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC)
+ .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(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC = withMakeIC)
+ IC0 <- .getPsi(param1, interpolfct, model, type(risk))
IC0 at modifyIC <- .modifyIC
+ if(withMakeIC) IC0 <- makeIC(IC0, model, ...)
return(IC0)
}
rm(mc)
}
}
- rm(famg, nsgn,gridn)
+ 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)
})
@@ -78,39 +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")]]
- .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){
+ 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 = withMakeIC))
+ return(.getPsi.wL(para, interpolfct, L2Fam, type(risk)))
else{
IC0 <- do.call(getStartIC, as.list(mc[-1]),
envir=parent.frame(2))
- if(withMakeIC) IC0 <- makeIC(IC0, L2Fam)
return(IC0)
}
}
- .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){
- psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC)
+ .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(!.is.na.Psi(param1, interpolfct, shnam)){
- IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk),
- withMakeIC = 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: branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -3,21 +3,23 @@
param1 <- param(model)
xi <- main(param1)
- .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){
+ .modifyIC0 <- function(L2Fam, IC){
xi0 <- main(param(L2Fam))
- return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC = withMakeIC))
+ return(.getPsi.P(xi0, L2Fam, type(risk)))
}
- .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){
- psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC)
+ .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)
}
- IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC = 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
@@ -68,6 +70,5 @@
IC <- generateIC(nb, L2Fam, res)
- if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -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)
@@ -61,12 +61,11 @@
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 +95,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)
@@ -128,7 +127,6 @@
IC <- generateIC(nb, L2Fam, res)
- if(withMakeIC) IC <- makeIC(IC,L2Fam)
return(IC)
}
Modified: branches/robast-1.2/pkg/RobExtremes/R/makeIC.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/R/makeIC.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/R/makeIC.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -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: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 15:57:02 UTC (rev 1134)
@@ -54,8 +54,17 @@
checkIC(pIC(RMXi))
system.time(RMXiw <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE))
checkIC(pIC(RMXiw))
+## uses contIC 0 - 1 standardization...
+## for a moment remove this method
+oldM <- setMethod("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
+
estimate(RMXi)
estimate(RMXiw)
+estimate(RMXiw2)
## our output:
mlEi
Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd
===================================================================
--- branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd 2018-08-12 15:54:52 UTC (rev 1133)
+++ branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd 2018-08-12 15:57:02 UTC (rev 1134)
@@ -19,9 +19,9 @@
to be stored in the respective \file{sysdata.rda} file. }
\usage{
-.getPsi(param, fct, L2Fam , type, withMakeIC)
-.getPsi.wL(param, fct, L2Fam , type, withMakeIC)
-.getPsi.P(xi, L2Fam , type, withMakeIC)
+.getPsi(param, fct, L2Fam , type)
+.getPsi.wL(param, fct, L2Fam , type)
+.getPsi.P(xi, L2Fam , type)
.is.na.Psi(param, fct, nam = "shape")
@@ -102,8 +102,6 @@
\item{namFzus}{character; infix for the name of the \file{.csv}-File
to which the results are written; used to split the
work on xi-grids into chunks.}
- \item{withMakeIC}{logical; if \code{TRUE} the [p]IC is passed through
- \code{makeIC} before return.}
}
\details{
\code{.getpsi} reads the respective interpolating function
More information about the Robast-commits
mailing list