[Distr-commits] r1068 - in pkg/distr: . R inst man src tests tests/Examples tests/unitTests vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 6 18:17:46 CET 2015
Author: ruckdeschel
Date: 2015-11-06 18:17:45 +0100 (Fri, 06 Nov 2015)
New Revision: 1068
Added:
pkg/distr/R/EmpiricalDistribution.R
pkg/distr/man/EmpiricalDistribution.Rd
Modified:
pkg/distr/.Rbuildignore
pkg/distr/DESCRIPTION
pkg/distr/NAMESPACE
pkg/distr/R/0distrOptions.R
pkg/distr/R/AllGenerics.R
pkg/distr/R/Convpow.R
pkg/distr/R/DiscreteDistribution.R
pkg/distr/R/Truncate.R
pkg/distr/R/internalUtils.R
pkg/distr/R/internals-qqplot.R
pkg/distr/R/makeAbscontDistribution.R
pkg/distr/R/plot-methods.R
pkg/distr/R/plot-methods_LebDec.R
pkg/distr/R/qqbounds.R
pkg/distr/R/qqplot.R
pkg/distr/R/solve.R
pkg/distr/inst/CITATION
pkg/distr/inst/NEWS
pkg/distr/man/0distr-package.Rd
pkg/distr/man/ConvPow.Rd
pkg/distr/man/DiscreteDistribution.Rd
pkg/distr/man/internals-qqplot.Rd
pkg/distr/man/internals.Rd
pkg/distr/man/operators-methods.Rd
pkg/distr/man/plot-methods.Rd
pkg/distr/man/qqplot.Rd
pkg/distr/src/ks.c
pkg/distr/tests/Examples/distr-Ex.Rout.save
pkg/distr/tests/doSvUnit.R
pkg/distr/tests/unitTests/runit.dontrunMinimum.R
pkg/distr/tests/unitTests/runit.dontrunOperatorsMethods.R
pkg/distr/tests/unitTests/runit.dontrunQQPlot.R
pkg/distr/vignettes/newDistributions.Rnw
Log:
branch 2.6 reintegriert
Modified: pkg/distr/.Rbuildignore
===================================================================
--- pkg/distr/.Rbuildignore 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/.Rbuildignore 2015-11-06 17:17:45 UTC (rev 1068)
@@ -1,5 +1,5 @@
+inst/doc/Rplots.pdf
vignettes/Rplots.pdf
-inst/doc/Rplots.pdf
^.*\.svn.+
^.*-Ex\.R$
build
\ No newline at end of file
Modified: pkg/distr/DESCRIPTION
===================================================================
--- pkg/distr/DESCRIPTION 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/DESCRIPTION 2015-11-06 17:17:45 UTC (rev 1068)
@@ -1,21 +1,22 @@
Package: distr
-Version: 2.5.3
-Date: 2014-08-08
-Title: Object oriented implementation of distributions
-Description: S4 Classes and Methods for distributions
-Authors at R: c(person("Florian", "Camphausen", role=c("aut")),
- person("Matthias", "Kohl", role=c("aut", "cph")),
- person("Peter", "Ruckdeschel", role=c("cre", "cph"), email="Peter.Ruckdeschel at itwm.fraunhofer.de"),
- person("Thomas", "Stabla", role=c("aut", "cph")),
- person("R Core Team", role = c("ctb", "cph"),
- comment="for source file ks.c/ routines 'pKS2' and 'pKolmogorov2x'"))
+Version: 2.6
+Date: 2015-11-06
+Title: Object Oriented Implementation of Distributions
+Description: S4-classes and methods for distributions.
+Authors at R: c(person("Florian", "Camphausen", role="ctb", comment="contributed as student in the
+ initial phase --2005"), person("Matthias", "Kohl", role=c("aut", "cph")),
+ person("Peter", "Ruckdeschel", role=c("cre", "cph"),
+ email="peter.ruckdeschel at uni-oldenburg.de"), person("Thomas", "Stabla", role="ctb",
+ comment="contributed as student in the initial phase --2005"), person("R Core Team",
+ role = c("ctb", "cph"), comment="for source file ks.c/ routines 'pKS2' and
+ 'pKolmogorov2x'"))
Depends: R(>= 2.14.0), methods, graphics, startupmsg, sfsmisc, SweaveListingUtils
Suggests: distrEx, svUnit (>= 0.7-11)
-Imports: stats
+Imports: stats, grDevices, utils, MASS
ByteCompile: yes
Encoding: latin1
License: LGPL-3
URL: http://distr.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 947
+SVNRevision: 1055
Modified: pkg/distr/NAMESPACE
===================================================================
--- pkg/distr/NAMESPACE 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/NAMESPACE 2015-11-06 17:17:45 UTC (rev 1068)
@@ -1,100 +1,104 @@
-useDynLib("distr")
-import("methods")
-import("stats")
-importFrom("graphics", "plot")
-importFrom("sfsmisc", "D1ss")
-import("startupmsg")
-import("SweaveListingUtils")
-
-export("Beta", "Binom", "Cauchy", "Chisq",
- "Dirac","Exp", "DExp", "Fd", "Gammad",
- "Geom", "Hyper", "Lnorm", "Logis",
- "Nbinom", "Norm", "Pois", "RtoDPQ",
- "RtoDPQ.d", "Td", "Unif", "Weibull", "Arcsine",
- "distroptions", "getdistrOption", "simplifyr",
- "Lattice", "DiscreteDistribution",
- "LatticeDistribution", "EuclideanSpace", "Reals",
- "Naturals", "standardMethods",
- "distrARITH", "distrMASK", "getLabel", "devNew")
-export("AbscontDistribution")
-export("DistrList", "UnivarDistrList")
-export("makeAbscontDistribution")
-exportClasses("rSpace", "EuclideanSpace", "Reals",
- "Naturals")
-exportClasses("Parameter")
-exportClasses("OptionalParameter", "OptionalMatrix")
-exportClasses("BetaParameter", "BinomParameter",
- "CauchyParameter", "ChisqParameter",
- "DiracParameter", "ExpParameter",
- "FParameter", "GammaParameter",
- "HyperParameter", "GeomParameter",
- "LogisParameter", "LnormParameter",
- "NbinomParameter", "NormParameter",
- "PoisParameter", "TParameter",
- "UnifParameter", "WeibullParameter",
- "UniNormParameter")
-exportClasses("Distribution")
-exportClasses("UnivariateDistribution", "AbscontDistribution",
- "DiscreteDistribution", "LatticeDistribution",
- "AffLinAbscontDistribution", "AffLinDiscreteDistribution",
- "AffLinLatticeDistribution", "AffLinDistribution", "Lattice",
- "Beta", "Binom", "Cauchy", "Chisq", "Dirac",
- "DExp", "Exp", "Fd", "Gammad", "Geom",
- "Hyper", "Logis", "Lnorm", "Nbinom", "Norm",
- "Pois", "Td", "Unif", "Weibull", "Arcsine",
- "ExpOrGammaOrChisq")
-exportClasses("UnivDistrListOrDistribution")
-exportClasses("CompoundDistribution")
-exportClasses("DistrList",
- "UnivarDistrList")
-exportClasses("OptionalNumeric", "PosSemDefSymmMatrix",
- "PosDefSymmMatrix",
- "Symmetry", "DistributionSymmetry",
- "NoSymmetry", "EllipticalSymmetry", "SphericalSymmetry",
- "DistrSymmList")
-exportMethods("Max", "Max<-", "Min", "Min<-", "d", "df",
- "df<-", "df1", "df1<-", "df2",
- "df2<-", "dimension", "dimension<-", "name",
- "name<-", "img", "k", "k<-",
- "lambda", "lambda<-", "liesIn", "location",
- "location<-", "m", "m<-", "mean",
- "mean<-", "meanlog", "meanlog<-", "n",
- "n<-", "ncp", "ncp<-", "p", "param",
- "prob", "prob<-", "q", "r", "rate", "p.l", "q.r",
- "rate<-", "scale", "scale<-", "sd", "sd<-",
- "sdlog", "sdlog<-", "shape", "shape<-",
- "shape1", "shape1<-", "shape2", "shape2<-",
- "size", "size<-", "support", "initialize",
- "print", "plot", "+", "-", "/", "*", "coerce",
- "Math", "log", "log10", "gamma", "lgamma", "digamma",
- "dim", "show", "convpow", "pivot", "sign",
- "lattice", "width", "Length", "pivot<-",
- "width<-", "Length<-", "liesInSupport",
- "isOldVersion", "conv2NewVersion", "gaps",
- "gaps<-", "setgaps", "getLow", "getUp")
-exportClasses("UnivarMixingDistribution",
- "UnivarLebDecDistribution",
- "AffLinUnivarLebDecDistribution",
- "AcDcLcDistribution")
-exportMethods("mixCoeff", "mixCoeff<-", "mixDistr", "mixDistr<-",
- "discretePart", "discretePart<-", "acPart", "acPart<-",
- "discreteWeight", "discreteWeight<-", "acWeight", "acWeight<-",
- "p.discrete", "d.discrete", "q.discrete", "r.discrete",
- "p.ac", "d.ac", "q.ac", "r.ac")
-exportMethods("decomposePM", "simplifyD", "showobj")
-exportMethods("Truncate","Minimum","Maximum","Huberize")
-exportMethods("solve", "sqrt")
-exportMethods("type", "SymmCenter", "Symmetry", ".logExact", ".lowerExact")
-export("UnivarMixingDistribution", "UnivarLebDecDistribution")
-export("RtoDPQ.LC", "flat.LCD", "flat.mix")
-exportMethods("abs","exp","^")
-exportMethods("NumbOfSummandsDistr","SummandsDistr")
-export("CompoundDistribution")
-export("PosDefSymmMatrix","PosSemDefSymmMatrix")
-export("NoSymmetry", "EllipticalSymmetry", "SphericalSymmetry",
- "DistrSymmList")
-export("qqbounds","igamma")
-exportMethods("qqplot")
-export(".isEqual",".isEqual01", ".inArgs", ".fillList",
- ".presubs", ".makeLenAndOrder", ".DistrCollapse")
-export("samplesize", "distribution", "samplesize<-")
\ No newline at end of file
+useDynLib("distr")
+import("methods")
+import("stats")
+importFrom("grDevices", "dev.list", "dev.new", "xy.coords")
+importFrom("graphics", "plot", "abline", "layout", "legend", "lines", "mtext", "par", "points", "title")
+importFrom("MASS", "ginv")
+importFrom("utils", "str")
+importFrom("sfsmisc", "D1ss")
+import("startupmsg")
+import("SweaveListingUtils")
+
+export("Beta", "Binom", "Cauchy", "Chisq",
+ "Dirac","Exp", "DExp", "Fd", "Gammad",
+ "Geom", "Hyper", "Lnorm", "Logis",
+ "Nbinom", "Norm", "Pois", "RtoDPQ",
+ "RtoDPQ.d", "Td", "Unif", "Weibull", "Arcsine",
+ "distroptions", "getdistrOption", "simplifyr",
+ "Lattice", "DiscreteDistribution",
+ "EmpiricalDistribution",
+ "LatticeDistribution", "EuclideanSpace", "Reals",
+ "Naturals", "standardMethods",
+ "distrARITH", "distrMASK", "getLabel", "devNew")
+export("AbscontDistribution")
+export("DistrList", "UnivarDistrList")
+export("makeAbscontDistribution")
+exportClasses("rSpace", "EuclideanSpace", "Reals",
+ "Naturals")
+exportClasses("Parameter")
+exportClasses("OptionalParameter", "OptionalMatrix")
+exportClasses("BetaParameter", "BinomParameter",
+ "CauchyParameter", "ChisqParameter",
+ "DiracParameter", "ExpParameter",
+ "FParameter", "GammaParameter",
+ "HyperParameter", "GeomParameter",
+ "LogisParameter", "LnormParameter",
+ "NbinomParameter", "NormParameter",
+ "PoisParameter", "TParameter",
+ "UnifParameter", "WeibullParameter",
+ "UniNormParameter")
+exportClasses("Distribution")
+exportClasses("UnivariateDistribution", "AbscontDistribution",
+ "DiscreteDistribution", "LatticeDistribution",
+ "AffLinAbscontDistribution", "AffLinDiscreteDistribution",
+ "AffLinLatticeDistribution", "AffLinDistribution", "Lattice",
+ "Beta", "Binom", "Cauchy", "Chisq", "Dirac",
+ "DExp", "Exp", "Fd", "Gammad", "Geom",
+ "Hyper", "Logis", "Lnorm", "Nbinom", "Norm",
+ "Pois", "Td", "Unif", "Weibull", "Arcsine",
+ "ExpOrGammaOrChisq")
+exportClasses("UnivDistrListOrDistribution")
+exportClasses("CompoundDistribution")
+exportClasses("DistrList",
+ "UnivarDistrList")
+exportClasses("OptionalNumeric", "PosSemDefSymmMatrix",
+ "PosDefSymmMatrix",
+ "Symmetry", "DistributionSymmetry",
+ "NoSymmetry", "EllipticalSymmetry", "SphericalSymmetry",
+ "DistrSymmList")
+exportMethods("Max", "Max<-", "Min", "Min<-", "d", "df",
+ "df<-", "df1", "df1<-", "df2",
+ "df2<-", "dimension", "dimension<-", "name",
+ "name<-", "img", "k", "k<-",
+ "lambda", "lambda<-", "liesIn", "location",
+ "location<-", "m", "m<-", "mean",
+ "mean<-", "meanlog", "meanlog<-", "n",
+ "n<-", "ncp", "ncp<-", "p", "param",
+ "prob", "prob<-", "q", "r", "rate", "p.l", "q.r",
+ "rate<-", "scale", "scale<-", "sd", "sd<-",
+ "sdlog", "sdlog<-", "shape", "shape<-",
+ "shape1", "shape1<-", "shape2", "shape2<-",
+ "size", "size<-", "support", "initialize",
+ "print", "plot", "+", "-", "/", "*", "coerce",
+ "Math", "log", "log10", "gamma", "lgamma", "digamma",
+ "dim", "show", "convpow", "pivot", "sign",
+ "lattice", "width", "Length", "pivot<-",
+ "width<-", "Length<-", "liesInSupport",
+ "isOldVersion", "conv2NewVersion", "gaps",
+ "gaps<-", "setgaps", "getLow", "getUp")
+exportClasses("UnivarMixingDistribution",
+ "UnivarLebDecDistribution",
+ "AffLinUnivarLebDecDistribution",
+ "AcDcLcDistribution")
+exportMethods("mixCoeff", "mixCoeff<-", "mixDistr", "mixDistr<-",
+ "discretePart", "discretePart<-", "acPart", "acPart<-",
+ "discreteWeight", "discreteWeight<-", "acWeight", "acWeight<-",
+ "p.discrete", "d.discrete", "q.discrete", "r.discrete",
+ "p.ac", "d.ac", "q.ac", "r.ac")
+exportMethods("decomposePM", "simplifyD", "showobj")
+exportMethods("Truncate","Minimum","Maximum","Huberize")
+exportMethods("solve", "sqrt")
+exportMethods("type", "SymmCenter", "Symmetry", ".logExact", ".lowerExact")
+export("UnivarMixingDistribution", "UnivarLebDecDistribution")
+export("RtoDPQ.LC", "flat.LCD", "flat.mix")
+exportMethods("abs","exp","^")
+exportMethods("NumbOfSummandsDistr","SummandsDistr")
+export("CompoundDistribution")
+export("PosDefSymmMatrix","PosSemDefSymmMatrix")
+export("NoSymmetry", "EllipticalSymmetry", "SphericalSymmetry",
+ "DistrSymmList")
+export("qqbounds","igamma")
+exportMethods("qqplot")
+export(".isEqual",".isEqual01", ".inArgs", ".fillList",
+ ".presubs", ".makeLenAndOrder", ".DistrCollapse")
+export("samplesize", "distribution", "samplesize<-")
Modified: pkg/distr/R/0distrOptions.R
===================================================================
--- pkg/distr/R/0distrOptions.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/0distrOptions.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -43,4 +43,4 @@
getdistrOption <- function(x)distroptions(x)[[1]]
-options("newDevice" = FALSE)
\ No newline at end of file
+options("newDevice" = FALSE)
Modified: pkg/distr/R/AllGenerics.R
===================================================================
--- pkg/distr/R/AllGenerics.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/AllGenerics.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -20,13 +20,13 @@
df <- function(x, ...)
{
dots <- list(...)
- if(hasArg(df1)) df1 <- dots$"df1"
+ if(hasArg("df1")) df1 <- dots$"df1"
else stop("Argument df1 missing")
- if(hasArg(df2)) df2 <- dots$"df2"
+ if(hasArg("df2")) df2 <- dots$"df2"
else stop("Argument df2 missing")
- log.arg <- if(hasArg(log)) dots$"log" else FALSE
+ log.arg <- if(hasArg("log")) dots$"log" else FALSE
- if(hasArg(ncp)) ncp <- dots$"ncp"
+ if(hasArg("ncp")) ncp <- dots$"ncp"
else ncp <- 0
if(isTRUE(all.equal(ncp,0))||(getRversion()>='2.4.0'))
@@ -54,7 +54,7 @@
sd <- function(x, ...){
dots <- list(...)
- na.rm <- ifelse(hasArg(na.rm), dots$"na.rm", FALSE)
+ na.rm <- ifelse(hasArg("na.rm"), dots$"na.rm", FALSE)
stats::sd(x = x, na.rm = na.rm)
}
Modified: pkg/distr/R/Convpow.R
===================================================================
--- pkg/distr/R/Convpow.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/Convpow.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -264,7 +264,7 @@
{if( !.isNatural0(N))
stop("N has to be a natural (or 0)")
if (N==0) return(Dirac(0))
- Dirac(shape=N*location(D1))}
+ Dirac(location =N*location(D1))}
)
setMethod("convpow",
Modified: pkg/distr/R/DiscreteDistribution.R
===================================================================
--- pkg/distr/R/DiscreteDistribution.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/DiscreteDistribution.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -1,14 +1,14 @@
###############################################################################
# Methods for Discrete Distributions
###############################################################################
-
+
## (c) Matthias Kohl: revised P.R. 030707
DiscreteDistribution <- function(supp, prob, .withArith = FALSE,
.withSim = FALSE, .lowerExact = TRUE, .logExact = FALSE,
- .DistrCollapse =
+ .DistrCollapse =
getdistrOption("DistrCollapse"),
- .DistrCollapse.Unique.Warn =
+ .DistrCollapse.Unique.Warn =
getdistrOption("DistrCollapse.Unique.Warn"),
.DistrResolution = getdistrOption("DistrResolution"),
Symmetry = NoSymmetry()){
@@ -30,7 +30,7 @@
if(!all(prob >= 0))
stop("'prob' contains values < 0")
}
-
+
o <- order(supp)
supp <- supp[o]
prob <- prob[o]
@@ -40,11 +40,11 @@
if (len>1 && min(diff(supp))< .DistrResolution){
erg <- .DistrCollapse(supp, prob, .DistrResolution)
if (len>length(erg$prob) && .DistrCollapse.Unique.Warn)
- warning("collapsing to unique support values")
+ warning("collapsing to unique support values")
prob <- erg$prob
supp <- erg$supp
}
- }else{
+ }else{
usupp <- unique(supp)
if(length(usupp) < len){
if(.DistrCollapse.Unique.Warn)
@@ -61,8 +61,14 @@
}
rm(len)
- rfun <- function(n){
- sample(x = supp, size = n, replace = TRUE, prob = prob)
+ if(length(supp) == 1){
+ rfun <- function(n){
+ rep(supp, n)
+ }
+ }else{
+ rfun <- function(n){
+ sample(x = supp, size = n, replace = TRUE, prob = prob)
+ }
}
dfun <- .makeDNew(supp, prob, Cont = FALSE)
@@ -84,7 +90,7 @@
if (.inArgs("lower.tail", p(object))){
function(q, lower.tail = TRUE, log.p = FALSE){
px <- p(object)(q, lower.tail = lower.tail)
- o.warn <- getOption("warn");
+ o.warn <- getOption("warn");
on.exit(options(warn=o.warn))
options(warn = -2)
dx <- d(object)(.setEqual(q, support(object)))
@@ -220,7 +226,7 @@
setMethod("+", c("DiscreteDistribution","DiscreteDistribution"),
function(e1,e2){
-
+
if(length(support(e1))==1) return(e2+support(e1))
if(length(support(e2))==1) return(e1+support(e2))
e1.L <- as(e1, "LatticeDistribution")
@@ -232,7 +238,7 @@
if (abs(abs(w1)-abs(w2))<getdistrOption("DistrResolution") ||
W[2] %% W[1] < getdistrOption("DistrResolution") )
return(e1.L + e2.L)
- }
+ }
.convDiscrDiscr(e1,e2)})
setMethod("+", c("Dirac","DiscreteDistribution"),
@@ -247,7 +253,7 @@
Distr at X0 <- e1
if(is(e1 at Symmetry,"SphericalSymmetry"))
- Distr at Symmetry <-
+ Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
Distr
@@ -258,7 +264,7 @@
Distr at X0 <- e1
if(is(e1 at Symmetry,"SphericalSymmetry"))
- Distr at Symmetry <-
+ Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)+e2)
Distr
@@ -268,17 +274,17 @@
function(e1, e2) {
Distr <- .multm(e1,e2, "AffLinDiscreteDistribution")
if(is(e1 at Symmetry,"SphericalSymmetry"))
- Distr at Symmetry <-
+ Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
- Distr
+ Distr
})
setMethod("+", c("AffLinDiscreteDistribution","numeric"),
function(e1, e2) {
Distr <- .plusm(e1,e2, "AffLinDiscreteDistribution")
if(is(e1 at Symmetry,"SphericalSymmetry"))
- Distr at Symmetry <-
+ Distr at Symmetry <-
SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2)
- Distr
+ Distr
})
## Group Math for discrete distributions
@@ -298,47 +304,47 @@
## exact: abs for discrete distributions
setMethod("abs", "DiscreteDistribution",function(x){
-
+
rnew <- function(n, ...){}
body(rnew) <- substitute({ abs(g(n, ...)) },
list(g = x at r))
-
+
xx <- x
supportnew <- support(x)
-
+
isSym0 <- FALSE
if(is(Symmetry(x),"SphericalSymmetry"))
if(.isEqual(SymmCenter(Symmetry(x)),0))
- isSym0 <- TRUE
-
+ isSym0 <- TRUE
+
if(isSym0){
supportnew <- supportnew[supportnew>=0]
-
+
.lowerExact = .lowerExact(x)
- dxlog <- if("log" %in% names(formals(d(x))))
+ dxlog <- if("log" %in% names(formals(d(x))))
quote({dx <- d(xx)(x, log = TRUE)})
else quote({dx <- log(d(xx)(x))})
- pxlog <- if("log.p" %in% names(formals(p(x))) &&
- "lower.tail" %in% names(formals(p(x))))
+ pxlog <- if("log.p" %in% names(formals(p(x))) &&
+ "lower.tail" %in% names(formals(p(x))))
quote({p(x)(q, lower.tail = FALSE, log.p = TRUE)})
else
quote({log(1-p(x)(q))})
- qxlog <- if("lower.tail" %in% names(formals(q(x))))
+ qxlog <- if("lower.tail" %in% names(formals(q(x))))
quote({qx <- if(lower.tail)
q(x)((1+p1)/2)
else
- q(x)(p1/2,lower.tail=FALSE)})
+ q(x)(p1/2,lower.tail=FALSE)})
else
quote({qx <- q(x)(if(lower.tail) (1+p1)/2 else 1-p1/2)})
- if("lower.tail" %in% names(formals(q(x)))&&
- "log.p" %in% names(formals(q(x))))
+ if("lower.tail" %in% names(formals(q(x)))&&
+ "log.p" %in% names(formals(q(x))))
qxlog <- quote({qx <- if(lower.tail) q(x)((1+p1)/2)
else
q(x)(if(log.p)p-log(2)
- else p1/2,lower.tail=FALSE,log.p=log.p)})
+ else p1/2,lower.tail=FALSE,log.p=log.p)})
dnew <- function(x, log = FALSE){}
@@ -349,7 +355,7 @@
dx[x<0] <- if(log) -Inf else 0
return(dx)
}, list(dxlog0 = dxlog))
-
+
pnew <- function(q, lower.tail = TRUE, log.p = FALSE){}
body(pnew) <- substitute({
if (!lower.tail){
@@ -359,7 +365,7 @@
px <- pmax(2 * p(x)(q) - 1,0)
if(log.p) px <- log(px)
}
- return(px)
+ return(px)
}, list(pxlog0 = pxlog))
qnew <- function(p, lower.tail = TRUE, log.p = FALSE){}
@@ -380,13 +386,13 @@
dnew <- function(x, log = FALSE){
o.warn <- getOption("warn"); options(warn = -1)
on.exit(options(warn=o.warn))
- dx <- (x>=0) * d(xx)(x) + (x>0) * d(xx)(-x)
+ dx <- (x>=0) * d(xx)(x) + (x>0) * d(xx)(-x)
options(warn = o.warn)
if (log) dx <- log(dx)
return(dx)
}
-
- pxlow <- if("lower.tail" %in% names(formals(p(x))))
+
+ pxlow <- if("lower.tail" %in% names(formals(p(x))))
substitute({p(x)(q, lower=FALSE)})
else
substitute({1-p(x)(q)})
@@ -394,21 +400,21 @@
pnew <- function(q, lower.tail = TRUE, log.p = FALSE){}
body(pnew) <- substitute({
px <- if (lower.tail)
- (q>=0) * (p(x)(q) - p.l(x)(-q))
+ (q>=0) * (p(x)(q) - p.l(x)(-q))
else pxlow0 + p.l(x)(-q)
if (log.p) px <- log(px)
return(px)
}, list(pxlow0=pxlow))
prob <- dnew(supportnew)
-
- qnew <- .makeQNew(supportnew, cumsum(prob),
- rev(cumsum(rev(prob))), notwithLLarg = x at .withSim,
+
+ qnew <- .makeQNew(supportnew, cumsum(prob),
+ rev(cumsum(rev(prob))), notwithLLarg = x at .withSim,
min(supportnew), max(supportnew), Cont = FALSE)
-
+
}
object <- new("DiscreteDistribution", r = rnew, p = pnew,
- q = qnew, d = dnew, support = supportnew,
+ q = qnew, d = dnew, support = supportnew,
.withSim = x at .withSim, .withArith = TRUE,
.lowerExact = .lowerExact(x))
object
@@ -420,7 +426,7 @@
### preliminary to export special functions
-if (getRversion()>='2.6.0'){
+if (getRversion()>='2.6.0'){
setMethod("log", "DiscreteDistribution",
function(x, base = exp(1)) {
@@ -428,31 +434,31 @@
call = sys.call(sys.parent(1)))$x))
ep <- getdistrOption("TruncQuantile")
basl <- log(base)
- if(p(x)(0)>ep)
+ if(p(x)(0)>ep)
stop(gettextf("log(%s) is not well-defined with positive probability ", xs))
else return(.logm.d(x)/basl)})
setMethod("log", "Dirac",
- function(x, base = exp(1)){
+ function(x, base = exp(1)){
xs <- as.character(deparse(match.call(
call = sys.call(sys.parent(1)))$x))
- loc <- location(x)
+ loc <- location(x)
ep <- getdistrOption("TruncQuantile")
basl <- log(base)
- if(loc < ep)
- stop(gettextf("log(%s) is not well-defined with positive probability ", xs))
+ if(loc < ep)
+ stop(gettextf("log(%s) is not well-defined with positive probability ", xs))
Dirac(log(loc)/basl)})
setMethod("log10", "DiscreteDistribution",
function(x) log(x = x, base = 10))
setMethod("sign", "DiscreteDistribution",
- function(x){
+ function(x){
d0 <- d(x)(0)
- DiscreteDistribution(supp=c(-1,0,1),
+ DiscreteDistribution(supp=c(-1,0,1),
prob=c(p(x)(-getdistrOption("TruncQuantile")),
d0,
- p(x)(getdistrOption("TruncQuantile"), lower=FALSE)))
+ p(x)(getdistrOption("TruncQuantile"), lower=FALSE)))
})
@@ -462,9 +468,9 @@
if(px0>0) stop("argument of 'digamma' must be concentrated on positive values")
rnew <- function(n, ...){}
body(rnew) <- substitute({ digamma(g(n, ...)) }, list(g = x at r))
-
- object <- DiscreteDistribution(
- supp=digamma(support(x)),
+
+ object <- DiscreteDistribution(
+ supp=digamma(support(x)),
prob=prob(x), .withArith = TRUE)
object
})
@@ -489,23 +495,22 @@
setMethod("sqrt", "DiscreteDistribution",
function(x) x^0.5)
-}
-setMethod("prob", "DiscreteDistribution",
+}
+setMethod("prob", "DiscreteDistribution",
function(object) {sp <- object at support
pr <- object at d(sp)
names(pr) <- paste(sp)
return(pr)
})
## Replace Methods
-setReplaceMethod("prob", "DiscreteDistribution",
- function(object, value){
- return(DiscreteDistribution(supp = object at support,
+setReplaceMethod("prob", "DiscreteDistribution",
+ function(object, value){
+ return(DiscreteDistribution(supp = object at support,
prob = value,
.withArith = object at .withArith,
.withSim = object at .withSim,
- .lowerExact = .lowerExact(object),
+ .lowerExact = .lowerExact(object),
.logExact = .logExact(object)))}
)
-
\ No newline at end of file
Copied: pkg/distr/R/EmpiricalDistribution.R (from rev 1067, branches/distr-2.6/pkg/distr/R/EmpiricalDistribution.R)
===================================================================
--- pkg/distr/R/EmpiricalDistribution.R (rev 0)
+++ pkg/distr/R/EmpiricalDistribution.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -0,0 +1,20 @@
+###############################################################################
+## Generating function to generate empirical distribution given some data
+###############################################################################
+
+## simple wrapper to DiscreteDistribution
+EmpiricalDistribution <- function(data, .withArith = FALSE,
+ .withSim = FALSE, .lowerExact = TRUE, .logExact = FALSE,
+ .DistrCollapse =
+ getdistrOption("DistrCollapse"),
+ .DistrCollapse.Unique.Warn =
+ getdistrOption("DistrCollapse.Unique.Warn"),
+ .DistrResolution = getdistrOption("DistrResolution"),
+ Symmetry = NoSymmetry()){
+ DiscreteDistribution(supp = data, .withArith = .withArith, .withSim = .withSim,
+ .lowerExact = .lowerExact, .logExact = .logExact,
+ .DistrCollapse = .DistrCollapse,
+ .DistrCollapse.Unique.Warn = .DistrCollapse.Unique.Warn,
+ .DistrResolution = .DistrResolution,
+ Symmetry = Symmetry)
+}
Modified: pkg/distr/R/Truncate.R
===================================================================
--- pkg/distr/R/Truncate.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/Truncate.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -193,6 +193,7 @@
setMethod("Truncate", "UnivarLebDecDistribution",
function(object, lower = -Inf, upper = Inf,
withSimplify = getdistrOption("simplifyD")){
+ ep <- .Machine$double.eps^2
if(lower >= upper+ep)
stop("Argument 'lower' must be smaller than argument 'upper'")
if((lower <= getLow(object))&&(upper >= getUp(object)))
Modified: pkg/distr/R/internalUtils.R
===================================================================
--- pkg/distr/R/internalUtils.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/internalUtils.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -1236,19 +1236,21 @@
.List <- function(list0) if(is.list(list0)) list0 else list(list0)
.fillList <- function(list0, len = length(list0)){
+ if(is.null(list0)) return(vector("list",len))
list0 <- .List(list0)
if(len == length(list0))
return(list0)
i <- 0
ll0 <- length(list0)
li0 <- vector("list",len)
- if(ll0)
- while(i < len){
- j <- 1 + ( i %% ll0)
- i <- i + 1
- li0[[i]] <- list0[[j]]
+ if(ll0){
+ while(i < len){
+ j <- 1 + ( i %% ll0)
+ i <- i + 1
+ li0[[i]] <- list0[[j]]
+ }
}
- return(li0)
+ return(li0)
}
#------------------------------------------------------------------------------
@@ -1270,4 +1272,18 @@
}
-
\ No newline at end of file
+.panel.mingle <- function(dots, element){
+ pF <- dots[[element]]
+ if(is.list(pF)) return(pF)
+ pFr <- if(typeof(pF)=="symbol") eval(pF) else{
+ pFc <- as.call(pF)
+ if(as.list(pFc)[[1]] == "list"){
+ lis <- vector("list",length(as.list(pFc))-1)
+ for(i in 1:length(lis)){
+ lis[[i]] <- pFc[[i+1]]
+ }
+ lis
+ }else pF
+ }
+ return(pFr)
+}
Modified: pkg/distr/R/internals-qqplot.R
===================================================================
--- pkg/distr/R/internals-qqplot.R 2015-11-06 16:14:04 UTC (rev 1067)
+++ pkg/distr/R/internals-qqplot.R 2015-11-06 17:17:45 UTC (rev 1068)
@@ -10,10 +10,10 @@
sapply(x, function(y) length(which(fct(y,gapm)))>0)
}
-.isReplicated <- function(x){
+.isReplicated <- function(x, tol=.Machine$double.eps){
tx <- table(x)
rx <- as.numeric(names(tx[tx>1]))
- sapply(x, function(y) any(abs(y-rx)<.Machine$double.eps))
+ sapply(x, function(y) any(abs(y-rx)<tol))
}
.NotInSupport <- function(x,D){
@@ -96,21 +96,44 @@
}
-.q2kolmogorov <- function(alpha,n,exact=(n<100)){ ## Kolmogorovstat
+.q2kolmogorov <- function(alpha,n,exact=(n<100), silent0 = TRUE){ ## Kolmogorovstat
if(is.numeric(alpha)) alpha <- as.vector(alpha)
else stop("Level alpha must be numeric.")
if(any(is.na(alpha))) stop("Level alpha must not contain missings.")
if(exact){
- fct <- function(p0){
- ### from ks.test from package stats:
- .pk2(p0,n) -alpha
- }
- res <- uniroot(fct,lower=0,upper=1)$root*sqrt(n)
+ fct <- function(p0){
+ ### from ks.test from package stats:
+ .pk2(p0,n) -alpha
+ }
+ i <- 0
+ oK <- FALSE
+ del <- 0.01
+ while(!oK && i < 20){
+ i <- i + 1
+ res <- try(uniroot(fct,lower=del,upper=3*(1-del)/sqrt(n))$root*sqrt(n), silent=silent0)
+ del <- del / 10
+ if(!is(res, "try-error")) oK <- TRUE
+ }
}else{
- fct <- function(p0){
- ### from ks.test from package stats:
- 1 - .pks2(p0,1e-09)-alpha }
- res <- uniroot(fct,lower=1e-12,upper=sqrt(n))$root
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1068
More information about the Distr-commits
mailing list