From noreply at r-forge.r-project.org  Thu Apr  3 01:09:09 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 01:09:09 +0200 (CEST)
Subject: [Robast-commits] r732 - in branches/robast-1.0/pkg/RobExtremes: . R
	man
Message-ID: <20140402230909.C517118042B@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 01:09:09 +0200 (Thu, 03 Apr 2014)
New Revision: 732

Added:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Modified:
   branches/robast-1.0/pkg/RobExtremes/NAMESPACE
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
   branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R
   branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd
   branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
   branches/robast-1.0/pkg/RobExtremes/man/GEVParameter-class.Rd
   branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
Log:
RobExtremes: 
+ fixed some issues with help of getVaR, getCVaR, ...
+ new print method for the results of these functions (and a corresponding S3class)
+ GEVFamily and GEVFamilyMuUnknown now have changed default starting estimators
  realized in startEstGEV.R : a CvM-MDE with xi varying on a grid...
+ GParetoFamily now handles left endpoint correctly and catches xi < -1/2
+ GEVFamily[MuUnknown] for xi>0 now handles left endpoint correctly and catches xi < -1/2
+ warning for large xi is switched off in GEVFamily[MuUnknown] if called internally
+ double definition of ddigamma eliminated
+ GEV now has a robust starting estimator for mu unknown


Modified: branches/robast-1.0/pkg/RobExtremes/NAMESPACE
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/NAMESPACE	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/NAMESPACE	2014-04-02 23:09:09 UTC (rev 732)
@@ -45,3 +45,4 @@
 export("loc", "loc<-", "kMAD", "Sn", "Qn", 
        "asvarMedkMAD","asvarPickands", "asvarQBCC")
 exportMethods("rescaleFunction")			  
+S3method(print, riskMeasure)
\ No newline at end of file

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-02 23:09:09 UTC (rev 732)
@@ -127,8 +127,10 @@
                  return(FALSE)
              if (any(param[1] <= tol)) 
                  return(FALSE)
-             if (any(param[2] <= tol))
+             if(object at param@withPosRestr) if (any(param[2] <= tol))
                  return(FALSE)
+             if (any(param[2] <= -1/2))
+                 return(FALSE)
              return(TRUE)
            })
 
@@ -146,9 +148,10 @@
                           start0Est = NULL, withPos = TRUE,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
-                          ..ignoreTrafo = FALSE){
+                          ..ignoreTrafo = FALSE,
+                          ..withWarningGEV = TRUE){
     theta <- c(loc, scale, shape)
-    .warningGEVShapeLarge(shape)
+    if(..withWarningGEV).warningGEVShapeLarge(shape)
     
     of.interest <- .pretreat.of.interest(of.interest,trafo)
 
@@ -234,13 +237,16 @@
     ## starting parameters
     startPar <- function(x,...){
         mu <- theta[1]
-        
+
         ## Pickand estimator
         if(is.null(start0Est)){
+        ### replaced 20140402: CvMMDE-with xi on Grid
         #source("kMedMad_Qn_Estimators.R")
-           PF <- GEVFamily(loc = theta[1], scale = theta[2], shape = theta[3])
-           e1 <- PickandsEstimator(x,ParamFamily=PF)
-           e0 <- estimate(e1)
+        ### replaced 20140402:
+        #   PF <- GEVFamily(loc = theta[1], scale = theta[2], shape = theta[3])
+        #   e1 <- PickandsEstimator(x,ParamFamily=PF)
+        #   e0 <- estimate(e1)
+           e0 <- .getBetaXiGEV(x=x, mu=mu, xiGrid=.getXiGrid(), withPos=withPos)
         }else{
            if(is(start0Est,"function")){
               e1 <- start0Est(x, ...)
@@ -263,9 +269,11 @@
            theta <- abs(theta)
         }else{
            if(!is.null(names(theta))){
+              if(theta["shape"]< (-1/2)) theta["shape"] <- -1/2+1e-4
               theta["scale"] <- abs(theta["scale"])
            }else{
               theta[1] <- abs(theta[1])
+              if(theta[2]< (-1/2)) theta[2] <- -1/2+1e-4
            }
         }
         return(theta)
@@ -273,12 +281,12 @@
 
     modifyPar <- function(theta){
         theta <- makeOKPar(theta)
-        .warningGEVShapeLarge(theta["shape"])
+        if(..withWarningGEV).warningGEVShapeLarge(theta["shape"])
         if(!is.null(names(theta))){
             sc <- theta["scale"]
             sh <- theta["shape"]
         }else{
-            theta <- abs(theta)
+            # changed 20140402: theta <- abs(theta)
             sc <- theta[1]
             sh <- theta[2]
         }
@@ -291,7 +299,7 @@
         sc <- force(main(param)[1])
         k <- force(main(param)[2])
         tr <- fixed(param)[1]
-        .warningGEVShapeLarge(k)
+        if(..withWarningGEV).warningGEVShapeLarge(k)
 
         Lambda1 <- function(x) {
          y <- x*0
@@ -327,7 +335,7 @@
     FisherInfo.fct <- function(param) {
         sc <- force(main(param)[1])
         k <- force(main(param)[2])
-        .warningGEVShapeLarge(k)
+        if(..withWarningGEV).warningGEVShapeLarge(k)
         G20 <- gamma(2*k)
         G10 <- gamma(k)
         G11 <- digamma(k)*gamma(k)

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-02 23:09:09 UTC (rev 732)
@@ -13,8 +13,10 @@
                  return(FALSE)
              if (any(param[2] <= tol))
                  return(FALSE)
-             if (any(param[3] <= tol))
+             if(object at param@withPosRestr) if (any(param[3] <= tol))
                  return(FALSE)
+             if (any(param[3] <= -1/2))
+                 return(FALSE)
              return(TRUE)
            })
 
@@ -32,9 +34,10 @@
                           start0Est = NULL, withPos = TRUE,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
-                          ..ignoreTrafo = FALSE){
+                          ..ignoreTrafo = FALSE,
+                          ..withWarningGEV = TRUE){
     theta <- c(loc, scale, shape)
-    .warningGEVShapeLarge(shape)
+    if(..withWarningGEV).warningGEVShapeLarge(shape)
     
     of.interest <- .pretreat.of.interest(of.interest,trafo)
 
@@ -121,24 +124,25 @@
 
     ## starting parameters
     startPar <- function(x,...){
-        mu <- min(x)
-        
+
         ## Pickand estimator
         if(is.null(start0Est)){
+        ### replaced 20140402: CvMMDE-with xi on Grid
         #source("kMedMad_Qn_Estimators.R")
-           PF <- GEVFamily(loc = theta[1], scale = theta[2], shape = theta[3])
-           e1 <- PickandsEstimator(x,ParamFamily=PF)
-           e0 <- estimate(e1)
+        #   PF <- GEVFamily(loc = theta[1], scale = theta[2], shape = theta[3])
+        #   e1 <- PickandsEstimator(x,ParamFamily=PF)
+        #   e0 <- estimate(e1)
+          e0 <- .getMuBetaXiGEV(x=x, xiGrid=.getXiGrid(), withPos=withPos)
         }else{
            if(is(start0Est,"function")){
               e1 <- start0Est(x, ...)
               e0 <-  if(is(e1,"Estimate")) estimate(e1) else e1
            }else stop("Argument 'start0Est' must be a function or NULL.")
            if(!is.null(names(e0)))
-               e0 <- e0[c("scale", "shape")]
+               e0 <- e0[c("loc","scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(any(x < mu-e0["scale"]/e0["shape"]))
+        if(any(x < e0[1]-e0[2]/e0[3]))
                stop("some data smaller than 'loc-scale/shape' ")
 
         names(e0) <- NULL
@@ -148,12 +152,14 @@
     ## what to do in case of leaving the parameter domain
     makeOKPar <- function(theta) {
         if(withPos){
-           theta <- abs(theta)
+           theta[2:3] <- abs(theta[2:3])
         }else{
            if(!is.null(names(theta))){
+              if(theta["shape"]< (-1/2)) theta["shape"] <- -1/2+1e-4
               theta["scale"] <- abs(theta["scale"])
            }else{
-              theta[1] <- abs(theta[1])
+              theta[2] <- abs(theta[2])
+              if(theta[3]< (-1/2)) theta[3] <- -1/2+1e-4
            }
         }
         return(theta)
@@ -161,14 +167,14 @@
 
     modifyPar <- function(theta){
         theta <- makeOKPar(theta)
-        .warningGEVShapeLarge(theta["shape"])
+        if(..withWarningGEV).warningGEVShapeLarge(theta["shape"])
         if(!is.null(names(theta))){
             loc <- theta["loc"]
             sc <- theta["scale"]
             sh <- theta["shape"]
         }else{
             loc <- theta[1]
-            theta[2:3] <- abs(theta[2:3])
+            #theta[2:3] <- abs(theta[2:3])
             sc <- theta[2]
             sh <- theta[3]
         }
@@ -181,7 +187,7 @@
         sc <- force(main(param)[2])
         k <- force(main(param)[3])
         tr <- force(main(param)[1])
-        .warningGEVShapeLarge(k)
+        if(..withWarningGEV).warningGEVShapeLarge(k)
 
         k1 <- k+1
         Lambda0 <- function(x) {
@@ -233,7 +239,7 @@
         sc <- force(main(param)[2])
         k <- force(main(param)[3])
         k1 <- k+1
-        .warningGEVShapeLarge(k)
+        if(..withWarningGEV).warningGEVShapeLarge(k)
         G20 <- gamma(2*k)
         G10 <- gamma(k)
         G11 <- digamma(k)*gamma(k)
@@ -319,11 +325,3 @@
     L2Fam at .withEvalL2derivDistr <- FALSE
     return(L2Fam)
 }
-
-#ddigamma(t,s) is d/ds \int_0^t exp(-x) x^(s-1) dx
-
-ddigamma <- function(t,s){
-              int <- function(x) exp(-x)*(log(x))*x^(s-1)
-              integrate(int, lower=0, upper=t)$value
-              }
-              
\ No newline at end of file

Modified: branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-04-02 23:09:09 UTC (rev 732)
@@ -12,11 +12,13 @@
                  param <- main(param)
              if (!all(is.finite(param))) 
                  return(FALSE)
-             #if (any(param[1] <= tol))
-             #    return(FALSE)
+             if (any(param[1] <= tol))
+                 return(FALSE)
              if(object at param@withPosRestr)
                  if (any(param[2] <= tol))
                      return(FALSE)
+             if (any(param[2] <= -1/2))
+                     return(FALSE)
              return(TRUE)
            })
 
@@ -142,8 +144,10 @@
                e0 <- e0[c("scale", "shape")]
         }
 
-        if(any(x < tr-e0["scale"]/e0["shape"]))
-               stop("some data smaller than 'loc-scale/shape' ")
+        if(any(x < tr-.Machine$double.eps))
+               stop("some data smaller than 'loc' ")
+#        if(any(x < tr-e0["scale"]/e0["shape"]))
+#               stop("some data smaller than 'loc-scale/shape' ")
 
         names(e0) <- NULL
         return(e0)
@@ -156,9 +160,11 @@
            theta <- abs(theta)
         }else{
            if(!is.null(names(theta))){
+              if(theta["shape"]< (-1/2)) theta["shape"] <- -1/2+1e-4
               theta["scale"] <- abs(theta["scale"])
            }else{
               theta[1] <- abs(theta[1])
+              if(theta[2]< (-1/2)) theta[2] <- -1/2+1e-4
            }
         }
         return(theta)

Modified: branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R	2014-04-02 23:09:09 UTC (rev 732)
@@ -15,9 +15,25 @@
   res <- param(L2Fam)@trafo(estimate(est))
   VaR <- res[[1]]
   varVaR <- (res[[2]]) %*% asvar(est) %*% t(res[[2]])
-  return(c(VaR=VaR,sqrt(varVaR/length(data))))
+  res <- c(VaR,sqrt(varVaR/length(data)))
+  names(res) <- c("Risk","varofRisk")
+  class(res) <- "riskMeasure"
+  res
 }
+print.riskMeasure <- function(x, level=NULL, ...){
+   mc <- as.list(match.call(expand.dots=TRUE)[-1])
+   digits <- if(is.null(mc$digits)) 3 else  mc$digits
+   if(is.null(level)){
+      cat(" ",signif(x[1],digits),"\n")
+      cat("(",signif(x[2],digits),")\n")
+   }else{qn <- qnorm((level+1)/2)
+      CI <- c(-1,1)*qn*x[2]+x[1]
+      cat(" ",signif(x[1],digits),"         [", signif(CI[1],digits), ",",
+              signif(CI[2],digits),"]\n")
+  }
+}
 
+
 getVaR <- function(data, model, level, rob=TRUE)
              .getTau(data, model, level, rob, of.interest="quantile", substitute(L2FamC$p <- level))
 

Added: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	                        (rev 0)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-02 23:09:09 UTC (rev 732)
@@ -0,0 +1,38 @@
+.getXiGrid <- function(){seq(-0.4,4,by=0.3)}
+
+
+.getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE){
+  x0 <- x-mu
+  s0 <- max(x0)-min(x0)
+  crit0 <- Inf
+  fu <- function(x,...) .getBetaXiGEV(x,mu,xiGrid = xiGrid,withPos=withPos)
+  for(xi in xiGrid){
+      funl <- function(sig){
+         mygev1 <- GEV(loc=0,scale=sig,shape=xi)
+         CvMDist(x0,mygev1)
+      }
+      sigCvMMD1 <- optimize(funl, interval=c(1e-5,s0))$minimum
+      print(c("sigma"=sigCvMMD1,"xi"=xi))
+      mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
+                         start0Est = fu, ..withWarningGEV=FALSE)
+      print(mygev)
+      print(param(mygev))
+      mde0 <- MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi))
+      print(c("roh"=estimate(mde0)))
+      if(criterion(mde0)<crit0){
+         mdeb <- mde0
+         crit0 <- criterion(mde0)
+      }
+  }
+  es <- estimate(mdeb)
+  names(es) <- c("scale","shape")
+  return(es)
+}
+
+.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE){
+  mu <- quantile(x,exp(-1))
+  es <- .getBetaXiGEV(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos)
+  es0 <- c(mu,es)
+  names(es0) <- c("loc","scale","shape")
+  return(es0)
+}

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd	2014-04-02 23:09:09 UTC (rev 732)
@@ -9,7 +9,8 @@
 \usage{
 GEVFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
               p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE)
