[Distr-commits] r1240 - branches/distr-2.8/pkg/distrMod/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Aug 4 16:01:53 CEST 2018
Author: ruckdeschel
Date: 2018-08-04 16:01:53 +0200 (Sat, 04 Aug 2018)
New Revision: 1240
Modified:
branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R
Log:
[distrMod] branch 2.8: discovered some issues with local variables in L2Families (global values were used instead...)
=> in code in SimpleL2ParamFamilies.R:
+ param.0 denotes the local current parameter of the L2Family
+ param is used as function argument
+ <paramname>.0 is used in .fct - functions as local variant (intern to fct) of the current parameter
+ in the substituted L2deriv.fct, we use <paramname>.1 which is substituted for <paramname>.0
+ in case <paramname>.0 is already used otherwise (as in NbinomMeanSizeFamily) we use <paramname>.00 instead
=> now except for shape values < 1 CvMMDEstimator works with variances ...
Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-02 10:26:30 UTC (rev 1239)
+++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-04 14:01:53 UTC (rev 1240)
@@ -13,7 +13,7 @@
param1 <- size
names(param1) <- "size"
if(missing(trafo)) trafo <- matrix(1, dimnames = list("prob","prob"))
- param <- ParamFamParameter(name = "probability of success",
+ param.0 <- ParamFamParameter(name = "probability of success",
main = param0,
fixed = param1,
trafo = trafo)
@@ -27,23 +27,23 @@
if(param>=1) return(1-.Machine$double.eps)
return(param)}
L2deriv.fct <- function(param){
- prob <- main(param)
+ prob.0 <- main(param)
fct <- function(x){}
- body(fct) <- substitute({ (x-size*prob)/(prob*(1-prob)) },
- list(size = size, prob = prob))
+ body(fct) <- substitute({ (x-size*prob.1)/(prob.1*(1-prob.1)) },
+ list(size = size, prob.0 = prob.1))
return(fct)}
- L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob))
+ L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob))
L2derivDistr <- UnivarDistrList((distribution - size*prob)/(prob*(1-prob)))
if(.isEqual(prob,0.5))
L2derivDistrSymm <- DistrSymmList(SphericalSymmetry(SymmCenter = 0))
else
L2derivDistrSymm <- DistrSymmList(NoSymmetry())
FisherInfo.fct <- function(param){
- prob <- main(param)
- PosDefSymmMatrix(matrix(size/(prob*(1-prob)),
+ prob.0 <- main(param)
+ PosDefSymmMatrix(matrix(size/(prob.0*(1-prob.0)),
dimnames=list("prob","prob")))}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
@@ -73,7 +73,7 @@
param0 <- lambda
names(param0) <- "lambda"
if(missing(trafo)) trafo <- matrix(1, dimnames = list("lambda","lambda"))
- param <- ParamFamParameter(name = "positive mean",
+ param.0 <- ParamFamParameter(name = "positive mean",
main = param0,
trafo = trafo)
modifyParam <- function(theta){ Pois(lambda = theta) }
@@ -82,20 +82,20 @@
makeOKPar <- function(param) {if(param<=0) return(.Machine$double.eps)
return(param)}
L2deriv.fct <- function(param){
- lambda <- main(param)
+ lambda.0 <- main(param)
fct <- function(x){}
- body(fct) <- substitute({ x/lambda-1 },
- list(lambda = lambda))
+ body(fct) <- substitute({ x/lambda.1-1 },
+ list(lambda.1 = lambda.0))
return(fct)}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = lambda))
L2derivDistr <- UnivarDistrList(distribution/lambda - 1)
L2derivDistrSymm <- DistrSymmList(NoSymmetry())
FisherInfo.fct <- function(param){
- lambda <- main(param)
- PosDefSymmMatrix(matrix(1/lambda,
+ lambda.0 <- main(param)
+ PosDefSymmMatrix(matrix(1/lambda.0,
dimnames=list("lambda","lambda")))}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
@@ -127,7 +127,7 @@
param1 <- size
names(param1) <- "size"
if(missing(trafo)) trafo <- matrix(1, dimnames = list("prob","prob"))
- param <- ParamFamParameter(name = "probability of success",
+ param.0 <- ParamFamParameter(name = "probability of success",
main = param0,
fixed = param1,
trafo = trafo)
@@ -140,20 +140,20 @@
if(param>=1) return(1-.Machine$double.eps)
return(param)}
L2deriv.fct <- function(param){
- prob <- main(param)
+ prob.0 <- main(param)
fct <- function(x){}
- body(fct) <- substitute({ (size/prob- x/(1-prob)) },
- list(size = size, prob = prob))
+ body(fct) <- substitute({ (size/prob.1- x/(1-prob.1)) },
+ list(size = size, prob.1 = prob.0))
return(fct)}
L2derivSymm <- FunSymmList(NonSymmetric())
L2derivDistr <- UnivarDistrList((size/prob- distribution/(1-prob)))
L2derivDistrSymm <- DistrSymmList(NoSymmetry())
FisherInfo.fct <- function(param){
- prob <- main(param)
- PosDefSymmMatrix(matrix(size/(prob^2*(1-prob)),
+ prob.0 <- main(param)
+ PosDefSymmMatrix(matrix(size/(prob.0^2*(1-prob.0)),
dimnames=list("prob","prob")))}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
@@ -182,7 +182,7 @@
param0 <- c(size,prob)
names(param0) <- nms <- c("size","prob")
if(missing(trafo)) trafo <- matrix(c(1,0,0,1),2,2, dimnames = list(c("size","prob"),c("size","prob")))
- param <- ParamFamParameter(name = "NegBinomParameter",
+ param.0 <- ParamFamParameter(name = "NegBinomParameter",
main = param0,
trafo = trafo)
modifyParam <- function(theta){ Nbinom(size = theta[1], prob = theta[2]) }
@@ -197,14 +197,14 @@
param["size"] <- min(1e-8, param["size"])
return(param)}
L2deriv.fct <- function(param){
- prob <- main(param)["prob"]
- size <- main(param)["size"]
+ prob.0 <- main(param)["prob"]
+ size.0 <- main(param)["size"]
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct2) <- substitute({ (size/prob- x/(1-prob)) },
- list(size = size, prob = prob))
- body(fct1) <- substitute({ digamma(x+size)-digamma(size)+log(prob)},
- list(size = size, prob = prob))
+ body(fct2) <- substitute({ (size.1/prob.1- x/(1-prob.1)) },
+ list(size.1 = size.0, prob.1 = prob.0))
+ body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)},
+ list(size.1 = size.0, prob.1 = prob.0))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
@@ -216,18 +216,18 @@
L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry())
FisherInfo.fct <- function(param){
- prob <- main(param)["prob"]
- size <- main(param)["size"]
- xn <- 0:min(max(support(distribution)),
- qnbinom(1e-6,size=size,prob=prob,lower.tail=FALSE),
+ prob.0 <- main(param)["prob"]
+ size.0 <- main(param)["size"]
+ xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.0))),
+ qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE),
1e5)
- I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob))
- I12 <- -1/prob
- I22 <- size/prob^2/(1-prob)
+ I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.0))
+ I12 <- -1/prob.0
+ I22 <- size.0/prob.0^2/(1-prob.0)
PosDefSymmMatrix(matrix(c(I11,I12,I12,I22),2,2,
dimnames=list(nms,nms)))}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
@@ -257,7 +257,7 @@
param0 <- c(size,mean)
names(param0) <- nms <- c("size","mean")
if(missing(trafo)) trafo <- matrix(c(1,0,0,1),2,2, dimnames = list(nms,nms))
- param <- ParamFamParameter(name = "probability of success",
+ param.0 <- ParamFamParameter(name = "probability of success",
main = param0,
trafo = trafo)
modifyParam <- function(theta){ Nbinom(size = theta[1], prob = theta[1]/(theta[1]+theta[2])) }
@@ -272,19 +272,19 @@
param["size"] <- min(1e-8, param["size"])
return(param)}
L2deriv.fct <- function(param){
- size.0 <- main(param)["size"]
- mean.0 <- main(param)["mean"]
- prob.0 <- size.0/(size.0+mean.0)
+ size.00 <- main(param)["size"]
+ mean.00 <- main(param)["mean"]
+ prob.00 <- size.00/(size.00+mean.00)
fct1 <- function(x){}
fct1.2 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ digamma(x+size)-digamma(size)+log(prob.2)},
- list(size = size.0, prob.2 = prob.0))
- body(fct1.2)<- substitute({ (size/prob.2- x/(1-prob.2)) },
- list(size = size.0, prob.2 = prob.0))
- body(fct2) <- substitute({ (1/prob.2-1)* fct1(x) - size/prob.2^2 * fct1.2(x)},
- list(size = size.0, prob.2 = prob.0))
+ body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)},
+ list(size.1 = size.00, prob.1 = prob.00))
+ body(fct1.2)<- substitute({ (size.1/prob.1- x/(1-prob.1)) },
+ 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)},
+ list(size.1 = size.00, prob.1 = prob.00))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
@@ -302,21 +302,21 @@
L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry())
FisherInfo.fct <- function(param){
- mean <- main(param)["mean"]
- size <- main(param)["size"]
- prob.0 <- size/(size+mean)
- xn <- 0:min(max(support(distribution)),
- qnbinom(1e-6,size=size,prob=prob.0,lower.tail=FALSE),
+ mean.0 <- main(param)["mean"]
+ size.0 <- main(param)["size"]
+ prob.00 <- size.0/(size.0+mean.0)
+ xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.00))),
+ qnbinom(1e-6,size=size.0,prob=prob.00,lower.tail=FALSE),
1e5)
- I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob.0))
- I12 <- -1/prob.0
- I22 <- size/prob.0^2/(1-prob.0)
- D.m <- matrix(c(1,1/prob.0-1,0,-size/prob.0^2),2,2)
+ I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.00))
+ I12 <- -1/prob.00
+ I22 <- size.0/prob.00^2/(1-prob.00)
+ D.m <- matrix(c(1,1/prob.00-1,0,-size.0/prob.00^2),2,2)
ma <- D.m%*%matrix(c(I11,I12,I12,I22),2,2)%*%t(D.m)
dimnames(ma) <- list(nms,nms)
PosDefSymmMatrix(ma)}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
@@ -347,7 +347,7 @@
param0 <- c(scale, shape)
names(param0) <- nms <- c("scale", "shape")
if(missing(trafo)) {trafo <- diag(2); dimnames(trafo) <-list(nms,nms)}
- param <- ParamFamParameter(name = "scale and shape",
+ param.0 <- ParamFamParameter(name = "scale and shape",
main = param0, trafo = trafo,
withPosRestr = TRUE,
.returnClsName ="ParamWithScaleAndShapeFamParameter")
@@ -364,14 +364,14 @@
makeOKPar <- function(param) {param <- abs(param)
return(param)}
L2deriv.fct <- function(param){
- scale <- main(param)[1]
- shape <- main(param)[2]
+ scale.0 <- main(param)[1]
+ shape.0 <- main(param)[2]
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({ (x/scale - shape)/scale },
- list(scale = scale, shape = shape))
- body(fct2) <- substitute({ log(x/scale) - digamma(shape) },
- list(scale = scale, shape = shape))
+ body(fct1) <- substitute({ (x/scale.1 - shape.1)/scale.1 },
+ list(scale.1 = scale.0, shape.1 = shape.0))
+ body(fct2) <- substitute({ log(x/scale.1) - digamma(shape.1) },
+ list(scale.1 = scale.0, shape.1 = shape.0))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = scale*shape),
NonSymmetric())
@@ -383,13 +383,13 @@
digamma(shape)))
L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry())
FisherInfo.fct <- function(param){
- scale <- main(param)[1]
- shape <- main(param)[2]
- PosDefSymmMatrix(matrix(c(shape/scale^2, 1/scale,
- 1/scale, trigamma(shape)), ncol=2,
+ scale.0 <- main(param)[1]
+ shape.0 <- main(param)[2]
+ PosDefSymmMatrix(matrix(c(shape.0/scale.0^2, 1/scale.0,
+ 1/scale.0, trigamma(shape.0)), ncol=2,
dimnames=list(nms,nms)))}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
L2Fam <- new("GammaFamily")
L2Fam at name <- name
L2Fam at distribution <- distribution
@@ -407,7 +407,7 @@
L2Fam at makeOKPar <- makeOKPar
L2Fam at scaleshapename <- c("scale"="scale","shape"="shape")
- L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param),
+ L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param.0),
Domain = Reals()))
if(!is.function(trafo))
@@ -427,6 +427,7 @@
return(L2Fam)
}
+(G1 <- GammaFamily())
##################################################################
## Beta family :: new 08/08 P.R.
@@ -438,7 +439,7 @@
param0 <- c(shape1, shape2)
names(param0) <- nms <- c("shape1", "shape2")
if(missing(trafo)) {trafo <- diag(2); dimnames(trafo) <-list(nms,nms)}
- param <- ParamFamParameter(name = "shape1 and shape2",
+ param.0 <- ParamFamParameter(name = "shape1 and shape2",
main = param0, trafo = trafo)
modifyParam <- function(theta){ Beta(shape1 = theta[1], shape2 = theta[2]) }
makeOKPar <- function(param) {param <- pmax(.Machine$double.eps,param)
@@ -454,16 +455,16 @@
return(st)
}
L2deriv.fct <- function(param){
- shape1 <- main(param)[1]
- shape2 <- main(param)[2]
+ shape1.0 <- main(param)[1]
+ shape2.0 <- main(param)[2]
fct1 <- function(x){}
fct2 <- function(x){}
- body(fct1) <- substitute({log(x)-digamma(shape1)+
- digamma(shape1+shape2)},
- list(shape1 = shape1, shape2 = shape2))
- body(fct2) <- substitute({log(1-x)-digamma(shape2)+
- digamma(shape1+shape2)},
- list(shape1 = shape1, shape2 = shape2))
+ body(fct1) <- substitute({log(x)-digamma(shape1.1)+
+ digamma(shape1.1+shape2.1)},
+ list(shape1.1 = shape1.0, shape2.1 = shape2.0))
+ body(fct2) <- substitute({log(1-x)-digamma(shape2.1)+
+ digamma(shape1.1+shape2.1)},
+ list(shape1.1 = shape1.0, shape2.1 = shape2.0))
return(list(fct1, fct2))}
L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric())
L2derivDistr <- NULL
@@ -474,13 +475,13 @@
digamma(shape2)+digamma(shape1+shape2))
L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry())
FisherInfo.fct <- function(param){
- shape1 <- main(param)[1]
- shape2 <- main(param)[2]
+# shape1.0 <- main(param)[1]
+# shape2.0 <- main(param)[2]
FI <- diag(trigamma(main(param)))-trigamma(sum(main(param)))
dimnames(FI) <- list(nms,nms)
PosDefSymmMatrix(FI)}
- FisherInfo <- FisherInfo.fct(param)
+ FisherInfo <- FisherInfo.fct(param.0)
res <- L2ParamFamily(name = name, distribution = distribution,
distrSymm = distrSymm, param = param, modifyParam = modifyParam,
props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm,
More information about the Distr-commits
mailing list