[Distr-commits] r804 - in branches/distr-2.4/pkg: distrEx distrEx/R distrEx/man distrMod distrMod/R distrMod/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue May 15 16:38:41 CEST 2012
Author: ruckdeschel
Date: 2012-05-15 16:38:40 +0200 (Tue, 15 May 2012)
New Revision: 804
Added:
branches/distr-2.4/pkg/distrEx/R/SnQn.R
branches/distr-2.4/pkg/distrMod/R/LDEstimator.R
branches/distr-2.4/pkg/distrMod/man/LDEstimator.Rd
branches/distr-2.4/pkg/distrMod/man/internalldeHelpers.Rd
Modified:
branches/distr-2.4/pkg/distrEx/DESCRIPTION
branches/distr-2.4/pkg/distrEx/NAMESPACE
branches/distr-2.4/pkg/distrEx/R/AllGeneric.R
branches/distr-2.4/pkg/distrEx/man/0distrEx-package.Rd
branches/distr-2.4/pkg/distrEx/man/Var.Rd
branches/distr-2.4/pkg/distrMod/DESCRIPTION
branches/distr-2.4/pkg/distrMod/NAMESPACE
branches/distr-2.4/pkg/distrMod/R/Estimator.R
branches/distr-2.4/pkg/distrMod/R/GParetoFamily.R
branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd
Log:
new: medSn, medQn, medkMAD and medkMADhybr (more generally LD-estimators) are implemented in distrMod; additionally (or to this end) Sn and Qn are implemented as functionals in distrEx
Modified: branches/distr-2.4/pkg/distrEx/DESCRIPTION
===================================================================
--- branches/distr-2.4/pkg/distrEx/DESCRIPTION 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrEx/DESCRIPTION 2012-05-15 14:38:40 UTC (rev 804)
@@ -1,11 +1,11 @@
Package: distrEx
Version: 2.4
-Date: 2011-11-18
+Date: 2012-05-15
Title: Extensions of package distr
Description: Extensions of package distr and some additional functionality
-Depends: R(>= 2.6.0), methods, distr(>= 2.2), evd, actuar, startupmsg
+Depends: R(>= 2.6.0), methods, distr(>= 2.2), evd, actuar, startupmsg, robustbase(>= 0.8-0)
Suggests: tcltk
-Author: Matthias Kohl, Peter Ruckdeschel
+Author: Matthias Kohl, Peter Ruckdeschel, Nataliya Horbenko
Maintainer: Matthias Kohl <Matthias.Kohl at stamats.de>
ByteCompile: yes
License: LGPL-3
Modified: branches/distr-2.4/pkg/distrEx/NAMESPACE
===================================================================
--- branches/distr-2.4/pkg/distrEx/NAMESPACE 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrEx/NAMESPACE 2012-05-15 14:38:40 UTC (rev 804)
@@ -3,6 +3,7 @@
import("startupmsg")
import("methods")
import("distr")
+import("robustbase")
exportClasses("Condition", "EuclCondition")
exportClasses("LMParameter",
@@ -39,7 +40,7 @@
"+", "*",
"name", "name<-",
"E", "var", "IQR", "skewness", "kurtosis",
- "sd", "median", "mad", "kMAD",
+ "sd", "median", "mad", "kMAD", "Sn", "Qn",
"m1df", "m2df",
"liesInSupport")
export("EuclCondition")
Modified: branches/distr-2.4/pkg/distrEx/R/AllGeneric.R
===================================================================
--- branches/distr-2.4/pkg/distrEx/R/AllGeneric.R 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrEx/R/AllGeneric.R 2012-05-15 14:38:40 UTC (rev 804)
@@ -170,4 +170,12 @@
setGeneric("plotCLT", function(Tn, ...) standardGeneric("plotCLT"))
}
+### new: 15.05.2012:
+if(!isGeneric("Qn")){
+ setGeneric("Qn", function(x, ...) standardGeneric("Qn"))
+}
+
+if(!isGeneric("Sn")){
+ setGeneric("Sn", function(x, ...) standardGeneric("Sn"))
+}
Added: branches/distr-2.4/pkg/distrEx/R/SnQn.R
===================================================================
--- branches/distr-2.4/pkg/distrEx/R/SnQn.R (rev 0)
+++ branches/distr-2.4/pkg/distrEx/R/SnQn.R 2012-05-15 14:38:40 UTC (rev 804)
@@ -0,0 +1,82 @@
+setMethod("Qn", signature(x = "ANY"),
+ function(x, ...){
+ dots <- list(...)
+ constant <- ifelse(hasArg(constant), dots$"constant", 2.21914)
+ finite.corr <- ifelse(hasArg(finite.corr), dots$"finite.corr",
+ !hasArg(constant))
+ if(hasArg(na.rm)) if(dots$"na.rm") x <- x[!is.na(x)]
+ robustbase::Qn(x, constant=constant, finite.corr=finite.corr)
+ })
+
+setMethod("Sn", signature(x = "ANY"),
+ function(x, ...){
+ dots <- list(...)
+ constant <- ifelse(hasArg(constant), dots$"constant", 1.1926)
+ finite.corr <- ifelse(hasArg(finite.corr), dots$"finite.corr",
+ !hasArg(constant))
+ if(hasArg(na.rm)) if(dots$"na.rm") x <- x[!is.na(x)]
+ robustbase::Sn(x, constant=constant, finite.corr=finite.corr)
+ })
+
+setMethod("Qn", signature(x = "UnivariateDistribution"),
+ function(x, q00 = NULL, ...){
+ if(is.null(q00)) q00 <- 10*q(x)(3/4)
+
+ intv <- function(xx,q0=q00) p(x)(q0+q(x)(xx))-5/8
+ intq <- function(q){
+ sapply(q, function(q1){
+ integrate(intv,lower=0,upper=1,q0=q1)$value})
+ }
+ qc = try(uniroot(intq,lower=-q00,upper=q00)$root,silent=TRUE)
+ if(is(qc,"try-error")) {
+ print("error")
+ return(NA)
+ }else return(qc)
+ })
+
+setMethod("Qn", signature(x = "DiscreteDistribution"),
+ function(x, ...){
+ x2 <- x-x
+ q(x2)(5/8)
+ })
+
+
+setMethod("Sn", signature(x = "UnivariateDistribution"),
+ function(x, low=0,upp=20, accuracy = 1000, ...){
+
+ g <- function(xx){
+ fct <- function(m) p(x)(m+xx)-p(x)(-m+xx)-0.5
+ m <- try(uniroot(fct, lower = low, upper = upp*q(x)(0.75))$root,
+ silent = TRUE)
+ if(is(m,"try-error")) {
+# print("error")
+ return(NA)
+ }else{ return(m) }
+ }
+
+ x0 <- q(x)(seq(1e-2/accuracy,1-1e-2/accuracy,length=accuracy))
+ y <- sapply(x0,g)
+
+ c0 <- median(y,na.rm=TRUE)
+ return(c0)
+ })
+
+setMethod("Sn", signature(x = "Norm"),
+ function(x, ...){
+ return(sd(x)* 0.8385098038)
+ })
+
+setMethod("Qn", signature(x = "Norm"),
+ function(x, ...){
+ return(sd(x)*0.45062411)
+ })
+
+setMethod("Sn", signature(x = "AffLinDistribution"),
+ function(x, ...){
+ return(abs(x at a) * Sn(x at X0,...))
+ })
+
+setMethod("Qn", signature(x = "AffLinDistribution"),
+ function(x, ...){
+ return(abs(x at a) * Qn(x at X0,...))
+ })
Modified: branches/distr-2.4/pkg/distrEx/man/0distrEx-package.Rd
===================================================================
--- branches/distr-2.4/pkg/distrEx/man/0distrEx-package.Rd 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrEx/man/0distrEx-package.Rd 2012-05-15 14:38:40 UTC (rev 804)
@@ -14,7 +14,7 @@
\item \code{E(X,f)} for the expectation of \code{f(X)}
where \code{X} is some distribution object and
\code{f} some function in \code{X} }
-\item further functionals: var, sd, IQR, mad, median, skewness, kurtosis
+\item further functionals: var, sd, IQR, mad, median, skewness, kurtosis, Sn, Qn
\item truncated moments,
\item distances between distributions
(Hellinger, Cramer von Mises, Kolmogorov, total variation, "convex contamination")
@@ -27,12 +27,12 @@
\tabular{ll}{
Package: \tab distrEx \cr
Version: \tab 2.4 \cr
-Date: \tab 2010-12-03 \cr
-Depends: \tab R(>= 2.6.0), methods, distr(>= 2.2), evd, actuar, startupmsg \cr
+Date: \tab 2012-05-15 \cr
+Depends: \tab R(>= 2.6.0), methods, distr(>= 2.2), evd, actuar, startupmsg, robustbase \cr
LazyLoad: \tab yes \cr
License: \tab LGPL-3 \cr
URL: \tab http://distr.r-forge.r-project.org/\cr
-SVNRevision: \tab 699 \cr
+SVNRevision: \tab 757 \cr
}
}
\section{Classes}{
Modified: branches/distr-2.4/pkg/distrEx/man/Var.Rd
===================================================================
--- branches/distr-2.4/pkg/distrEx/man/Var.Rd 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrEx/man/Var.Rd 2012-05-15 14:38:40 UTC (rev 804)
@@ -163,6 +163,19 @@
\alias{kurtosis,Unif-method}
\alias{kurtosis,Weibull-method}
\alias{kurtosis,Td-method}
+\alias{Sn}
+\alias{Sn-methods}
+\alias{Sn,ANY-method}
+\alias{Sn,UnivariateDistribution-method}
+\alias{Sn,Norm-method}
+\alias{Sn,AffLinDistribution-method}
+\alias{Qn}
+\alias{Qn-methods}
+\alias{Qn,ANY-method}
+\alias{Qn,UnivariateDistribution-method}
+\alias{Qn,Norm-method}
+\alias{Qn,DiscreteDistribution-method}
+\alias{Qn,AffLinDistribution-method}
\title{Generic Functions for the Computation of Functionals}
\description{
@@ -313,7 +326,21 @@
\S4method{kurtosis}{Td}(x, ...)
\S4method{kurtosis}{Unif}(x, ...)
\S4method{kurtosis}{Weibull}(x, ...)
+
+Sn(x, ...)
+\S4method{Sn}{ANY}(x, ...)
+\S4method{Sn}{UnivariateDistribution}(x, low = 0, upp = 20, accuracy = 1000, ...)
+\S4method{Sn}{AffLinDistribution}(x, ...)
+\S4method{Sn}{Norm}(x, ...)
+
+Qn(x, ...)
+\S4method{Qn}{ANY}(x, ...)
+\S4method{Qn}{UnivariateDistribution}(x, q00 = NULL, ...)
+\S4method{Qn}{AffLinDistribution}(x, ...)
+\S4method{Qn}{DiscreteDistribution}(x, ...)
+\S4method{Qn}{Norm}(x, ...)
}
+
\arguments{
\item{x}{ object of class \code{"UnivariateDistribution"}}
\item{fun}{ if missing the (conditional) variance resp. standard deviation is computed
@@ -324,6 +351,13 @@
\item{useApply}{ logical: should \code{sapply}, respectively \code{apply}
be used to evaluate \code{fund}.}
\item{withCond}{ logical: is \code{cond} in the argument list of \code{fun}. }
+ \item{q00}{numeric or NULL: determines search interval (from \code{-q00} to \code{q00})
+ for \code{Qn}; if \code{NULL} (default) \code{q00}
+ is set to \code{10*q(x)(3/4)} internally. }
+ \item{low}{numeric; lower bound for search interval; defaults to \code{0}. }
+ \item{upp}{numeric; upper bound for search interval; defaults to \code{20}.
+ Is used internally as \code{upp*q(x)(0.75)}. }
+ \item{accuracy}{numeric; number of grid points; defaults to \code{1000}. }
}
\value{
The value of the corresponding functional at the distribution in the argument is computed.
@@ -405,7 +439,21 @@
if arguments \code{fun}, \code{cond} are missing: \code{kurtosis(x at X0)}
else uses method for \code{signature(x = "UnivariateDistribution")}}
- \item{\code{var}, \code{signature(x = "Arcsine")}:}{
+ \item{\code{Qn}, \code{signature(x = "Any")}:}{
+ interface to the \pkg{robustbase}-function \code{Qn} --- see \code{\link[robustbase]{Qn}}.}
+ \item{\code{Qn}, \code{signature(x = "UnivariateDistribution")}:}{
+ Qn of univariate distributions.}
+ \item{\code{Qn}, \code{signature(x = "DiscreteDistribution")}:}{
+ Qn of discrete distributions.}
+ \item{\code{Qn}, \code{signature(x = "AffLinDistribution")}:}{\code{abs(x at a) * Qn(x at X0)}}
+
+ \item{\code{Sn}, \code{signature(x = "Any")}:}{
+ interface to the \pkg{robustbase}-function \code{Qn} --- see \code{\link[robustbase]{Sn}}.}
+ \item{\code{Sn}, \code{signature(x = "UnivariateDistribution")}:}{
+ Sn of univariate distributions using pseudo-random variables (Thx to N. Horbenko).}
+ \item{\code{Sn}, \code{signature(x = "AffLinDistribution")}:}{\code{abs(x at a) * Sn(x at X0)}}
+
+ \item{\code{var}, \code{signature(x = "Arcsine")}:}{
exact evaluation using explicit expressions.}
\item{\code{var}, \code{signature(x = "Beta")}:}{
for noncentrality 0 exact evaluation using explicit expressions.}
@@ -627,6 +675,12 @@
\item{\code{kurtosis}, \code{signature(x = "Weibull")}:}{
exact evaluation using explicit expressions.}
+ \item{\code{Sn}, \code{signature(x = "Norm")}:}{
+ exact evaluation using explicit expressions.}
+
+ \item{\code{Qn}, \code{signature(x = "Norm")}:}{
+ exact evaluation using explicit expressions.}
+
}}
%\references{ ~put references to the literature/web site here ~ }
\author{Peter Ruckdeschel \email{Peter.Ruckdeschel at itwm.fraunhofer.de}}
@@ -670,7 +724,8 @@
\seealso{\code{\link{distrExIntegrate}}, \code{\link{m1df}}, \code{\link{m2df}},
\code{\link[distr]{Distribution-class}},\cr
\code{\link[stats]{sd}}, \code{\link[stats:cor]{var}}, \code{\link[stats]{IQR}},\cr
- \code{\link[stats]{median}}, \code{\link[stats]{mad}}, \code{\link[distr:sd-methods]{sd}} }
+ \code{\link[stats]{median}}, \code{\link[stats]{mad}}, \code{\link[distr:sd-methods]{sd}},\cr
+ \code{\link[robustbase]{Sn}}, \code{\link[robustbase]{Qn}}}
\concept{functional}
\concept{var}
\concept{sd}
@@ -679,6 +734,8 @@
\concept{median}
\concept{skewness}
\concept{kurtosis}
+\concept{Sn}
+\concept{Qn}
\keyword{methods}
\keyword{distribution}
\concept{integration}
Modified: branches/distr-2.4/pkg/distrMod/DESCRIPTION
===================================================================
--- branches/distr-2.4/pkg/distrMod/DESCRIPTION 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrMod/DESCRIPTION 2012-05-15 14:38:40 UTC (rev 804)
@@ -1,12 +1,12 @@
Package: distrMod
Version: 2.4
-Date: 2011-11-18
+Date: 2012-05-15
Title: Object oriented implementation of probability models
Description: Object oriented implementation of probability models based on packages 'distr' and
'distrEx'
Author: Matthias Kohl, Peter Ruckdeschel
Maintainer: Peter Ruckdeschel <Peter.Ruckdeschel at itwm.fraunhofer.de>
-Depends: R(>= 2.6.0), methods, startupmsg, distr(>= 2.2), distrEx(>= 2.2), RandVar(>= 0.6.3),
+Depends: R(>= 2.6.0), methods, startupmsg, distr(>= 2.2), distrEx(>= 2.4), RandVar(>= 0.6.3),
MASS, stats4
ByteCompile: yes
License: LGPL-3
Modified: branches/distr-2.4/pkg/distrMod/NAMESPACE
===================================================================
--- branches/distr-2.4/pkg/distrMod/NAMESPACE 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrMod/NAMESPACE 2012-05-15 14:38:40 UTC (rev 804)
@@ -80,3 +80,4 @@
export("NormScaleUnknownLocationFamily", "NormLocationUnknownScaleFamily")
export("L2LocationUnknownScaleFamily", "L2ScaleUnknownLocationFamily")
export("meRes", "get.criterion.fct")
+export("LDEstimator", "medkMAD", "medSn", "medQn", "medkMADhybr")
Modified: branches/distr-2.4/pkg/distrMod/R/Estimator.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/Estimator.R 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrMod/R/Estimator.R 2012-05-15 14:38:40 UTC (rev 804)
@@ -67,7 +67,7 @@
res at trafo <- list(fct = trafo, mat = trafo(main(param))$mat)
}
- res at estimate <- estimate[idx]
+ res at estimate <- estimate[idm]
asvar <- NULL
if(!missing(asvar.fct))
@@ -78,7 +78,7 @@
if(!.isUnitMatrix(res at trafo$mat)){
res at estimate <- res at trafo$fct(estimate)
if(!is.null(asvar))
- res at asvar <- res at trafo$mat%*%asvar[idx,idx]%*%t(res at trafo$mat)
+ res at asvar <- res at trafo$mat%*%asvar[idm,idm]%*%t(res at trafo$mat)
}
Modified: branches/distr-2.4/pkg/distrMod/R/GParetoFamily.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/GParetoFamily.R 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrMod/R/GParetoFamily.R 2012-05-15 14:38:40 UTC (rev 804)
@@ -257,7 +257,9 @@
## Pickand estimator
if(is.null(start0Est)){
- e0 <- HybridEstimator(x, up=300, ...)
+ e0 <- medkMADhybr(x, ParamFamily=GParetoFamily(loc = theta[1],
+ scale = theta[2], shape = theta[3]),
+ q.lo = 1e-6, q.up = 20)
}else{
if(is(start0Est,"function")){
e1 <- start0Est(x, ...)
@@ -271,14 +273,28 @@
}
modifyPar <- function(theta){
- theta <- abs(theta)
- GPareto(loc = loc, scale = theta[1], shape = theta[2])
+ if(!is.null(names)){
+ sc <- theta["scale"]
+ sh <- theta["shape"]
+ }else{
+ theta <- abs(theta)
+ sc <- theta[1]
+ sh <- theta[2]
+ }
+ GPareto(loc = loc, scale = sc, shape = sh)
}
## what to do in case of leaving the parameter domain
makeOKPar <- function(theta) {
- theta <- abs(theta)
- theta[2] <- pmin(theta[2],10)
+ if(!is.null(names)){
+ sc <- theta["scale"]
+ sh <- theta["shape"]
+ }else{
+ theta <- abs(theta)
+ sc <- theta[1]
+ sh <- theta[2]
+ }
+ theta[2] <- pmin(sh,10)
return(theta)
}
Added: branches/distr-2.4/pkg/distrMod/R/LDEstimator.R
===================================================================
--- branches/distr-2.4/pkg/distrMod/R/LDEstimator.R (rev 0)
+++ branches/distr-2.4/pkg/distrMod/R/LDEstimator.R 2012-05-15 14:38:40 UTC (rev 804)
@@ -0,0 +1,206 @@
+.prepend <- function(prep, list0, dots = NULL){
+ if(length(list0)+length(dots)==0) return(list(prep))
+ n <- length(list0) + 1
+ list1 <- vector("list",n)
+ list1[[1]] <- prep
+ names(list1)[1] <- "x"
+ if(n>1) for(i in 2:n) {
+ list1[[i]] <- list0[[i-1]]
+ names(list1)[i] <- names(list0)[i-1]}
+ ldots <- length(dots)
+ l1 <- length(list1)
+ if(ldots) {
+ for( i in 1:ldots){
+ list1[[l1+i]] <- dots[[i]]
+ names(list1)[l1+i] <- names(dots)[i]
+ }
+ }
+ return(list1)
+}
+
+.LDMatch <- function(x.0, loc.est.0,disp.est.0,
+ loc.fctal.0, disp.fctal.0, ParamFamily.0,
+ loc.est.ctrl.0 = NULL, loc.fctal.ctrl.0=NULL,
+ disp.est.ctrl.0 = NULL, disp.fctal.ctrl.0=NULL,
+ q.lo.0 =0, q.up.0=Inf, log.q.0 =TRUE, ...
+ ){
+ dots <- list(...)
+ loc.emp <- do.call(loc.est.0, args = .prepend(x.0,loc.est.ctrl.0, dots))
+ disp.emp <- do.call(disp.est.0, args = .prepend(x.0,disp.est.ctrl.0, dots))
+ q.emp <- if(log.q.0) log(loc.emp)-log(disp.emp) else loc.emp/disp.emp
+ q.f <- function(xi){
+ distr.new <- ParamFamily.0 at modifyParam(theta=c("scale"=1,"shape"=xi))
+ loc.th <- do.call(loc.fctal.0, args = .prepend(distr.new,loc.fctal.ctrl.0, dots))
+ sc.th <- do.call(disp.fctal.0, args = .prepend(distr.new,disp.fctal.ctrl.0, dots))
+ val <- if(log.q.0) log(loc.th)-log(sc.th) - q.emp else
+ loc.th/sc.th-q.emp
+ return(val)
+ }
+ xi.0 <- uniroot(q.f,lower=q.lo.0,upper=q.up.0)$root
+ distr.new.0 <- ParamFamily.0 at modifyParam(theta=c("scale"=1,"shape"=xi.0))
+ m1xi <- do.call(loc.fctal.0, args = .prepend(distr.new.0,loc.fctal.ctrl.0, dots))
+ val <- c("shape"=xi.0,"scale"=loc.emp/m1xi)
+ return(val)
+}
+
+LDEstimator <- function(x, loc.est, disp.est,
+ loc.fctal, disp.fctal, ParamFamily,
+ loc.est.ctrl = NULL, loc.fctal.ctrl=NULL,
+ disp.est.ctrl = NULL, disp.fctal.ctrl=NULL,
+ q.lo =0, q.up=Inf, log.q =TRUE,
+ name, Infos, asvar = NULL, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...){
+ param0 <- main(param(ParamFamily))
+ if(!all(c("shape","scale") %in% names(param0)))
+ stop("LDEstimators expect shape-scale models.")
+ name.est <- "LDEstimator"
+ es.call <- match.call()
+ if(missing(name))
+ name <- "Some estimator"
+ LDnames <- paste("Location:",
+ paste(deparse(substitute(loc.fctal))),
+ " ","Dispersion:",
+ paste(deparse(substitute(disp.fctal))))
+ estimator <- function(x,...){
+ .LDMatch(x.0= x,
+ loc.est.0 = loc.est, disp.est.0 = disp.est,
+ loc.fctal.0 = loc.fctal, disp.fctal.0 = disp.fctal,
+ ParamFamily.0 = ParamFamily,
+ loc.est.ctrl.0 = loc.est.ctrl,
+ loc.fctal.ctrl.0 = loc.fctal.ctrl,
+ disp.est.ctrl.0 = disp.est.ctrl,
+ disp.fctal.ctrl.0 = disp.fctal.ctrl,
+ q.lo.0 = q.lo, q.up.0 = q.up, log.q.0 = log.q)
+ }
+
+
+ asvar.0 <- asvar
+ nuis.idx.0 <- nuis.idx
+ trafo.0 <- trafo
+ fixed.0 <- fixed
+ na.rm.0 <- na.rm
+
+ estimate <- Estimator(x, estimator, name, Infos,
+ asvar = asvar.0, nuis.idx = nuis.idx.0,
+ trafo = trafo.0, fixed = fixed.0,
+ na.rm = na.rm.0, ...)
+ if(missing(asvar)) asvar <- NULL
+ if(is.null(asvar))
+ if(!missing(asvar.fct))
+ if(!is.null(asvar.fct))
+ asvar <- asvar.fct(ParamFamily, estimate, ...)
+
+ estimate at untransformed.asvar <- asvar
+
+ l.e <- length(estimate at untransformed.estimate)
+ idx <- NULL
+ idm <- 1:l.e
+ if(!is.null(nuis.idx))
+ {idx <- nuis.idx
+ idm <- idm[-idx]
+ mat <- diag(length(idm))}
+
+ if(!.isUnitMatrix(estimate at trafo$mat)){
+ estimate at estimate <- estimate at trafo$fct(estimate)
+ if(!is.null(asvar))
+ estimate at asvar <- estimate at trafo$mat%*%asvar[idm,idm]%*%t(estimate at trafo$mat)
+ }
+
+ estimate at estimate.call <- es.call
+
+ if(missing(Infos))
+ Infos <- matrix(c("LDEstimator", LDnames),
+ ncol=2, dimnames=list(character(0), c("method", "message")))
+ else{
+ Infos <- matrix(c(rep("LDEstimator", length(Infos)+1), c(LDnames,Infos)),
+ ncol = 2)
+ colnames(Infos) <- c("method", "message")
+ }
+ estimate at Infos <- Infos
+ return(estimate)
+}
+
+
+medkMAD <- function(x, k=1, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...){
+ es.call <- match.call()
+ if(missing(k)) k <- 1
+ es <- LDEstimator(x, loc.est = median, disp.est = kMAD,
+ loc.fctal = median, disp.fctal = kMAD,
+ ParamFamily = ParamFamily,
+ loc.est.ctrl = NULL, loc.fctal.ctrl = NULL,
+ disp.est.ctrl = list(k=k, na.rm = na.rm),
+ disp.fctal.ctrl=list(k=k),
+ q.lo =q.lo, q.up=q.up, log.q=TRUE,
+ name = "medkMAD", Infos="medkMAD",
+ asvar = NULL, nuis.idx = nuis.idx, trafo = trafo, fixed = fixed,
+ asvar.fct = asvar.fct, na.rm = na.rm, ...)
+ es at estimate.call <- es.call
+ return(es)
+ }
+
+medQn <- function(x, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...){
+ es.call <- match.call()
+ es <- LDEstimator(x, loc.est = median, disp.est = Qn,
+ loc.fctal = median, disp.fctal = Qn,
+ ParamFamily = ParamFamily,
+ loc.est.ctrl = NULL, loc.fctal.ctrl = NULL,
+ disp.est.ctrl = list(constant=1,na.rm = na.rm),
+ disp.fctal.ctrl = NULL,
+ q.lo =q.lo, q.up=q.up, log.q=TRUE,
+ name = "medQn", Infos="medQn",
+ asvar = NULL, nuis.idx = nuis.idx, trafo = trafo, fixed = fixed,
+ asvar.fct = asvar.fct, na.rm = na.rm, ...)
+ es at estimate.call <- es.call
+ return(es)
+ }
+
+medSn <- function(x, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ accuracy = 1000, ...){
+ es.call <- match.call()
+ es <- LDEstimator(x, loc.est = median, disp.est = Sn,
+ loc.fctal = median, disp.fctal = Sn,
+ ParamFamily = ParamFamily,
+ loc.est.ctrl = NULL, loc.fctal.ctrl = NULL,
+ disp.est.ctrl = list(constant=1,na.rm = na.rm),
+ disp.fctal.ctrl = list(accuracy=accuracy),
+ q.lo =q.lo, q.up=q.up, log.q=TRUE,
+ name = "medSn", Infos="medSn",
+ asvar = NULL, nuis.idx = nuis.idx, trafo = trafo, fixed = fixed,
+ asvar.fct = asvar.fct, na.rm = na.rm, ...)
+ es at estimate.call <- es.call
+ return(es)
+ }
+
+medkMADhybr <- function(x, k=1, ParamFamily, q.lo =1e-6, q.up=10,
+ KK=20, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...){
+ i <- 1
+ es <- try(medkMAD(x, k = k, ParamFamily = ParamFamily,
+ q.lo = q.lo, q.up = q.up,
+ nuis.idx = nuis.idx, trafo = trafo,
+ fixed = fixed, asvar.fct = asvar.fct, na.rm = na.rm,
+ ...), silent=TRUE)
+ if(! any(is.na(es)) && !is(es,"try-error"))
+ {return(es)}
+
+ k1 <- 3.23
+ while(i<KK){
+ i <- i + 1
+ es <- try(medkMAD(x, k = k1, ParamFamily = ParamFamily,
+ q.lo = q.lo, q.up = q.up,
+ nuis.idx = nuis.idx, trafo = trafo,
+ fixed = fixed, asvar.fct = asvar.fct, na.rm = na.rm,
+ ...), silent=TRUE)
+ k1 <- k1 * 3
+ if(! any(is.na(es)) && !is(es,"try-error"))
+ {return(es)}
+ }
+ return(c("scale"=NA,"shape"=NA))
+}
Modified: branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd 2012-04-26 16:06:13 UTC (rev 803)
+++ branches/distr-2.4/pkg/distrMod/man/0distrMod-package.Rd 2012-05-15 14:38:40 UTC (rev 804)
@@ -16,13 +16,13 @@
\tabular{ll}{
Package: \tab distrMod \cr
Version: \tab 2.4 \cr
-Date: \tab 2010-12-03 \cr
+Date: \tab 2012-05-15 \cr
Depends: \tab R(>= 2.6.0), methods, startupmsg, distr(>= 2.2), distrEx(>=
2.2), RandVar(>= 0.6.3), MASS, stats4 \cr
LazyLoad: \tab yes \cr
License: \tab LGPL-3 \cr
URL: \tab http://distr.r-forge.r-project.org/\cr
-SVNRevision: \tab 699 \cr
+SVNRevision: \tab 757 \cr
}}
\section{Classes}{
Added: branches/distr-2.4/pkg/distrMod/man/LDEstimator.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/LDEstimator.Rd (rev 0)
+++ branches/distr-2.4/pkg/distrMod/man/LDEstimator.Rd 2012-05-15 14:38:40 UTC (rev 804)
@@ -0,0 +1,138 @@
+\name{LDEstimator}
+\alias{LDEstimator}
+\alias{medkMAD}
+\alias{medkMADhybr}
+\alias{medSn}
+\alias{medQn}
+
+\title{ Function to compute LD (location-dispersion) estimates }
+\description{
+ Function \code{LDEstimator} provides a general way to compute
+ estimates for a given parametric family of probability measures
+ (with a scale and shape parameter) which
+ can be obtained by matching location and dispersion functionals
+ against empirical counterparts.
+}
+\usage{
+LDEstimator(x, loc.est, disp.est, loc.fctal, disp.fctal, ParamFamily,
+ loc.est.ctrl = NULL, loc.fctal.ctrl=NULL,
+ disp.est.ctrl = NULL, disp.fctal.ctrl=NULL,
+ q.lo =0, q.up=Inf, log.q =TRUE,
+ name, Infos, asvar = NULL, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...)
+medkMAD(x, k=1, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...)
+medkMADhybr(x, k=1, ParamFamily, q.lo =1e-6, q.up=10, KK = 20, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...)
+medSn(x, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ accuracy = 1000, ...)
+medQn(x, ParamFamily, q.lo =1e-6, q.up=10, nuis.idx = NULL,
+ trafo = NULL, fixed = NULL, asvar.fct = NULL, na.rm = TRUE,
+ ...)
+}
+\arguments{
+ \item{x}{ (empirical) data }
+ \item{ParamFamily}{an object of class \code{"ParamFamily"}. The parametric
+ family at which to evaluate the LDEstimator; the respective
+ (main) parameter must contain \code{"scale"}
+ and \code{"shape"}. }
+ \item{loc.est}{a function expecting \code{x} (a numeric vector)
+ as first argument; location estimator. }
+ \item{disp.est}{a function expecting \code{x} (a numeric vector)
+ as first argument; dispersion estimator; may only take
+ non-negative values. }
+ \item{loc.fctal}{a function expecting a distribution object as first
+ argument; location functional. }
+ \item{disp.fctal}{a function expecting a distribution object as first
+ argument; dispersion functional; may only take
+ non-negative values. }
+ \item{loc.est.ctrl}{a list (or \code{NULL}); optional additional arguments
+ for the location estimator. }
+ \item{disp.est.ctrl}{a list (or \code{NULL}); optional additional arguments
+ for the dispersion estimator. }
+ \item{loc.fctal.ctrl}{a list (or \code{NULL}); optional additional arguments
+ for the location functional. }
+ \item{disp.fctal.ctrl}{a list (or \code{NULL}); optional additional arguments
+ for the dispersion functional. }
+ \item{k}{numeric; additional parameter for \code{\link[distrEx]{kMAD}}. }
+ \item{KK}{numeric; Maximal number of trials with different \code{k} in
+ \code{medkMADhybr} . }
+ \item{q.lo}{numeric; lower bound for search intervall in shape parameter. }
+ \item{q.up}{numeric; upper bound for search intervall in shape parameter. }
+ \item{log.q}{logical; shall the zero search be done on log-scale? }
+ \item{name}{ optional name for estimator. }
+ \item{Infos}{ character: optional informations about estimator }
+ \item{asvar}{ optionally the asymptotic (co)variance of the estimator }
+ \item{nuis.idx}{ optionally the indices of the estimate belonging
+ to nuisance parameter}
+ \item{fixed}{ optionally (numeric) the fixed part of the parameter}
+ \item{trafo}{ an object of class \code{MatrixorFunction} -- a transformation
+ for the main parameter}
+ \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}))
+ and \code{param} (the parameter value as object of class
+ \code{ParamFamParameter}); arguments are called by name; \code{asvar.fct}
+ may also process further arguments passed through the \code{\dots} argument}
+ \item{na.rm}{logical: if \code{TRUE}, the estimator is evaluated at \code{complete.cases(x)}.}
+ \item{accuracy}{numeric: argument to be passed on to \code{\link[distrEx]{Sn}}. }
+ \item{\dots}{further arguments to be passed to location estimator and functional
+ and dispersion estimator and functional. }
+}
+\details{
+ The arguments \code{loc.est}, \code{disp.est} (location and dispersion estimators)
+ have to be functions with first argument \code{x} (a numeric vector with the
+ empirical data) and additional, optional individual arguments to be passed on
+ in the respective calls as lists \code{loc.est.ctrl}, \code{disp.est.ctrl},
+ and global additional arguments through the \code{\dots} argument.
+ Similarly, arguments \code{loc.fctal}, \code{disp.fctal} (location and
+ dispersion functionals) have to be functions with first argument an
+ object of class \code{UnivariateDistribution}, and additional, optional
+ individual arguments to be passed on
+ in the respective calls as lists \code{loc.fctal.ctrl}, \code{disp.fctal.ctrl},
+ and global additional arguments again through the \code{\dots} argument.
+ Uses \code{\link{.LDMatch}} internally.
+}
+\note{The values for \code{q.lo} and \code{q.up} are a bit delicate and
+ have to be found, model by model, by try and error.}
+\value{
+ An object of S4-class \code{"Estimate"}.
+}
+\references{
+P. Ruckdeschel, N. Horbenko (2011): Yet another breakdown point notion:
+EFSBP --illustrated at scale-shape models. ArXiv 1005.1480. To appear at Metrika.
+DOI: 10.1007/s00184-011-0366-4.
+
+A. Marazzi and C. Ruffieux (1999): The truncated mean of asymmetric distribution.
+Computational Statistics and Data Analysis 32: 79–100 .
+}
+
+%\references{ }
+\author{Nataliya Horbenko \email{Nataliya.Horbenko at itwm.fraunhofer.de},\cr
+ Peter Ruckdeschel \email{Peter.Ruckdeschel at itwm.fraunhofer.de}}
+%\note{}
+\seealso{\code{\link{ParamFamily-class}}, \code{\link{ParamFamily}},
+ \code{\link{Estimate-class}} }
+\examples{
+## (empirical) Data
+x <- rgamma(50, scale = 0.5, shape = 3)
+
+## parametric family of probability measures
+G <- GammaFamily(scale = 1, shape = 2)
+
+medQn(x = x, ParamFamily = G, q.lo = 1e-3, q.up = 15)
+medSn(x = x, ParamFamily = G, q.lo = 1e-3, q.up = 15)
+medkMAD(x = x, ParamFamily = G, q.lo = 1e-3, q.up = 15)
+medkMADhybr(x = x, ParamFamily = G, q.lo = 1e-3, q.up = 15)
+medkMAD(x = x, k=10, ParamFamily = G, q.lo = 1e-3, q.up = 15)
+
+##not at all robust:
+LDEstimator(x, loc.est = mean, disp.est = sd,
+ loc.fctal = E, disp.fctal = sd,
+ ParamFamily = G, q.lo = 1e-3, q.up = 15)
+}
+\keyword{univar}
Added: branches/distr-2.4/pkg/distrMod/man/internalldeHelpers.Rd
===================================================================
--- branches/distr-2.4/pkg/distrMod/man/internalldeHelpers.Rd (rev 0)
+++ branches/distr-2.4/pkg/distrMod/man/internalldeHelpers.Rd 2012-05-15 14:38:40 UTC (rev 804)
@@ -0,0 +1,80 @@
+\name{internal_ldehelpers_for_distrMod}
+\alias{internal_ldehelpers_for_distrMod}
+\alias{.prepend}
+\alias{.LDMatch}
+
+\title{Internal helper functions for treating LDEstimators in package distrMod}
+
+\description{
+These functions are used internally by function \code{LDEstimator}
+in package ``distrMod''.}
+
+\usage{
+.prepend(prep, list0, dots = NULL)
+.LDMatch(x.0, loc.est.0, disp.est.0, loc.fctal.0, disp.fctal.0,
+ ParamFamily.0, loc.est.ctrl.0 = NULL, loc.fctal.ctrl.0=NULL,
+ disp.est.ctrl.0 = NULL, disp.fctal.ctrl.0=NULL,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 804
More information about the Distr-commits
mailing list