[Distr-commits] r946 - in branches/distr-2.6/pkg/distrMod: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jul 28 13:09:12 CEST 2014
Author: ruckdeschel
Date: 2014-07-28 13:09:12 +0200 (Mon, 28 Jul 2014)
New Revision: 946
Modified:
branches/distr-2.6/pkg/distrMod/DESCRIPTION
branches/distr-2.6/pkg/distrMod/R/0distrModUtils.R
branches/distr-2.6/pkg/distrMod/R/AllPlot.R
branches/distr-2.6/pkg/distrMod/R/SimpleL2ParamFamilies.R
branches/distr-2.6/pkg/distrMod/R/confint.R
branches/distr-2.6/pkg/distrMod/R/internalMleCalc.R
branches/distr-2.6/pkg/distrMod/R/qqplot.R
Log:
[distrMod] removed ::: internal dependencies (within distr-Fam of pkgs) by copying respective routines
Modified: branches/distr-2.6/pkg/distrMod/DESCRIPTION
===================================================================
--- branches/distr-2.6/pkg/distrMod/DESCRIPTION 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/DESCRIPTION 2014-07-28 11:09:12 UTC (rev 946)
@@ -4,8 +4,10 @@
Title: Object oriented implementation of probability models
Description: Object oriented implementation of probability models based on packages 'distr' and
'distrEx'
-Author: Matthias Kohl, Peter Ruckdeschel
-Maintainer: Peter Ruckdeschel <Peter.Ruckdeschel at itwm.fraunhofer.de>
+Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")),
+ person("Peter", "Ruckdeschel", role=c("cre", "cph"), email="Peter.Ruckdeschel at itwm.fraunhofer.de"),
+ person("R Core Team", role = c("ctb", "cph"),
+ comment="for source file 'format.perc'"))
Depends: R(>= 2.14.0), distr(>= 2.5.2), distrEx(>= 2.4), RandVar(>= 0.6.3), MASS, stats4,
methods
ByteCompile: yes
Modified: branches/distr-2.6/pkg/distrMod/R/0distrModUtils.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/0distrModUtils.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/0distrModUtils.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -89,10 +89,6 @@
return(ret)
}
-##caching:
-.csimpsum <- distr:::.csimpsum
-### still to be tested and improved:
-## covariance for minimum CvM distance estimator acc. Ri:94, pp.132-133
.CvMMDCovariance<- function(L2Fam, param, mu = distribution(L2Fam),
withplot = FALSE, withpreIC = FALSE,
@@ -406,3 +402,315 @@
}
+#------------------------------------
+#### utilities copied from package distr v.2.6 svn-rev 943
+#------------------------------------
+.inArgs <- function(arg, fct)
+ {as.character(arg) %in% names(formals(fct))}
+
+.isEqual <- function(p0, p1, tol = min( getdistrOption("TruncQuantile")/2,
+ .Machine$double.eps^.7
+ ))
+ abs(p0-p1)< tol
+
+.csimpsum <- function(fx){
+ l <- length(fx)
+ l2 <- l%/%2
+ if (l%%2 == 0) {
+ fx <- c(fx[1:l2],(fx[l2]+fx[l2+1])/2,fx[(l2+1):l])
+ l <- l+1}
+ f.even <- fx[seq(l) %% 2 == 0]
+ f.odd <- fx[seq(l) %% 2 == 1]
+ fs <- 2 * cumsum(f.odd) - f.odd - f.odd[1]
+ fsm <- 4 * cumsum(f.even)
+ ff <- c(0,(fs[2:(l2+1)]+fsm)/3 )
+ ff
+}
+
+.List <- function(list0) if(is.list(list0)) list0 else list(list0)
+
+.fillList <- function(list0, len = length(list0)){
+ 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]]
+ }
+ return(li0)
+}
+
+.confqq <- function(x,D, datax = TRUE, withConf.pw = TRUE,
+ withConf.sim = TRUE, alpha,
+ col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI,
+ col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI,
+ n,exact.sCI=(n<100),exact.pCI=(n<100), nosym.pCI = FALSE,
+ with.legend = TRUE, legend.bg = "white",
+ legend.pos = "topleft", legend.cex = 0.8,
+ legend.pref = "", legend.postf = "",
+ legend.alpha = alpha, qqb0=NULL, debug = FALSE){
+
+ x <- sort(unique(x))
+ if("gaps" %in% names(getSlots(class(D))))
+ {if(!is.null(gaps(D)))
+ x <- sort(unique(c(x, gaps(D))))
+ }
+ SI <- .SingleDiscrete(x,D)
+# print(SI)
+ SI.in <- SI<4
+ SIi <- SI[SI.in]
+ SI.c <- SIi>0
+ x.in <- x[SI.in]
+ x.c <- x.in[SI.c]
+ x.d <- x.in[!SI.c]
+
+
+ qqb <- if(is.null(qqb0)) qqbounds(x,D,alpha,n,withConf.pw, withConf.sim,
+ exact.sCI,exact.pCI,nosym.pCI, debug) else qqb0
+
+ qqb$crit <- qqb$crit[SI.in,]
+
+ if(qqb$err["pw"]){
+ if(sum(SI.c)>0){
+ if(datax){
+ lines(x.c, qqb$crit[SI.c,"pw.right"],
+ col=col.pCI,lty=lty.pCI,lwd=lwd.pCI)
+ lines(x.c, qqb$crit[SI.c,"pw.left"],
+ col=col.pCI,lty=lty.pCI,lwd=lwd.pCI)
+ }else{
+ lines(qqb$crit[SI.c,"pw.right"], x.c,
+ col=col.pCI,lty=lty.pCI,lwd=lwd.pCI)
+ lines(qqb$crit[SI.c,"pw.left"], x.c,
+ col=col.pCI,lty=lty.pCI,lwd=lwd.pCI)
+ }
+ }
+ if(sum(!SI.c)>0){
+ if(datax){
+ points(x.d, qqb$crit[!SI.c,"pw.right"],
+ col=col.pCI, pch=pch.pCI, cex = cex.pCI)
+ points(x.d, qqb$crit[!SI.c,"pw.left"],
+ col=col.pCI, pch=pch.pCI, cex = cex.pCI)
+ }else{
+ points(qqb$crit[!SI.c,"pw.right"], x.d,
+ col=col.pCI, pch=pch.pCI, cex = cex.pCI)
+ points(qqb$crit[!SI.c,"pw.left"], x.d,
+ col=col.pCI, pch=pch.pCI, cex = cex.pCI)
+ }
+ }
+ }
+ if(qqb$err["sim"]){
+ if(sum(SI.c)>0){
+ if(datax){
+ lines(x.c, qqb$crit[SI.c,"sim.right"],
+ col=col.sCI,lty=lty.sCI,lwd=lwd.sCI)
+ lines(x.c, qqb$crit[SI.c,"sim.left"],
+ col=col.sCI,lty=lty.sCI,lwd=lwd.sCI)
+ }else{
+ lines(qqb$crit[SI.c,"sim.right"], x.c,
+ col=col.sCI,lty=lty.sCI,lwd=lwd.sCI)
+ lines(qqb$crit[SI.c,"sim.left"], x.c,
+ col=col.sCI,lty=lty.sCI,lwd=lwd.sCI)
+ }
+ }
+ if(sum(!SI.c)>0){
+ if(datax){
+ points(x.d, qqb$crit[!SI.c,"sim.right"],
+ col=col.sCI, pch=pch.sCI, cex = cex.sCI)
+ points(x.d, qqb$crit[!SI.c,"sim.left"],
+ col=col.sCI, pch=pch.sCI, cex = cex.sCI)
+ }else{
+ points(qqb$crit[!SI.c,"sim.right"], x.d,
+ col=col.sCI, pch=pch.sCI, cex = cex.sCI)
+ points(qqb$crit[!SI.c,"sim.left"], x.d,
+ col=col.sCI, pch=pch.sCI, cex = cex.sCI)
+ }
+ }
+ }
+ if(with.legend){
+ if( qqb$err["pw"] || qqb$err["sim"] ){
+ expression1 <- substitute(
+ legpf~nosym0~"pointw."~ex.p~alpha==alpha0~"%- conf. interval"~legpof,
+ list(legpf = legend.pref, legpof = legend.postf,
+ ex.p = if(exact.pCI) "exact" else "asympt.",
+ alpha0 = round(legend.alpha*100,2),
+ nosym0 = if(nosym.pCI&&exact.pCI) "shortest asymm." else "symm"))
+ expression2 <- substitute(
+ legpf~"simult."~ex.s~alpha==alpha0~"%- conf. interval"~legpof,
+ list(legpf = legend.pref, legpof = legend.postf,
+ ex.s = if(exact.sCI) "exact" else "asympt.",
+ alpha0 = round(legend.alpha*100,2)))
+
+ lcl <- list()
+ if(!qqb$err["sim"]){
+ expression3 <- expression1
+ lcl$pch <- if(sum(!SI.c)>0) pch.pCI else NULL
+ lcl$lty <- if(sum(SI.c)>0) lty.pCI else NULL
+ lcl$col <- col.pCI
+ lcl$lwd <- if(sum(SI.c)>0) 2 else NULL
+ }
+ if(!qqb$err["pw"]){
+ expression3 <- expression2
+ lcl$pch <- if(sum(!SI.c)>0) pch.sCI else NULL
+ lcl$lty <- if(sum(SI.c)>0) lty.sCI else NULL
+ lcl$col <- col.sCI
+ lcl$lwd <- if(sum(SI.c)>0) 2 else NULL
+ }
+ if( qqb$err["pw"] && qqb$err["sim"]){
+ expression3 <- eval(substitute(expression(expression1, expression2)))
+ lcl$pch <- if(sum(!SI.c)>0) c(pch.pCI, pch.sCI) else NULL
+ lcl$lty <- if(sum(SI.c)>0) c(lty.pCI, lty.sCI) else NULL
+ lcl$col <- c(col.pCI,col.sCI)
+ lcl$lwd <- if(sum(SI.c)>0) 2 else NULL
+ }
+ do.call(legend, c(list(legend.pos, legend = expression3, bg = legend.bg,
+ merge = FALSE, cex = legend.cex), lcl))
+ }
+ }
+ return(invisible(qqb))
+}
+
+.deleteItemsMCL <- function(mcl){
+ mcl$n <- NULL
+ mcl$col.IdL <- mcl$alpha.CI <- mcl$lty.IdL <- NULL
+ mcl$col.NotInSupport <- mcl$check.NotInSupport <- NULL
+ mcl$exact.sCI <- mcl$exact.pCI <- NULL
+ mcl$withConf <- mcl$withConf.sim <- mcl$withConf.pw <- NULL
+ mcl$withIdLine <- mcl$distance <- NULL
+ mcl$col.pCI <- mcl$lty.pCI <- mcl$col.sCI <- mcl$lty.sCI <- NULL
+ mcl$lwd.IdL <- mcl$lwd.pCI <- mcl$lwd.sCI <- NULL
+ mcl$withLab <- mcl$lab.pts <- mcl$which.lbs <- NULL
+ mcl$which.Order <- mcl$order.traf <- NULL
+ mcl$col.pch <- mcl$cex.pch <- mcl$jit.fac <- NULL
+ mcl$col.lbl <- mcl$cex.lbl <- mcl$adj.lbl <- NULL
+ mcl$exp.cex2.pch <- mcl$exp.cex2.lbl <- NULL
+ mcl$exp.fadcol.pch <- mcl$exp.fadcol.lbl <- NULL
+ mcl$nosym.pCI <- mcl$n.CI <- mcl$n.adj <- NULL
+ mcl$legend.cex <- mcl$with.legend <- mcl$legend.bg <- NULL
+ mcl$legend.pos <- mcl$legend.pref <- mcl$legend.postf <- NULL
+ mcl$legend.alpha <- NULL
+mcl}
+
+## helpers
+.inGaps <- function(x,gapm){
+ if(is.null(gapm)) return(rep(FALSE,length(x)))
+ fct <- function(x,m){ m[,2]>=x & m[,1]<=x}
+ sapply(x, function(y) length(which(fct(y,gapm)))>0)
+}
+
+.isReplicated <- function(x){
+ tx <- table(x)
+ rx <- as.numeric(names(tx[tx>1]))
+ sapply(x, function(y) any(abs(y-rx)<.Machine$double.eps))
+}
+
+.NotInSupport <- function(x,D){
+ if(length(x)==0) return(logical(0))
+ nInSupp <- which(x < q(D)(0))
+ nInSupp <- unique(sort(c(nInSupp,which(x > q(D)(1)))))
+
+ nInSuppo <-
+ if("support" %in% names(getSlots(class(D))))
+ which( ! x %in% support(D)) else numeric(0)
+ if("gaps" %in% names(getSlots(class(D)))){
+ InGap <- which( .inGaps(x,gaps(D)))
+ if("support" %in% names(getSlots(class(D))))
+ nInSupp <- unique(sort(c(nInSupp, intersect(InGap,nInSuppo))))
+ else
+ nInSupp <- unique(sort(c(nInSupp, InGap)))
+ }else{
+ nInSupp <- unique(sort(c(nInSupp, nInSuppo)))
+ }
+ return((1:length(x)) %in% nInSupp)
+}
+
+.SingleDiscrete <- function(x,D){
+ ## produces a logical vector of
+ ## 0 : discrete mass point
+ ## 1 : within continuous support
+ ## 2 : left gap point
+ ## 3 : right gap point
+ ## 4 : not in support
+ lx <- x * 0
+
+ lx[.NotInSupport(x,D)] <- 4
+
+ idx.0 <- ((x>q(D)(1)) | (x<q(D)(0)))
+ iG <- rep(FALSE,length(x))
+
+ if(is(D, "DiscreteDistribution")){
+ return(lx)
+ }
+ if("gaps" %in% names(getSlots(class(D)))){
+ if(!is.null(gaps(D))){
+ lx[apply(sapply(gaps(D)[,1], function(u) .isEqual(u,x)),1,any)] <- 2
+ lx[apply(sapply(gaps(D)[,2], function(u) .isEqual(u,x)),1,any)] <- 3
+ iG <- .inGaps(x,gaps(D))
+ lx[!idx.0 & !iG] <- 1
+ }else{
+ lx[!idx.0 & !iG] <- 1
+ }
+ }
+ if("support" %in% names(getSlots(class(D)))){
+ idx <- x %in% support(D)
+ if("acPart" %in% names(getSlots(class(D))))
+ idx.0 <- ((x>q.ac(D)(1)) | (x<q.ac(D)(0)))
+ lx[idx & (idx.0|iG)] <- 0
+ }
+
+ return(lx)
+}
+
+
+.makeLenAndOrder <- function(x,ord){
+ n <- length(ord)
+ x <- rep(x, length.out=n)
+ x[ord]
+}
+
+#------------------------------------------------------------------------------
+# .presubs : for titles etc
+#------------------------------------------------------------------------------
+
+.presubs <- function(inp, frompat, topat){
+### replaces in an expression or a string all frompat patterns to topat patterns
+
+logic <- FALSE
+inCx <- sapply(inp,
+ function(inpx){
+ inC <- deparse(inpx)
+ l <- length(frompat)
+ for(i in 1:l)
+ { if (is.language(topat[[i]])){
+ totxt <- deparse(topat[[i]])
+ totxt <- gsub("expression\\(", "\", ", gsub("\\)$",", \"",totxt))
+ if (length(grep(frompat[i],inC))) logic <<- TRUE
+ inC <- gsub(frompat[i],totxt,inC)
+ }else inC <- gsub(frompat[i], topat[[i]], inC)
+ }
+ return(inC)
+ })
+if(length(grep("expression",inCx))>0)
+ inCx <- gsub("expression\\(", "", gsub("\\)$","",inCx))
+if (length(inCx) > 1) {
+ inCx <- paste(inCx, c(rep(",", length(inCx)-1), ""),
+ sep = "", collapse = "\"\\n\",")
+ if ( any(as.logical(c(lapply(inp,is.language)))) | logic )
+ inCx <- paste("expression(paste(", gsub("\\\\n"," ", inCx), "))", sep ="")
+ else
+ inCx <- paste("paste(",inCx,")", sep ="")
+}else inCx <- paste("expression(paste(",inCx,"))",sep="")
+outC <- eval(parse(text = eval(inCx)))
+return(outC)
+}
+
+#---------------------------------------------------
+### from packages stats:
+#---------------------------------------------------
+format.perc <- function (probs, digits)
+paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits),
+ "%")
Modified: branches/distr-2.6/pkg/distrMod/R/AllPlot.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/AllPlot.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/AllPlot.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -47,7 +47,7 @@
iL <- length(to.draw[to.draw <= 3])+length(l2dpl)
iLD <- (1:iL)[to.draw <= 3]
iLL <- (1:iL)[to.draw > 3]
- inner <- distr:::.fillList(inner,iL)
+ inner <- .fillList(inner,iL)
innerD <- if(length(iLD)) inner[iLD] else NULL
innerL <- if(length(iLL)) inner[iLL] else NULL
}else{innerLog <- innerD <- innerL <- inner}
@@ -115,7 +115,7 @@
lineT <- NA
.mpresubs <- function(inx)
- distr:::.presubs(inx, c("%C", "%D", "%A"),
+ .presubs(inx, c("%C", "%D", "%A"),
c(as.character(class(x)[1]),
as.character(date()),
as.character(deparse(xc))))
Modified: branches/distr-2.6/pkg/distrMod/R/SimpleL2ParamFamilies.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/SimpleL2ParamFamilies.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/SimpleL2ParamFamilies.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -4,7 +4,7 @@
BinomFamily <- function(size = 1, prob = 0.5, trafo){
name <- "Binomial family"
distribution <- Binom(size = size, prob = prob)
- if(distr:::.isEqual(prob,0.5))
+ if(.isEqual(prob,0.5))
distrSymm <- SphericalSymmetry(SymmCenter = size*prob)
else
distrSymm <- NoSymmetry()
@@ -34,7 +34,7 @@
return(fct)}
L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob))
L2derivDistr <- UnivarDistrList((distribution - size*prob)/(prob*(1-prob)))
- if(distr:::.isEqual(prob,0.5))
+ if(.isEqual(prob,0.5))
L2derivDistrSymm <- DistrSymmList(SphericalSymmetry(SymmCenter = 0))
else
L2derivDistrSymm <- DistrSymmList(NoSymmetry())
Modified: branches/distr-2.6/pkg/distrMod/R/confint.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/confint.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/confint.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -26,7 +26,7 @@
### code borrowed from confint.default from package stats
a <- (1 - level)/2
a <- c(a, 1 - a)
- pct <- stats:::format.perc(a, 3)
+ pct <- format.perc(a, 3)
fac <- qnorm(a)
ci <- array(NA, dim = c(length(object at estimate), 2),
dimnames = list(names(object at estimate), pct)
Modified: branches/distr-2.6/pkg/distrMod/R/internalMleCalc.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/internalMleCalc.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/internalMleCalc.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -146,8 +146,6 @@
##########################################################################
-## caching to speed up things:
-.inArgs <- distr:::.inArgs
.callParamFamParameter <- function(PFam, theta, idx, nuis, fixed){
Modified: branches/distr-2.6/pkg/distrMod/R/qqplot.R
===================================================================
--- branches/distr-2.6/pkg/distrMod/R/qqplot.R 2014-07-28 10:52:52 UTC (rev 945)
+++ branches/distr-2.6/pkg/distrMod/R/qqplot.R 2014-07-28 11:09:12 UTC (rev 946)
@@ -30,14 +30,7 @@
}
-### helper functions from distr
-.confqq <- distr:::.confqq
-.isReplicated <- distr:::.isReplicated
-.makeLenAndOrder <- distr:::.makeLenAndOrder
-.inGaps <- distr:::.inGaps
-.deleteItemsMCL <- distr:::.deleteItemsMCL
-.NotInSupport <- distr:::.NotInSupport
setMethod("qqplot", signature(x = "ANY",
y = "UnivariateDistribution"),
More information about the Distr-commits
mailing list