[Robast-commits] r989 - branches/robast-1.1/pkg/RobExtremes/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 19 13:49:40 CEST 2018
Author: ruckdeschel
Date: 2018-07-19 13:49:40 +0200 (Thu, 19 Jul 2018)
New Revision: 989
Added:
branches/robast-1.1/pkg/RobExtremes/R/L2LocScaleShapeUnion-methods.R
Modified:
branches/robast-1.1/pkg/RobExtremes/R/AllClass.R
branches/robast-1.1/pkg/RobExtremes/R/AllGeneric.R
branches/robast-1.1/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
branches/robast-1.1/pkg/RobExtremes/R/SnQn.R
branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R
branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R
Log:
[RobExtremes] branch 1.1 some bug fixes :
+ in .define.tau.Dtau.withMu
+ in getStartIC.R (in names risk type is without ".")
+ fixed modifyIC in "getStartIC",signature(model = "L2LocScaleShapeUnion")
+ some fixes in .checkEstClassForParamFamiliyMethods
+ class ParamWithLocAndScaleAndShapeFamParameter now contains ParamWithScaleAndShapeFamParameter
* in addition, now use slot locscaleshapename in generating function of GEVFamilyMuUnknown
* skipped again falsely added method for Sn for GEVU
* allow for versions < 3.0 when reading grid from sysdata.rda
* new generics/methods for locationname, locscaleshapename(<-), scaleshapename, locscalename, shapename, scalename
* use prefix evd:: to clarify which [p,d,q,r]gumbel to take
* L2LocScaleShapeUnion gains slot locscaleshapename = "character" / looses slot scaleshapename = "character"
Modified: branches/robast-1.1/pkg/RobExtremes/R/AllClass.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/AllClass.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/AllClass.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -23,10 +23,14 @@
}
+#setClassUnion("ParamWithLocAndScaleAndShapeFamParameterUnion",
+# c("ParamWithScaleFamParameter",
+# "ParamWithShapeFamParameter")
+# )
+
setClass("ParamWithLocAndScaleAndShapeFamParameter",
- contains = c("ParamWithScaleFamParameter",
- "ParamWithShapeFamParameter")
- )
+ contains = c("ParamWithScaleAndShapeFamParameter")
+)
# parameter of Gumbel distribution
@@ -47,10 +51,10 @@
# Gumbel distribution
setClass("Gumbel",
- prototype = prototype(r = function(n){ rgumbel(n, loc = 0, scale = 1) },
- d = function(x, log){ dgumbel(x, loc = 0, scale = 1, log = FALSE) },
+ prototype = prototype(r = function(n){ evd::rgumbel(n, loc = 0, scale = 1) },
+ d = function(x, log){ evd::dgumbel(x, loc = 0, scale = 1, log = FALSE) },
p = function(q, lower.tail = TRUE, log.p = FALSE){
- p0 <- pgumbel(q, loc = 0, scale = 1, lower.tail = lower.tail)
+ p0 <- evd::pgumbel(q, loc = 0, scale = 1, lower.tail = lower.tail)
if(log.p) return(log(p0)) else return(p0)
},
q = function(p, loc = 0, scale = 1, lower.tail = TRUE, log.p = FALSE){
@@ -66,7 +70,7 @@
p0 <- p
p0[ii01] <- if(log.p) log(0.5) else 0.5
- q1 <- qgumbel(p0, loc = 0, scale = 1,
+ q1 <- evd::qgumbel(p0, loc = 0, scale = 1,
lower.tail = lower.tail)
q1[i0] <- if(lower.tail) -Inf else Inf
q1[i1] <- if(!lower.tail) -Inf else Inf
@@ -198,7 +202,7 @@
prototype = prototype(
r = function(n){ rgev(n,loc = 0, scale = 1, shape = 0.5) },
d = function(x, log = FALSE){
- dgev(x, loc = 0, scale = 1, shape = 0.5, log = log)
+ dgev(x, loc = 0, scale = 1, shape = 0.5, log = log)
},
p = function(q, lower.tail = TRUE, log.p = FALSE ){
p0 <- pgev(q, loc = 0, scale = 1, shape = 0.5)
@@ -250,7 +254,7 @@
setClass("WeibullFamily", contains="L2ScaleShapeUnion")
## virtual in-between class for common parts in modifyModel - method
-setClass("L2LocScaleShapeUnion", representation(scaleshapename ="character"),
+setClass("L2LocScaleShapeUnion", representation(locscaleshapename = "character"),
contains = c("L2GroupParamFamily","VIRTUAL")
)
Modified: branches/robast-1.1/pkg/RobExtremes/R/AllGeneric.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/AllGeneric.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/AllGeneric.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -46,3 +46,16 @@
if(!isGeneric("gpd.profxi")){
setGeneric("gpd.profxi", function(z, ...) standardGeneric("gpd.profxi"))
}
+if(!isGeneric("locscaleshapename")){
+ setGeneric("locscaleshapename", function(object) standardGeneric("locscaleshapename"))
+}
+if(!isGeneric("locscaleshapename<-")){
+ setGeneric("locscaleshapename<-", function(object,value) standardGeneric("locscaleshapename<-"))
+}
+if(!isGeneric("shapename")){
+ setGeneric("shapename", function(object) standardGeneric("shapename"))
+}
+if(!isGeneric("locationname")){
+ setGeneric("locationname", function(object) standardGeneric("locationname"))
+}
+
Modified: branches/robast-1.1/pkg/RobExtremes/R/GEVFamilyMuUnknown.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/GEVFamilyMuUnknown.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/GEVFamilyMuUnknown.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -40,7 +40,7 @@
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;
+ tau <- function(theta){ th <- theta[1:2];
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}
@@ -158,9 +158,9 @@
## parameters
names(theta) <- c("loc", "scale", "shape")
- scaleshapename <- c("scale"="scale", "shape"="shape")
+# scaleshapename <- c("scale"="scale", "shape"="shape")
+ locscaleshapename <- c("location"="location", "scale"="scale", "shape"="shape")
-
btq <- bDq <- btes <- bDes <- btel <- bDel <- NULL
if(!is.null(p)){
btq <- substitute({ q <- theta[1] + theta[2]*((-log(p0))^(-theta[3])-1)/theta[3]
@@ -386,7 +386,7 @@
I22 <- ..I33
}
mat <- PosSemDefSymmMatrix(matrix(c(I00,I01,I02,I01,I11,I12,I02,I12,I22),3,3))
- cs <- c("location",scaleshapename)
+ cs <- locscaleshapename
dimnames(mat) <- list(cs,cs)
return(mat)
}
@@ -398,7 +398,8 @@
## initializing the GPareto family with components of L2-family
L2Fam <- new("GEVFamilyMuUnknown")
- L2Fam at scaleshapename <- scaleshapename
+# L2Fam at scaleshapename <- scaleshapename
+ L2Fam at locscaleshapename <- locscaleshapename
L2Fam at name <- name
L2Fam at param <- param
L2Fam at distribution <- distribution
Added: branches/robast-1.1/pkg/RobExtremes/R/L2LocScaleShapeUnion-methods.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/L2LocScaleShapeUnion-methods.R (rev 0)
+++ branches/robast-1.1/pkg/RobExtremes/R/L2LocScaleShapeUnion-methods.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -0,0 +1,27 @@
+setMethod("locscaleshapename", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at locscaleshapename)
+setMethod("locscalename", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at locscaleshapename[c("location","scale")])
+
+setMethod("scaleshapename", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at locscaleshapename[c("scale","shape")])
+
+setMethod("scalename", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at locscaleshapename["scale"])
+
+setMethod("shapename", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at scaleshapename["shape"])
+
+setMethod("locationname", signature(object = "L2LocScaleShapeUnion"),
+ function(object) object at locscaleshapename["location"])
+
+
+setReplaceMethod("locscaleshapename", "L2LocationScaleUnion",
+ function(object, value){
+ if(length(value)!=3)
+ stop("value of slot 'locscaleshapename' must be of length three")
+ if(is.null(names(value))) names(value) <- c("location","scale","shape")
+ object at locscalename <- value
+ object
+ })
+
Modified: branches/robast-1.1/pkg/RobExtremes/R/SnQn.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/SnQn.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/SnQn.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -110,7 +110,7 @@
# sng <- try(getFromNamespace(".Sn", ns = "RobAStRDA"), silent =TRUE)
if(is(famg,"try-error")) return(Sn(as(x,"AbscontDistribution")))
# if(!nam %in% names(sng)) return(Sn(as(x,"AbscontDistribution")))
- if(!.versionSuff("fun")=="fun.N") return(Sn(as(x,"AbscontDistribution")))
+# if(!.versionSuff("fun")=="fun.N") return(Sn(as(x,"AbscontDistribution")))
snf <- famg[["Sn"]][[.versionSuff("fun")]]
ret <- snf(shape(x))
if(is.na(ret)) return(Sn(as(x,"AbscontDistribution")))
@@ -130,5 +130,3 @@
setMethod("Sn", signature(x = "Weibull"),
function(x, ...).Sn.intp(x,".Weibull") )
-setMethod("Sn", signature(x = "GEVU"),
- function(x, ...).Sn.intp(x,".GEV") )
Modified: branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -12,7 +12,7 @@
function(PFam, estimator) as(estimator,"GPDMCEstimate"))
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamily",estimator="Estimate"),
- function(PFam, estimator) as(estimator,"GEVkStepEstimate"))
+ function(PFam, estimator) as(estimator,"GEVEstimate"))
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamily",estimator="LDEstimate"),
function(PFam, estimator) as(estimator,"GEVLDEstimate"))
@@ -24,7 +24,7 @@
function(PFam, estimator) as(estimator,"GEVMCEstimate"))
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamilyMuUnknown",estimator="Estimate"),
- function(PFam, estimator) as(estimator,"GEVkStepEstimate"))
+ function(PFam, estimator) as(estimator,"GEVEstimate"))
setMethod(".checkEstClassForParamFamily",
signature=signature(PFam="GEVFamilyMuUnknown",estimator="LDEstimate"),
function(PFam, estimator) as(estimator,"GEVLDEstimate"))
Modified: branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-07-19 11:39:26 UTC (rev 988)
+++ branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-07-19 11:49:40 UTC (rev 989)
@@ -5,7 +5,7 @@
mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
mc$neighbor <- ContNeighborhood(radius=0.5)
- gridn <- type(risk)
+ gridn <- gsub("\\.","",type(risk))
nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="")
if(nam==".GeneralizedPareto") nam <- ".GPareto"
@@ -21,9 +21,9 @@
famg <- try(getFromNamespace(nam, ns = "RobAStRDA"), silent=TRUE)
#sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE)
if(!is(famg,"try-error")) nsng <- names(famg)
- if(length(nsng)&&.versionSuff("fun")=="fun.N"){
+ if(length(nsng)){
if(gridn %in% nsng){
- interpolfct <- famg[[gridn]][["fun.N"]]
+ interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
.modifyIC0 <- function(L2Fam, IC){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
@@ -54,24 +54,23 @@
mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
mc$neighbor <- ContNeighborhood(radius=0.5)
- gridn <- type(risk)
+ gridn <- gsub("\\.","",type(risk))
nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="")
if(nam==".GEV") nam <- ".GEVU"
param1 <- param(model)
- scshnm <- scaleshapename(model)
- shnam <- scshnm["shape"]
-
+ locscshnm <- locscaleshapename(model)
+ shnam <- locscshnm["shape"]
nsng <- character(0)
famg <- try(getFromNamespace(nam, ns = "RobAStRDA"), silent=TRUE)
#sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE)
if(!is(famg,"try-error")) nsng <- names(famg)
- if(length(nsng)&&.versionSuff("fun")=="fun.N"){
+ if(length(nsng)){
if(gridn %in% nsng){
- interpolfct <- famg[[gridn]][["fun.N"]]
- .modifyIC <- function(L2Fam, IC){
+ interpolfct <- famg[[gridn]][[.versionSuff("fun")]]
+ .modifyIC0 <- function(L2Fam, IC){
para <- param(L2Fam)
if(!.is.na.Psi(para, interpolfct, shnam))
return(.getPsi.wL(para, interpolfct, L2Fam, type(risk)))
@@ -79,6 +78,11 @@
return(do.call(getStartIC, as.list(mc[-1]),
envir=parent.frame(2)))
}
+ .modifyIC <- function(L2Fam,IC){
+ psi.0 <- .modifyIC0(L2Fam,IC)
+ psi.0 at modifyIC <- .modifyIC
+ return(psi.0)
+ }
if(!.is.na.Psi(param1, interpolfct, shnam)){
IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk))
IC0 at modifyIC <- .modifyIC
More information about the Robast-commits
mailing list