+              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE,
+              ..withWarningGEV = TRUE)
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -29,6 +30,7 @@
   \item{withL2derivDistr}{logical: shall the distribution of the L2 derivative
       be computed? Defaults to \code{FALSE} (to speeds up computations).}
   \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.}
+  \item{..withWarningGEV}{logical: shall warnings be issued if shape is large?}
 }
 \details{
   The slots of the corresponding L2 differentiable 

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-04-02 23:09:09 UTC (rev 732)
@@ -9,7 +9,8 @@
 \usage{
 GEVFamilyMuUnknown(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
               p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE)
+              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE,
+              ..withWarningGEV = TRUE)
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -29,6 +30,7 @@
   \item{withL2derivDistr}{logical: shall the distribution of the L2 derivative
       be computed? Defaults to \code{FALSE} (to speeds up computations).}
   \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.}
+  \item{..withWarningGEV}{logical: shall warnings be issued if shape is large?}
 }
 \details{
   The slots of the corresponding L2 differentiable 

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVParameter-class.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVParameter-class.Rd	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVParameter-class.Rd	2014-04-02 23:09:09 UTC (rev 732)
@@ -19,11 +19,11 @@
 \section{Slots}{
   \describe{
     \item{\code{loc}}{ real number: location parameter of 
-      a generalized Pareto distribution. }
+      a GEV distribution. }
     \item{\code{scale}}{ real number: scale parameter of 
-      a generalized Pareto distribution. }
+      a GEV distribution. }
     \item{\code{shape}}{ real number: shape parameter of 
-      a generalized Pareto distribution. }
+      a GEV distribution. }
     \item{\code{name}}{ default name is 
       \dQuote{parameter of a GEV distribution}. }
   }

Modified: branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	2014-03-23 16:50:05 UTC (rev 731)
+++ branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	2014-04-02 23:09:09 UTC (rev 732)
@@ -1,7 +1,8 @@
 \name{getCVaR}
 \alias{getVaR}
-\alias{getVaR}
+\alias{getCVaR}
 \alias{getEL}
+\alias{print.riskMeasure}
 
 \title{Risk Measures for Scale-Shape Families}
 \description{
@@ -12,19 +13,29 @@
 getVaR(data, model, level, rob=TRUE)
 getCVaR(data, model, level, rob=TRUE)
 getEL(data, model, N0, rob=TRUE)
+\method{print}{riskMeasure}(x, level=NULL, ...)
 }
 \arguments{
   \item{data}{data at which to compute the risk measure. }
   \item{model}{an object of class \code{"L2ScaleShapeFamily"}.
                The parametric family at which to evaluate the risk measure. }
   \item{level}{real: probability needed for VaR and CVaR. }
-  \item{N0}{real: expected frequency for expected loss }
+  \item{N0}{real: expected frequency for expected loss. }
   \item{rob}{logical; if \code{TRUE} (default) the RMXE-parametric estimator is
-             used; otherwise the MLE.}
+             used; otherwise the MLE. }
+  \item{x}{an object of (S3-)class \code{"riskmeasure"}. }
+  \item{...}{further arguments for \code{print}. }
  }
-\value{A vector of length 2 with first coordinate the respective risk measure
-and the second a corresponding (asymptotic) standard error for the risk
-measure.}
+\value{The risk measures \code{getVaR}, \code{getCVaR}, \code{getEL} return
+an (S3) object of class \code{"riskMeasure"}, i.e., a numeric vector
+of length 2 with components \code{"Risk"} and \code{"varofRisk"}
+containing the respective risk measure
+and a corresponding (asymptotic) standard error for the risk
+measure. To the return class \code{"riskMeasure"},
+there is a particular \code{print}-method; if the corresponding argument
+\code{level} is \code{NULL} (default) the corresponding standard error
+is printed together with the risk measure; otherwise a corresponding
+CLT-based confidence interval for the risk meausre is produced.}
 \references{
 P. Ruckdeschel, N. Horbenko (2013): Optimally-Robust Estimators in Generalized
 Pareto Models. Statistics 47(4), 762--791.
@@ -35,7 +46,7 @@
 \seealso{\code{\link{GParetoFamily}}, \code{\link{GEVFamily}}, \code{\link{WeibullFamily}}, \code{\link{GammaFamily}}}
 \examples{
   set.seed(123)
-  GPD <- GPartoFamily(loc=20480, scale=7e4, shape=0.3)
+  GPD <- GParetoFamily(loc=20480, scale=7e4, shape=0.3)
   data <- r(GPD)(500)
   getVaR(data,GPD,0.99)
   getVaR(data,GPD,0.99, rob=FALSE)


From noreply at r-forge.r-project.org  Thu Apr  3 03:17:48 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 03:17:48 +0200 (CEST)
Subject: [Robast-commits] r733 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403011748.31F26185183@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 03:17:47 +0200 (Thu, 03 Apr 2014)
New Revision: 733

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes: bugfix bounds must be right for shape < 0 ...
 eliminated some erroneous prints

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-02 23:09:09 UTC (rev 732)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:17:47 UTC (rev 733)
@@ -256,9 +256,12 @@
                e0 <- e0[c("scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(any(x < mu-e0["scale"]/e0["shape"]))
+        if(e0[3]>0) if(any(x < e0[1]-e0[2]/e0[3]))
                stop("some data smaller than 'loc-scale/shape' ")
 
+        if(e0[3]<0) if(any(x > e0[1]-e0[2]/e0[3]))
+               stop("some data larger than 'loc-scale/shape' ")
+
         names(e0) <- NULL
         return(e0)
     }

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-02 23:09:09 UTC (rev 732)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-03 01:17:47 UTC (rev 733)
@@ -142,9 +142,12 @@
                e0 <- e0[c("loc","scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(any(x < e0[1]-e0[2]/e0[3]))
+        if(e0[3]>0) if(any(x < e0[1]-e0[2]/e0[3]))
                stop("some data smaller than 'loc-scale/shape' ")
 
+        if(e0[3]<0) if(any(x > e0[1]-e0[2]/e0[3]))
+               stop("some data larger than 'loc-scale/shape' ")
+
         names(e0) <- NULL
         return(e0)
     }

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-02 23:09:09 UTC (rev 732)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 01:17:47 UTC (rev 733)
@@ -1,4 +1,4 @@
-.getXiGrid <- function(){seq(-0.4,4,by=0.3)}
+.getXiGrid <- function(){seq(-0.48,5,by=0.5)}
 
 
 .getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE){
@@ -12,13 +12,9 @@
          CvMDist(x0,mygev1)
       }
       sigCvMMD1 <- optimize(funl, interval=c(1e-5,s0))$minimum
-      print(c("sigma"=sigCvMMD1,"xi"=xi))
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)
-      print(mygev)
-      print(param(mygev))
       mde0 <- MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi))
-      print(c("roh"=estimate(mde0)))
       if(criterion(mde0)<crit0){
          mdeb <- mde0
          crit0 <- criterion(mde0)


From noreply at r-forge.r-project.org  Thu Apr  3 03:36:09 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 03:36:09 +0200 (CEST)
Subject: [Robast-commits] r734 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403013610.212B21872DF@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 03:36:08 +0200 (Thu, 03 Apr 2014)
New Revision: 734

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
Log:
RobExtremes: argh yet another bug for GEV (mu known)

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:17:47 UTC (rev 733)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:36:08 UTC (rev 734)
@@ -256,10 +256,10 @@
                e0 <- e0[c("scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(e0[3]>0) if(any(x < e0[1]-e0[2]/e0[3]))
+        if(e0[3]>0) if(any(x < mu-e0[1]/e0[2]))
                stop("some data smaller than 'loc-scale/shape' ")
 
-        if(e0[3]<0) if(any(x > e0[1]-e0[2]/e0[3]))
+        if(e0[3]<0) if(any(x > mu-e0[1]/e0[2]))
                stop("some data larger than 'loc-scale/shape' ")
 
         names(e0) <- NULL


From noreply at r-forge.r-project.org  Thu Apr  3 03:48:40 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 03:48:40 +0200 (CEST)
Subject: [Robast-commits] r735 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403014840.467D6186F1D@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 03:48:39 +0200 (Thu, 03 Apr 2014)
New Revision: 735

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
Log:
... RobExtremes: yet an index wrong

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:36:08 UTC (rev 734)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:48:39 UTC (rev 735)
@@ -256,10 +256,10 @@
                e0 <- e0[c("scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(e0[3]>0) if(any(x < mu-e0[1]/e0[2]))
+        if(e0[2]>0) if(any(x < mu-e0[1]/e0[2]))
                stop("some data smaller than 'loc-scale/shape' ")
 
-        if(e0[3]<0) if(any(x > mu-e0[1]/e0[2]))
+        if(e0[2]<0) if(any(x > mu-e0[1]/e0[2]))
                stop("some data larger than 'loc-scale/shape' ")
 
         names(e0) <- NULL


From noreply at r-forge.r-project.org  Thu Apr  3 09:58:03 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 09:58:03 +0200 (CEST)
Subject: [Robast-commits] r736 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403075803.6A2EF18715D@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 09:58:03 +0200 (Thu, 03 Apr 2014)
New Revision: 736

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
   branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes: yet another fix with the search interval for GEV

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 01:48:39 UTC (rev 735)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-03 07:58:03 UTC (rev 736)
@@ -257,10 +257,10 @@
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
         if(e0[2]>0) if(any(x < mu-e0[1]/e0[2]))
-               stop("some data smaller than 'loc-scale/shape' ")
+               stop("shape is positive and some data smaller than 'loc-scale/shape' ")
 
         if(e0[2]<0) if(any(x > mu-e0[1]/e0[2]))
-               stop("some data larger than 'loc-scale/shape' ")
+               stop("shape is negative and some data larger than 'loc-scale/shape' ")
 
         names(e0) <- NULL
         return(e0)

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-03 01:48:39 UTC (rev 735)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-03 07:58:03 UTC (rev 736)
@@ -143,10 +143,10 @@
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
         if(e0[3]>0) if(any(x < e0[1]-e0[2]/e0[3]))
-               stop("some data smaller than 'loc-scale/shape' ")
+               stop("shape is positive and some data smaller than 'loc-scale/shape' ")
 
         if(e0[3]<0) if(any(x > e0[1]-e0[2]/e0[3]))
-               stop("some data larger than 'loc-scale/shape' ")
+               stop("shape is negative and some data larger than 'loc-scale/shape' ")
 
         names(e0) <- NULL
         return(e0)

Modified: branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-04-03 01:48:39 UTC (rev 735)
+++ branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-04-03 07:58:03 UTC (rev 736)
@@ -146,6 +146,8 @@
 
         if(any(x < tr-.Machine$double.eps))
                stop("some data smaller than 'loc' ")
+        if(e0[2]<0) if(any(x > tr-e0[1]/e0[2]))
+               stop("shape is negative and some data larger than 'loc-scale/shape' ")
 #        if(any(x < tr-e0["scale"]/e0["shape"]))
 #               stop("some data smaller than 'loc-scale/shape' ")
 

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 01:48:39 UTC (rev 735)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 07:58:03 UTC (rev 736)
@@ -11,7 +11,8 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      sigCvMMD1 <- optimize(funl, interval=c(1e-5,s0))$minimum
+      intv <- if(xi<0) c(1e-5, max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*min(x)-mu),s0)
+      sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)
       mde0 <- MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi))


From noreply at r-forge.r-project.org  Thu Apr  3 11:28:39 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 11:28:39 +0200 (CEST)
Subject: [Robast-commits] r737 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403092839.AE9FD186F2C@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 11:28:38 +0200 (Thu, 03 Apr 2014)
New Revision: 737

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes: ...yet another time played around the search interval for sigma in startEstGEV.R

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 07:58:03 UTC (rev 736)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 09:28:38 UTC (rev 737)
@@ -11,7 +11,7 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      intv <- if(xi<0) c(1e-5, max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*min(x)-mu),s0)
+      intv <- if(xi<0) c(min(1e-5,xi/4*min(x)-mu), max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*max(x)-mu),max(s0,2*xi*max(x)-mu))
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)


