[Distr-commits] r1343 - in branches/distr-2.9/pkg: distrEx/R distrEx/inst distrEx/man distrMod/inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 30 23:12:49 CEST 2019
Author: ruckdeschel
Date: 2019-04-30 23:12:49 +0200 (Tue, 30 Apr 2019)
New Revision: 1343
Modified:
branches/distr-2.9/pkg/distrEx/R/Expectation.R
branches/distr-2.9/pkg/distrEx/R/Functionals.R
branches/distr-2.9/pkg/distrEx/R/Kurtosis.R
branches/distr-2.9/pkg/distrEx/R/Skewness.R
branches/distr-2.9/pkg/distrEx/R/distrExOptions.R
branches/distr-2.9/pkg/distrEx/inst/NEWS
branches/distr-2.9/pkg/distrEx/man/E.Rd
branches/distr-2.9/pkg/distrEx/man/Var.Rd
branches/distr-2.9/pkg/distrEx/man/distrExOptions.Rd
branches/distr-2.9/pkg/distrMod/inst/NEWS
Log:
[distrEx] branch 2.9: + 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
+ to this end there is a new distrExoption propagate.names.functionals
used as default in the functionals
[distrMod] branch 2.9 moved recent changes (in NEWS) to new intermediate version 2.8.2
Modified: branches/distr-2.9/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.9/pkg/distrEx/R/Expectation.R 2019-04-13 09:28:04 UTC (rev 1342)
+++ branches/distr-2.9/pkg/distrEx/R/Expectation.R 2019-04-30 21:12:49 UTC (rev 1343)
@@ -484,10 +484,13 @@
setMethod("E", signature(object = "Norm",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL,...){
- if(is.null(low) && is.null(upp))
- return(mean(object))
- else{
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
+ if(is.null(low) && is.null(upp)){
+ ret.v <- mean(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
if(low == -Inf){
@@ -505,7 +508,9 @@
setMethod("E", signature(object = "Beta",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...,
+ diagnostic = FALSE){
mc <- match.call()
if(!is.null(low)) if(low <= 0) low <- NULL
@@ -522,7 +527,11 @@
}
return(res)
- }else return(shape1(object)/(shape1(object)+shape2(object)))
+ }else{
+ ret.v <- shape1(object)/(shape1(object)+shape2(object))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
## source: https://mathworld.wolfram.com/BetaDistribution.html
@@ -529,12 +538,15 @@
setMethod("E", signature(object = "Binom",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
- if(is.null(low) && is.null(upp))
- return(size(object)*prob(object))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- size(object)*prob(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
if(low == -Inf){
@@ -588,11 +600,14 @@
setMethod("E", signature(object = "Chisq",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= 0) low <- NULL
- if(is.null(low) && is.null(upp))
- return(df(object)+ncp(object))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- df(object)+ncp(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
if(low == -Inf){
@@ -611,10 +626,13 @@
setMethod("E", signature(object = "Dirac",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
- if(is.null(low) && is.null(upp))
- return(location(object))
- else{
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
+ if(is.null(low) && is.null(upp)){
+ ret.v <- location(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
return(location(object)*(location(object)>=low & location(object) <=upp))
@@ -645,11 +663,14 @@
setMethod("E", signature(object = "Exp",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= 0) low <- NULL
- if(is.null(low) && is.null(upp))
- return(1/rate(object))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- 1/rate(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
if(is.null(low)) low <- -Inf
if(is.null(upp)) upp <- Inf
if(low == -Inf){
@@ -669,15 +690,18 @@
setMethod("E", signature(object = "Fd",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...,
+ diagnostic = FALSE){
if(!is.null(low)) if(low <= 0) low <- NULL
if(is.null(low) && is.null(upp)){
df1 <- df1(object)
df2 <- df2(object)
d <- ncp(object)
- return(ifelse(df2>2,df2/(df2-2)*(df1+d)/df1,Inf))
- }
- else{
+ ret.v <- ifelse(df2>2,df2/(df2-2)*(df1+d)/df1,Inf)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(as(object,"AbscontDistribution"), low=low, upp=upp, ..., diagnostic = diagnostic)
@@ -696,11 +720,15 @@
setMethod("E", signature(object = "Gammad",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...,
+ diagnostic = FALSE){
if(!is.null(low)) if(low <= 0) low <- NULL
- if(is.null(low) && is.null(upp))
- return(shape(object)*scale(object))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- shape(object)*scale(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(object, fun = function(x)1, low=low, upp=upp, ..., diagnostic = diagnostic)
@@ -764,14 +792,17 @@
setMethod("E", signature(object = "Geom",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
- if(is.null(low) && is.null(upp))
- return(1/ prob(object) -1)
- else
- return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
- })
+ if(is.null(low) && is.null(upp)){
+ ret.v <- 1/ prob(object) -1
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
+ }})
### source https://mathworld.wolfram.com/GeometricDistribution.html
@@ -778,23 +809,30 @@
setMethod("E", signature(object = "Hyper",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
- if(is.null(low) && is.null(upp))
- return(k(object)*m(object)/(m(object)+n(object)))
- else
- return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
- })
+ if(is.null(low) && is.null(upp)){
+ ret.v <- k(object)*m(object)/(m(object)+n(object))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
+ }})
### source https://mathworld.wolfram.com/HypergeometricDistribution.html
setMethod("E", signature(object = "Logis",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
- if(is.null(low) && is.null(upp))
- return(location(object))
- else{
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"),
+ ..., diagnostic = FALSE){
+ if(is.null(low) && is.null(upp)){
+ ret.v <- location(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(as(object,"AbscontDistribution"), low=low, upp=upp, ..., diagnostic = diagnostic)
@@ -813,11 +851,15 @@
setMethod("E", signature(object = "Lnorm",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...,
+ diagnostic = FALSE){
if(!is.null(low)) if(low <= 0) low <- NULL
- if(is.null(low) && is.null(upp))
- return(exp(meanlog(object)+sdlog(object)^2/2))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- exp(meanlog(object)+sdlog(object)^2/2)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
if(is.null(low) && is.null(upp)) return(0) else{
mc <- match.call()
@@ -838,25 +880,32 @@
setMethod("E", signature(object = "Nbinom",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"),
+ ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
- if(is.null(low) && is.null(upp))
- return(size(object)*(1-prob(object))/prob(object))
- else
- return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
- })
+ if(is.null(low) && is.null(upp)){
+ ret.v <- size(object)*(1-prob(object))/prob(object)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
+ return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
+ }})
### source https://mathworld.wolfram.com/NegativeBinomialDistribution.html
setMethod("E", signature(object = "Pois",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ...){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(!is.null(low)) if(low <= min(support(object))) low <- NULL
if(!is.null(upp)) if(upp >= max(support(object))) upp <- NULL
- if(is.null(low) && is.null(upp))
- return(lambda(object))
- else
+ if(is.null(low) && is.null(upp)){
+ ret.v <- (lambda(object))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else
return(E(as(object,"DiscreteDistribution"), low=low, upp=upp, ...))
})
### source https://mathworld.wolfram.com/PoissonDistribution.html
@@ -864,14 +913,18 @@
setMethod("E", signature(object = "Td",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"),
+ ..., diagnostic = FALSE){
## correction thanks to G.Jay Kerns
- if(is.null(low) && is.null(upp))
- return(ifelse( df(object)>1,
+ if(is.null(low) && is.null(upp)){
+ ret.v <- ifelse( df(object)>1,
ncp(object)*sqrt(df(object)/2)*
- exp(lgamma((df(object)-1)/2)-lgamma(df(object)/2)),
- NA))
- else{
+ exp(lgamma((df(object)-1)/2)-lgamma(df(object)/2)),
+ NA)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(as(object,"AbscontDistribution"), low=low, upp=upp, ..., diagnostic = diagnostic)
@@ -889,12 +942,16 @@
setMethod("E", signature(object = "Unif",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"),
+ ..., diagnostic = FALSE){
if(!is.null(low)) if(low <= Min(object)) low <- NULL
if(!is.null(upp)) if(upp >= Max(object)) upp <- NULL
- if(is.null(low) && is.null(upp))
- return((Max(object)+Min(object))/2)
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- (Max(object)+Min(object))/2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(as(object,"AbscontDistribution"), low=low, upp=upp, ..., diagnostic = diagnostic)
@@ -913,11 +970,15 @@
setMethod("E", signature(object = "Weibull",
fun = "missing",
cond = "missing"),
- function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){
+ function(object, low = NULL, upp = NULL,
+ propagate.names=getdistrExOption("propagate.names.functionals"),
+ ..., diagnostic = FALSE){
if(!is.null(low)) if(low <= 0) low <- NULL
- if(is.null(low) && is.null(upp))
- return(scale(object)*gamma(1+1/shape(object)))
- else{
+ if(is.null(low) && is.null(upp)){
+ ret.v <- scale(object)*gamma(1+1/shape(object))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else{
mc <- match.call()
res <- E(object, fun = function(x)1, low=low, upp=upp, ..., diagnostic = diagnostic)
Modified: branches/distr-2.9/pkg/distrEx/R/Functionals.R
===================================================================
--- branches/distr-2.9/pkg/distrEx/R/Functionals.R 2019-04-13 09:28:04 UTC (rev 1342)
+++ branches/distr-2.9/pkg/distrEx/R/Functionals.R 2019-04-30 21:12:49 UTC (rev 1343)
@@ -86,29 +86,37 @@
#sd
################################################################################
setMethod("sd", signature(x = "UnivariateDistribution"),
- function(x, fun, cond, withCond = FALSE, useApply = TRUE, ...){
+ function(x, fun, cond, withCond = FALSE, useApply = TRUE,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
+ propagate.names0 <- propagate.names
+ dots <- list(...)
+ dots$propagate.names <- NULL
if(missing(fun))
{if(missing(cond))
- return(sqrt(var(x, useApply = useApply, ...)))
+ return(sqrt(do.call(var,c(list(x, useApply = useApply,
+ propagate.names=propagate.names0),dots))))
else
- return(sqrt(var(x, cond = cond, withCond = FALSE, useApply = useApply,
- ...)))
+ return(sqrt(do.call(var,c(list(x, cond =cond, withCond = FALSE,
+ useApply = useApply, dots)))))
}else{
if(missing(cond))
- return(sqrt(var(x, fun = fun, useApply = useApply, ...)))
+ return(sqrt(do.call(var,c(list(x, fun = fun, useApply = useApply, dots)))))
else
- return(sqrt(var(x, fun = fun, cond = cond, withCond = FALSE,
- useApply = useApply,...)))
- }
+ return(sqrt(do.call(var,c(list(x, fun = fun, cond =cond, withCond = FALSE,
+ useApply = useApply, dots)))))
+ }
})
### overload "sd" method for "Norm" ...
setMethod("sd", signature(x = "Norm"),
- function(x, fun, cond, withCond = FALSE, useApply = TRUE, ...){
+ function(x, fun, cond, withCond = FALSE, useApply = TRUE,
+ propagate.names=getdistrExOption("propagate.names.functionals"), ...){
if(missing(fun))
- {if(missing(cond))
- return(sd(param(x)))
- else
+ {if(missing(cond)){
+ ret.v <- sd(param(x))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }else
return(sqrt(var(x, cond = cond, withCond = FALSE, useApply = useApply,
...)))}
else
@@ -116,7 +124,7 @@
return(sqrt(var(x, fun = fun, useApply = useApply, ...)))
else
return(sqrt(var(x, fun = fun, cond = cond, withCond = FALSE,
- useApply = useApply,...)))}
+ useApply = useApply,...)))}
})
@@ -203,7 +211,7 @@
# some exact variances:
#################################################################
setMethod("var", signature(x = "Norm"),
- function(x,...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"),...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -211,12 +219,14 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(sd(x)^2)
+ else{
+ ret.v <- sd(x)^2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
setMethod("var", signature(x = "Binom"),
- function(x,...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"),...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -224,8 +234,10 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"DiscreteDistribution"),...))
- else
- return(size(x)*prob(x)*(1-prob(x)))
+ else{
+ ret.v <- size(x)*prob(x)*(1-prob(x))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source: https://mathworld.wolfram.com/BinomialDistribution.html
@@ -245,7 +257,7 @@
### source https://mathworld.wolfram.com/CauchyDistribution.html
setMethod("var", signature(x = "Chisq"),
- function(x,...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"),...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -253,8 +265,10 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(2*(df(x)+2*ncp(x)))
+ else{
+ ret.v <- 2*(df(x)+2*ncp(x))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source https://mathworld.wolfram.com/Chi-SquaredDistribution.html
@@ -277,7 +291,7 @@
### source https://mathworld.wolfram.com/LaplaceDistribution.html
setMethod("var", signature(x = "Exp"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -285,14 +299,16 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(1/rate(x)^2)
+ else{
+ ret.v <- 1/rate(x)^2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source https://mathworld.wolfram.com/ExponentialDistribution.html
setMethod("var", signature(x = "Fd"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -300,18 +316,19 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- {df1 <- df1(x)
+ else{df1 <- df1(x)
df2 <- df2(x)
d <- ncp(x)
Ex2 <- (E(x))^2
Exx <- df2^2/(df2-2)/(df2-4)*((df1+d)^2+2*df1+4*d)/df1^2
- return(ifelse(df2>4,Exx-Ex2, NA ))}
+ ret.v <- if(df2>4) Exx-Ex2 else NA
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source (without ncp) https://mathworld.wolfram.com/F-Distribution.html
setMethod("var", signature(x = "Gammad"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -319,13 +336,15 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(shape(x)*scale(x)^2)
+ else{
+ ret.v <- shape(x)*scale(x)^2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source https://mathworld.wolfram.com/GammaDistribution.html
setMethod("var", signature(x = "Geom"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -333,12 +352,17 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"DiscreteDistribution"),...))
- else {p <- prob(x); e <- 1/p-1; return(e+e^2)}
+ else{
+ p <- prob(x)
+ e0 <- 1/p-1
+ ret.v <- e0+e0^2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source https://mathworld.wolfram.com/GeometricDistribution.html
setMethod("var", signature(x = "Hyper"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -346,16 +370,18 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"DiscreteDistribution"),...))
- else
- {k <- k(x);
- m <- m(x);
- n <- n(x);
- return(k*n/(m+n)*m/(m+n)*(m+n-k)/(m+n-1))}
+ else{
+ k <- k(x)
+ m <- m(x)
+ n <- n(x)
+ ret.v <- k*n/(m+n)*m/(m+n)*(m+n-k)/(m+n-1)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)}
})
### source https://mathworld.wolfram.com/HypergeometricDistribution.html
setMethod("var", signature(x = "Logis"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -363,13 +389,16 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(pi^2/3*scale(x)^2)
+ else{
+ ret.v <- pi^2/3*scale(x)^2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
### source https://mathworld.wolfram.com/LogisticDistribution.html
setMethod("var", signature(x = "Lnorm"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -377,13 +406,16 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(exp(2*meanlog(x)+sdlog(x)^2)*(exp(sdlog(x)^2)-1))
+ else{
+ ret.v <- exp(2*meanlog(x)+sdlog(x)^2)*(exp(sdlog(x)^2)-1)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
### source https://mathworld.wolfram.com/LogNormalDistribution.html
setMethod("var", signature(x = "Nbinom"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -391,12 +423,17 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"DiscreteDistribution"),...))
- else {p <- prob(x); e <- 1/p-1; return(size(x)*(e+e^2))}
+ else{
+ p <- prob(x); e0 <- 1/p-1
+ ret.v <- size(x)*(e0+e0^2)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
### source https://mathworld.wolfram.com/NegativeBinomialDistribution.html
setMethod("var", signature(x = "Pois"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -404,13 +441,16 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"DiscreteDistribution"),...))
- else
- return(lambda(x))
+ else{
+ ret.v <- lambda(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
### source https://mathworld.wolfram.com/PoissonDistribution.html
setMethod("var", signature(x = "Td"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -421,8 +461,10 @@
else
{n <- df(x); d<- ncp(x)
## correction thanks to G.Jay Kerns ### corrected again P.R.
- return(ifelse( n>2, n/(n-2)*(1+d^2)
- -d^2*n/2*exp(2*(lgamma((n-1)/2)-lgamma(n/2))), NA))
+ ret.v <- ifelse( n>2, n/(n-2)*(1+d^2)
+ -d^2*n/2*exp(2*(lgamma((n-1)/2)-lgamma(n/2))), NA)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
}
})
@@ -429,7 +471,7 @@
### source https://mathworld.wolfram.com/NoncentralStudentst-Distribution.html
setMethod("var", signature(x = "Unif"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -437,13 +479,16 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return((Max(x)-Min(x))^2/12)
+ else{
+ ret.v <- (Max(x)-Min(x))^2/12
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
### source https://mathworld.wolfram.com/UniformDistribution.html
setMethod("var", signature(x = "Weibull"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -451,13 +496,17 @@
if(hasArg(upp)) upp <- dots$upp
if(hasArg(fun)||hasArg(cond)||!is.null(low)||!is.null(upp))
return(var(as(x,"AbscontDistribution"),...))
- else
- return(scale(x)^2*(gamma(1+2/shape(x))- (gamma(1 + 1/shape(x)))^2))
+ else{
+ ret.v <- scale(x)^2*(gamma(1+2/shape(x))- (gamma(1 + 1/shape(x)))^2)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+
+ }
})
### source https://mathworld.wolfram.com/WeibullDistribution.html
setMethod("var", signature(x = "Beta"),
- function(x, ...){
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals"), ...){
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
fun <- NULL; cond <- NULL; low <- NULL; upp <- NULL
@@ -465,9 +514,12 @@
if(hasArg(upp)) upp <- dots$upp
if((hasArg(fun))||(hasArg(cond))||(!isTRUE(all.equal(ncp(x),0))))
return(var(as(x,"AbscontDistribution"),...))
- else
- {a<-shape1(x); b<- shape2(x)
- return(a*b/(a+b)^2/(a+b+1))}
+ else{
+ a<-shape1(x); b<- shape2(x)
+ ret.v <- a*b/(a+b)^2/(a+b+1)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
})
## source: https://mathworld.wolfram.com/BetaDistribution.html
@@ -489,31 +541,71 @@
#################################################################
setMethod("median", signature(x = "Norm"),
- function(x) mean(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- mean(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Cauchy"),
- function(x) location(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- location(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Dirac"),
- function(x) location(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- location(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "DExp"),
function(x) 0)
setMethod("median", signature(x = "Exp"),
- function(x) log(2)/rate(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- log(2)/rate(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Geom"),
- function(x) ceiling(-log(2)/log(1-prob(x))-1))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- ceiling(-log(2)/log(1-prob(x))-1)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Logis"),
- function(x) location(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- location(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Lnorm"),
- function(x) exp(meanlog(x)))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- exp(meanlog(x))
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Unif"),
- function(x) (Min(x)+Max(x))/2)
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- (Max(x)+Min(x))/2
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("median", signature(x = "Arcsine"),
function(x) 0)
@@ -524,10 +616,20 @@
#################################################################
setMethod("IQR", signature(x = "Norm"),
- function(x) 2*qnorm(3/4)*sd(x))
+ function(x, propagate.names=getdistrExOption("propagate.names.functionals")){
+ ret.v <- 2*qnorm(3/4)*sd(x)
+ if(!propagate.names){names(ret.v) <- NULL}
+ return(ret.v)
+ }
+ )
setMethod("IQR", signature(x = "Cauchy"),
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1343
More information about the Distr-commits
mailing list