[Distr-commits] r1381 - in pkg/distrEx: . R inst man tests/Examples

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sat Nov 12 22:34:35 CET 2022


Author: ruckdeschel
Date: 2022-11-12 22:34:34 +0100 (Sat, 12 Nov 2022)
New Revision: 1381

Added:
   pkg/distrEx/tests/Examples/distrEx-Ex.Rout.save
Removed:
   pkg/distrEx/tests/Examples/distrEx-Ex_i386.Rout.save
   pkg/distrEx/tests/Examples/distrEx-Ex_x64.Rout.save
Modified:
   pkg/distrEx/DESCRIPTION
   pkg/distrEx/R/Expectation.R
   pkg/distrEx/R/Functionals.R
   pkg/distrEx/R/KolmogorovDist.R
   pkg/distrEx/R/Kurtosis.R
   pkg/distrEx/R/Skewness.R
   pkg/distrEx/R/distrExOptions.R
   pkg/distrEx/inst/NEWS
   pkg/distrEx/man/0distrEx-package.Rd
   pkg/distrEx/man/E.Rd
   pkg/distrEx/man/KolmogorovDist.Rd
   pkg/distrEx/man/Var.Rd
   pkg/distrEx/man/distrExOptions.Rd
Log:
[distrEx] trunk: ported changes from devel to branch for release 2.9; checks oK on Windows

Modified: pkg/distrEx/DESCRIPTION
===================================================================
--- pkg/distrEx/DESCRIPTION	2022-11-12 18:41:34 UTC (rev 1380)
+++ pkg/distrEx/DESCRIPTION	2022-11-12 21:34:34 UTC (rev 1381)
@@ -1,6 +1,6 @@
 Package: distrEx
-Version: 2.8.0
-Date: 2019-03-29
+Version: 2.9.0
+Date: 2022-11-12
 Title: Extensions of Package 'distr'
 Description: Extends package 'distr' by functionals, distances, and conditional distributions.
 Depends: R(>= 3.4), methods, distr(>= 2.8.0)
@@ -15,4 +15,4 @@
 URL: http://distr.r-forge.r-project.org/
 LastChangedDate: {$LastChangedDate$}
 LastChangedRevision: {$LastChangedRevision$}
-VCS/SVNRevision: 1332
+VCS/SVNRevision: 1380

Modified: pkg/distrEx/R/Expectation.R
===================================================================
--- pkg/distrEx/R/Expectation.R	2022-11-12 18:41:34 UTC (rev 1380)
+++ pkg/distrEx/R/Expectation.R	2022-11-12 21:34:34 UTC (rev 1381)
@@ -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: pkg/distrEx/R/Functionals.R
===================================================================
--- pkg/distrEx/R/Functionals.R	2022-11-12 18:41:34 UTC (rev 1380)
+++ pkg/distrEx/R/Functionals.R	2022-11-12 21:34:34 UTC (rev 1381)
@@ -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
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/distr -r 1381


More information about the Distr-commits mailing list