From noreply at r-forge.r-project.org  Thu Apr  3 11:37:25 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 11:37:25 +0200 (CEST)
Subject: [Robast-commits] r738 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403093725.EF185187024@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 11:37:25 +0200 (Thu, 03 Apr 2014)
New Revision: 738

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes: packed startEstGEV.R into a try-catch...

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 09:28:38 UTC (rev 737)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 09:37:25 UTC (rev 738)
@@ -15,10 +15,12 @@
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)
-      mde0 <- MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi))
-      if(criterion(mde0)<crit0){
-         mdeb <- mde0
-         crit0 <- criterion(mde0)
+      mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi)),silent=TRUE)
+      if(!is(mde0,"try-error")){
+          if(criterion(mde0)<crit0){
+             mdeb <- mde0
+             crit0 <- criterion(mde0)
+          }
       }
   }
   es <- estimate(mdeb)


From noreply at r-forge.r-project.org  Thu Apr  3 13:07:10 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 13:07:10 +0200 (CEST)
Subject: [Robast-commits] r739 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403110710.98961187301@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 13:07:10 +0200 (Thu, 03 Apr 2014)
New Revision: 739

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
...RobExtremes: now the sigma search range could include negative values -> fixed

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 09:37:25 UTC (rev 738)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 11:07:10 UTC (rev 739)
@@ -11,7 +11,7 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      intv <- if(xi<0) c(min(1e-5,xi/4*min(x)-mu), max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*max(x)-mu),max(s0,2*xi*max(x)-mu))
+      intv <- if(xi<0) c(max(1e-5,xi/4*min(x)-mu), max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*max(x)-mu),max(s0,2*xi*max(x)-mu))
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)


From noreply at r-forge.r-project.org  Thu Apr  3 13:21:15 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 13:21:15 +0200 (CEST)
Subject: [Robast-commits] r740 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403112115.348CF186E61@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 13:21:14 +0200 (Thu, 03 Apr 2014)
New Revision: 740

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes: now only let pass admissible starting estimators

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 11:07:10 UTC (rev 739)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 11:21:14 UTC (rev 740)
@@ -17,7 +17,8 @@
                          start0Est = fu, ..withWarningGEV=FALSE)
       mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi)),silent=TRUE)
       if(!is(mde0,"try-error")){
-          if(criterion(mde0)<crit0){
+          es <- estimate(mde0)
+          if(criterion(mde0)<crit0&(1+es[2]*min(x0)/es[1]>0)){
              mdeb <- mde0
              crit0 <- criterion(mde0)
           }


From noreply at r-forge.r-project.org  Thu Apr  3 13:35:57 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 13:35:57 +0200 (CEST)
Subject: [Robast-commits] r741 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403113557.89D1318700B@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 13:35:57 +0200 (Thu, 03 Apr 2014)
New Revision: 741

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
argh: RobExtremes --- stills throws errors ... hopefully this is it

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 11:21:14 UTC (rev 740)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 11:35:57 UTC (rev 741)
@@ -18,9 +18,10 @@
       mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi)),silent=TRUE)
       if(!is(mde0,"try-error")){
           es <- estimate(mde0)
-          if(criterion(mde0)<crit0&(1+es[2]*min(x0)/es[1]>0)){
+          crit1 <- criterion(mde0)
+          if(crit1<crit0&(1+min(es[2]*x0/es[1])>0)){
              mdeb <- mde0
-             crit0 <- criterion(mde0)
+             crit0 <- crit1
           }
       }
   }


From noreply at r-forge.r-project.org  Thu Apr  3 13:46:38 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 13:46:38 +0200 (CEST)
Subject: [Robast-commits] r742 -
	branches/robast-1.0/pkg/RobExtremes/inst/scripts
Message-ID: <20140403114638.66C75186C0F@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 13:46:37 +0200 (Thu, 03 Apr 2014)
New Revision: 742

Added:
   branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R
Log:
RobExtremes: committed script to check GEV ... 

Added: branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R	                        (rev 0)
+++ branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R	2014-04-03 11:46:37 UTC (rev 742)
@@ -0,0 +1,23 @@
+require(RobExtremes)
+set.seed(123)
+
+x <- rgev(100,shape=2,scale=30,loc=4) ### x still causes problems....
+x1 <- rgev(100,shape=-.2,scale=30,loc=4)
+gev0 <- GEVFamilyMuUnknown(withPos=FALSE)
+gev1 <- GEVFamilyMuUnknown(loc=quantile(x,exp(-1)),withPos=FALSE)
+MLEstimator(x,gev0)
+MLEstimator(x,gev1)
+MLEstimator(x1,gev0)
+MLEstimator(x1,gev1)
+fucheck <- function(x,mu,sigma,xi){
+   1+min((x-mu)/sigma*xi)
+}
+(est1 <- RobExtremes:::.getMuBetaXiGEV(x,withPos=FALSE))
+fucheck(x,mu=est1[1],sigma=est1[2],xi=est1[3])
+(est2 <- RobExtremes:::.getBetaXiGEV(x,mu=quantile(x,exp(-1)),withPos=FALSE))
+fucheck(x,mu=quantile(x,exp(-1)),sigma=est2[1],xi=est2[2])
+
+(est3 <- RobExtremes:::.getMuBetaXiGEV(x1,withPos=FALSE))
+fucheck(x1,mu=est3[1],sigma=est3[2],xi=est3[3])
+(est4 <- RobExtremes:::.getBetaXiGEV(x1,mu=quantile(x,exp(-1)),withPos=FALSE))
+fucheck(x1,mu=quantile(x,exp(-1)),sigma=est4[1],xi=est4[2])


From noreply at r-forge.r-project.org  Thu Apr  3 17:04:54 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 17:04:54 +0200 (CEST)
Subject: [Robast-commits] r743 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403150454.4CD1D186FCC@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 17:04:49 +0200 (Thu, 03 Apr 2014)
New Revision: 743

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/Functionals.R
Log:
RobExtremes: bug in (population) variance of GEV xi=0 discovered

Modified: branches/robast-1.0/pkg/RobExtremes/R/Functionals.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/Functionals.R	2014-04-03 11:46:37 UTC (rev 742)
+++ branches/robast-1.0/pkg/RobExtremes/R/Functionals.R	2014-04-03 15:04:49 UTC (rev 743)
@@ -55,7 +55,7 @@
         return(var(as(x,"AbscontDistribution"),...))
     else{ xi <- shape(x); sigma <- scale(x)
         if(xi>=1/2) return(NA)
-        if(xi==0) return(pi^2/6)
+        if(xi==0) return(sigma^2*pi^2/6)
         if((xi!=0)&&(xi<1/2))return(sigma^2*(gamma(1-2*xi)-gamma(1-xi)^2)/xi^2)
     }})
 ### http://en.wikipedia.org/wiki/Generalized_extreme_value_distribution


From noreply at r-forge.r-project.org  Thu Apr  3 17:15:15 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 17:15:15 +0200 (CEST)
Subject: [Robast-commits] r744 - in branches/robast-1.0/pkg/RobExtremes: R
	inst/scripts
Message-ID: <20140403151515.50B55185C04@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 17:15:14 +0200 (Thu, 03 Apr 2014)
New Revision: 744

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
   branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R
Log:
RobExtremes:: yet two more fixes

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 15:04:49 UTC (rev 743)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 15:15:14 UTC (rev 744)
@@ -11,7 +11,9 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      intv <- if(xi<0) c(max(1e-5,xi/4*min(x)-mu), max(xi*min(x)-mu,2e-5)) else c(max(1e-5,xi*max(x)-mu),max(s0,2*xi*max(x)-mu))
+      intup <- min(xi*(x-mu))
+      if(intup<0) break
+      intv <-  c(1e-5,min(s0,intup))
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)

Modified: branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R	2014-04-03 15:04:49 UTC (rev 743)
+++ branches/robast-1.0/pkg/RobExtremes/inst/scripts/GEVcheck.R	2014-04-03 15:15:14 UTC (rev 744)
@@ -4,7 +4,7 @@
 x <- rgev(100,shape=2,scale=30,loc=4) ### x still causes problems....
 x1 <- rgev(100,shape=-.2,scale=30,loc=4)
 gev0 <- GEVFamilyMuUnknown(withPos=FALSE)
-gev1 <- GEVFamilyMuUnknown(loc=quantile(x,exp(-1)),withPos=FALSE)
+gev1 <- GEVFamily(loc=quantile(x,exp(-1)),withPos=FALSE)
 MLEstimator(x,gev0)
 MLEstimator(x,gev1)
 MLEstimator(x1,gev0)


From noreply at r-forge.r-project.org  Thu Apr  3 17:38:00 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  3 Apr 2014 17:38:00 +0200 (CEST)
Subject: [Robast-commits] r745 - branches/robast-1.0/pkg/RobExtremes/R
Message-ID: <20140403153801.13E06186F29@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-03 17:38:00 +0200 (Thu, 03 Apr 2014)
New Revision: 745

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
Log:
RobExtremes fixed the problem with inadmissible return values of MLE

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 15:15:14 UTC (rev 744)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-03 15:38:00 UTC (rev 745)
@@ -11,23 +11,33 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      intup <- min(xi*(x-mu))
-      if(intup<0) break
-      intv <-  c(1e-5,min(s0,intup))
+      intlo <- max(-xi*(x-mu))
+      intv <-  c(max(1e-5,intlo), s0)
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
                          start0Est = fu, ..withWarningGEV=FALSE)
       mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi)),silent=TRUE)
+      es0 <- c(NA,NA)
       if(!is(mde0,"try-error")){
           es <- estimate(mde0)
           crit1 <- criterion(mde0)
-          if(crit1<crit0&(1+min(es[2]*x0/es[1])>0)){
-             mdeb <- mde0
-             crit0 <- crit1
+          if(1+min(es[2]*x0/es[1])>0){
+             if(crit1<crit0){
+                mdeb <- mde0
+                crit0 <- crit1
+                es0 <- es
+             }
+          }else{
+             es[1] <- intlo+1e-5
+             mygev2 <- GEV(loc=0,scale=es[1],shape=es[2])
+             crit1 <- CvMDist(x0,mygev2)
+             if(crit1<crit0){
+                crit0 <- crit1
+                es0 <- es
+             }
           }
       }
   }
-  es <- estimate(mdeb)
   names(es) <- c("scale","shape")
   return(es)
 }


From noreply at r-forge.r-project.org  Mon Apr  7 15:25:12 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon,  7 Apr 2014 15:25:12 +0200 (CEST)
Subject: [Robast-commits] r746 - pkg/RobAStRDA
Message-ID: <20140407132512.52E12186EA7@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-07 15:25:11 +0200 (Mon, 07 Apr 2014)
New Revision: 746

Modified:
   pkg/RobAStRDA/DESCRIPTION
Log:
RobAStRDA in trunk:: xz compression added in DESCRIPTION

Modified: pkg/RobAStRDA/DESCRIPTION
===================================================================
--- pkg/RobAStRDA/DESCRIPTION	2014-04-03 15:38:00 UTC (rev 745)
+++ pkg/RobAStRDA/DESCRIPTION	2014-04-07 13:25:11 UTC (rev 746)
@@ -8,6 +8,7 @@
 Maintainer: Peter Ruckdeschel <peter.ruckdeschel at itwm.fraunhofer.de>
 LazyData: yes
 LazyLoad: yes
+SysDataCompression: xz
 ByteCompile: yes
 License: LGPL-3
 URL: http://robast.r-forge.r-project.org/


From noreply at r-forge.r-project.org  Wed Apr  9 23:20:48 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed,  9 Apr 2014 23:20:48 +0200 (CEST)
Subject: [Robast-commits] r747 - in branches/robast-1.0/pkg/RobExtremes: R
	man
Message-ID: <20140409212048.16934186DCB@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-09 23:20:47 +0200 (Wed, 09 Apr 2014)
New Revision: 747

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
   branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd
   branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
Log:
RobExtremes: startEstGEV.R now works with soft bound 1+ xi (x-mu)/sigma > 0 (only to hold for lower quantile...) controlled by argument secLevel

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-07 13:25:11 UTC (rev 746)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-09 21:20:47 UTC (rev 747)
@@ -146,6 +146,7 @@
                           of.interest = c("scale", "shape"),
                           p = NULL, N = NULL, trafo = NULL,
                           start0Est = NULL, withPos = TRUE,
