[Distr-commits] r812 - in branches/distr-2.4/pkg/distrMod: . R inst/scripts man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun May 20 20:48:37 CEST 2012
Author: ruckdeschel
Date: 2012-05-20 20:48:36 +0200 (Sun, 20 May 2012)
New Revision: 812
Modified:
branches/distr-2.4/pkg/distrMod/NAMESPACE
branches/distr-2.4/pkg/distrMod/R/0distrModUtils.R
branches/distr-2.4/pkg/distrMod/R/AllClass.R
branches/distr-2.4/pkg/distrMod/R/AllGeneric.R
branches/distr-2.4/pkg/distrMod/R/AllShow.R
branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies-methods.R
branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies.R
branches/distr-2.4/pkg/distrMod/R/MCEstimator.R
branches/distr-2.4/pkg/distrMod/R/MDEstimator.R
branches/distr-2.4/pkg/distrMod/R/MLEstimator.R
branches/distr-2.4/pkg/distrMod/R/ParamFamParameter.R
branches/distr-2.4/pkg/distrMod/R/SimpleL2ParamFamilies.R
branches/distr-2.4/pkg/distrMod/R/internalMleCalc.R
branches/distr-2.4/pkg/distrMod/R/mleCalc-methods.R
branches/distr-2.4/pkg/distrMod/R/setAs.R
branches/distr-2.4/pkg/distrMod/R/validParameter.R
branches/distr-2.4/pkg/distrMod/inst/scripts/examples2.R
branches/distr-2.4/pkg/distrMod/inst/scripts/modelExp3.R
branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd
branches/distr-2.4/pkg/distrMod/man/MCEstimate-class.Rd
branches/distr-2.4/pkg/distrMod/man/MDEstimator.Rd
branches/distr-2.4/pkg/distrMod/man/MLEstimator.Rd
branches/distr-2.4/pkg/distrMod/man/ParamFamParameter-class.Rd
branches/distr-2.4/pkg/distrMod/man/ParamFamParameter.Rd
branches/distr-2.4/pkg/distrMod/man/ParamFamily.Rd
branches/distr-2.4/pkg/distrMod/man/internalClassUnions-class.Rd
branches/distr-2.4/pkg/distrMod/man/internalmleHelpers.Rd
branches/distr-2.4/pkg/distrMod/man/internals.Rd
branches/distr-2.4/pkg/distrMod/man/mleCalc-methods.Rd
branches/distr-2.4/pkg/distrMod/man/trafo-methods.Rd
branches/distr-2.4/pkg/distrMod/man/validParameter-methods.Rd
Log:
distrMod: new intermediate classes/ class unions for scale families and scale shape families; consequent use of argument validity.check in MCE estimators.
Modified: branches/distr-2.4/pkg/distrMod/NAMESPACE
===================================================================
--- branches/distr-2.4/pkg/distrMod/NAMESPACE 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/NAMESPACE 2012-05-20 18:48:36 UTC (rev 812)
@@ -22,7 +22,9 @@
exportClasses("L2GroupParamFamily", "L2LocationFamily",
"L2ScaleFamily", "L2LocationScaleFamily")
exportClasses("L2LocationScaleUnion")
-exportClasses("L2ScaleShapeUnion")
+exportClasses("L2ScaleShapeUnion", "L2ScaleUnion")
+exportClasses("ParamWithScaleFamParameter", "ParamWithShapeFamParameter",
+ "ParamWithScaleAndShapeFamParameter")
exportClasses("BinomFamily","PoisFamily", "NormLocationFamily",
"NormScaleFamily", "ExpScaleFamily",
"LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily",
@@ -49,7 +51,8 @@
"name.estimate", "trafo.estimate", "nuisance.estimate",
"fixed.estimate", "Infos", "Infos<-", "addInfo<-",
"criterion", "criterion<-", "criterion.fct", "method",
- "samplesize", "asvar", "asvar<-", "optimwarn")
+ "samplesize", "asvar", "asvar<-", "optimwarn",
+ "withPosRestr", "withPosRestr<-")
exportMethods("untransformed.estimate", "untransformed.asvar")
exportMethods("confint")
exportMethods("nuisance", "main")
Modified: branches/distr-2.4/pkg/distrMod/R/0distrModUtils.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/0distrModUtils.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/0distrModUtils.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -110,8 +110,9 @@
param0 <- L2Fam at param
dim0 <- dimension(param0)
# print(param0)
- paramP <- ParamFamParameter(name = name(param0), main = main(param),
- trafo = diag(dim0))
+ paramP <- param0
+ paramP at main <- main(param)
+ paramP at trafo <- diag(dim0)
# print(paramP)
L2Fam <- modifyModel(L2Fam, paramP)
Modified: branches/distr-2.4/pkg/distrMod/R/AllClass.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/AllClass.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/AllClass.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -112,6 +112,19 @@
return(TRUE)}
})
+setClass("ParamWithScaleFamParameter",
+ contains = "ParamFamParameter")
+
+setClass("ParamWithShapeFamParameter",
+ representation(withPosRestr = "logical"),
+ prototype(withPosRestr = TRUE),
+ contains = "ParamFamParameter")
+
+setClass("ParamWithScaleAndShapeFamParameter",
+ contains = c("ParamWithScaleFamParameter",
+ "ParamWithShapeFamParameter")
+ )
+
### from Matthias' thesis / ROptEst
## family of probability measures
setClass("ProbFamily", representation(name = "character",
@@ -143,6 +156,7 @@
param = new("ParamFamParameter", main = 0, trafo = matrix(1))),
contains = "ProbFamily")
+
### from Matthias' thesis / ROptEst
## L2-differentiable parametric family of probability measures
setClass("L2ParamFamily",
@@ -212,6 +226,8 @@
Logderiv = function(x)x),
contains = "L2ParamFamily")
+
+
## virtual in-between class for common parts in modifyModel - method
setClass("L2LocationScaleUnion",
representation(locscalename = "character"),
@@ -220,10 +236,14 @@
## virtual in-between class for common parts in modifyModel - method
setClass("L2ScaleShapeUnion",
- representation(withPos = "logical"),
contains = c("L2GroupParamFamily","VIRTUAL")
)
+## virtual in-between class for common parts log/original scale methods
+setClassUnion("L2ScaleUnion",
+ c("L2LocationScaleUnion","L2ScaleShapeUnion")
+ )
+
## L2-differentiable (univariate) location family
setClass("L2LocationFamily",
prototype = prototype(locscalename = c("loc"="loc"),
Modified: branches/distr-2.4/pkg/distrMod/R/AllGeneric.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/AllGeneric.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/AllGeneric.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -278,9 +278,9 @@
if(!isGeneric("optimwarn")){
setGeneric("optimwarn", function(object) standardGeneric("optimwarn"))
}
-if(!isGeneric("withPos")){
- setGeneric("withPos", function(object) standardGeneric("withPos"))
+if(!isGeneric("withPosRestr")){
+ setGeneric("withPosRestr", function(object) standardGeneric("withPosRestr"))
}
-if(!isGeneric("withPos<-")){
- setGeneric("withPos<-", function(object,value) standardGeneric("withPos<-"))
+if(!isGeneric("withPosRestr<-")){
+ setGeneric("withPosRestr<-", function(object,value) standardGeneric("withPosRestr<-"))
}
Modified: branches/distr-2.4/pkg/distrMod/R/AllShow.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/AllShow.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/AllShow.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -79,6 +79,16 @@
}
}
})
+
+setMethod("show", "ParamWithShapeFamParameter",
+ function(object){
+ show(as(object,"ParamFamParameter"))
+ if(object at withPosRestr)
+ cat(gettext("Shape parameter must not be negative.\n"))
+})
+setMethod("show", "ParamWithScaleAndShapeFamParameter",
+ getMethod("show", "ParamWithShapeFamParameter"))
+
setMethod("show", "ParamFamily",
function(object){
cat(gettextf("An object of class \"%s\"\n", class(object)))
Modified: branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies-methods.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies-methods.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies-methods.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -7,8 +7,8 @@
setMethod("locscalename", signature(object = "L2LocationScaleUnion"),
function(object) object at locscalename)
-setMethod("withPos", signature(object = "L2ScaleShapeUnion"),
- function(object) object at withPos)
+setMethod("withPosRestr", signature(object = "L2ScaleShapeUnion"),
+ function(object) object at param@withPosRestr)
setReplaceMethod("LogDeriv", "L2GroupParamFamily",
function(object, value){
@@ -24,10 +24,13 @@
object
})
-setReplaceMethod("withPos", "L2ScaleShapeUnion",
+setReplaceMethod("withPosRestr", "L2ScaleShapeUnion",
function(object, value){
if(length(value)!=1)
- stop("value of slot 'withPos' must be of length one")
- object at withPos <- value
+ stop("value of slot 'withPosRestr' must be of length one")
+ param <- object at param
+ withPosRestr(param) <- value
+ object at param <- param
object
})
+
Modified: branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/L2GroupFamilies.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -183,7 +183,8 @@
if(missing(trafo)) {trafo <- matrix(1)
dimnames(trafo) <- list(scalename,scalename)}
param <- ParamFamParameter(name = "scale", main = param0,
- fixed = param1, trafo = trafo)
+ fixed = param1, trafo = trafo,
+ .returnClsName ="ParamWithScaleFamParameter")
if(missing(modParam)){
modParam <- function(theta){}
body(modParam) <- substitute({ theta*centraldistribution+loc },
@@ -340,7 +341,8 @@
dimnames(trafo) <- list(locscalename,
locscalename)}
param <- ParamFamParameter(name = "location and scale", main = param0,
- trafo = trafo)
+ trafo = trafo,
+ .returnClsName ="ParamWithScaleFamParameter")
startPar <- function(x,...) {
st <- c(median(x),mad(x, constant=mad.const))
@@ -534,7 +536,8 @@
dimnames(trafo) <- list(locscalename["loc"],
locscalename["loc"])}
param <- ParamFamParameter(name = "location and scale", main = param0[1],
- nuisance = param0[2], trafo = trafo)
+ nuisance = param0[2], trafo = trafo,
+ .returnClsName ="ParamWithScaleFamParameter")
if(missing(modParam))
modParam <- function(theta){theta[2]*centraldistribution+theta[1] }
props <- c(paste("The", name, "is invariant under"),
@@ -710,7 +713,8 @@
if(missing(trafo)) {trafo <- matrix(1)
dimnames(trafo) <- list("scale","scale")}
param <- ParamFamParameter(name = "scale and location", main = param0[1],
- nuisance = param0[2], trafo = trafo)
+ nuisance = param0[2], trafo = trafo,
+ .returnClsName ="ParamWithScaleFamParameter")
if(missing(modParam))
modParam <- function(theta){theta[1]*centraldistribution+theta[2] }
props <- c(paste("The", name, "is invariant under"),
Modified: branches/distr-2.4/pkg/distrMod/R/MCEstimator.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/MCEstimator.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/MCEstimator.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -24,6 +24,9 @@
## manipulation of the arg list to method mceCalc
argList <- c(list(x = x, PFam = ParamFamily, criterion = criterion,
startPar = startPar, penalty = penalty))
+
+ if(missing(validity.check)) validity.check <- TRUE
+ argList$validity.check <- validity.check
if(missing(Infos)) Infos <- NULL
argList <- c(argList, Infos = Infos)
if(missing(crit.name)) crit.name <- ""
@@ -46,7 +49,7 @@
if(!is.null(asv)) argList <- c(argList, asvar.fct = asv)
if(!is.null(dots)) argList <- c(argList, dots)
-
+
## digesting the results of mceCalc
res <- do.call(.process.meCalcRes, argList)
res at completecases <- completecases
Modified: branches/distr-2.4/pkg/distrMod/R/MDEstimator.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/MDEstimator.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/MDEstimator.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -4,7 +4,8 @@
MDEstimator <- function(x, ParamFamily, distance = KolmogorovDist,
dist.name, paramDepDist = FALSE,
startPar = NULL, Infos,
- trafo = NULL, penalty = 1e20, asvar.fct, na.rm = TRUE,
+ trafo = NULL, penalty = 1e20,
+ validity.check = TRUE, asvar.fct, na.rm = TRUE,
...){
## preparation: getting the matched call
@@ -27,6 +28,9 @@
argList <- c(list(x = x, PFam = ParamFamily, criterion = distance,
startPar = startPar, penalty = penalty,
crit.name = dist.name, withthetaPar = paramDepDist))
+
+ if(missing(validity.check)) validity.check <- TRUE
+ argList$validity.check <- validity.check
if(missing(Infos)) Infos <- NULL
argList <- c(argList, Infos = Infos)
if(!is.null(dots)) argList <- c(argList, dots)
@@ -43,7 +47,9 @@
if(!missing(asvar.fct)) argList <- c(argList, asvar.fct = asvar.fct)
if(!is.null(dots)) argList <- c(argList, dots)
-
+ if(!validity.check %in% names(argList))
+ argList$validity.check <- TRUE
+
## digesting the results of mceCalc
res <- do.call(.process.meCalcRes, argList)
Modified: branches/distr-2.4/pkg/distrMod/R/MLEstimator.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/MLEstimator.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/MLEstimator.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -5,7 +5,8 @@
## Maximum-Likelihood estimator
MLEstimator <- function(x, ParamFamily, startPar = NULL,
- Infos, trafo = NULL, penalty = 1e20, na.rm = TRUE, ...){
+ Infos, trafo = NULL, penalty = 1e20,
+ validity.check = TRUE, na.rm = TRUE, ...){
## preparation: getting the matched call
es.call <- match.call()
@@ -23,6 +24,9 @@
## manipulation of the arg list to method mceCalc
argList <- c(list(x = x, PFam = ParamFamily, startPar = startPar,
penalty = penalty))
+
+ if(missing(validity.check)) validity.check <- TRUE
+ argList$validity.check <- validity.check
if(missing(Infos)) Infos <- NULL
argList <- c(argList, Infos = Infos)
if(!is.null(dots)) argList <- c(argList, dots)
@@ -41,7 +45,7 @@
if(!is.null(asv)) argList <- c(argList, asvar.fct = asv)
if(!is.null(dots)) argList <- c(argList, dots)
-
+
## digesting the results of mceCalc
res <- do.call(what = ".process.meCalcRes", args = argList)
Modified: branches/distr-2.4/pkg/distrMod/R/ParamFamParameter.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/ParamFamParameter.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/ParamFamParameter.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -1,6 +1,9 @@
### from Matthias' thesis / ROptEst
## generating function
-ParamFamParameter <- function(name, main = numeric(0), nuisance, fixed, trafo){
+ParamFamParameter <- function(name, main = numeric(0), nuisance, fixed, trafo,
+ ..., .returnClsName = NULL){
+
+ mc <- as.list(match.call(expand.dots=TRUE))
if(missing(name))
name <- "parameter of a parametric family of probability measures"
if(missing(nuisance))
@@ -16,13 +19,35 @@
if(.validTrafo(trafo, dimension = ln.m, dimensionwithN = ln)) ### check validity
trafo <- trafo[,1:ln.m,drop=FALSE]
- PFP <- new("ParamFamParameter")
+ if(is.null(.returnClsName))
+ PFP <- new("ParamFamParameter")
+ else
+ PFP <- new(.returnClsName)
+
PFP at name <- name
PFP at main <- main
PFP at nuisance <- nuisance
PFP at fixed <- fixed
PFP at trafo <- trafo
+ lN <- length(mc$...)
+ if(lN){
+ nms <- names(mc$...)
+ mat <- pmatch(nms,"withPosRestr")
+ ws <- lS <- TRUE
+ if(1 %in% mat){
+ PFP at withPosRestr <- mc$...[[which(mat==1)]]
+ ws <- FALSE
+ }
+ nms0 <- which(nms=="")
+ if(length(nms0)){
+ if(ws){
+ PFP at withPosRestr <- mc$...[[nms0[1]]]
+ ws <- FALSE
+ nms0 <- nms0[-1]
+ }
+ }
+ }
return(PFP)
}
@@ -58,7 +83,14 @@
return(mat0)
})
-
+setMethod("withPosRestr", "ParamWithShapeFamParameter", function(object) object at withPosRestr)
+setMethod("main", "ParamWithScaleAndShapeFamParameter", function(object) object at main)
+setMethod("nuisance", "ParamWithScaleAndShapeFamParameter", function(object) object at nuisance)
+setMethod("fixed", "ParamWithScaleAndShapeFamParameter", function(object) object at fixed)
+setMethod("trafo", signature(object = "ParamWithScaleAndShapeFamParameter",
+ param = "missing"),
+ getMethod("trafo", signature(object = "ParamFamParameter",
+ param = "missing")))
## replace methods
setReplaceMethod("main", "ParamFamParameter",
function(object, value){
@@ -90,10 +122,14 @@
object at trafo <- value
object
})
-
## method length
setMethod("length", "ParamFamParameter",
function(x){ length(x at main) + length(x at nuisance) })
## method dimension
setMethod("dimension", "ParamFamParameter", function(object) length(object at main))
+
+setReplaceMethod("withPosRestr", "ParamWithShapeFamParameter", function(object,value){
+ object at withPosRestr
+ })
+
Modified: branches/distr-2.4/pkg/distrMod/R/SimpleL2ParamFamilies.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/SimpleL2ParamFamilies.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/SimpleL2ParamFamilies.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -341,7 +341,9 @@
names(param0) <- nms <- c("scale", "shape")
if(missing(trafo)) {trafo <- diag(2); dimnames(trafo) <-list(nms,nms)}
param <- ParamFamParameter(name = "scale and shape",
- main = param0, trafo = trafo)
+ main = param0, trafo = trafo,
+ withPosRestr = TRUE,
+ .returnClsName ="ParamWithScaleAndShapeFamParameter")
modifyParam <- function(theta){ Gammad(scale = theta[1], shape = theta[2]) }
props <- c("The Gamma family is scale invariant via the parametrization",
"'(nu,shape)=(log(scale),shape)'")
@@ -408,7 +410,6 @@
list(s1 = scale, s2 = shape, Tr = trafo))
L2Fam at fam.call <- f.call
- L2Fam at withPos <- TRUE
L2Fam at LogDeriv <- function(x) -(shape-1)/x + 1/scale
L2Fam at L2deriv <- L2deriv
Modified: branches/distr-2.4/pkg/distrMod/R/internalMleCalc.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/internalMleCalc.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/internalMleCalc.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -20,7 +20,7 @@
#internal helper
##########################################################################
.process.meCalcRes <- function(res, PFam, trafo, res.name, call,
- asvar.fct, ...){
+ asvar.fct, check.validity, ...){
lmx <- length(main(PFam))
lnx <- length(nuisance(PFam))
idx <- 1:lmx
@@ -74,7 +74,7 @@
}
- if(!validParameter(PFam,param))
+ if(!validParameter(PFam,param) && check.validity)
{warning("Optimization for MCE did not give a valid result. You could try to use argument 'penalty'.")
theta <- as.numeric(rep(NA, lnx+lmx))
res <- new("MCEstimate", name = est.name, estimate = theta,
@@ -125,3 +125,32 @@
## caching to speed up things:
.inArgs <- distr:::.inArgs
+.callParamFamParameter <- function(PFam, theta, idx, nuis, fixed){
+
+ clsParam <- paste(class(param(PFam)))
+ sltsParam <- setdiff(names(getSlots(class(param(PFam)))),
+ names(getSlots("ParamFamParameter")))
+ if(clsParam=="ParamFamParameter") clsParam <- NULL
+
+ main <- if(is.null(idx)) theta else theta[idx]
+ paramCallArgs <- list( main = main,
+ nuisance = nuis,
+ fixed = fixed)
+
+ paramCallArgs$name <- if(!is.null(names(theta)))
+ names(theta) else param(PFam)@name
+
+ if(!is.null(clsParam)){
+ paramCallArgs$.returnClsName <- clsParam
+ lparamCallArgs <- length(paramCallArgs)
+ if(length(sltsParam)){
+ for(i in 1:length(sltsParam)){
+ paramCallArgs[[lparamCallArgs+i]] <- slot(param(PFam),sltsParam[i])
+ names(paramCallArgs)[lparamCallArgs+i] <- sltsParam[i]
+ }
+ }
+ }
+
+ param0 <- do.call(ParamFamParameter, args = paramCallArgs)
+ return(param0)
+}
\ No newline at end of file
Modified: branches/distr-2.4/pkg/distrMod/R/mleCalc-methods.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/mleCalc-methods.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/mleCalc-methods.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -64,12 +64,13 @@
setMethod("mleCalc", signature(x = "numeric", PFam = "ParamFamily"),
- function(x, PFam, startPar = NULL, penalty = 1e20, Infos = NULL, ...){
+ function(x, PFam, startPar = NULL, penalty = 1e20, Infos = NULL,
+ validity.check = TRUE, ...){
res <- mceCalc(x = x, PFam = PFam,
criterion = .negLoglikelihood, startPar = startPar,
penalty = penalty, crit.name = "neg.Loglikelihood",
- Infos = Infos, ...)
+ Infos = Infos, validity.check = validity.check, ...)
names(res$criterion) <- "neg.Loglikelihood"
return(res)
})
@@ -80,7 +81,8 @@
setMethod("mceCalc", signature(x = "numeric", PFam = "ParamFamily"),
function(x, PFam, criterion, startPar = NULL, penalty = 1e20,
- crit.name = "", Infos = NULL, withthetaPar = FALSE, ...){
+ crit.name = "", Infos = NULL, validity.check = TRUE,
+ withthetaPar = FALSE, ...){
if(is.null(startPar)) startPar <- startPar(PFam)(x,...)
@@ -91,7 +93,8 @@
allwarns <<- character(0)
fun <- function(theta, Data, ParamFamily, criterionF, ...){
- vP <- validParameter(ParamFamily, theta)
+ vP <- TRUE
+ if(validity.check) vP <- validParameter(ParamFamily, theta)
dots <- list(...)
dots$trafo <- NULL
dots$penalty <- NULL
@@ -147,19 +150,19 @@
crit <- res$value
}
- vP <- validParameter(PFam, theta)
+ vP <- TRUE
+ if(validity.check) vP <- validParameter(PFam, theta)
if(!vP) theta <- makeOKPar(PFam)(theta)
idx <- if(lnx) lmx + 1:lnx else 1:(lmx+lnx)
nuis.idx <- if(lnx) idx else NULL
nuis <- if(lnx) theta[-idx] else NULL
- param <- ParamFamParameter(name = names(theta),
- main = theta[idx],
- nuisance = nuis,
- fixed = fixed)
+ param <- .callParamFamParameter(PFam, theta, idx, nuis, fixed)
+
fun2 <- function(theta, Data, ParamFamily, criterion, ...){
- vP <- validParameter(ParamFamily, theta)
+ vP <- TRUE
+ if(validity.check) vP <- validParameter(ParamFamily, theta)
if(!vP) theta <- makeOKPar(ParamFamily)(theta)
if(lnx)
names(theta) <- c(names(main(ParamFamily)),
Modified: branches/distr-2.4/pkg/distrMod/R/setAs.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/setAs.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/setAs.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -1,8 +1,7 @@
setAs("MCEstimate", "mle", def = function(from){
crit.f0 <- from at criterion.fct
start.f0 <- as.list(from at untransformed.estimate)
-
- if(!.isUnitMatrix(trafo(from)$mat)){
+ if(!.isUnitMatrix(trafo(from)$mat)){
### we have to turn crit.f0 into a function in the
### transformed parameter; to this end, we specify
@@ -39,8 +38,8 @@
## generate a valid ParamFamParameter object out of it
param <- ParamFamParameter(main = est.main, nuisance = est.nuis,
fixed = from at fixed)
-
- ## "invert" (locally!) the transformation,
+
+ ## "invert" (locally!) the transformation,
# i.e. th1 "=" trafo^-1(th0)
D1 <- (trafo(from)$fct)(th0)$mat
th1 <- est1 + solve(D1, th0-est0)
Modified: branches/distr-2.4/pkg/distrMod/R/validParameter.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/validParameter.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/R/validParameter.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -14,34 +14,47 @@
"try-error")) return(FALSE)
return(TRUE)})
+ setMethod("validParameter", signature(object = "L2ScaleUnion"),
+ function(object, param, tol=.Machine$double.eps){
+ if(missing(tol)) tol <- .Machine$double.eps
+ if(is(param,"ParamFamParameter"))
+ param <- main(param)
+ sc <- NULL
+ if(is(try(sc <- param["scale"], silent=TRUE),"try-error"))
+ if(is(object,"L2LocationScaleUnion"))
+ try(sc <- param[locationscale(object)["scale"]],silent=TRUE)
+ if(!is.null(sc) && !is.na(sc)) if(sc <= tol) return(FALSE)
+ if(!all(is.finite(param))) return(FALSE)
+ return(TRUE)})
+
setMethod("validParameter", signature(object = "L2ScaleFamily"),
function(object, param, tol=.Machine$double.eps){
+ if(!getMethod("validParameter","L2ScaleUnion")(object,param,tol))
+ return(FALSE)
if(is(param,"ParamFamParameter"))
param <- main(param)
- if(!all(is.finite(param))) return(FALSE)
if(length(param)!=1) return(FALSE)
- return(param > tol)})
+ return(TRUE)})
setMethod("validParameter", signature(object = "L2LocationFamily"),
function(object, param){
- if(is(param,"ParamFamParameter"))
+ if(!getMethod("validParameter","L2ScaleUnion")(object,param))
+ return(FALSE)
+ if(is(param,"ParamFamParameter"))
param <- main(param)
- if(!all(is.finite(param))) return(FALSE)
- if(length(param)!=1) return(FALSE)
- TRUE})
+ if(length(param)!=1) return(FALSE)
+ TRUE})
setMethod("validParameter", signature(object = "L2LocationScaleFamily"),
function(object, param, tol=.Machine$double.eps){
+ if(!getMethod("validParameter","L2ScaleUnion")(object,param,tol))
+ return(FALSE)
if(is(param,"ParamFamParameter") && length(nuisance(object)))
theta <- c(main(param), nuisance(param))
else {if (is(param,"ParamFamParameter")) param <- main(param)
theta <- param
}
- if(!all(is.finite(theta))) return(FALSE)
if(length(theta)>2||length(theta)<1) return(FALSE)
- if(any(names(theta)%in% c("scale", "sd"))){
- return(theta[names(theta)%in% c("scale", "sd")]>tol)
- }
return(TRUE)
})
@@ -66,13 +79,17 @@
return(TRUE)
})
- setMethod("validParameter", signature(object = "GammaFamily"),
+ setMethod("validParameter", signature(object = "L2ScaleShapeUnion"),
function(object, param, tol=.Machine$double.eps){
- if(is(param,"ParamFamParameter"))
+ if(!getMethod("validParameter","L2ScaleUnion")(object,param,tol))
+ return(FALSE)
+ if(is(param,"ParamFamParameter")){
+# wR <- withPosRestr(param)
param <- main(param)
- if(!all(is.finite(param))) return(FALSE)
+ }
if(length(param)>2||length(param)<1) return(FALSE)
- if(any(param<= tol)) return(FALSE)
+ if("shape"%in%names(param))
+ if(param["shape"] <= tol && object at withPosRestr) return(FALSE)
return(TRUE)
})
Modified: branches/distr-2.4/pkg/distrMod/inst/scripts/examples2.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/inst/scripts/examples2.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/inst/scripts/examples2.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -219,7 +219,8 @@
#CvM distance
# 0.03114585
#
-#MDE.asvar <- distrMod:::.CvMMDCovariance(my3dF,
-# param = ParamFamParameter(main= estimate(MDE)),
-# expon = 2, withplot = TRUE)
+MDE.asvar <- distrMod:::.CvMMDCovariance(my3dF,
+ param = ParamFamParameter(main= estimate(MDE),
+ .returnClsName = "ParamWithScaleFamParameter"),
+ expon = 2, withplot = TRUE)
Modified: branches/distr-2.4/pkg/distrMod/inst/scripts/modelExp3.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/inst/scripts/modelExp3.R 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/inst/scripts/modelExp3.R 2012-05-20 18:48:36 UTC (rev 812)
@@ -69,7 +69,8 @@
# 0.02527883
asvar(mde.CvM) <- distrMod:::.CvMMDCovariance(my3dF,
- param = ParamFamParameter(main= estimate(MDE)),
+ param = ParamFamParameter(main= estimate(MDE),
+ .returnClsName = "ParamWithScaleFamParameter"),
expon = 2, withplot = TRUE)
# a confidence interval
confint(mde.CvM)
Modified: branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd 2012-05-20 18:48:36 UTC (rev 812)
@@ -70,6 +70,9 @@
|>|>|>|>|>|>"NormLocationScaleFamily" [*]
|>|>|>|>|>|>"CauchyLocationScaleFamily" [*]
+and a (virtual) class union "L2ScaleUnion" between
+ "L2LocationScaleUnion" and "L2ScaleShapeUnion"
+
##########################
ParamFamParameter
##########################
Modified: branches/distr-2.4/pkg/distrMod/man/MCEstimate-class.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/MCEstimate-class.Rd 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/man/MCEstimate-class.Rd 2012-05-20 18:48:36 UTC (rev 812)
@@ -124,7 +124,8 @@
(m <- MLEstimator(x, G))
m.mle <- as(m,"mle")
par(mfrow=c(1,2))
-plot(profile(m))
+profileM <- profile(m)
+## plot-profile throws an error
}
\concept{estimate}
\keyword{classes}
Modified: branches/distr-2.4/pkg/distrMod/man/MDEstimator.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/MDEstimator.Rd 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/man/MDEstimator.Rd 2012-05-20 18:48:36 UTC (rev 812)
@@ -9,7 +9,7 @@
\usage{
MDEstimator(x, ParamFamily, distance = KolmogorovDist, dist.name,
paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL,
- penalty = 1e20, asvar.fct, na.rm = TRUE, ...)
+ penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -32,6 +32,8 @@
\item{trafo}{ an object of class \code{MatrixorFunction} -- a transformation
for the main parameter}
\item{penalty}{(non-negative) numeric: penalizes non valid parameter-values}
+ \item{validity.check}{logical: shall return parameter value be checked for
+ validity? Defaults to yes (\code{TRUE})}
\item{asvar.fct}{optionally: a function to determine the corresponding
asymptotic variance; if given, \code{asvar.fct} takes arguments
\code{L2Fam}((the parametric model as object of class \code{L2ParamFamily}))
Modified: branches/distr-2.4/pkg/distrMod/man/MLEstimator.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/MLEstimator.Rd 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/man/MLEstimator.Rd 2012-05-20 18:48:36 UTC (rev 812)
@@ -10,7 +10,8 @@
}
\usage{
MLEstimator(x, ParamFamily, startPar = NULL,
- Infos, trafo = NULL, penalty = 1e20, na.rm = TRUE, ...)
+ Infos, trafo = NULL, penalty = 1e20,
+ validity.check = TRUE, na.rm = TRUE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -26,6 +27,8 @@
\item{trafo}{ an object of class \code{MatrixorFunction} -- a transformation
for the main parameter}
\item{penalty}{(non-negative) numeric: penalizes non valid parameter-values}
+ \item{validity.check}{logical: shall return parameter value be checked for
+ validity? Defaults to yes (\code{TRUE})}
\item{na.rm}{logical: if \code{TRUE}, the estimator is evaluated at \code{complete.cases(x)}.}
\item{\dots}{ further arguments to \code{criterion} or \code{optimize}
or \code{optim}, respectively. }
Modified: branches/distr-2.4/pkg/distrMod/man/ParamFamParameter-class.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/ParamFamParameter-class.Rd 2012-05-20 11:48:59 UTC (rev 811)
+++ branches/distr-2.4/pkg/distrMod/man/ParamFamParameter-class.Rd 2012-05-20 18:48:36 UTC (rev 812)
@@ -1,21 +1,34 @@
\name{ParamFamParameter-class}
\docType{class}
\alias{ParamFamParameter-class}
+\alias{ParamWithScaleFamParameter-class}
+\alias{ParamWithScaleAndShapeFamParameter-class}
+\alias{ParamWithShapeFamParameter-class}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 812
More information about the Distr-commits
mailing list