[Distr-commits] r1247 - branches/distr-2.8/pkg/distrMod/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 6 00:59:39 CEST 2018
Author: ruckdeschel
Date: 2018-08-06 00:59:39 +0200 (Mon, 06 Aug 2018)
New Revision: 1247
Modified:
branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R
branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R
Log:
[distrMod] branch 2.8:
+ the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect
restrictions in the support of the underlying distribution: the L2derivatives are 0
whenever the argument x has liesInSupport(x,distribution) == FALSE
Modified: branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-05 20:58:25 UTC (rev 1246)
+++ branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-05 22:59:39 UTC (rev 1247)
@@ -40,9 +40,9 @@
"with location parameter 'loc'")
if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution)
L2deriv.fct <- function(param){
- loc <- main(param)
+ loc.0 <- main(param)
fct <- function(x){}
- body(fct) <- substitute({ LogDeriv(x - loc) }, list(loc = loc))
+ body(fct) <- substitute({ LogDeriv(x - loc.1) }, list(loc.1 = loc.0))
return(fct)}
L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals()))
@@ -194,13 +194,26 @@
"the group of transformations 'g(y) = scale*y'",
"with scale parameter 'scale'")
if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution)
- L2deriv.fct <- function(param){
- scale <- main(param)
+ if(is.finite(q.l(centraldistribution)(0)) || is.finite(q.l(centraldistribution)(1)) ){
+ L2deriv.fct <- function(param){
+ scale.0 <- main(param)
+ distr.0 <- scale.0*centraldistribution + loc
fct <- function(x){}
- body(fct) <- substitute({ ((x - loc)/scale*LogDeriv((x - loc)/scale)-1)/scale },
- list(loc = loc, scale = scale))
+ body(fct) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- ((x[inS] - loc.1)/scale*LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1
+ return(y)},
+ list(loc.1 = loc, scale.1 = scale.0))
return(fct)}
- L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals()))
+ }else{
+ L2deriv.fct <- function(param){
+ scale.0 <- main(param)
+ fct <- function(x){}
+ body(fct) <- substitute({ ((x - loc.1)/scale.1*LogDeriv((x - loc.1)/scale.1)-1)/scale.1 },
+ list(loc.1 = loc, scale.1 = scale.0))
+ return(fct)}
+ }
+ L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals()))
L2derivDistr <- if(missing(L2derivDistr.0))
@@ -365,15 +378,15 @@
locscalename["loc"] else 1
snm <- if(locscalename["scale"] %in% nmsL)
locscalename["scale"] else 2
- mean <- main(param)[lnm]
- sd <- main(param)[snm]
+ mean.0 <- main(param)[lnm]
+ sd.0 <- main(param)[snm]
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale },
- list(loc = mean, scale = sd))
+ body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
body(fct2) <- substitute({
- ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale },
- list(loc = mean, scale = sd))
+ ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
return(list(fct1, fct2))}
L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param),
@@ -547,15 +560,15 @@
if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution)
L2deriv.fct <- function(param){
- mean <- main(param)
- sd <- nuisance(param)
+ mean.0 <- main(param)
+ sd.0 <- nuisance(param)
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale },
- list(loc = mean, scale = sd))
+ body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
body(fct2) <- substitute({
- ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale },
- list(loc = mean, scale = sd))
+ ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
return(list(fct1, fct2))}
L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param),
@@ -723,18 +736,38 @@
"with location parameter 'loc' and scale parameter 'scale'")
if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution)
- L2deriv.fct <- function(param){
- mean <- nuisance(param)
- sd <- main(param)
+ if(is.finite(q.l(centraldistribution)(0)) || is.finite(q.l(centraldistribution)(1)) ){
+ L2deriv.fct <- function(param){
+ mean.0 <- nuisance(param)
+ sd.0 <- main(param)
+ distr.0 <- sd.0*centraldistribution+mean.0
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale },
- list(loc = mean, scale = sd))
- body(fct2) <- substitute({
- ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale },
- list(loc = mean, scale = sd))
+ body(fct1) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- LogDeriv((x[inS] - loc.1)/scale.1)/scale.1
+ return(y)},
+ list(loc.1 = mean.0, scale.1 = sd.0))
+ body(fct2) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- ((x[inS] - loc.1)/scale.1 *
+ LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1
+ return(y)},
+ list(loc.1 = mean.0, scale.1 = sd.0))
return(list(fct1, fct2))}
-
+ }else{
+ L2deriv.fct <- function(param){
+ mean.0 <- nuisance(param)
+ sd.0 <- main(param)
+ fct1 <- function(x){}
+ fct2 <- function(x){}
+ body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
+ body(fct2) <- substitute({
+ ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 },
+ list(loc.1 = mean.0, scale.1 = sd.0))
+ return(list(fct1, fct2))}
+ }
L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param),
Domain = Reals()))
Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 20:58:25 UTC (rev 1246)
+++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 22:59:39 UTC (rev 1247)
@@ -28,8 +28,12 @@
return(param)}
L2deriv.fct <- function(param){
prob.0 <- main(param)
+ distr.0 <- Binom(size = size, prob = prob.0)
fct <- function(x){}
- body(fct) <- substitute({ (x-size*prob.1)/(prob.1*(1-prob.1)) },
+ body(fct) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (x[inS]-size*prob.1)/(prob.1*(1-prob.1))
+ return(y)},
list(size = size, prob.1 = prob.0))
return(fct)}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob))
@@ -83,8 +87,12 @@
return(param)}
L2deriv.fct <- function(param){
lambda.0 <- main(param)
+ distr.0 <- Pois(lambda=lambda.0)
fct <- function(x){}
- body(fct) <- substitute({ x/lambda.1-1 },
+ body(fct) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- x[inS]/lambda.1-1
+ return(y)},
list(lambda.1 = lambda.0))
return(fct)}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = lambda))
@@ -141,8 +149,13 @@
return(param)}
L2deriv.fct <- function(param){
prob.0 <- main(param)
+ distr.0 <- Nbinom(size=size, prob=prob.0)
fct <- function(x){}
- body(fct) <- substitute({ (size/prob.1- x/(1-prob.1)) },
+ body(fct) <- substitute({
+ y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (size/prob.1- x[inS]/(1-prob.1))
+ return(y)},
list(size = size, prob.1 = prob.0))
return(fct)}
L2derivSymm <- FunSymmList(NonSymmetric())
@@ -199,11 +212,20 @@
L2deriv.fct <- function(param){
prob.0 <- main(param)["prob"]
size.0 <- main(param)["size"]
+ distr.0 <- Nbinom(size=size.0, prob=prob.0)
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct2) <- substitute({ (size.1/prob.1- x/(1-prob.1)) },
+ body(fct2) <- substitute({
+ y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1))
+ return(y)},
list(size.1 = size.0, prob.1 = prob.0))
- body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)},
+ body(fct1) <- substitute({
+ y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1)
+ return(y)},
list(size.1 = size.0, prob.1 = prob.0))
return(list(fct1, fct2))}
@@ -275,15 +297,26 @@
size.00 <- main(param)["size"]
mean.00 <- main(param)["mean"]
prob.00 <- size.00/(size.00+mean.00)
-
+ distr.0 <- Nbinom(size=size.00, prob=prob.00)
+
fct1 <- function(x){}
fct1.2 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)},
+ body(fct1) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1)
+ return(y)},
list(size.1 = size.00, prob.1 = prob.00))
- body(fct1.2)<- substitute({ (size.1/prob.1- x/(1-prob.1)) },
+ body(fct1.2)<- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1))
+ return(y)},
list(size.1 = size.00, prob.1 = prob.00))
- body(fct2) <- substitute({ (1/prob.1-1)* fct1(x) - size.1/prob.1^2 * fct1.2(x)},
+ body(fct2) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (1/prob.1-1)* fct1(x[inS]) -
+ size.1/prob.1^2 * fct1.2(x[inS])
+ return(y)},
list(size.1 = size.00, prob.1 = prob.00))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
@@ -366,11 +399,18 @@
L2deriv.fct <- function(param){
scale.0 <- main(param)[1]
shape.0 <- main(param)[2]
+ distr.0 <- Gammad(scale = scale.0, shape = shape.0)
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ (x/scale.1 - shape.1)/scale.1 },
+ body(fct1) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- (x[inS]/scale.1 - shape.1)/scale.1
+ return(y)},
list(scale.1 = scale.0, shape.1 = shape.0))
- body(fct2) <- substitute({ log(x/scale.1) - digamma(shape.1) },
+ body(fct2) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- log(x[inS]/scale.1) - digamma(shape.1)
+ return(y)},
list(scale.1 = scale.0, shape.1 = shape.0))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = scale*shape),
@@ -456,13 +496,20 @@
L2deriv.fct <- function(param){
shape1.0 <- main(param)[1]
shape2.0 <- main(param)[2]
+ distr.0 <- Beta(shape1=shape1.0, shape2 = shape2.0)
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({log(x)-digamma(shape1.1)+
- digamma(shape1.1+shape2.1)},
+ body(fct1) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- log(x[inS])-digamma(shape1.1)+
+ digamma(shape1.1+shape2.1)
+ return(y)},
list(shape1.1 = shape1.0, shape2.1 = shape2.0))
- body(fct2) <- substitute({log(1-x)-digamma(shape2.1)+
- digamma(shape1.1+shape2.1)},
+ body(fct2) <- substitute({y <- 0*x
+ inS <- liesInSupport(distr.0, x)
+ y[inS] <- log(1-x[inS])-digamma(shape2.1)+
+ digamma(shape1.1+shape2.1)
+ return(y)},
list(shape1.1 = shape1.0, shape2.1 = shape2.0))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
More information about the Distr-commits
mailing list