+                          secLevel = 0.7,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
                           ..ignoreTrafo = FALSE,
@@ -237,6 +238,8 @@
     ## starting parameters
     startPar <- function(x,...){
         mu <- theta[1]
+        n <- length(x)
+        epsn <- min(floor(secLevel*sqrt(n))+1,n)
 
         ## Pickand estimator
         if(is.null(start0Est)){
@@ -256,12 +259,12 @@
                e0 <- e0[c("scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(e0[2]>0) if(any(x < mu-e0[1]/e0[2]))
+        if(quantile(e0[2]/e0[1]*(x-mu), epsn/n)< (-1)){
+           if(e0[2]>0)
                stop("shape is positive and some data smaller than 'loc-scale/shape' ")
-
-        if(e0[2]<0) if(any(x > mu-e0[1]/e0[2]))
+           else
                stop("shape is negative and some data larger than 'loc-scale/shape' ")
-
+        }
         names(e0) <- NULL
         return(e0)
     }

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-07 13:25:11 UTC (rev 746)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-09 21:20:47 UTC (rev 747)
@@ -32,6 +32,7 @@
                           of.interest = c("scale", "shape"),
                           p = NULL, N = NULL, trafo = NULL,
                           start0Est = NULL, withPos = TRUE,
+                          secLevel = 0.7,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
                           ..ignoreTrafo = FALSE,
@@ -125,6 +126,9 @@
     ## starting parameters
     startPar <- function(x,...){
 
+        n <- length(x)
+        epsn <- min(floor(secLevel*sqrt(n))+1,n)
+
         ## Pickand estimator
         if(is.null(start0Est)){
         ### replaced 20140402: CvMMDE-with xi on Grid
@@ -142,12 +146,12 @@
                e0 <- e0[c("loc","scale", "shape")]
         }
 #        print(e0); print(str(x)); print(head(summary(x))); print(mu)
-        if(e0[3]>0) if(any(x < e0[1]-e0[2]/e0[3]))
+        if(quantile(e0[3]/e0[2]*(x-e0[1]), epsn/n)< (-1)){
+           if(e0[3]>0)
                stop("shape is positive and some data smaller than 'loc-scale/shape' ")
-
-        if(e0[3]<0) if(any(x > e0[1]-e0[2]/e0[3]))
+           else if(e0[3]<0)
                stop("shape is negative and some data larger than 'loc-scale/shape' ")
-
+        }
         names(e0) <- NULL
         return(e0)
     }

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-07 13:25:11 UTC (rev 746)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-09 21:20:47 UTC (rev 747)
@@ -1,7 +1,11 @@
-.getXiGrid <- function(){seq(-0.48,5,by=0.5)}
+.getXiGrid <- function(){c(0.1,seq(-0.48,5,by=0.5))}
 
 
-.getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE){
+.getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7){
+
+  n <- length(x)
+  epsn <- min(floor(secLevel*sqrt(n))+1,n)
+
   x0 <- x-mu
   s0 <- max(x0)-min(x0)
   crit0 <- Inf
@@ -11,7 +15,7 @@
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
       }
-      intlo <- max(-xi*(x-mu))
+      intlo <- quantile(-xi*(x-mu),1-epsn/n)
       intv <-  c(max(1e-5,intlo), s0)
       sigCvMMD1 <- optimize(funl, interval=intv)$minimum
       mygev <- GEVFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
@@ -21,7 +25,7 @@
       if(!is(mde0,"try-error")){
           es <- estimate(mde0)
           crit1 <- criterion(mde0)
-          if(1+min(es[2]*x0/es[1])>0){
+          if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
              if(crit1<crit0){
                 mdeb <- mde0
                 crit0 <- crit1
@@ -42,9 +46,9 @@
   return(es)
 }
 
-.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE){
+.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7){
   mu <- quantile(x,exp(-1))
-  es <- .getBetaXiGEV(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos)
+  es <- .getBetaXiGEV(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos, secLevel = secLevel)
   es0 <- c(mu,es)
   names(es0) <- c("loc","scale","shape")
   return(es0)

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd	2014-04-07 13:25:11 UTC (rev 746)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVFamily.Rd	2014-04-09 21:20:47 UTC (rev 747)
@@ -9,8 +9,8 @@
 \usage{
 GEVFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
               p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE,
-              ..withWarningGEV = TRUE)
+              secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr  = FALSE,
+              ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE)
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -24,6 +24,13 @@
   \item{trafo}{ matrix or NULL: transformation of the parameter }
   \item{start0Est}{ startEstimator --- if \code{NULL} \code{\link{PickandsEstimator}} is used }
   \item{withPos}{ logical of length 1: Is shape restricted to positive values? }
+  \item{secLevel}{ a numeric of length 1:
+       In the ideal GEV model, for each observastion \eqn{X_i}{Xi}, the expression
+       \eqn{1+\frac{{\rm shape}(X_i-{\rm loc})}{{\rm scale}}}{1+shape(Xi-loc)/scale}
+       must be positive, which in principle could be attacked by a single outlier.
+       Hence for sample size \eqn{n} we allow for \eqn{\varepsilon n}{eps n}
+       violations, interpreting the violations as outliers. Here
+       \eqn{\varepsilon = {\tt secLevel}/\sqrt{n}}{eps = secLevel/sqrt(n)}. }
   \item{withCentL2}{logical: shall L2 derivative be centered by substracting
        the E()? Defaults to \code{FALSE}, but higher accuracy can be achieved
        when set to \code{TRUE}.}

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-04-07 13:25:11 UTC (rev 746)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-04-09 21:20:47 UTC (rev 747)
@@ -9,8 +9,8 @@
 \usage{
 GEVFamilyMuUnknown(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
               p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE,
-              ..withWarningGEV = TRUE)
+              secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr  = FALSE,
+              ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE)
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -24,6 +24,13 @@
   \item{trafo}{ matrix or NULL: transformation of the parameter }
   \item{start0Est}{ startEstimator --- if \code{NULL} \code{\link{PickandsEstimator}} is used }
   \item{withPos}{ logical of length 1: Is shape restricted to positive values? }
+  \item{secLevel}{ a numeric of length 1:
+       In the ideal GEV model, for each observastion \eqn{X_i}{Xi}, the expression
+       \eqn{1+\frac{{\rm shape}(X_i-{\rm loc})}{{\rm scale}}}{1+shape(Xi-loc)/scale}
+       must be positive, which in principle could be attacked by a single outlier.
+       Hence for sample size \eqn{n} we allow for \eqn{\varepsilon n}{eps n}
+       violations, interpreting the violations as outliers. Here
+       \eqn{\varepsilon = {\tt secLevel}/\sqrt{n}}{eps = secLevel/sqrt(n)}. }
   \item{withCentL2}{logical: shall L2 derivative be centered by substracting
        the E()? Defaults to \code{FALSE}, but higher accuracy can be achieved
        when set to \code{TRUE}.}


From noreply at r-forge.r-project.org  Sat Apr 12 15:05:32 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sat, 12 Apr 2014 15:05:32 +0200 (CEST)
Subject: [Robast-commits] r748 - in branches/robast-1.0/pkg/RobExtremes: R
	man
Message-ID: <20140412130532.62C4F186E8E@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-12 15:05:31 +0200 (Sat, 12 Apr 2014)
New Revision: 748

Added:
   branches/robast-1.0/pkg/RobExtremes/R/startEstGPD.R
Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
   branches/robast-1.0/pkg/RobExtremes/man/GParetoFamily.Rd
Log:
RobExtremes: fixed issue with check.validity as notified by B. Spangl, and extended starting estimator in GParetoFamily

Modified: branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-04-09 21:20:47 UTC (rev 747)
+++ branches/robast-1.0/pkg/RobExtremes/R/GParetoFamily.R	2014-04-12 13:05:31 UTC (rev 748)
@@ -41,6 +41,7 @@
                           of.interest = c("scale", "shape"), 
                           p = NULL, N = NULL, trafo = NULL,
                           start0Est = NULL, withPos = TRUE,
+                          secLevel = 0.7,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
                           ..ignoreTrafo = FALSE){
@@ -127,14 +128,19 @@
     ## starting parameters
     startPar <- function(x,...){
         tr <- theta[1]
-        
+        n <- length(x)
+        epsn <- min(floor(secLevel*sqrt(n))+1,n)
+
         ## Pickand estimator
         if(is.null(start0Est)){
            PF <- GParetoFamily(loc = theta[1],
                             scale = theta[2], shape = theta[3])
-           e1 <- medkMADhybr(c(x), k=10, ParamFamily = PF,
-                             q.lo = 1e-3, q.up = 15)
-           e0 <- estimate(e1)
+           e1 <- try(
+           medkMADhybr(c(x), k=10, ParamFamily = PF,
+                             q.lo = 1e-3, q.up = 15), silent =TRUE)
+           if(is(e1,"try-error")){ e0 <- .getBetaXiGPD(x=x, mu=tr,
+                       xiGrid=.getXiGrid(), withPos=withPos)
+           }else e0 <- estimate(e1)
         }else{
            if(is(start0Est,"function")){
               e1 <- start0Est(x, ...)
@@ -144,9 +150,9 @@
                e0 <- e0[c("scale", "shape")]
         }
 
-        if(any(x < tr-.Machine$double.eps))
+        if(quantile(e0[2]*(x-tr), epsn/n)<.Machine$double.eps)
                stop("some data smaller than 'loc' ")
-        if(e0[2]<0) if(any(x > tr-e0[1]/e0[2]))
+        if(e0[2]<0) if(quantile(x,1-epsn/n) > tr-e0[1]/e0[2])
                stop("shape is negative and some data larger than 'loc-scale/shape' ")
 #        if(any(x < tr-e0["scale"]/e0["shape"]))
 #               stop("some data smaller than 'loc-scale/shape' ")

Modified: branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-09 21:20:47 UTC (rev 747)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGEV.R	2014-04-12 13:05:31 UTC (rev 748)
@@ -1,7 +1,8 @@
 .getXiGrid <- function(){c(0.1,seq(-0.48,5,by=0.5))}
 
 
-.getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7){
+.getBetaXiGEV <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7,
+                          .issueIntermediateParams = FALSE){
 
   n <- length(x)
   epsn <- min(floor(secLevel*sqrt(n))+1,n)
@@ -9,8 +10,47 @@
   x0 <- x-mu
   s0 <- max(x0)-min(x0)
   crit0 <- Inf
+
   fu <- function(x,...) .getBetaXiGEV(x,mu,xiGrid = xiGrid,withPos=withPos)
+  e0 <- NULL
+
+  ### first try (to ensure global consistency): PickandsEstimator
+  try({mygev <- GEVFamily(loc=0,scale=1,shape=0.1, withPos=withPos,
+                     ..withWarningGEV=FALSE)
+       e1 <- PickandsEstimator(x,ParamFamily=mygev)
+       if(.issueIntermediateParams){
+           cat("Pickands:\n");print(e1) }
+       e0 <- estimate(e1)}, silent=TRUE)
+
+  if(!is.null(e0)) if(!is(e0,"try-error")){
+      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"=es0[1],"shape"=es0[2])),silent=TRUE)
+      es0 <- c(NA,NA)
+      if(!is(mde0,"try-error")){
+          es <- estimate(mde0)
+          crit1 <- criterion(mde0)
+          if(.issueIntermediateParams){
+             cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), , "   ")
+          }
+          if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
+             mdeb <- mde0
+             crit0 <- crit1
+             es0 <- es
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' fulfilled;\n")
+             }
+          }else{
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' violated;\n")
+             }
+          }
+      }
+  }
+
+  i <- 0
   for(xi in xiGrid){
+      i <- i + 1
       funl <- function(sig){
          mygev1 <- GEV(loc=0,scale=sig,shape=xi)
          CvMDist(x0,mygev1)
@@ -25,16 +65,28 @@
       if(!is(mde0,"try-error")){
           es <- estimate(mde0)
           crit1 <- criterion(mde0)
+          if(.issueIntermediateParams){
+              cat("candidate no",i+1, ":\n", round(es,6), " crit:", round(crit1,6), "   ")
+          }
           if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
+             if(.issueIntermediateParams){
+                   cat("side condition '1+sc/sh (x-mu) >0' fulfilled;\n")
+             }
              if(crit1<crit0){
                 mdeb <- mde0
                 crit0 <- crit1
                 es0 <- es
              }
           }else{
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' violated;\n")
+             }
              es[1] <- intlo+1e-5
              mygev2 <- GEV(loc=0,scale=es[1],shape=es[2])
              crit1 <- CvMDist(x0,mygev2)
+             if(.issueIntermediateParams){
+                 cat("candidate no",i+1, "(b):\n", round(es,6), " crit:", round(crit1,6), "   ")
+             }
              if(crit1<crit0){
                 crit0 <- crit1
                 es0 <- es
@@ -46,9 +98,12 @@
   return(es)
 }
 
-.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7){
+.getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7,
+                            .issueIntermediateParams = FALSE){
   mu <- quantile(x,exp(-1))
-  es <- .getBetaXiGEV(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos, secLevel = secLevel)
+  es <- .getBetaXiGEV(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos,
+                      secLevel = secLevel,
+                      .issueIntermediateParams = .issueIntermediateParams)
   es0 <- c(mu,es)
   names(es0) <- c("loc","scale","shape")
   return(es0)

Added: branches/robast-1.0/pkg/RobExtremes/R/startEstGPD.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/startEstGPD.R	                        (rev 0)
+++ branches/robast-1.0/pkg/RobExtremes/R/startEstGPD.R	2014-04-12 13:05:31 UTC (rev 748)
@@ -0,0 +1,106 @@
+.getBetaXiGPD <- function(x, mu, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7,
+                          .issueIntermediateParams = FALSE){
+
+  n <- length(x)
+  epsn <- min(floor(secLevel*sqrt(n))+1,n)
+
+  x0 <- x-mu
+  s0 <- max(x0)-min(x0)
+  crit0 <- Inf
+
+  fu <- function(x,...) .getBetaXiGPD(x,mu,xiGrid = xiGrid,withPos=withPos)
+  e0 <- NULL
+
+  ### first try (to ensure global consistency): PickandsEstimator
+  try({mygpd <- GParetoFamily(loc=0,scale=1,shape=0.1, withPos=withPos)
+       e1 <- medkMADhybr(x,ParamFamily=mygpd, k=10)
+       if(.issueIntermediateParams){
+       cat("MedkMAD:\n");print(e1)}
+       e0 <- estimate(e1)}, silent=TRUE)
+
+  if(!is.null(e0)) if(!is(e0,"try-error")){
+      mygpd <- GParetoFamily(loc=0,scale=e0[1],shape=e0[2], withPos=withPos,
+                         start0Est = fu)
+      mde0 <- try(MDEstimator(x0, mygpd, distance=CvMDist, startPar=c("scale"=es0[1],"shape"=es0[2])),silent=TRUE)
+      es0 <- c(NA,NA)
+      if(!is(mde0,"try-error")){
+          es <- estimate(mde0)
+          crit1 <- criterion(mde0)
+          if(.issueIntermediateParams){
+             cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), , "   ")
+          }
+          if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
+             mdeb <- mde0
+             crit0 <- crit1
+             es0 <- es
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' fulfilled;\n")
+             }
+          }else{
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' violated;\n")
+             }
+          }
+      }
+  }
+
+  i <- 0
+  for(xi in xiGrid){
+      i <- i + 1
+      funl <- function(sig){
+         mygpd1 <- GPareto(loc=0,scale=sig,shape=xi)
+         CvMDist(x0,mygpd1)
+      }
+      intlo <- quantile(-xi*(x-mu),1-epsn/n)
+      intv <-  c(max(1e-5,intlo), s0)
+      sigCvMMD1 <- optimize(funl, interval=intv)$minimum
+      mygpd <- GParetoFamily(loc=0,scale=sigCvMMD1,shape=xi, withPos=withPos,
+                         start0Est = fu)
+      mde0 <- try(MDEstimator(x0, mygpd, distance=CvMDist, startPar=c("scale"=sigCvMMD1,"shape"=xi)),silent=TRUE)
+      es0 <- c(NA,NA)
+      if(!is(mde0,"try-error")){
+          es <- estimate(mde0)
+          crit1 <- criterion(mde0)
+          if(.issueIntermediateParams){
+              cat("candidate no",i+1, ":\n", round(es,6), " crit:", round(crit1,6), "   ")
+          }
+          if(quantile(1+es[2]*x0/es[1], epsn/n)>0){
+             if(.issueIntermediateParams){
+                   cat("side condition '1+sc/sh (x-mu) >0' fulfilled;\n")
+             }
+             if(crit1<crit0){
+                mdeb <- mde0
+                crit0 <- crit1
+                es0 <- es
+             }
+          }else{
+             if(.issueIntermediateParams){
+                cat("side condition '1+sc/sh (x-mu) >0' violated;\n")
+             }
+             es[1] <- intlo+1e-5
+             mygpd2 <- GPareto(loc=0,scale=es[1],shape=es[2])
+             crit1 <- CvMDist(x0,mygpd2)
+             if(.issueIntermediateParams){
+                 cat("candidate no",i+1, "(b):\n", round(es,6), " crit:", round(crit1,6), "   ")
+             }
+             if(crit1<crit0){
+                crit0 <- crit1
+                es0 <- es
+             }
+          }
+      }
+  }
+  names(es) <- c("scale","shape")
+  return(es)
+}
+
+#.getMuBetaXiGPD <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7,
+#                            .issueIntermediateParams = FALSE){
+#  mu <- quantile(x,exp(-1))
+#  es <- .getBetaXiGPD(x=x, mu=mu, xiGrid=xiGrid, withPos=withPos,
+#                      secLevel = secLevel,
+#                      .issueIntermediateParams = .issueIntermediateParams)
+#  es0 <- c(mu,es)
+#  names(es0) <- c("loc","scale","shape")
+#  return(es0)
+#}

