[Robast-commits] r885 - pkg/RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 1 16:11:58 CEST 2016
Author: ruckdeschel
Date: 2016-09-01 16:11:58 +0200 (Thu, 01 Sep 2016)
New Revision: 885
Added:
pkg/RobAStBase/R/internalGridHelpers.R
Modified:
pkg/RobAStBase/R/00internal.R
pkg/RobAStBase/R/AllPlot.R
pkg/RobAStBase/R/AllShow.R
pkg/RobAStBase/R/bALEstimate.R
pkg/RobAStBase/R/comparePlot.R
pkg/RobAStBase/R/cutoff-class.R
pkg/RobAStBase/R/ddPlot.R
pkg/RobAStBase/R/ddPlot_utils.R
pkg/RobAStBase/R/getRiskBV.R
pkg/RobAStBase/R/infoPlot.R
pkg/RobAStBase/R/interpolRisks.R
pkg/RobAStBase/R/kStepEstimate.R
pkg/RobAStBase/R/kStepEstimator.R
pkg/RobAStBase/R/oneStepEstimator.R
pkg/RobAStBase/R/outlyingPlot.R
pkg/RobAStBase/R/plotRescaledAxis.R
pkg/RobAStBase/R/plotWrapper.R
pkg/RobAStBase/R/qqplot.R
pkg/RobAStBase/R/selectorder.R
Log:
R-Code updated from branch
Modified: pkg/RobAStBase/R/00internal.R
===================================================================
--- pkg/RobAStBase/R/00internal.R 2016-09-01 14:11:24 UTC (rev 884)
+++ pkg/RobAStBase/R/00internal.R 2016-09-01 14:11:58 UTC (rev 885)
@@ -6,6 +6,52 @@
paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits),
"%")
+.DistrCollapse <- function(support, prob,
+ eps = getdistrOption("DistrResolution")){
+ supp <- support
+ prob <- as.vector(prob)
+ suppIncr <- diff(c(supp[1]-2*eps,supp)) < eps
+ groups <- cumsum(!suppIncr)
+ prob <- as.vector(tapply(prob, groups, sum))
+ supp0 <- as.vector(tapply(supp, groups, quantile, probs = 0.5, type = 1))
+ reps <- .getRefIdx(supp,supp0,eps)
+# cat("III\n")
+# print(length(reps))
+# print(length(supp0))
+# cat("III\n")
+ ### in order to get a "support member" take the leftmost median
+ return(list(supp = supp0, prob = prob, groups=groups, reps = reps))
+# newDistribution <- DiscreteDistribution(supp=supp,prob=prob)
+# return(newDistribution)
+}
+
+.getRefIdx <- function(x,y, eps = getdistrOption("DistrResolution")){
+ ## x and y are sorted; y=unique(x) (modulo rounding)
+ ## wI gives the first index in x such that x is representing the group
+ wI <- y*0
+ j <- 1
+ rmin <- Inf
+ for(i in 1:length(wI)){
+ again <- TRUE
+ while(again&&j<=length(x)){
+ rmina <- abs(x[j]-y[i])
+ if(rmina< rmin-eps){
+ rmin <- rmina
+ wI[i] <- j
+ }else{
+ if(rmina>rmin+eps){
+ rmin <- Inf
+ again <- FALSE
+ j <- j-1
+ }
+ }
+ j <- j + 1
+ }
+ }
+ if(wI[i] == 0) wI[i] <- length(x)
+ return(wI)
+}
+
#------------------------------------------------------------------------------
### for distrXXX pre 2.5
#------------------------------------------------------------------------------
@@ -17,6 +63,8 @@
{as.character(arg) %in% names(formals(fct))}
.fillList <- function(list0, len = length(list0)){
+ if(is.null(list0)) return(vector("list",len))
+ if(!is.list(list0)) list0 <- list(list0)
if(len == length(list0))
return(list0)
i <- 0
@@ -128,3 +176,18 @@
}
+.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/RobAStBase/R/AllPlot.R
===================================================================
--- pkg/RobAStBase/R/AllPlot.R 2016-09-01 14:11:24 UTC (rev 884)
+++ pkg/RobAStBase/R/AllPlot.R 2016-09-01 14:11:58 UTC (rev 885)
@@ -3,20 +3,30 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
+ with.automatic.grid = TRUE,
with.legend = FALSE, legend = NULL, legend.bg = "white",
legend.location = "bottomright", legend.cex = 0.8,
withMBR = FALSE, MBRB = NA, MBR.fac = 2, col.MBR = par("col"),
lty.MBR = "dashed", lwd.MBR = 0.8,
- scaleX = FALSE, scaleX.fct, scaleX.inv,
+ x.vec = NULL, scaleX = FALSE, scaleX.fct, scaleX.inv,
scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
- mfColRow = TRUE, to.draw.arg = NULL){
+ mfColRow = TRUE, to.draw.arg = NULL, withSubst = TRUE){
xc <- match.call(call = sys.call(sys.parent(1)))$x
+ xcc <- as.character(deparse(xc))
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
+ .mpresubs <- if(withSubst){
+ function(inx)
+ .presubs(inx, c("%C", "%A", "%D" ),
+ c(as.character(class(x)[1]),
+ as.character(date()),
+ xcc))
+ }else function(inx)inx
+
if(!is.logical(inner)){
if(!is.list(inner))
inner <- as.list(inner)
@@ -52,10 +62,45 @@
if(!is.null(x.ticks)) dots$xaxt <- "n"
if(!is.null(y.ticks)){
- y.ticks <- .fillList(list(y.ticks), dims0)
+ y.ticks <- .fillList(y.ticks, dims0)
dots$yaxt <- "n"
}
+ scaleY.fct <- .fillList(scaleY.fct, dims0)
+ scaleY.inv <- .fillList(scaleY.inv, dims0)
+
+ pF <- expression({})
+ if(!is.null(dots[["panel.first"]])){
+ pF <- .panel.mingle(dots,"panel.first")
+ }
+ ..panelFirst <- .fillList(pF,dims0)
+ if(with.automatic.grid)
+ ..panelFirst <- .producePanelFirstS(
+ ..panelFirst,x, to.draw.arg, FALSE,
+ x.ticks = x.ticks, scaleX = scaleX, scaleX.fct = scaleX.fct,
+ y.ticks = y.ticks, scaleY = scaleY, scaleY.fct = scaleY.fct)
+ gridS <- if(with.automatic.grid)
+ substitute({grid <- function(...){}}) else expression({})
+ pF <- vector("list",dims0)
+ if(dims0>0)
+ for(i in 1:dims0){
+ pF[[i]] <- substitute({ gridS0
+ pF0},
+ list(pF0=..panelFirst[[i]], gridS0=gridS))
+ }
+
+ pL <- expression({})
+ if(!is.null(dots[["panel.last"]])){
+ pL <- .panel.mingle(dots,"panel.last")
+ }
+ ..panelLast <- .fillList(pL,dims0)
+ pL <- vector("list",dims0)
+ if(dims0>0)
+ for(i in 1:dims0)
+ pL[[i]] <- if(is.null(..panelLast[[i]])) expression({}) else ..panelLast[[i]]
+
+ dots$panel.last <- dots$panel.first <- NULL
+
MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
MBRB <- MBRB * MBR.fac
@@ -84,14 +129,28 @@
upper <- max(upper,xM)
}
h <- upper - lower
- x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
+ if(is.null(x.vec)){
+ if(scaleX){
+ xpl <- scaleX.fct(lower - 0.1*h)
+ xpu <- scaleX.fct(upper + 0.1*h)
+ xp.vec <- seq(from = xpl, to = xpu, length = 1000)
+ x.vec <- scaleX.inv(xp.vec)
+ }else{
+ x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
+ }
+ }
plty <- "l"
lty <- "solid"
}else{
- if(is(e1, "DiscreteDistribution")) x.vec <- support(e1)
- else{
- x.vec <- r(e1)(1000)
- x.vec <- sort(unique(x.vec))
+ if(!is.null(x.vec)){
+ if(is(distr, "DiscreteDistribution"))
+ x.vec <- intersect(x.vec,support(e1))
+ }else{
+ if(is(e1, "DiscreteDistribution")) x.vec <- support(e1)
+ else{
+ x.vec <- r(e1)(1000)
+ x.vec <- sort(unique(x.vec))
+ }
}
plty <- "p"
lty <- "dotted"
@@ -119,11 +178,6 @@
subL <- FALSE
lineT <- NA
- .mpresubs <- function(inx)
- .presubs(inx, c("%C", "%D", "%A"),
- c(as.character(class(x)[1]),
- as.character(date()),
- as.character(deparse(xc))))
if (hasArg(main)){
mainL <- TRUE
@@ -195,7 +249,7 @@
if(with.legend){
fac.leg <- if(dims0>1) 3/4 else .75/.8
if(missing(legend.location)){
- legend.location <- .fillList(list("bottomright"), dims0)
+ legend.location <- .fillList("bottomright", dims0)
}else{
legend.location <- as.list(legend.location)
legend.location <- .fillList(legend.location, dims0)
@@ -237,18 +291,33 @@
fct <- function(x) sapply(x, IC1 at Map[[indi]])
print(xlim[,i])
resc <-.rescalefct(x.vec, fct, scaleX, scaleX.fct,
- scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
ylim[,i], dots)
dots <- resc$dots
dots$xlim <- xlim[,i]
dots$ylim <- ylim[,i]
x.vec1 <- resc$X
y.vec1 <- resc$Y
+
+ finiteEndpoints <- rep(FALSE,4)
+ if(scaleX){
+ finiteEndpoints[1] <- is.finite(scaleX.inv(min(x.vec1, xlim[1,i])))
+ finiteEndpoints[2] <- is.finite(scaleX.inv(max(x.vec1, xlim[2,i])))
+ }
+ if(scaleY){
+ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(y.vec1, ylim[1,i])))
+ finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(y.vec1, ylim[2,i])))
+ }
+
+
do.call(plot, args=c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
- xlab = xlab, ylab = ylab), dots))
+ xlab = .mpresubs(xlab), ylab = .mpresubs(ylab),
+ panel.first = pF[[i]],
+ panel.last = pL[[i]]), dots))
.plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
- scaleY,scaleY.fct, scaleY.inv,
+ scaleY,scaleY.fct[[i]], scaleY.inv[[i]],
xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
+ finiteEndpoints = finiteEndpoints,
x.ticks = x.ticks, y.ticks = y.ticks[[i]])
if(withMBR){
MBR.i <- MBRB[i,]
@@ -258,7 +327,7 @@
if(is(e1, "DiscreteDistribution")){
x.vec1D <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
rescD <-.rescalefct(x.vec1D, fct, scaleX, scaleX.fct,
- scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
ylim[,i], dots)
x.vecD <- rescD$X
y.vecD <- rescD$Y
@@ -327,19 +396,25 @@
dots.without <- dots
dots.without$col <- dots.without$cex <- dots.without$pch <- NULL
+ dims0 <- .getDimsTD(L2Fam,dots[["to.draw.arg"]])
pL <- expression({})
if(!is.null(dots$panel.last))
- pL <- dots$panel.last
+ pL <- .panel.mingle(dots,"panel.last")
+ pL <- .fillList(pL, dims0)
+ if(dims0) for(i in 1:dims0){
+ if(is.null(pL[[i]])) pL[[i]] <- expression({})
+ }
dots$panel.last <- NULL
+
pL <- substitute({
y1 <- y0s
ICy <- sapply(y0s,ICMap0[[indi]])
- print(xlim[,i])
+ #print(xlim[,i])
resc.dat <-.rescalefct(y0s, function(x) sapply(x,ICMap0[[indi]]),
scaleX, scaleX.fct, scaleX.inv,
- scaleY, scaleY.fct, xlim[,i], ylim[,i],
+ scaleY, scaleY.fct[[i]], xlim[,i], ylim[,i],
dwo0)
y1 <- resc.dat$X
ICy <- resc.dat$Y
Modified: pkg/RobAStBase/R/AllShow.R
===================================================================
--- pkg/RobAStBase/R/AllShow.R 2016-09-01 14:11:24 UTC (rev 884)
+++ pkg/RobAStBase/R/AllShow.R 2016-09-01 14:11:58 UTC (rev 885)
@@ -136,9 +136,9 @@
if(is(oI,"IC"))
show(oI)
- else{oIC <- object[[i]]@Curve
+ else{oIC <- oI at Curve
for(j in 1:length(oIC))
show(oIC[[j]]@Map)
}
}
-})
\ No newline at end of file
+})
Modified: pkg/RobAStBase/R/bALEstimate.R
===================================================================
--- pkg/RobAStBase/R/bALEstimate.R 2016-09-01 14:11:24 UTC (rev 884)
+++ pkg/RobAStBase/R/bALEstimate.R 2016-09-01 14:11:58 UTC (rev 885)
@@ -1,163 +1,163 @@
-###############################################################################
-## Functions and methods for "ALEstimate" classes and subclasses
-###############################################################################
-
-setMethod("pIC", "ALEstimate", function(object) object at pIC)
-setMethod("asbias", "ALEstimate", function(object) object at asbias)
-setMethod("steps", "kStepEstimate", function(object) object at steps)
-setMethod("Mroot", "MEstimate", function(object) object at Mroot)
-
-setMethod("confint", signature(object="ALEstimate", method="missing"),
- function(object, method, level = 0.95) {
- objN <- paste(deparse(substitute(object)),sep="",collapse="")
-
- if(is.null(object at asvar)){
- cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
- return(NULL)
- }
-
- sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
- names(sd0) <- names(object at estimate)
-
-### code borrowed from confint.default from package stats
- a <- (1 - level)/2
- a <- c(a, 1 - a)
- 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))
- ci[] <- main(object) + sd0 %o% fac
-### end of borrowed code
-
- new("Confint", type = gettext("asymptotic (LAN-based)"),
- samplesize.estimate = object at samplesize,
- call.estimate = object at estimate.call,
- name.estimate = object at name,
- trafo.estimate = object at trafo,
- nuisance.estimate = nuisance(object),
- fixed.estimate = fixed(object),
- confint = ci)
-})
-
-setMethod("confint", signature(object="ALEstimate", method="symmetricBias"),
- function(object, method, level = 0.95) {
- objN <- paste(deparse(substitute(object)),sep="",collapse="")
-
- if(is.null(object at asvar)){
- cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
- return(NULL)
- }
- if(is.null(object at asbias)){
- cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
- return(confint(object))
- }
-
- sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
- names(sd0) <- names(object at estimate)
-
-### code borrowed from confint.default from package stats
- a <- (1 - level)/2
- a <- c(a, 1 - a)
- pct <- .format.perc(a, 3)
- fac <- qnorm(a, mean = c(-object at asbias, object at asbias))
- ci <- array(NA, dim = c(length(object at estimate), 2),
- dimnames = list(names(object at estimate), pct))
- ci[] <- main(object) + sd0 %o% fac
-### end of borrowed code
-
- new("Confint", type = c(
- gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
- gettextf("for %s", name(method))
- ),
- samplesize.estimate = object at samplesize,
- call.estimate = object at estimate.call,
- name.estimate = object at name,
- trafo.estimate = object at trafo,
- nuisance.estimate = nuisance(object),
- fixed.estimate = fixed(object),
- confint = ci)
-})
-
-setMethod("confint", signature(object="ALEstimate", method="onesidedBias"),
- function(object, method, level = 0.95) {
- objN <- paste(deparse(substitute(object)),sep="",collapse="")
-
- if(is.null(object at asvar)){
- cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
- return(NULL)
- }
- if(is.null(object at asbias)){
- cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
- return(confint(object))
- }
-
- sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
- names(sd0) <- names(object at estimate)
-
-### code borrowed from confint.default from package stats
- a <- (1 - level)/2
- a <- c(a, 1 - a)
- pct <- .format.perc(a, 3)
- if(method at sign == -1)
- M <- c(-object at asbias, 0)
- else
- M <- c(0, object at asbias)
- fac <- qnorm(a, mean = M)
- ci <- array(NA, dim = c(length(object at estimate), 2),
- dimnames = list(names(object at estimate), pct))
- ci[] <- main(object) + sd0 %o% fac
-### end of borrowed code
-
- new("Confint", type = c(
- gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
- gettextf("for %s", name(method))
- ),
- samplesize.estimate = object at samplesize,
- call.estimate = object at estimate.call,
- name.estimate = object at name,
- trafo.estimate = object at trafo,
- nuisance.estimate = nuisance(object),
- fixed.estimate = fixed(object),
- confint = ci)
-})
-
-setMethod("confint", signature(object="ALEstimate", method="asymmetricBias"),
- function(object, method, level = 0.95) {
- objN <- paste(deparse(substitute(object)),sep="",collapse="")
-
- if(is.null(object at asvar)){
- cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
- return(NULL)
- }
- if(is.null(object at asbias)){
- cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
- return(confint(object))
- }
-
- sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
- names(sd0) <- names(object at estimate)
-
-### code borrowed from confint.default from package stats
- a <- (1 - level)/2
- a <- c(a, 1 - a)
- pct <- .format.perc(a, 3)
- fac <- qnorm(a, mean = c(-object at asbias, object at asbias)/method at nu)
- ci <- array(NA, dim = c(length(object at estimate), 2),
- dimnames = list(names(object at estimate), pct))
- ci[] <- main(object) + sd0 %o% fac
-### end of borrowed code
-
- nuround <- round(nu,3)
- new("Confint", type = c(
- gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
- gettextf("for %s with nu =(%f,%f)",
- name(method), nuround[1], nuround[2])
- ),
- samplesize.estimate = object at samplesize,
- call.estimate = object at estimate.call,
- name.estimate = object at name,
- trafo.estimate = object at trafo,
- nuisance.estimate = nuisance(object),
- fixed.estimate = fixed(object),
- confint = ci)
-})
+###############################################################################
+## Functions and methods for "ALEstimate" classes and subclasses
+###############################################################################
+
+setMethod("pIC", "ALEstimate", function(object) object at pIC)
+setMethod("asbias", "ALEstimate", function(object) object at asbias)
+setMethod("steps", "kStepEstimate", function(object) object at steps)
+setMethod("Mroot", "MEstimate", function(object) object at Mroot)
+
+setMethod("confint", signature(object="ALEstimate", method="missing"),
+ function(object, method, level = 0.95) {
+ objN <- paste(deparse(substitute(object)),sep="",collapse="")
+
+ if(is.null(object at asvar)){
+ cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
+ return(NULL)
+ }
+
+ sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
+ names(sd0) <- names(object at estimate)
+
+### code borrowed from confint.default from package stats
+ a <- (1 - level)/2
+ a <- c(a, 1 - a)
+ 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))
+ ci[] <- main(object) + sd0 %o% fac
+### end of borrowed code
+
+ new("Confint", type = gettext("asymptotic (LAN-based)"),
+ samplesize.estimate = object at samplesize,
+ call.estimate = object at estimate.call,
+ name.estimate = object at name,
+ trafo.estimate = object at trafo,
+ nuisance.estimate = nuisance(object),
+ fixed.estimate = fixed(object),
+ confint = ci)
+})
+
+setMethod("confint", signature(object="ALEstimate", method="symmetricBias"),
+ function(object, method, level = 0.95) {
+ objN <- paste(deparse(substitute(object)),sep="",collapse="")
+
+ if(is.null(object at asvar)){
+ cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
+ return(NULL)
+ }
+ if(is.null(object at asbias)){
+ cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
+ return(confint(object))
+ }
+
+ sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
+ names(sd0) <- names(object at estimate)
+
+### code borrowed from confint.default from package stats
+ a <- (1 - level)/2
+ a <- c(a, 1 - a)
+ pct <- .format.perc(a, 3)
+ fac <- qnorm(a, mean = c(-object at asbias, object at asbias))
+ ci <- array(NA, dim = c(length(object at estimate), 2),
+ dimnames = list(names(object at estimate), pct))
+ ci[] <- main(object) + sd0 %o% fac
+### end of borrowed code
+
+ new("Confint", type = c(
+ gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
+ gettextf("for %s", name(method))
+ ),
+ samplesize.estimate = object at samplesize,
+ call.estimate = object at estimate.call,
+ name.estimate = object at name,
+ trafo.estimate = object at trafo,
+ nuisance.estimate = nuisance(object),
+ fixed.estimate = fixed(object),
+ confint = ci)
+})
+
+setMethod("confint", signature(object="ALEstimate", method="onesidedBias"),
+ function(object, method, level = 0.95) {
+ objN <- paste(deparse(substitute(object)),sep="",collapse="")
+
+ if(is.null(object at asvar)){
+ cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
+ return(NULL)
+ }
+ if(is.null(object at asbias)){
+ cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
+ return(confint(object))
+ }
+
+ sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
+ names(sd0) <- names(object at estimate)
+
+### code borrowed from confint.default from package stats
+ a <- (1 - level)/2
+ a <- c(a, 1 - a)
+ pct <- .format.perc(a, 3)
+ if(method at sign == -1)
+ M <- c(-object at asbias, 0)
+ else
+ M <- c(0, object at asbias)
+ fac <- qnorm(a, mean = M)
+ ci <- array(NA, dim = c(length(object at estimate), 2),
+ dimnames = list(names(object at estimate), pct))
+ ci[] <- main(object) + sd0 %o% fac
+### end of borrowed code
+
+ new("Confint", type = c(
+ gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
+ gettextf("for %s", name(method))
+ ),
+ samplesize.estimate = object at samplesize,
+ call.estimate = object at estimate.call,
+ name.estimate = object at name,
+ trafo.estimate = object at trafo,
+ nuisance.estimate = nuisance(object),
+ fixed.estimate = fixed(object),
+ confint = ci)
+})
+
+setMethod("confint", signature(object="ALEstimate", method="asymmetricBias"),
+ function(object, method, level = 0.95) {
+ objN <- paste(deparse(substitute(object)),sep="",collapse="")
+
+ if(is.null(object at asvar)){
+ cat(gettextf("Slot 'asvar' of object %s has not (yet) been filled.\n", objN))
+ return(NULL)
+ }
+ if(is.null(object at asbias)){
+ cat(gettextf("Slot 'asbias' of object %s has not (yet) been filled.\n", objN))
+ return(confint(object))
+ }
+
+ sd0 <- sqrt(diag(as.matrix(object at asvar))/object at samplesize)
+ names(sd0) <- names(object at estimate)
+
+### code borrowed from confint.default from package stats
+ a <- (1 - level)/2
+ a <- c(a, 1 - a)
+ pct <- .format.perc(a, 3)
+ fac <- qnorm(a, mean = c(-object at asbias, object at asbias)/method at nu)
+ ci <- array(NA, dim = c(length(object at estimate), 2),
+ dimnames = list(names(object at estimate), pct))
+ ci[] <- main(object) + sd0 %o% fac
+### end of borrowed code
+
+ nuround <- round(nu,3)
+ new("Confint", type = c(
+ gettext("asymptotic (LAN-based), uniform (bias-aware)\n"),
+ gettextf("for %s with nu =(%f,%f)",
+ name(method), nuround[1], nuround[2])
+ ),
+ samplesize.estimate = object at samplesize,
+ call.estimate = object at estimate.call,
+ name.estimate = object at name,
+ trafo.estimate = object at trafo,
+ nuisance.estimate = nuisance(object),
+ fixed.estimate = fixed(object),
+ confint = ci)
+})
Modified: pkg/RobAStBase/R/comparePlot.R
===================================================================
--- pkg/RobAStBase/R/comparePlot.R 2016-09-01 14:11:24 UTC (rev 884)
+++ pkg/RobAStBase/R/comparePlot.R 2016-09-01 14:11:58 UTC (rev 885)
@@ -6,30 +6,32 @@
col = par("col"), lwd = par("lwd"), lty,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
+ with.automatic.grid = TRUE,
with.legend = FALSE, legend = NULL, legend.bg = "white",
legend.location = "bottomright", legend.cex = 0.8,
withMBR = FALSE, MBRB = NA, MBR.fac = 2, col.MBR = par("col"),
lty.MBR = "dashed", lwd.MBR = 0.8,
- scaleX = FALSE, scaleX.fct, scaleX.inv,
+ x.vec = NULL, scaleX = FALSE, scaleX.fct, scaleX.inv,
scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
- cex.pts = 1, col.pts = par("col"),
+ cex.pts = 1, cex.pts.fun = NULL, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
- which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+ which.lbs = NULL, which.Order = NULL, return.Order = FALSE,
+ withSubst = TRUE){
.mc <- match.call(call = sys.call(sys.parent(1)))
.xc<- function(obj) as.character(deparse(.mc[[obj]]))
xc <- c(.xc("obj1"), .xc("obj2"))
if(!is.null(obj3)) xc <- c(xc, .xc("obj3"))
if(!is.null(obj4)) xc <- c(xc, .xc("obj4"))
-
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
dotsP <- dots
dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
-
+ dots.points <- .makedotsPt(dots)
+
ncomp <- 2+ (!missing(obj3)|!is.null(obj3)) +
(!missing(obj4)|!is.null(obj4))
@@ -78,10 +80,18 @@
if(!is.null(x.ticks)) dotsP$xaxt <- "n"
if(!is.null(y.ticks)){
- y.ticks <- .fillList(list(y.ticks), dims0)
+ y.ticks <- .fillList(y.ticks, dims0)
dotsP$yaxt <- "n"
}
+ if(!is.null(cex.pts.fun)){
+ cex.pts.fun <- .fillList(cex.pts.fun, dims0*ncomp)
+ }
+
+
+ scaleY.fct <- .fillList(scaleY.fct, dims0)
+ scaleY.inv <- .fillList(scaleY.inv, dims0)
+
MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
MBRB <- MBRB * MBR.fac
@@ -107,13 +117,27 @@
upper <- max(upper,xM)
}
h <- upper - lower
- x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
+ if(is.null(x.vec)){
+ if(scaleX){
+ xpl <- scaleX.fct(lower - 0.1*h)
+ xpu <- scaleX.fct(upper + 0.1*h)
+ xp.vec <- seq(from = xpl, to = xpu, length = 1000)
+ x.vec <- scaleX.inv(xp.vec)
+ }else{
+ x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
+ }
+ }
plty <- "l"
if(missing(lty)) lty <- "solid"
}else{
- if(is(distr, "DiscreteDistribution")) x.vec <- support(distr) else{
- x.vec <- r(distr)(1000)
- x.vec <- sort(unique(x.vec))
+ if(!is.null(x.vec)){
+ if(is(distr, "DiscreteDistribution"))
+ x.vec <- intersect(x.vec,support(distr))
+ }else{
+ if(is(distr, "DiscreteDistribution")) x.vec <- support(distr) else{
+ x.vec <- r(distr)(1000)
+ x.vec <- sort(unique(x.vec))
+ }
}
plty <- "p"
if(missing(lty)) lty <- "dotted"
@@ -147,7 +171,8 @@
lineT <- NA
- .mpresubs <- function(inx)
+
+ .mpresubs <- if(withSubst){function(inx)
.presubs(inx, c(paste("%C",1:ncomp,sep=""),
"%D",
paste("%A",1:ncomp,sep="")),
@@ -156,7 +181,7 @@
if(is.null(obj3))NULL else as.character(class(obj3)[1]),
if(is.null(obj4))NULL else as.character(class(obj4)[1]),
as.character(date()),
- xc))
+ xc))} else function(inx)inx
mainL <- FALSE
if (hasArg(main)){
@@ -231,7 +256,31 @@
dotsT$main <- dotsT$cex.main <- dotsT$col.main <- dotsT$line <- NULL
- pL <- if(!is.null(dotsP$panel.last)) dotsP$panel.last else expression({})
+ pF <- expression({})
+ if(!is.null(dots[["panel.first"]])){
+ pF <- .panel.mingle(dots,"panel.first")
+ }
+ ..panelFirst <- .fillList(pF,dims0)
+ if(with.automatic.grid)
+ ..panelFirst <- .producePanelFirstS(
+ ..panelFirst,obj1 , to.draw.arg, FALSE,
+ x.ticks = x.ticks, scaleX = scaleX, scaleX.fct = scaleX.fct,
+ y.ticks = y.ticks, scaleY = scaleY, scaleY.fct = scaleY.fct)
+ gridS <- if(with.automatic.grid)
+ substitute({grid <- function(...){}}) else expression({})
+ pF <- vector("list",dims0)
+ if(dims0>0)
+ for(i in 1:dims0){
+ pF[[i]] <- substitute({ gridS0
+ pF0},
+ list(pF0=..panelFirst[[i]], gridS0=gridS))
+ }
+ dots$panel.first <- NULL
+ pL <- expression({})
+ if(!is.null(dots[["panel.last"]])){
+ pL <- .panel.mingle(dots,"panel.last")
+ }
+ pL <- .fillList(pL, dims0)
dotsP$panel.last <- NULL
sel1 <- sel2 <- sel3 <- sel4 <- NULL
@@ -253,9 +302,14 @@
return(.SelectOrderData(data, fct.aI, which.lbs, which.Order))}
sel1 <- def.sel(IC1); sel2 <- def.sel(IC2)
+ selAlly <- c(sel1$y,sel2$y)
- if(is(obj3, "IC")) sel3 <- def.sel(IC3)
- if(is(obj4, "IC")) sel4 <- def.sel(IC4)
+ if(is(obj3, "IC")){ sel3 <- def.sel(IC3)
+ selAlly <- c(selAlly,sel3$y)
+ }
+ if(is(obj4, "IC")){ sel4 <- def.sel(IC4)
+ selAlly <- c(selAlly,sel4$y)
+ }
dots.points <- .makedotsLowLevel(dots)
dots.points$col <- dots.points$cex <- dots.points$pch <- NULL
@@ -264,7 +318,7 @@
pL <- substitute({
doIt <- function(sel.l,fct.l,j.l){
rescd <- .rescalefct(sel.l$data, fct.l, scaleX, scaleX.fct,
- scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
ylim[,i], dotsP)
if(is(distr, "DiscreteDistribution"))
rescd$Y <- jitter(rescd$Y, factor = jitter.fac0[j.l])
@@ -275,7 +329,10 @@
col.l <- if(is.na(al0[j.l])) col0[j.l] else
addAlphTrsp2col(col0[j.l], al0[j.l])
- cex.l <- log(sel.l$y+1)*3*cex0[j.l]
+
+ cfun <- if(is.null(cexfun)) NULL else cexfun[[(i-1)*ncomp+j.l]]
+
+ cex.l <- .cexscale(sel.l$y,selAlly,cex=cex0[j.l], fun = cfun) ##.cexscale in infoPlot.R
do.call(points, args=c(list(rescd$X, rescd$Y, cex = cex.l,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 885
More information about the Robast-commits
mailing list