[Distr-commits] r792 - in pkg/distrMod: R man tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 21 00:37:31 CET 2012
Author: stamats
Date: 2012-02-21 00:37:31 +0100 (Tue, 21 Feb 2012)
New Revision: 792
Modified:
pkg/distrMod/R/0distrModUtils.R
pkg/distrMod/R/SimpleL2ParamFamilies.R
pkg/distrMod/R/modifyModel.R
pkg/distrMod/man/modifyModel-methods.Rd
pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save
Log:
added modifyModel method for ParamFamily, some minor corrections due to more strict checking in R devel
Modified: pkg/distrMod/R/0distrModUtils.R
===================================================================
--- pkg/distrMod/R/0distrModUtils.R 2012-02-20 14:07:52 UTC (rev 791)
+++ pkg/distrMod/R/0distrModUtils.R 2012-02-20 23:37:31 UTC (rev 792)
@@ -277,12 +277,12 @@
else Delta <- function(x) Delta1(x)
Map.Delta[[i]] <- Delta
env.i <- environment(Map.Delta[[i]]) <- new.env()
- assign("i", i, env=env.i)
- assign("fct", fct, env=env.i)
- assign("fct0", fct0, env=env.i)
- assign("Delta", Delta, env=env.i)
- assign("Delta0", Delta0, env=env.i)
- assign("Delta1", Delta1, env=env.i)
+ assign("i", i, envir=env.i)
+ assign("fct", fct, envir=env.i)
+ assign("fct0", fct0, envir=env.i)
+ assign("Delta", Delta, envir=env.i)
+ assign("Delta0", Delta0, envir=env.i)
+ assign("Delta1", Delta1, envir=env.i)
if(withplot){
windows()
plot(x.seq, sapply(x.seq,Map.Delta[[i]]),
@@ -307,7 +307,7 @@
for(i in 1:Dim)
{ Map.phi1[[i]] <- function(x) evalRandVar(phi,x)[i] * p(distr)(x)
env.i <- environment(Map.phi1[[i]]) <- new.env()
- assign("i", i, env=env.i)
+ assign("i", i, envir=env.i)
}
phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals())
@@ -333,19 +333,19 @@
phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1])
env.i <- environment(phi1) <- new.env()
- assign("i", i, env=env.i)
+ assign("i", i, envir=env.i)
if(is(distr,"DiscreteDistribution"))
psi0 <- function(x) phi0a(x) * (x %in% support(mu))
else psi0 <- function(x) phi0a(x)
Map.psi[[i]] <- psi0
env.i <- environment(Map.psi[[i]]) <- new.env()
- assign("i", i, env=env.i)
- assign("fct", fct, env=env.i)
- assign("fct0", fct0, env=env.i)
- assign("psi0", psi0, env=env.i)
- assign("phi0a", phi0a, env=env.i)
- assign("phi0", phi0, env=env.i)
+ assign("i", i, envir=env.i)
+ assign("fct", fct, envir=env.i)
+ assign("fct0", fct0, envir=env.i)
+ assign("psi0", psi0, envir=env.i)
+ assign("phi0a", phi0a, envir=env.i)
+ assign("phi0", phi0, envir=env.i)
}
psi <- EuclRandVariable(Map = Map.psi, Domain = Reals())
Modified: pkg/distrMod/R/SimpleL2ParamFamilies.R
===================================================================
--- pkg/distrMod/R/SimpleL2ParamFamilies.R 2012-02-20 14:07:52 UTC (rev 791)
+++ pkg/distrMod/R/SimpleL2ParamFamilies.R 2012-02-20 23:37:31 UTC (rev 792)
@@ -215,7 +215,7 @@
prob <- main(param)["prob"]
size <- main(param)["size"]
xn <- 0:min(max(support(distribution)),
- qnbinom(1e-6,size=size,prob=prob,lower=FALSE),
+ qnbinom(1e-6,size=size,prob=prob,lower.tail=FALSE),
1e5)
I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob))
I12 <- -1/prob
@@ -299,7 +299,7 @@
size <- main(param)["size"]
prob.0 <- size/(size+mean)
xn <- 0:min(max(support(distribution)),
- qnbinom(1e-6,size=size,prob=prob.0,lower=FALSE),
+ qnbinom(1e-6,size=size,prob=prob.0,lower.tail=FALSE),
1e5)
I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob.0))
I12 <- -1/prob.0
@@ -694,7 +694,7 @@
EvenSymmetric(SymmCenter = loc)),
L2derivDistrSymm = DistrSymmList(SphericalSymmetry(),
NoSymmetry()),
- L2derivDistr = UnivarDistrList(Arcsine(),abs(Arcsine())),
+ L2derivDistr.0 = UnivarDistrList(Arcsine(),abs(Arcsine())),
FisherInfo.0 = matrix(c(1,0,0,1)/2,2,2,
dimnames = list(c("loc","scale"),
c("loc","scale"))),
Modified: pkg/distrMod/R/modifyModel.R
===================================================================
--- pkg/distrMod/R/modifyModel.R 2012-02-20 14:07:52 UTC (rev 791)
+++ pkg/distrMod/R/modifyModel.R 2012-02-20 23:37:31 UTC (rev 792)
@@ -1,4 +1,52 @@
### move model from one parameter to the next...
+setMethod("modifyModel", signature(model = "ParamFamily", param = "ParamFamParameter"),
+ function(model, param, .withCall = TRUE, ...){
+ M <- model
+ theta <- c(main(param),nuisance(param))
+ M at distribution <- model at modifyParam(theta)
+ M at param <- param
+ #we loose symmetry if available ...
+ M at distrSymm <- NoSymmetry()
+
+ if(paste(M at fam.call[1]) == "ParamFamily")
+ fam.call <- eval(substitute(
+ call("ParamFamily",
+ name = name0,
+ distribution = distribution0,
+ distrSymm = distrSymm0,
+ param = param0,
+ props = props0,
+ startPar = startPar0,
+ makeOKPar = makeOKPar0,
+ modifyParam = modifyParam0,
+ ),
+ list( name0 = M at name,
+ distribution0 = M at distribution,
+ distrSymm0 = M at distrSymm,
+ param0 = M at param,
+ props0 = M at props,
+ startPar0 = M at startPar,
+ makeOKPar0 = M at startPar,
+ modifyParam0 = M at modifyParam,
+ )
+ ))
+ else{
+ fam.call <- model at fam.call
+ par.names <- names(theta)
+ call.n <- names(fam.call)
+ w <- which(call.n %in% par.names)
+ if(length(w))
+ fam.call <- fam.call[-w]
+ fam.call <- as.call(c(as.list(fam.call),theta))
+ }
+
+ M at fam.call <- fam.call
+ class(M) <- class(model)
+ return(M)
+ })
+
+
+### move model from one parameter to the next...
setMethod("modifyModel", signature(model = "L2ParamFamily", param = "ParamFamParameter"),
function(model, param, .withCall = TRUE, .withL2derivDistr = TRUE,
...){
Modified: pkg/distrMod/man/modifyModel-methods.Rd
===================================================================
--- pkg/distrMod/man/modifyModel-methods.Rd 2012-02-20 14:07:52 UTC (rev 791)
+++ pkg/distrMod/man/modifyModel-methods.Rd 2012-02-20 23:37:31 UTC (rev 792)
@@ -2,6 +2,7 @@
\docType{methods}
\alias{modifyModel-methods}
\alias{modifyModel}
+\alias{modifyModel,ParamFamily,ParamFamParameter-method}
\alias{modifyModel,L2ParamFamily,ParamFamParameter-method}
\alias{modifyModel,L2LocationFamily,ParamFamParameter-method}
\alias{modifyModel,L2ScaleFamily,ParamFamParameter-method}
@@ -16,6 +17,8 @@
}
\usage{
modifyModel(model, param,...)
+\S4method{modifyModel}{ParamFamily,ParamFamParameter}(model,param,
+ .withCall = TRUE, ...)
\S4method{modifyModel}{L2ParamFamily,ParamFamParameter}(model,param,
.withCall = TRUE, .withL2derivDistr = TRUE, ...)
\S4method{modifyModel}{L2LocationFamily,ParamFamParameter}(model,param, ...)
@@ -26,7 +29,7 @@
\S4method{modifyModel}{ExpScaleFamily,ParamFamParameter}(model,param, ...)
}
\arguments{
- \item{model}{an object of class \code{L2ParamFamily} --- the model to move.}
+ \item{model}{an object of class \code{ParamFamily} --- the model to move.}
\item{param}{an object of class \code{ParamFamParameter} --- the parameter to move to.}
\item{.withCall}{logical: shall slot \code{fam.call} be updated?}
\item{.withL2derivDistr}{logical: shall slot \code{L2derivDistr} be updated?}
Modified: pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save
===================================================================
--- pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2012-02-20 14:07:52 UTC (rev 791)
+++ pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2012-02-20 23:37:31 UTC (rev 792)
@@ -1,6 +1,6 @@
-R version 2.14.0 Patched (2011-11-28 r57759)
-Copyright (C) 2011 The R Foundation for Statistical Computing
+R version 2.14.2 beta (2012-02-20 r58436)
+Copyright (C) 2012 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
Platform: x86_64-unknown-linux-gnu (64-bit)
@@ -33,7 +33,7 @@
Loading required package: SweaveListingUtils
:SweaveListingUtils> Utilities for Sweave together with
:SweaveListingUtils> TeX listings package (version
-:SweaveListingUtils> 0.5.4)
+:SweaveListingUtils> 0.5.5)
:SweaveListingUtils>
:SweaveListingUtils> Some functions from package 'base'
:SweaveListingUtils> are intentionally masked ---see
@@ -594,7 +594,7 @@
{
((x - 0)/1 * LogDeriv((x - 0)/1) - 1)/1
}
-<environment: 0x7ff1308>
+<environment: 0x7326f18>
> checkL2deriv(E1)
precision of centering: -1.51181e-06
@@ -778,7 +778,7 @@
{
LogDeriv(x - 0)
}
-<environment: 0x8e41d08>
+<environment: 0x23dff60>
> checkL2deriv(G1)
precision of centering: 1.51181e-06
@@ -820,8 +820,8 @@
Slot "fct":
function (x)
QuadFormNorm(x, A = A)
-<bytecode: 0x890d9f0>
-<environment: 0x890cc48>
+<bytecode: 0x830f610>
+<environment: 0x830f808>
>
> ## The function is currently defined as
@@ -1099,7 +1099,7 @@
{
((x - 0)/1 * LogDeriv((x - 0)/1) - 1)/1
}
-<environment: 0xae408a8>
+<environment: 0xa6de010>
> checkL2deriv(L1)
precision of centering: -0.003003394
@@ -2128,7 +2128,7 @@
return(abs(x))
else return(sqrt(colSums(x^2)))
}
-<bytecode: 0x9649050>
+<bytecode: 0x82e4368>
<environment: namespace:distrMod>
> name(EuclNorm)
[1] "EuclideanNorm"
@@ -2160,7 +2160,7 @@
return(abs(x))
else return(sqrt(colSums(x^2)))
}
-<bytecode: 0x9649050>
+<bytecode: 0x82e4368>
<environment: namespace:distrMod>
>
@@ -2626,8 +2626,8 @@
Slot "fct":
function (x)
QuadFormNorm(x, A = A0)
-<bytecode: 0xb1b6130>
-<environment: 0xb1b6360>
+<bytecode: 0x79c93f8>
+<environment: 0x79c9660>
>
> ## The function is currently defined as
@@ -2665,8 +2665,8 @@
Slot "fct":
function (x)
QuadFormNorm(x, A = A)
-<bytecode: 0xafd7d88>
-<environment: 0xafd7f48>
+<bytecode: 0x7686758>
+<environment: 0x7686918>
>
> ## The function is currently defined as
@@ -4118,7 +4118,7 @@
> ### * <FOOTER>
> ###
> cat("Time elapsed: ", proc.time() - get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed: 50.019 0.524 50.77 0 0
+Time elapsed: 49.319 0.156 49.537 0 0
> grDevices::dev.off()
null device
1
More information about the Distr-commits
mailing list