Modified: branches/robast-1.0/pkg/RobExtremes/man/GParetoFamily.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GParetoFamily.Rd	2014-04-09 21:20:47 UTC (rev 747)
+++ branches/robast-1.0/pkg/RobExtremes/man/GParetoFamily.Rd	2014-04-12 13:05:31 UTC (rev 748)
@@ -9,7 +9,8 @@
 \usage{
 GParetoFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
               p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              withCentL2 = FALSE, withL2derivDistr  = FALSE, ..ignoreTrafo = FALSE)
+              secLevel = 0.7,  withCentL2 = FALSE, withL2derivDistr  = FALSE,
+              ..ignoreTrafo = FALSE)
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -23,6 +24,13 @@
   \item{trafo}{ matrix or NULL: transformation of the parameter }
   \item{start0Est}{ startEstimator --- if \code{NULL} \code{\link{medkMADhybr}} is used }
   \item{withPos}{ logical of length 1: Is shape restricted to positive values? }
+  \item{secLevel}{ a numeric of length 1:
+       In the ideal GEV model, for each observastion \eqn{X_i}{Xi}, the expression
+       \eqn{1+\frac{{\rm shape}(X_i-{\rm loc})}{{\rm scale}}}{1+shape(Xi-loc)/scale}
+       must be positive, which in principle could be attacked by a single outlier.
+       Hence for sample size \eqn{n} we allow for \eqn{\varepsilon n}{eps n}
+       violations, interpreting the violations as outliers. Here
+       \eqn{\varepsilon = {\tt secLevel}/\sqrt{n}}{eps = secLevel/sqrt(n)}. }
   \item{withCentL2}{logical: shall L2 derivative be centered by substracting
        the E()? Defaults to \code{FALSE}, but higher accuracy can be achieved
        when set to \code{TRUE}.}


From noreply at r-forge.r-project.org  Tue Apr 15 00:36:08 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 15 Apr 2014 00:36:08 +0200 (CEST)
Subject: [Robast-commits] r749 - branches/robast-1.0/pkg/ROptEst/R
Message-ID: <20140414223608.488A2186F78@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-15 00:36:07 +0200 (Tue, 15 Apr 2014)
New Revision: 749

Modified:
   branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
Log:
ROptEst: fixed Matthias' error-issue in TeaserExample.R

Modified: branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-04-12 13:05:31 UTC (rev 748)
+++ branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-04-14 22:36:07 UTC (rev 749)
@@ -65,28 +65,27 @@
         }
 
 
