[Robast-commits] r1293 - pkg/RobExtremes/R

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

Author: ruckdeschel
Date: 2024-02-07 03:28:20 +0100 (Wed, 07 Feb 2024)
New Revision: 1293

Modified:
   pkg/RobExtremes/R/PickandsEstimator.R
   pkg/RobExtremes/R/asvarPickands.R
Log:
[RobExtremes] merged branch 1.3 into trunk, i.e.,
+  taking up a suggestion by Andreas.Scheidegger at eawag.ch, we introduced new 
   argument propagate.names in our functionals controlling whether names 
   obtained from parameter coordinates should be propagated to return values 
   of specific S4 methods for functionals for Gumbel, GEV, GPD, Pareto
+  triggered by a mail by mekontsodimitri at gmail.com, we enhanced PickandsEstimator();
   (a) it no longer requires the location parameter to be 0
   and (b) it now also can be applied to GEVFamilyMuUnknown models.


Modified: pkg/RobExtremes/R/PickandsEstimator.R
===================================================================
--- pkg/RobExtremes/R/PickandsEstimator.R	2024-02-07 02:27:26 UTC (rev 1292)
+++ pkg/RobExtremes/R/PickandsEstimator.R	2024-02-07 02:28:20 UTC (rev 1293)
@@ -42,13 +42,15 @@
                         ...){
     force(ParamFamily)
     isGP <- is(ParamFamily,"GParetoFamily")
-    if(!(isGP|is(ParamFamily,"GEVFamily")))
+	isGEV.mu <- is(ParamFamily,"GEVFamilyMuUnknown")
+    if(!(isGP|isGEV.mu|is(ParamFamily,"GEVFamily")))
          stop("Pickands estimator only available for GPD and GEVD.")
     es.call <- match.call()
     if(missing(alpha)) alpha <- if(isGP) 2 else 2.248
     if(length(alpha)>1 || any(!is.finite(alpha)) || any(alpha<=1))
        stop("'alpha' has to be a numeric > 1 of length 1.")
-
+    
+	if(isGEV.mu){mu.est <- quantile(x,exp(-1))}
     if(missing(name))
         name <- "PickandsEstimator"
 
@@ -59,9 +61,20 @@
     if(is.null(fixed)) fixed <- fixed(ParamFamily)
     fixed.0 <- fixed
     na.rm.0 <- na.rm
-
-    .mPick <- function(x) .PickandsEstimator(x,alpha=alpha, GPD.l=isGP)
-    estimate <- Estimator(x, .mPick, name, Infos,
+    cent <- if(!isGEV.mu) fixed else mu.est
+    .mPick <- if(!isGEV.mu){ function(x) .PickandsEstimator(x-cent,alpha=alpha, GPD.l=isGP)
+	          }else{ function(x){
+			     .mPick0 <- numeric(3)
+	             .mPick0[2:3] <- .PickandsEstimator(x-cent,alpha=alpha, GPD.l=isGP)
+				 .mPick0[1] <- mu.est
+				 names(.mPick0) <- c("loc","scale","shape")
+				 return(.mPick0)}}
+    if(isGEV.mu){para0 <- param(ParamFamily)
+                 main(para0)["loc"] <- mu.est
+                 ParamFamily at param <- para0				 
+	}
+	             
+	estimate <- Estimator(x, .mPick, name, Infos,
                           asvar.fct = asvar.fct.0, asvar = NULL,
                           nuis.idx = nuis.idx.0, trafo = trafo.0,
                           fixed = fixed.0, na.rm = na.rm.0, ...,

Modified: pkg/RobExtremes/R/asvarPickands.R
===================================================================
--- pkg/RobExtremes/R/asvarPickands.R	2024-02-07 02:27:26 UTC (rev 1292)
+++ pkg/RobExtremes/R/asvarPickands.R	2024-02-07 02:28:20 UTC (rev 1293)
@@ -1,7 +1,8 @@
 asvarPickands <- function(model, alpha=2){
 
     isGP <- is(model,"GParetoFamily")
-    if(!(isGP|is(model,"GEVFamily")))
+    isGEV.mu <- is(model,"GEVFamilyMuUnknown")
+	if(!(isGP|isGEV.mu|is(model,"GEVFamily")))
          stop("Pickands estimator only available for GPD and GEVD.")
 
   scshn <- scaleshapename(model)
@@ -16,9 +17,11 @@
     al2 <- exp(-1/alpha^2)
   }
 
-  M2 <- q.l(model)(al1)
-  M4 <- q.l(model)(al2)
 
+  c0 <- if(isGEV.mu) main(param(model))["loc"] else fixed(param(model))
+  M2 <- q.l(model)(al1)-c0
+  M4 <- q.l(model)(al2)-c0
+
   xi <- log((M4-M2)/M2)/log(alpha)
   qu <- 1/(alpha^xi-1)
   beta <- xi * M2 * qu
@@ -66,13 +69,29 @@
   s22 <- al2^(-1)*(1-al2)*(-log(al2))^(-2-2*xi)
   }
   S <- beta^2*matrix(c(s11,s12,s21,s22),2,2)
-
+  if(isGEV.mu){
+  ## var = a1(1-a2)/a1 /a2 * (log(a1)log(a2))^(-(1+xi)) * sig^2
+  ##    =  (1/a2-1) (log(a1)log(a2))^(-(1+xi)) * sig^2
+  ## [a1=a2=exp(-1)] =  exp(1)-1     
+ s31 <- exp(1)-1  
+ s32 <- al1^(-1)*(1-al1)*(-log(al1))^(-1-1*xi)
+ s33 <- al2^(-1)*(1-al2)*(-log(al2))^(-1-1*xi)
+ S0 <- C0 <- matrix(NA,3,3)
+ S0[,1] <- S0[1,] <- c(s31,s32,s33)*beta^2  
+ S0[2:3,2:3] <- S 
+ S <- S0
+ C0[1,] <- C0[,1] <- c(1,0,0)
+ C0[2:3,2:3] <- C 
+ C <- C0
+  }
   ASV_Pick <- t(C) %*% S %*% (C)
   ASV_Pick <- PosSemDefSymmMatrix(ASV_Pick)
-  dimnames(ASV_Pick) <- list(scshn,scshn)
+  dimnames(ASV_Pick) <- if(isGEV.mu)
+     list(c("loc",scshn),c("loc",scshn)) else list(scshn,scshn)
   return(ASV_Pick)
 }
 
+
 asvarQBCC <- function(model, p1 = 1/3, p2= 2/3){
 
    if(!(is(model,"WeibullFamily")))
@@ -122,4 +141,3 @@
 
 
 
-