[Robast-commits] r997 - branches/robast-1.1/pkg/RobExtremes/inst/AddMaterial

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

Author: ruckdeschel
Date: 2018-07-20 14:27:03 +0200 (Fri, 20 Jul 2018)
New Revision: 997

Added:
   branches/robast-1.1/pkg/RobExtremes/inst/AddMaterial/getLMPareto.R
Log:
[RobExtremes] branch 1.1 code for the computation of LMs for Pareto

Added: branches/robast-1.1/pkg/RobExtremes/inst/AddMaterial/getLMPareto.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/inst/AddMaterial/getLMPareto.R	                        (rev 0)
+++ branches/robast-1.1/pkg/RobExtremes/inst/AddMaterial/getLMPareto.R	2018-07-20 12:27:03 UTC (rev 997)
@@ -0,0 +1,50 @@
+### getLMs for Pareto
+.checkIC <- function(IC,L2deriv,Distr){
+   IC. <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
+   IC.. <- function(x) sapply(x,function(y) c(IC. at Map[[1]](q.l(Distr)(y))))
+   IC2. <- IC. %*% t(L2deriv)
+   IC2.. <- function(x) sapply(x,function(y) c(IC2. at Map[[1]](q.l(Distr)(y))))
+   IV <- integrate(IC..,0,1)$value
+   IV2 <- integrate(IC2..,0,1)$value - 1
+   return(c(cent=IV,consist=IV2))
+}
+..getLM <- function(IC){
+   return(c(b=clip(IC),a=cent(IC),aw=cent(weight(IC)),A=stand(IC),Aw=stand(weight(IC))))
+}
+
+PF <- ParetoFamily(shape=1)
+## necessary Jul 20, 2018 due to bug:
+PF at L2derivDistr[[1]] <- 1-Exp(1)
+
+L2deriv. <- as(diag(1) %*% PF at L2deriv, "EuclRandVariable")
+D1. <- PF at distribution
+
+ICRMX <- radiusMinimaxIC(L2Fam=PF, neighbor= ContNeighborhood(), risk = asMSE(), verbose = TRUE, loRad = 0, upRad = Inf, z.start = 0, A.start = 2, upper = 1e7, lower = 1e-7, OptOrIter = "iterate", maxiter = 150, tol = .Machine$double.eps^0.7, loRad0 = 1e-3)
+.checkIC(ICRMX,L2deriv.,D1.)
+(RMXw <- ..getLM(ICRMX))
+
+RobPF <- InfRobModel(center = PF, neighbor = ContNeighborhood(radius = 0.5))
+ICMBR <- optIC(model = RobPF, risk = asBias(), verbose = TRUE, z.start = 0, A.start = 2, upper = 1e7, lower = 1e-7, OptOrIter = "iterate", maxiter = 150, tol = .Machine$double.eps^0.7)
+.checkIC(ICMBR,L2deriv.,D1.)
+(MBRw <- ..getLM(ICMBR))
+
+asM <- asMSE()
+ICOMS <- optIC(model = RobPF, risk = asM, verbose = TRUE, z.start = 0, A.start = 2, upper = 1e7, lower = 1e-7, OptOrIter = "iterate", maxiter = 150, tol = .Machine$double.eps^0.7)
+.checkIC(ICRMX,L2deriv.,D1.)
+(OMSw <- ..getLM(ICOMS))
+
+.ParetoLM <- list()
+.ParetoLM$RMX <- RMXw
+.ParetoLM$OMS <- OMSw
+.ParetoLM$MBR <- MBRw
+
+baseP <- "C:/rtest/RobASt/branches/robast-1.1/pkg"
+bufferP <- "RobExtremesBuffer"
+RobExP <- "RobExtremes/R"
+unzF <- file.path(baseP,bufferP,"Paretosysdata.rda")
+zF <-   file.path(baseP,bufferP,"ParetoZipsysdata.rda")
+rdaF <- file.path(baseP,RobExP,"sysdata.rda")
+
+save(.ParetoLM, file=unzF)
+save(.ParetoLM, file=zF, compress="xz")
+save(.ParetoLM, file=rdaF, compress="xz")