-.getFunCnip <- function(IC1, IC2, risk, L2Fam, r, b20=NULL){
+.getFunCnip <- function(IC1,IC2, risk, L2Fam, r, b20=NULL){
 
         riskfct <- getRiskFctBV(risk, biastype(risk))
-
        .getTrVar <- function(IC){
            R <- Risks(IC)[["trAsCov"]]
            if(is.null(R)) R <- getRiskIC(IC, risk = trAsCov(), L2Fam = L2Fam)
            if(length(R) > 1) R <- R$value
            return(R)
         }
-        R1 <- .getTrVar(IC1)
-        R2 <- .getTrVar(IC2)
+        R1 <- .getTrVar (IC1)
+        R2 <- .getTrVar (IC2)
 
 
         fun <- function(x){
-            y1 <- evalIC(IC1, as.matrix(x,ncol=1))
-            r1 <- riskfct(var=R1, bias=r*fct(normtype(risk))(y1))
+            y1 <- sapply(x, function(x1)evalIC(IC1,as.matrix(x1,ncol=1)))
+            r1 <- riskfct(var=R1,bias=r*fct(normtype(risk))(y1))
             if(!is.null(b20)){
                r2 <- riskfct(var=R1, bias=b20)
             }else{
-               y2 <- sapply(x, function(x0) evalIC(IC2,x0))
-               r2 <- riskfct(var=R2, bias=r*fct(normtype(risk))(y2))
+               y2 <- sapply(x,function(x0) evalIC(IC2,x0))
+               r2 <- riskfct(var=R2,bias=r*fct(normtype(risk))(y2))
             }
             r1 - r2
         }
@@ -121,7 +120,7 @@
             if(fCpl) b20 <- neighbor at radius*Risks(IC2)$asBias$value
         dots$fromCniperPlot <- NULL
         
-        fun <- .getFunCnip(IC1, IC2, risk, L2Fam, neighbor at radius, b20)
+        fun <- .getFunCnip(IC1,IC2, risk, L2Fam, neighbor at radius, b20)
 
         if(missing(scaleX.fct)){
            scaleX.fct <- p(L2Fam)
@@ -138,7 +137,6 @@
         dots$x <- resc$X
         dots$y <- resc$Y
 
-
         dots$type <- "l"
         if(is.null(dots$main)) dots$main <- gettext("Cniper region plot")
         if(is.null(dots$xlab)) dots$xlab <- gettext("Dirac point")
@@ -165,7 +163,6 @@
                    dots$lty <- ltyo[[1]]
             }
         }
-        dots <- dots[names(dots) != "withMaxRisk"]
         do.call(plot,dots)
 
         dots <- .makedotsLowLevel(dots)
@@ -192,18 +189,17 @@
 
         mc <- match.call(expand.dots = FALSE)
 
-        if(!is.null(as.list(mc)$lower)) lower <- p(L2Fam)(lower)
-        if(!is.null(as.list(mc)$upper)) upper <- p(L2Fam)(upper)
-        lower <- q(L2Fam)(lower)
-        upper <- q(L2Fam)(upper)
+        if(is.null(as.list(mc)$lower)) lower <- q(L2Fam)(lower)
+        if(is.null(as.list(mc)$upper)) upper <- q(L2Fam)(upper)
+#        lower <- q(L2Fam)(lower)
+#        upper <- q(L2Fam)(upper)
 
         robMod <- InfRobModel(center = L2Fam, neighbor = neighbor)
 
         psi <- optIC(model = L2Fam, risk = asCov())
         eta <- optIC(model = robMod, risk = risk)
 
-        fun <- .getFunCnip(psi, eta, risk, L2Fam, neighbor at radius)
-
+        fun <- .getFunCnip(psi,eta, risk, L2Fam, neighbor at radius)
         res <- uniroot(fun, lower = lower, upper = upper)$root
         names(res) <- "cniper point"
         res
@@ -222,12 +218,12 @@
                            which.lbs = NULL, which.Order  = NULL,
                            return.Order = FALSE){
 
-        mc <- match.call(#call = sys.call(sys.parent(1)),
+        mc0 <- match.call(#call = sys.call(sys.parent(1)),
                        expand.dots = FALSE)
+        mc <- match.call(#call = sys.call(sys.parent(1)),
+                       expand.dots = TRUE)
         mcl <- as.list(mc[-1])
-        mcl <- mcl[names(mcl) != "..."]
-        dots <- as.list(mc$"...")
-        mcl <- .merge.lists(mcl, dots)
+        dots <- as.list(mc0$"...")
 
         robMod <- InfRobModel(center = L2Fam, neighbor = neighbor)
 
@@ -240,6 +236,7 @@
            mcl$main <- gettext("Cniper point plot")
 
         if(withMaxRisk) mcl$fromCniperPlot <- TRUE
+        mcl$withMaxRisk <- NULL
         do.call(cniperCont, mcl)
 }
 


From noreply at r-forge.r-project.org  Tue Apr 15 01:24:50 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 15 Apr 2014 01:24:50 +0200 (CEST)
Subject: [Robast-commits] r750 - branches/robast-1.0/pkg/ROptEst/R
Message-ID: <20140414232450.2429D186DCB@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-15 01:24:49 +0200 (Tue, 15 Apr 2014)
New Revision: 750

Modified:
   branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
   branches/robast-1.0/pkg/ROptEst/R/plotWrapper.R
Log:
ROptEst: found the bug -- used the wrong variance

Modified: branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-04-14 22:36:07 UTC (rev 749)
+++ branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-04-14 23:24:49 UTC (rev 750)
@@ -82,7 +82,7 @@
             y1 <- sapply(x, function(x1)evalIC(IC1,as.matrix(x1,ncol=1)))
             r1 <- riskfct(var=R1,bias=r*fct(normtype(risk))(y1))
             if(!is.null(b20)){
-               r2 <- riskfct(var=R1, bias=b20)
+               r2 <- riskfct(var=R2, bias=b20)
             }else{
                y2 <- sapply(x,function(x0) evalIC(IC2,x0))
                r2 <- riskfct(var=R2,bias=r*fct(normtype(risk))(y2))

Modified: branches/robast-1.0/pkg/ROptEst/R/plotWrapper.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/plotWrapper.R	2014-04-14 22:36:07 UTC (rev 749)
+++ branches/robast-1.0/pkg/ROptEst/R/plotWrapper.R	2014-04-14 23:24:49 UTC (rev 750)
@@ -73,9 +73,7 @@
   ##
 
   ## Scaling of the axes
-  print(fam)
   scaleList <- rescaleFunction(fam, FALSE, rescale)
-  print(scaleList)
 
   argsList <- c(list(L2Fam = substitute(fam)
                    ,data = substitute(NULL)


From noreply at r-forge.r-project.org  Wed Apr 16 01:12:55 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 16 Apr 2014 01:12:55 +0200 (CEST)
Subject: [Robast-commits] r751 - in branches/robast-1.0/pkg/RobExtremes: R
	inst/AddMaterial/interpolation man
Message-ID: <20140415231255.94046186F14@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-16 01:12:55 +0200 (Wed, 16 Apr 2014)
New Revision: 751

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
   branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
   branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R
   branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R
   branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
   branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
   branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd
Log:
RobExtremes: fixed buglets in GEVFamilyMuUnknown which hindered evaluation of LagrangeMults, prepared code for evaluation of LMs on xi grid for this family; .pretreat.of.interest and .define.tau.Dtau are more accurate now; cleaned small buglet in modifyPar

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamily.R	2014-04-15 23:12:55 UTC (rev 751)
@@ -15,34 +15,46 @@
     }
 
 ### pretreatment of of.interest
-.pretreat.of.interest <- function(of.interest,trafo){
+.pretreat.of.interest <- function(of.interest,trafo,withMu=FALSE){
     if(is.null(trafo)){
         of.interest <- unique(of.interest)
-        if(length(of.interest) > 2)
+        if(!withMu && length(of.interest) > 2)
             stop("A maximum number of two parameters resp. parameter transformations may be selected.")
-        if(!all(of.interest %in% c("scale", "shape", "quantile", "expected loss", "expected shortfall")))
+        if(withMu && length(of.interest) > 3)
+            stop("A maximum number of three parameters resp. parameter transformations may be selected.")
+        if(!withMu && !all(of.interest %in% c("scale", "shape", "quantile", "expected loss", "expected shortfall")))
             stop("Parameters resp. transformations of interest have to be selected from: ",
                 "'scale', 'shape', 'quantile', 'expected loss', 'expected shortfall'.")
+        if(withMu && !all(of.interest %in% c("loc", "scale", "shape", "quantile", "expected loss", "expected shortfall")))
+            stop("Parameters resp. transformations of interest have to be selected from: ",
+                "'loc', 'scale', 'shape', 'quantile', 'expected loss', 'expected shortfall'.")
 
         ## reordering of of.interest
-        if(("scale" %in% of.interest) && ("scale" != of.interest[1])){
-            of.interest[2] <- of.interest[1]
-            of.interest[1] <- "scale"
+        muAdd <- 0
+        if(withMu & "loc" %in% of.interest){
+           muAdd <- 1
+           muWhich <- which(of.interest=="loc")
+           notmuWhich <- which(!of.interest %in% "loc")
+           of.interest <- of.interest[c(muWhich,notmuWhich)]
         }
-        if(!("scale" %in% of.interest) && ("shape" %in% of.interest) && ("shape" != of.interest[1])){
-            of.interest[2] <- of.interest[1]
-            of.interest[1] <- "shape"
+        if(("scale" %in% of.interest) && ("scale" != of.interest[1+muAdd])){
+            of.interest[2+muAdd] <- of.interest[1+muAdd]
+            of.interest[1+muAdd] <- "scale"
         }
+        if(!("scale" %in% of.interest) && ("shape" %in% of.interest) && ("shape" != of.interest[1+muAdd])){
+            of.interest[2+muAdd] <- of.interest[1+muAdd]
+            of.interest[1+muAdd] <- "shape"
+        }
         if(!any(c("scale", "shape") %in% of.interest) && ("quantile" %in% of.interest)
-          && ("quantile" != of.interest[1])){
-            of.interest[2] <- of.interest[1]
-            of.interest[1] <- "quantile"
+          && ("quantile" != of.interest[1+muAdd])){
+            of.interest[2+muAdd] <- of.interest[1+muAdd]
+            of.interest[1+muAdd] <- "quantile"
         }
         if(!any(c("scale", "shape", "quantile") %in% of.interest)
           && ("expected shortfall" %in% of.interest)
-          && ("expected shortfall" != of.interest[1])){
-            of.interest[2] <- of.interest[1]
-            of.interest[1] <- "expected shortfall"
+          && ("expected shortfall" != of.interest[1+muAdd])){
+            of.interest[2+muAdd] <- of.interest[1+muAdd]
+            of.interest[1+muAdd] <- "expected shortfall"
         }
     }
   return(of.interest)
@@ -74,12 +86,20 @@
             }else{
                 tau1 <- tau
                 tau <- function(theta){ }
-                body(tau) <- substitute({ btq0; c(tau0(theta), q) },
-                                        list(btq0=btq, tau0 = tau1))
+                body(tau) <- substitute({ btq0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, q)
+                                          names(th) <- c(names(th0),"quantile")
+                                          th
+                                         }, list(btq0=btq, tau0 = tau1))
                 Dtau1 <- Dtau
                 Dtau <- function(theta){}
-                body(Dtau) <- substitute({ bDq0; rbind(Dtau0(theta), D) },
-                                         list(Dtau0 = Dtau1, bDq0 = bDq))
+                body(Dtau) <- substitute({ bDq0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"quantile")
+                                           D1
+                                           }, list(Dtau0 = Dtau1, bDq0 = bDq))
             }
         }
         if("expected shortfall" %in% of.interest){
@@ -90,12 +110,18 @@
             }else{
                 tau1 <- tau
                 tau <- function(theta){ }
-                body(tau) <- substitute({ btes0; c(tau0(theta), es) },
-                                        list(tau0 = tau1, btes0=btes))
+                body(tau) <- substitute({ btes0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, es)
+                                          names(th) <- c(names(th0),"expected shortfall")
+                                          th}, list(tau0 = tau1, btes0=btes))
                 Dtau1 <- Dtau
                 Dtau <- function(theta){}
-                body(Dtau) <- substitute({ bDes0; rbind(Dtau0(theta), D) },
-                                         list(Dtau0 = Dtau1, bDes0=bDes))
+                body(Dtau) <- substitute({ bDes0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"expected shortfall")
+                                           D1}, list(Dtau0 = Dtau1, bDes0=bDes))
             }
         }
         if("expected loss" %in% of.interest){
@@ -106,12 +132,18 @@
             }else{
                 tau1 <- tau
                 tau <- function(theta){ }
-                body(tau) <- substitute({ btel0; c(tau0(theta), el) },
-                                        list(tau0 = tau1, btel0=btel))
+                body(tau) <- substitute({ btel0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, el)
+                                          names(th) <- c(names(th0),"expected los")
+                                          th}, list(tau0 = tau1, btel0=btel))
                 Dtau1 <- Dtau
                 Dtau <- function(theta){}
-                body(Dtau) <- substitute({ bDel0; rbind(Dtau0(theta), D) },
-                                         list(Dtau0 = Dtau1, bDel0=bDel))
+                body(Dtau) <- substitute({ bDel0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"expected loss")
+                                           D1}, list(Dtau0 = Dtau1, bDel0=bDel))
             }
         }
         trafo <- function(x){ list(fval = tau(x), mat = Dtau(x)) }
@@ -287,7 +319,8 @@
 
     modifyPar <- function(theta){
         theta <- makeOKPar(theta)
-        if(..withWarningGEV).warningGEVShapeLarge(theta["shape"])
+        sh <- if(!is.null(names(theta))) theta["shape"] else theta[2]
+        if(..withWarningGEV).warningGEVShapeLarge(sh)
         if(!is.null(names(theta))){
             sc <- theta["scale"]
             sh <- theta["shape"]

Modified: branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/R/GEVFamilyMuUnknown.R	2014-04-15 23:12:55 UTC (rev 751)
@@ -28,19 +28,130 @@
 ## trafo: optional parameter transformation
 ## start0Est: startEstimator for MLE and MDE --- if NULL HybridEstimator is used;
 
+.define.tau.Dtau.withMu <- function(of.interest, btq, bDq, btes,
+                                    bDes, btel, bDel, p, N){
+        tau <- NULL
+        if("loc" %in% of.interest){
+            tau <- function(theta){ th <- theta[1]; names(th) <- "loc";  th}
+            Dtau <- function(theta){ D <- t(c(1, 0,0)); rownames(D) <- "loc"; D}
+        }
+        if("scale" %in% of.interest){
+            if(is.null(tau)){
+               tau <- function(theta){th <- theta[2]; names(th) <- "scale"; th}
+               Dtau <- function(theta){D <- t(c(0,1,0));rownames(D) <- "scale";D}
+            }else{
+               tau <- function(theta){ th <- theta;
+                                       names(th) <- c("loc","scale");  th}
+               Dtau <- function(theta){ D <- t(matrix(c(1,0,0,0,1, 0),3,2))
+                                        rownames(D) <- c("loc","scale"); D}
+            }
+        }
+        if("shape" %in% of.interest){
+            if(is.null(tau)){
+               tau <- function(theta){th <- theta[3]; names(th) <- "shape"; th}
+               Dtau <- function(theta){D <- t(c(0,0,1));rownames(D) <- "shape";D}
+            }else{
+                .tauo <- tau
+                .Dtauo <- Dtau
+                tau <- function(theta){
+                            th1 <- .tauo(theta)
+                            th <- c(th1,theta[3])
+                            names(th) <- c(names(th1),"shape")
+                            th}
+                Dtau <- function(theta){
+                            D0 <- .Dtauo(theta)
+                            D <- rbind(D0,t(c(0,0,1)))
+                            rownames(D) <- c(rownames(D0),"shape")
+                            D}
+            }
+        }
+        if("quantile" %in% of.interest){
+            if(is.null(p)) stop("Probability 'p' has to be specified.")
+            if(is.null(tau)){
+                tau <- function(theta){ }; body(tau) <- btq
+                Dtau <- function(theta){ };body(Dtau) <- bDq
+            }else{
+                tau1 <- tau
+                tau <- function(theta){ }
+                body(tau) <- substitute({ btq0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, q)
+                                          names(th) <- c(names(th0),"quantile")
+                                          th
+                                         }, list(btq0=btq, tau0 = tau1))
+                Dtau1 <- Dtau
+                Dtau <- function(theta){}
+                body(Dtau) <- substitute({ bDq0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"quantile")
+                                           D1
+                                           }, list(Dtau0 = Dtau1, bDq0 = bDq))
+            }
+        }
+        if("expected shortfall" %in% of.interest){
+            if(is.null(p)) stop("Probability 'p' has to be specified.")
+            if(is.null(tau)){
+                tau <- function(theta){ };  body(tau) <- btes
+                Dtau <- function(theta){ }; body(Dtau) <- bDes
+            }else{
+                tau1 <- tau
+                tau <- function(theta){ }
+                body(tau) <- substitute({ btes0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, es)
+                                          names(th) <- c(names(th0),"expected shortfall")
+                                          th}, list(tau0 = tau1, btes0=btes))
+                Dtau1 <- Dtau
+                Dtau <- function(theta){}
+                body(Dtau) <- substitute({ bDes0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"expected shortfall")
+                                           D1}, list(Dtau0 = Dtau1, bDes0=bDes))
+            }
+        }
+        if("expected loss" %in% of.interest){
+            if(is.null(N)) stop("Expected frequency 'N' has to be specified.")
+            if(is.null(tau)){
+                tau <- function(theta){ }; body(tau) <- btel
+                Dtau <- function(theta){ }; body(Dtau) <- bDel
+            }else{
+                tau1 <- tau
+                tau <- function(theta){ }
+                body(tau) <- substitute({ btel0
+                                          th0 <- tau0(theta)
+                                          th <- c(th0, el)
+                                          names(th) <- c(names(th0),"expected los")
+                                          th}, list(tau0 = tau1, btel0=btel))
+                Dtau1 <- Dtau
+                Dtau <- function(theta){}
+                body(Dtau) <- substitute({ bDel0
+                                           D0 <- Dtau0(theta)
+                                           D1 <- rbind(D0, D)
+                                           rownames(D1) <- c(rownames(D0),"expected loss")
+                                           D1}, list(Dtau0 = Dtau1, bDel0=bDel))
+            }
+        }
+        trafo <- function(x){ list(fval = tau(x), mat = Dtau(x)) }
+        return(trafo)
+}
+
+
 GEVFamilyMuUnknown <- function(loc = 0, scale = 1, shape = 0.5,
-                          of.interest = c("scale", "shape"),
+                          of.interest = c("loc","scale", "shape"),
                           p = NULL, N = NULL, trafo = NULL,
                           start0Est = NULL, withPos = TRUE,
                           secLevel = 0.7,
                           withCentL2 = FALSE,
                           withL2derivDistr  = FALSE,
                           ..ignoreTrafo = FALSE,
-                          ..withWarningGEV = TRUE){
+                          ..withWarningGEV = TRUE,
+                          ..name =""){
     theta <- c(loc, scale, shape)
     if(..withWarningGEV).warningGEVShapeLarge(shape)
     
-    of.interest <- .pretreat.of.interest(of.interest,trafo)
+    of.interest <- .pretreat.of.interest(of.interest,trafo,withMu=TRUE)
 
     ##symmetry
     distrSymm <- NoSymmetry()
@@ -110,8 +221,8 @@
 
     fromOfInt <- FALSE
     if(is.null(trafo)||..ignoreTrafo){fromOfInt <- TRUE
-       trafo <- .define.tau.Dtau(of.interest, btq, bDq, btes, bDes,
-                                 btel, bDel, p, N)
+       trafo <- .define.tau.Dtau.withMu(of.interest, btq, bDq, btes, bDes,
+                                        btel, bDel, p, N)
     }else if(is.matrix(trafo) & nrow(trafo) > 3)
            stop("number of rows of 'trafo' > 3")
 ####
@@ -174,7 +285,8 @@
 
     modifyPar <- function(theta){
         theta <- makeOKPar(theta)
-        if(..withWarningGEV).warningGEVShapeLarge(theta["shape"])
+        sh <- if(!is.null(names(theta))) theta["shape"] else theta[3]
+        if(..withWarningGEV).warningGEVShapeLarge(sh)
         if(!is.null(names(theta))){
             loc <- theta["loc"]
             sc <- theta["scale"]
@@ -274,7 +386,7 @@
 
 
     FisherInfo <- FisherInfo.fct(param)
-    name <- "GEV Family"
+    name <- if(..name=="") "GEV Family" else ..name
 
     ## initializing the GPareto family with components of L2-family
     L2Fam <- new("GEVFamilyMuUnknown")
@@ -288,8 +400,8 @@
     L2Fam at startPar <- startPar
     L2Fam at makeOKPar <- makeOKPar
     L2Fam at modifyParam <- modifyPar
-    L2Fam at L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
-    L2Fam at L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry())
+    L2Fam at L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric(), NonSymmetric())
+    L2Fam at L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry(), NoSymmetry())
 
     L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param),
                                Domain = Reals()))
@@ -300,7 +412,7 @@
     }
 
     if(fromOfInt){
-       L2Fam at fam.call <- substitute(GEVFamily(loc = loc0, scale = scale0,
+       L2Fam at fam.call <- substitute(GEVFamilyMuUnknown(loc = loc0, scale = scale0,
                                  shape = shape0, of.interest = of.interest0,
                                  p = p0, N = N0,
                                  withPos = withPos0, withCentL2 = FALSE,
@@ -309,7 +421,7 @@
                               of.interest0 = of.interest, p0 = p, N0 = N,
                               withPos0 = withPos))
     }else{
-       L2Fam at fam.call <- substitute(GEVFamily(loc = loc0, scale = scale0,
+       L2Fam at fam.call <- substitute(GEVFamilyMuUnknown(loc = loc0, scale = scale0,
                                  shape = shape0, of.interest = NULL,
                                  p = p0, N = N0, trafo = trafo0,
                                  withPos = withPos0, withCentL2 = FALSE,

Modified: branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R	2014-04-15 23:12:55 UTC (rev 751)
@@ -16,11 +16,11 @@
 .getLMGrid <- function(xiGrid = getShapeGrid(),
                       PFam = GParetoFamily(scale=1,shape=2),
                       optFct = .RMXE.xi, GridFileName="LMGrid.Rdata",
-                      withPrint = FALSE){
+                      withPrint = FALSE, len = 13){
    ### changed defaults and argnames (for historical reasons):
    ROptEst::.getLMGrid(thGrid = xiGrid, PFam = PFam, optFct = optFct,
            modifyfct = NULL, GridFileName = GridFileName,
-           withPrint = withPrint)}
+           withPrint = withPrint, len = len)}
 
 
 .svInt <- function(optF = .RMXE.th, xiGrid = getShapeGrid(700, cutoff.at.0=0.005),
@@ -30,12 +30,13 @@
                    maxiter = 150, tol = .Machine$double.eps^0.5,
                    loRad = 0, upRad = Inf, loRad0 = 1e-3,
                    loRad.s=0.2, up.Rad.s=1,
-                   withStartLM = TRUE){
+                   withStartLM = TRUE, len = 13){
              namF <- gsub("\\.th$","",paste(deparse(substitute(optF))))
              namF <- gsub(" ", "",namF)
              to <- gsub("XXXX",gsub(" ","",name(PFam)),
                     gsub("YYYY", namF, "interpolYYYYXXXX.csv"))
              print(to)
+             len0 <- if(name(PFam)=="GEVU Family") 25 else 13
              .generateInterpGrid(thGrid = xiGrid,
                   PFam = PFam, toFileCSV = to,
                   getFun =  ROptEst::.getLMGrid,
@@ -44,7 +45,7 @@
                   upper = upper, lower = lower, OptOrIter = OptOrIter,
                   maxiter = maxiter, tol = tol, loRad = loRad, upRad = upRad,
                   loRad0 = loRad0, loRad.s = loRad.s, up.Rad.s = up.Rad.s,
-                  withStartLM = withStartLM)
+                  withStartLM = withStartLM, len = len0)
 }
 
 

Modified: branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R	2014-04-15 23:12:55 UTC (rev 751)
@@ -1,4 +1,4 @@
-getLMs <- function(Gridnam,Famnam,xi=0.7, baseDir="C:/rtest/robast", withPrint=FALSE){
+getLMs <- function(Gridnam,Famnam,xi=0.7, baseDir="C:/rtest/robast", withPrint=FALSE, withLoc = FALSE){
    ## Gridnam in (Sn,OMSE,RMXE,MBRE) ## uses partial matching!!
    ## Famnam in "Generalized Pareto Family",
    ##           "GEV Family",
@@ -6,12 +6,15 @@
    ##           "Weibull Family"  ## uses partial matching!!
    ## xi Scaleparameter (can be vector)
    ## basedir: Oberverzeichnis des r-forge svn checkouts
+   ## withPrint: diagnostischer Output?
+   ## withLoc: anzuschalten bei GEVFamilyMuUnknown...
    file <- file.path(baseDir, "branches/robast-0.9/pkg/RobAStRDA/R/sysdata.rda")
    if(!file.exists(file)) stop("Fehler mit Checkout")
    nE <- new.env()
    load(file, envir=nE)
    Gnams <- c("Sn","OMSE","RMXE","MBRE")
    Fnams <- c("Generalized Pareto Family",
+              "GEVU Family",
               "GEV Family",
               "Gamma family",
               "Weibull Family")
@@ -38,8 +41,16 @@
       len <- length(fct)
       LM <- sapply(1:len, function(i) fct[[i]](xi))
       if(length(xi)==1) LM <- matrix(LM,ncol=len)
-      colnames(LM) <- c("b","a1.a", "a2.a", "a1.i", "a2.i", "A11.a",
-                 "A12.a", "A21.a", "A22.a", "A11.i", "A12.i", "A21.i", "A22.i")
+      if(withLoc){
+         colnames(LM) <- c("b","a1.a", "a2.a", "a3.a", "a1.i", "a2.i", "a3.i",
+                           "A11.a", "A12.a", "A13.a", "A21.a", "A22.a", "A23.a",
+                           "A31.a", "A32.a", "A33.a", "A11.i", "A12.i", "A13.i",
+                           "A21.i", "A22.i", "A23.i", "A31.i", "A32.i", "A33.i")
+      }else{
+         colnames(LM) <- c("b","a1.a", "a2.a", "a1.i", "a2.i", "A11.a",
+                           "A12.a", "A21.a", "A22.a", "A11.i", "A12.i",
+                           "A21.i", "A22.i")
+      }
       return(cbind(xi,LM))
    }else{
       Sn <- fct(xi)

Modified: branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R	2014-04-15 23:12:55 UTC (rev 751)
@@ -5,7 +5,7 @@
 ### open R session
 require(RobExtremes)
 ### -> change this according to where you checked out the svn repo:
-.basepath <- "C:/rtest/RobASt/branches/robast-0.9/pkg"
+.basepath <- "C:/rtest/RobASt/branches/robast-1.0./pkg"
 ## <-
 oldwd <- getwd()
 .myFolderTo <- file.path(.basepath,"RobExtremesBuffer")
@@ -17,7 +17,8 @@
 #
 #PF <- GParetoFamily()
 #PF <- GEVFamily()
-PF <- GammaFamily()
+PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+#PF <- GammaFamily()
 #PF <- WeibullFamily()
 ###
 .svInt <- RobExtremes:::.svInt
@@ -25,7 +26,8 @@
 #    RobExtremes:::.generateInterpGridSn(PFam = PF)}
 ## to make this parallel, start this on several processors
 #.svInt1()
-.svInt(.OMSE.th, PFam=PF, xiGrid = getShapeGrid(3, cutoff.at.0=0.005))
+#.svInt(.OMSE.th, PFam=PF, xiGrid = getShapeGrid(3, cutoff.at.0=0.005))
+#.svInt(.OMSE.th, PFam=PF)
 #.svInt(.MBRE.th, PFam=PF)
 .svInt(.RMXE.th, PFam=PF)
 setwd(oldwd)

Modified: branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd	2014-04-15 23:12:55 UTC (rev 751)
@@ -7,10 +7,11 @@
   represents a Generalized EV family with unknown location parameter \code{mu}.
 }
 \usage{
-GEVFamilyMuUnknown(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"),
-              p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE,
-              secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr  = FALSE,
-              ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE)
+GEVFamilyMuUnknown(loc = 0, scale = 1, shape = 0.5, of.interest = c("loc",
+              "scale", "shape"), p = NULL, N = NULL, trafo = NULL,
+              start0Est = NULL, withPos = TRUE, secLevel = 0.7,
+              withCentL2 = FALSE, withL2derivDistr  = FALSE,
+              ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE, ..name = "")
 }
 \arguments{
   \item{loc}{ real: known/fixed threshold/location parameter }
@@ -38,6 +39,8 @@
       be computed? Defaults to \code{FALSE} (to speeds up computations).}
   \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.}
   \item{..withWarningGEV}{logical: shall warnings be issued if shape is large?}
+  \item{..name}{character: optional alternative name for the parametric family;
+                used in generating interpolating grids. }
 }
 \details{
   The slots of the corresponding L2 differentiable 

Modified: branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd	2014-04-14 23:24:49 UTC (rev 750)
+++ branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd	2014-04-15 23:12:55 UTC (rev 751)
@@ -30,13 +30,14 @@
 .OMSE.xi(xi, PFam)
 
 .getLMGrid(xiGrid = getShapeGrid(), PFam = GParetoFamily(scale=1,shape=2),
-           optFct = .RMXE.xi, GridFileName="LMGrid.Rdata", withPrint = FALSE)
+           optFct = .RMXE.xi, GridFileName="LMGrid.Rdata", withPrint = FALSE,
+           len = 13)
 
 .svInt(optF = .RMXE.th, xiGrid = getShapeGrid(700, cutoff.at.0=0.005),
        PFam = GParetoFamily(shape=1,scale=2), radius = 0.5, upper = 1e4,
        lower = 1e-4, OptOrIter = "iterate",  maxiter = 150,
        tol = .Machine$double.eps^0.5, loRad = 0, upRad = Inf, loRad0 = 1e-3,
-       loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE)
+       loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE, len = 13)
 
 .generateInterpGridSn(xiGrid = getShapeGrid(500, cutoff.at.0=0.005),
                       PFam = GParetoFamily(), withPrint = TRUE)
@@ -94,6 +95,7 @@
    internally set to \code{max(loRad,loRad0)}. }
   \item{withStartLM}{ logical of length 1: shall the LM's of the preceding grid
     value serve as starting value for the next grid value? }
+  \item{len}{integer; number of Lagrange multipliers to be calibrated. }
 }
 \details{
    \code{.getpsi} reads the respective interpolating function


From noreply at r-forge.r-project.org  Wed Apr 16 01:14:02 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 16 Apr 2014 01:14:02 +0200 (CEST)
Subject: [Robast-commits] r752 - in branches/robast-1.0/pkg/ROptEst: R man
Message-ID: <20140415231402.502DF186F41@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-16 01:14:01 +0200 (Wed, 16 Apr 2014)
New Revision: 752

Modified:
   branches/robast-1.0/pkg/ROptEst/R/interpolLM.R
   branches/robast-1.0/pkg/ROptEst/man/internal-interpolate.Rd
Log:
ROptEst:: preparations for evalation of LMs on xi grid for GEVFamilyMuUnknown. 

Modified: branches/robast-1.0/pkg/ROptEst/R/interpolLM.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/interpolLM.R	2014-04-15 23:12:55 UTC (rev 751)
+++ branches/robast-1.0/pkg/ROptEst/R/interpolLM.R	2014-04-15 23:14:01 UTC (rev 752)
@@ -61,7 +61,7 @@
                        maxiter = 50, tol = .Machine$double.eps^0.4,
                        loRad = 0, upRad = Inf, loRad0 = 1e-3,
                        loRad.s=0.2, up.Rad.s=1,
-                       withStartLM = TRUE
+                       withStartLM = TRUE, len = 13
                        ){
    wprint <- function(...){ if (withPrint) print(...)}
    thGrid <- unique(sort(thGrid))
@@ -89,7 +89,7 @@
                print(A.start)
                print(z.start)
                print(c(r.start.l,r.start.u))
-               if(is(a,"try-error")|any(is.na(a))){ a <- rep(NA,13)}else{
+               if(is(a,"try-error")|any(is.na(a))){ a <- rep(NA,len)}else{
                   if(withStartLM){
                      if(itLM==1){
                         z1 <<- a[["a.w"]]
@@ -170,11 +170,11 @@
 
 .generateInterpGrid <- function(thGrid, PFam, toFileCSV = "temp.csv",
             getFun = .getLMGrid, ..., modifyfct, nameInSysdata,
-            GridFileName, withPrint = TRUE){
+            GridFileName, withPrint = TRUE, len = 13){
   if(missing(GridFileName))
      GridFileName <- paste(gsub("^\\.(.+)","\\1",nameInSysdata),".Rdata",sep="")
   Grid <- getFun(thGrid = thGrid, PFam = PFam, ..., modifyfct = modifyfct,
-                 withPrint = withPrint, GridFileName = GridFileName)
+                 withPrint = withPrint, GridFileName = GridFileName, len = len)
   .saveGridToCSV(Grid,toFileCSV,name(PFam),nameInSysdata)
   return(invisible(NULL))
 }

Modified: branches/robast-1.0/pkg/ROptEst/man/internal-interpolate.Rd
===================================================================
--- branches/robast-1.0/pkg/ROptEst/man/internal-interpolate.Rd	2014-04-15 23:12:55 UTC (rev 751)
+++ branches/robast-1.0/pkg/ROptEst/man/internal-interpolate.Rd	2014-04-15 23:14:01 UTC (rev 752)
@@ -38,7 +38,7 @@
            upper = 1e4, lower = 1e-4, OptOrIter = "iterate",
            maxiter = 50, tol = .Machine$double.eps^0.4,
            loRad = 0, upRad = Inf, loRad0 = 1e-3,
-           loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE)
+           loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE, len = 13)
 
 
 .saveGridToCSV(Grid, toFileCSV, namPFam, nameInSysdata)
@@ -47,7 +47,7 @@
 
 .generateInterpGrid(thGrid, PFam, toFileCSV = "temp.csv",
             getFun = .getLMGrid, ..., modifyfct, nameInSysdata,
-            GridFileName, withPrint = TRUE)
+            GridFileName, withPrint = TRUE, len = 13)
 }
 
 \arguments{
@@ -114,6 +114,7 @@
                 \code{withPrint}; produces the y-values for the
                 interpolation grid. }
   \item{\dots}{further arguments to be passed on to \code{getFun}. }
+  \item{len}{integer; number of Lagrange multipliers to be calibrated. }
 }
 \details{
   \code{.MBRE.th} computes the Lagrange multipliers for the MBRE estimator,


From noreply at r-forge.r-project.org  Wed Apr 16 11:25:02 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 16 Apr 2014 11:25:02 +0200 (CEST)
Subject: [Robast-commits] r753 - in branches/robast-1.0/pkg/RobExtremes: R
	inst/AddMaterial/interpolation man
Message-ID: <20140416092502.57894187787@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-04-16 11:25:01 +0200 (Wed, 16 Apr 2014)
New Revision: 753

Modified:
   branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R
   branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
   branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd
Log:
RobExtremes: continued with preparation of LM evaluation

Modified: branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R	2014-04-15 23:14:01 UTC (rev 752)
+++ branches/robast-1.0/pkg/RobExtremes/R/interpolLM.R	2014-04-16 09:25:01 UTC (rev 753)
@@ -30,9 +30,9 @@
                    maxiter = 150, tol = .Machine$double.eps^0.5,
                    loRad = 0, upRad = Inf, loRad0 = 1e-3,
                    loRad.s=0.2, up.Rad.s=1,
-                   withStartLM = TRUE, len = 13){
+                   withStartLM = TRUE, len = 13,namFzus =""){
              namF <- gsub("\\.th$","",paste(deparse(substitute(optF))))
-             namF <- gsub(" ", "",namF)
+             namF <- paste(gsub(" ", "",namF),namFzus,sep="")
              to <- gsub("XXXX",gsub(" ","",name(PFam)),
                     gsub("YYYY", namF, "interpolYYYYXXXX.csv"))
              print(to)

Modified: branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R	2014-04-15 23:14:01 UTC (rev 752)
+++ branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R	2014-04-16 09:25:01 UTC (rev 753)
@@ -6,28 +6,153 @@
 require(RobExtremes)
 ### -> change this according to where you checked out the svn repo:
 .basepath <- "C:/rtest/RobASt/branches/robast-1.0./pkg"
+.myFolderTo <- file.path(.basepath,"RobExtremesBuffer")
 ## <-
 oldwd <- getwd()
-.myFolderTo <- file.path(.basepath,"RobExtremesBuffer")
 setwd(.myFolderTo)
 .OMSE.th <- ROptEst:::.OMSE.th
 .MBRE.th <- ROptEst:::.MBRE.th
 .RMXE.th <- ROptEst:::.RMXE.th
 .modify.xi.PFam.call <- RobExtremes:::.modify.xi.PFam.call
 #
-#PF <- GParetoFamily()
-#PF <- GEVFamily()
-PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
-#PF <- GammaFamily()
-#PF <- WeibullFamily()
 ###
+xiGridpos <- getShapeGrid(700, cutoff.at.0=0.005)
+lxipos <- length(xiGridpos)
+(lxipos1 <- 1:(lxipos%/%4))
+(lxipos2 <- (1:(lxipos%/%4))+lxipos%/%4)
+(lxipos3 <- (1:(lxipos%/%4))+2*lxipos%/%4)
+(lxipos4 <- (1:lxipos)[-c(1:(3*(lxipos%/%4)))])
+xiGridpos1 <- xiGridpos[lxipos1]
+xiGridpos2 <- xiGridpos[lxipos2]
+xiGridpos3 <- xiGridpos[lxipos3]
+xiGridpos4 <- xiGridpos[lxipos4]
+xiGridneg <- seq(-1/2+0.005,-0.005,length=150)
+
 .svInt <- RobExtremes:::.svInt
-#.svInt1 <- function(){
-#    RobExtremes:::.generateInterpGridSn(PFam = PF)}
+###
+#
 ## to make this parallel, start this on several processors
-#.svInt1()
-#.svInt(.OMSE.th, PFam=PF, xiGrid = getShapeGrid(3, cutoff.at.0=0.005))
-#.svInt(.OMSE.th, PFam=PF)
-#.svInt(.MBRE.th, PFam=PF)
-.svInt(.RMXE.th, PFam=PF)
+#
+# compute the interpolation grid of Lagrange multiplier values
+#   (still not as interpolators, still not yet smoothed)
+#
+### Block01--Block15: GEVFamilyMuUnknown
+#    Block01--Block05: RMXE, (pos1, pos2, pos3, pos4, neg)
+#    Block06--Block10: OMSE, (pos1, pos2, pos3, pos4, neg)
+#    Block11--Block15: MBRE, (pos1, pos2, pos3, pos4, neg)
+##
+### Block16--Block18: GEVFamily, negative xi: RMXE, OMSE, MBRE
+#
+### Block18--Block21: GParetoFamily, negative xi: RMXE, OMSE, MBRE
+#
+# in the end, the results are stored in files like
+#   interpol.OMSEpos1GEVUFamily.csv in
+#
+if(FALSE){
+  ## Block01::      interpol.RMXEpos1GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridpos1,namFzus="pos1")
+}
+if(FALSE){
+  ## Block02::      interpol.RMXEpos2GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridpos2,namFzus="pos2")
+}
+if(FALSE){
+  ## Block03::      interpol.RMXEpos3GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridpos3,namFzus="pos3")
+}
+if(FALSE){
+  ## Block04::      interpol.RMXEpos4GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridpos4,namFzus="pos4")
+}
+if(FALSE){
+  ## Block05::      interpol.RMXEnegGEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridneg,namFzus="neg")
+}
+if(FALSE){
+  ## Block06::      interpol.OMSEpos1GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridpos1,namFzus="pos1")
+}
+if(FALSE){
+  ## Block07::      interpol.OMSEpos2GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridpos2,namFzus="pos2")
+}
+if(FALSE){
+  ## Block08::      interpol.OMSEpos3GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridpos4,namFzus="pos3")
+}
+if(FALSE){
+  ## Block09::      interpol.OMSEpos4GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridpos3,namFzus="pos4")
+}
+if(FALSE){
+  ## Block10::      interpol.OMSEnegGEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridneg,namFzus="neg")
+}
+if(FALSE){
+  ## Block11::      interpol.MBREpos1GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridpos1,namFzus="pos1")
+}
+if(FALSE){
+  ## Block12::      interpol.MBREpos2GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridpos2,namFzus="pos2")
+}
+if(FALSE){
+  ## Block13::      interpol.MBREpos3GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridpos3,namFzus="pos3")
+}
+if(FALSE){
+  ## Block14::      interpol.MBREpos4GEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridpos4,namFzus="pos4")
+}
+if(FALSE){
+  ## Block15::      interpol.MBREnegGEVUFamily.csv
+   PF <- GEVFamilyMuUnknown(withPos=FALSE, ..name="GEVU Family")
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridneg,namFzus="neg")
+}
+if(FALSE){
+  ## Block16::      interpol.RMXEnegGEVFamily.csv
+   PF <- GEVFamily(withPos=FALSE)
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+if(FALSE){
+  ## Block17::      interpol.OMSEnegGEVFamily.csv
+   PF <- GEVFamily(withPos=FALSE)
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+if(FALSE){
+  ## Block18::      interpol.MBREnegGEVFamily.csv
+   PF <- GEVFamily(withPos=FALSE)
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+if(FALSE){
+  ## Block19::      interpol.RMXEnegGParetoFamily.csv
+   PF <- GParetoFamily(withPos=FALSE)
+  .svInt(.RMXE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+if(FALSE){
+  ## Block20::      interpol.OMSEnegGParetoFamily.csv
+   PF <- GParetoFamily(withPos=FALSE)
+  .svInt(.OMSE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+if(FALSE){
+  ## Block21::      interpol.MBREnegGParetoFamily.csv
+   PF <- GParetoFamily(withPos=FALSE)
+  .svInt(.MBRE.th, PFam=PF, xiGrid = xiGridneg, namFzus="neg")
+}
+
+
 setwd(oldwd)

Modified: branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd	2014-04-15 23:14:01 UTC (rev 752)
+++ branches/robast-1.0/pkg/RobExtremes/man/internal-interpolate.Rd	2014-04-16 09:25:01 UTC (rev 753)
@@ -37,7 +37,7 @@
        PFam = GParetoFamily(shape=1,scale=2), radius = 0.5, upper = 1e4,
        lower = 1e-4, OptOrIter = "iterate",  maxiter = 150,
        tol = .Machine$double.eps^0.5, loRad = 0, upRad = Inf, loRad0 = 1e-3,
-       loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE, len = 13)
+       loRad.s = 0.2, up.Rad.s = 1, withStartLM = TRUE, len = 13, namFzus = "")
 
 .generateInterpGridSn(xiGrid = getShapeGrid(500, cutoff.at.0=0.005),
                       PFam = GParetoFamily(), withPrint = TRUE)
@@ -96,6 +96,9 @@
   \item{withStartLM}{ logical of length 1: shall the LM's of the preceding grid
     value serve as starting value for the next grid value? }
   \item{len}{integer; number of Lagrange multipliers to be calibrated. }
+  \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.}
 }
 \details{
    \code{.getpsi} reads the respective interpolating function