[Robast-commits] r531 - in branches/robast-0.9/pkg/RobAStBase: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Jan 12 15:41:38 CET 2013
Author: ruckdeschel
Date: 2013-01-12 15:41:38 +0100 (Sat, 12 Jan 2013)
New Revision: 531
Modified:
branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R
branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R
branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R
branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R
branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R
branches/robast-0.9/pkg/RobAStBase/man/comparePlot.Rd
branches/robast-0.9/pkg/RobAStBase/man/cutoff.Rd
branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-0.9/pkg/RobAStBase/man/plot-methods.Rd
Log:
RobAStBase: finished debugging;remains to find good examples
Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-01-12 14:41:38 UTC (rev 531)
@@ -57,18 +57,6 @@
}
MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
-
-# Code only useable from ROptEst on...
-#
-# if(withMBR && all(is.na(MBRB))){
-# robModel <- InfRobModel(center = L2fam, neighbor =
-# ContNeighborhood(radius = 0.5))
-# ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE)
-# if(!is(ICmbr,"try-error"))
-# MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), todraw)
-# else withMBR <- FALSE
-# }
-
MBRB <- MBRB * MBR.fac
e1 <- L2Fam at distribution
@@ -79,6 +67,9 @@
if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
+ if(!length(xlim) %in% c(2,2*dims0))
+ stop("Wrong length of Argument xlim");
+ xlim <- matrix(xlim, 2,dims0)
}
if(is(e1, "AbscontDistribution")){
lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
@@ -105,7 +96,7 @@
plty <- "p"
lty <- "dotted"
if(!is.null(dots$xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
-
+
}
}
ylim <- eval(dots$ylim)
@@ -244,15 +235,17 @@
indi <- to.draw[i]
if(!is.null(ylim)) dots$ylim <- ylim[,i]
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],
ylim[,i], dots)
dots <- resc$dots
+ dots$xlim <- xlim[,i]
+ dots$ylim <- ylim[,i]
x.vec1 <- resc$X
y.vec1 <- resc$Y
- do.call(plot, args=c(list(x.vec1, y.vec1, type = plty, lty = lty,
- xlab = xlab, ylab = ylab, dots)))
-
+ do.call(plot, args=c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
+ xlab = xlab, ylab = ylab), dots))
.plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
scaleY,scaleY.fct, scaleY.inv,
xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
@@ -264,9 +257,9 @@
}
if(is(e1, "DiscreteDistribution")){
x.vec1D <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
- rescD <-.rescalefct(x.vecD, fct, scaleX, scaleX.fct,
+ rescD <-.rescalefct(x.vec1D, fct, scaleX, scaleX.fct,
scaleX.inv, scaleY, scaleY.fct, xlim[,i],
- ylim[,i], dotsP)
+ ylim[,i], dots)
x.vecD <- rescD$X
y.vecD <- rescD$Y
@@ -282,14 +275,14 @@
legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
}
- if(!hasArg(cex.main)) cex.main <- par("cex.main") else cex.main <- dots$"cex.main"
- if(!hasArg(col.main)) col.main <- par("col.main") else col.main <- dots$"col.main"
+ cex.main <- if(!hasArg(cex.main)) par("cex.main") else dots$"cex.main"
+ col.main <- if(!hasArg(col.main)) par("col.main") else dots$"col.main"
if (mainL)
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
- if(!hasArg(cex.sub)) cex.sub <- par("cex.sub") else cex.sub <- dots$"cex.sub"
- if(!hasArg(col.sub)) col.sub <- par("col.sub") else col.sub <- dots$"col.sub"
+ cex.sub <- if(!hasArg(cex.sub)) par("cex.sub") else dots$"cex.sub"
+ col.sub <- if(!hasArg(col.sub)) par("col.sub") else dots$"col.sub"
if (subL)
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
@@ -301,8 +294,9 @@
setMethod("plot", signature(x = "IC",y = "numeric"),
function(x, y, ..., cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
- which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
+ which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
@@ -310,6 +304,7 @@
pch.pts <- rep(pch.pts, length.out=n)
lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,n)
+
L2Fam <- eval(x at CallL2Fam)
trafO <- trafo(L2Fam at param)
dims <- nrow(trafO)
@@ -327,12 +322,12 @@
which.lbs, which.Order)
i.d <- sel$ind
i0.d <- sel$ind1
- x.d <- sel$data
n <- length(i.d)
dots.without <- dots
dots.without$col <- dots.without$cex <- dots.without$pch <- NULL
+
pL <- expression({})
if(!is.null(dots$panel.last))
pL <- dots$panel.last
@@ -341,15 +336,18 @@
pL <- substitute({
y1 <- y0s
ICy <- sapply(y0s,ICMap0[[indi]])
+ print(xlim[,i])
resc.dat <-.rescalefct(y0s, function(x) sapply(x,ICMap0[[indi]]),
scaleX, scaleX.fct, scaleX.inv,
- scaleY, scaleY.fct, dwo0$xlim, dwo0$ylim, dwo0)
+ scaleY, scaleY.fct, xlim[,i], ylim[,i],
+ dwo0)
y1 <- resc.dat$X
ICy <- resc.dat$Y
if(is(e1, "DiscreteDistribution"))
ICy <- jitter(ICy, factor = jitter.fac0)
+ if(!is.na(al0)) col0 <- sapply(col0, addAlphTrsp2col,alpha=al0)
do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0,
col = col0, pch = pch0), dwo0))
@@ -358,10 +356,10 @@
cex = log(absy0+1)*1.5*cex0, col = col0)
}
pL0
- }, list(pL0 = pL, ICMap0 = ICMap, y0s = x.d, absy0 = absInfo0,
+ }, list(pL0 = pL, ICMap0 = ICMap, y0s = sel$data, absy0 = sel$y,
dwo0 = dots.without, cex0 = cex.pts, pch0 = pch.pts[i.d],
col0 = col.pts, with.lab0 = with.lab, lab.pts0 = lab.pts[i.d],
- jitter.fac0 = jitter.fac
+ al0 = alpha.trsp, jitter.fac0 = jitter.fac
))
do.call("plot", args = c(list(x = x, panel.last = pL), dots))
Modified: branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R 2013-01-12 14:41:38 UTC (rev 531)
@@ -1,3 +1,4 @@
+.makeLenAndOrder <- distr:::.makeLenAndOrder
setMethod("comparePlot", signature("IC","IC"),
function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
..., withSweave = getdistrOption("withSweave"),
@@ -15,11 +16,11 @@
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
- .xc <- function(obj) as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))[[obj]]))
+ .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"))
@@ -87,6 +88,7 @@
if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
+ xlim <- matrix(xlim, 2,dims0)
}
if(is(distr, "AbscontDistribution")){
lower0 <- getLow(distr, eps = getdistrOption("TruncQuantile")*2)
@@ -233,7 +235,7 @@
absInfoEval <- function(x,IC){
QF <- ID
- if(is(object,"ContIC") & dims>1 ){
+ if(is(IC,"ContIC") & dims>1 ){
if (is(normtype(object),"QFNorm"))
QF <- QuadForm(normtype(object))
}
@@ -249,8 +251,9 @@
if(is(obj3, "IC")) sel3 <- def.sel(IC3)
if(is(obj4, "IC")) sel4 <- def.sel(IC4)
- dots.points <- .makeLowLevel(dots)
+ dots.points <- .makedotsLowLevel(dots)
dots.points$col <- dots.points$cex <- dots.points$pch <- NULL
+ alp.v <- rep(alpha.trsp,length.out = ncomp)
pL <- substitute({
doIt <- function(sel.l,fct.l,j.l){
@@ -263,19 +266,22 @@
n.l <- length(i.l)
pch.pts.l <- rep(pch0, length.out=n.l)
lab.pts.l <- if(is.null(lab0)) paste(i.l) else lab0[i.l]
+
+ 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]
do.call(points, args=c(list(rescd$X, rescd$Y, cex = cex.l,
- col = col0[j.l], pch = pch.pts.l), dwo0))
+ col = col.l, pch = pch.pts.l), dwo0))
if(with.lab0)
- text(rescd$X, rescd$Y, labels = lab.pts0.l,
- cex = cex.l/2, col = col0[j.l])
+ text(rescd$X, rescd$Y, labels = lab.pts.l,
+ cex = cex.l/2, col = col.l)
}
doIt(sel1,fct1,1); doIt(sel2,fct2,2)
- if(!is.null(obj30)) doIt(sel3,fct3,2)
- if(!is.null(obj40)) doIt(sel4,fct4,4)
+ if(is(obj3, "IC")) doIt(sel3,fct3,3)
+ if(is(obj4, "IC")) doIt(sel4,fct4,4)
pL0
}, list(pL0 = pL, cex0 = cex.pts, pch0 = pch.pts, col0 = col.pts,
- jitter.fac0 = jitter.fac, dwo0 = dots.points,
+ jitter.fac0 = jitter.fac, dwo0 = dots.points, al0 = alp.v,
with.lab0 = with.lab, lab0 = lab.pts)
)
}
@@ -301,18 +307,18 @@
if(is(obj3, "IC")){
resc.args$fc <- fct3 <- function(x) sapply(x, IC3 at Map[[indi]])
- resc2 <- do.call(.rescalefct, resc.args)
+ resc3 <- do.call(.rescalefct, resc.args)
matp <- cbind(matp,resc3$Y)
}
if(is(obj4, "IC")){
resc.args$fc <- fct4 <- function(x) sapply(x, IC4 at Map[[indi]])
- resc2 <- do.call(.rescalefct, resc.args)
+ resc4 <- do.call(.rescalefct, resc.args)
matp <- cbind(matp,resc4$Y)
}
- do.call(plot, args=c(x = resc1$X, y = matp[,1],
+ do.call(plot, args=c(list(x = resc1$X, y = matp[,1],
type = plty, lty = lty, col = col[1], lwd = lwd,
- xlab = xlab, ylab = ylab, dotsP, list(panel.last = pL)))
+ xlab = xlab, ylab = ylab), dotsP, list(panel.last = pL)))
do.call(matlines, args = c(list( x = resc1$X, y = matp[,-1],
lty = lty, col = col[-1], lwd = lwd), dotsL))
Modified: branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R 2013-01-12 14:41:38 UTC (rev 531)
@@ -38,7 +38,7 @@
if(missing(lab.pts)|| is.null(lab.pts)){
- lab.pts <- if(!is.null(colnames(data))) colnames(data) else 1:ncol(data)
+ lab.pts <- if(!is.null(colnames(data))) colnames(data) else id.n1
}
data <- data[,id.n, drop = FALSE]
@@ -63,6 +63,13 @@
if(is.null(dots$xlab)) dots$xlab <- name(dist.x)
if(is.null(dots$ylab)) dots$ylab <- name(dist.y)
+ if(!is.null(dots$log)){
+ if(grepl("x",dots$log)) dots$xlab <- paste(dots$xlab, "(log-scale)",
+ sep=" ")
+ if(grepl("y",dots$log)) dots$ylab <- paste(dots$ylab, "(log-scale)",
+ sep=" ")
+ }
+
if(is.null(cutoff.quantile.x))
cutoff.quantile.x <- 0.95
@@ -87,18 +94,32 @@
ndata.x <- fct(dist.x)(data.x)
ndata.y <- fct(dist.y)(data.y)
- print(ndata.x)
+# print(head(ndata.x))
+ co.x <- fct(cutoff.x)(data.x)
+ co.y <- fct(cutoff.y)(data.y)
+
if(is.null(adj)) adj <- 0
- if(is.null(cex.idn)) cex.idn <- 1
- if(is.null(col.idn)) col.idn <- par("col")
- if(is.null(col.cutoff)) col.cutoff <- "red"
+ if(missing(cex.idn)||is.null(cex.idn))
+ cex.idn <- if(is.null(dots$cex)) 1 else dots$cex
+ if(missing(col.idn)||is.null(col.idn))
+ col.idn <- if(is.null(dots$col)) par("col") else dots$col
+
if(is.null(dots$lwd)) dots$lwd <- par("lwd")
if(is.null(dots$lty)) dots$lty <- par("lty")
+ col.cutoff <- rep(col.cutoff,length.out=2)
+ if(missing(lty.cutoff) && !is.null(dots$lty)) lty.cutoff <- dots$lty
+ if(missing(lwd.cutoff) && !is.null(dots$lwd)) lwd.cutoff <- dots$lwd
+ if(missing(cex.abline) && !is.null(dots$cex)) cex.abline <- dots$cex
+ if(missing(adj.abline) && !is.null(dots$adj)) lty.abline <- dots$adj
+ if(missing(font.abline) && !is.null(dots$font)) font.abline <- dots$font
pdots <- .makedotsLowLevel(dots)
+ pdots$xlab <- dots$xlab
+ pdots$ylab <- dots$ylab
+ pdots$nsim <- NULL
pdots$x <- NULL
pdots$y <- NULL
pdots$offset <- NULL
@@ -106,16 +127,65 @@
pdots$untf <- NULL
abdots <- .makedotsAB(dots)
- abdots$col <- col.cutoff
+ if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff[[1]]
+ if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff[1]
+ abdots$col <- col.cutoff[1]
+ abdots$jitt.fac <- dots$jitt.fac
+
+ abdots <- list(abdots,abdots)
+ abdots$jitt.fac <- pdots$jitt.fac
+
+ if(!is.null(abdots$lty))
+ if(is.list(lty.cutoff)) abdots[[2]]$lty <- lty.cutoff[[2]]
+ if(!is.null(abdots$lwd))
+ if(length(lwd.cutoff)>1) abdots[[2]]$lwd <- lwd.cutoff[2]
+
+ ab.textL <- rep(text.abline,length.out=2)
+ abtdots.x <- abtdots.y <- vector("list",0)
+ cex.abline <- rep(cex.abline, length.out = 2)
+ col.abline <- rep(if(!is.null(col.abline))
+ col.abline else "red", length.out = 2)
+ font.abline <- rep(font.abline, length.out = 2)
+ adj.abline <- matrix(rep(adj.abline,length.out=4),2,2)
+
+
+ .mpresubs <- function(inx)
+ .presubs(inx, c("%qx", "%qy", "%cx", "%cy"),
+ c(gettextf(text.abline.x.fmt.qx,
+ round(cutoff.quantile.x*100,1)),
+ gettextf(text.abline.y.fmt.qy,
+ round(cutoff.quantile.y*100,1)),
+ gettextf(text.abline.x.fmt.cx,
+ round(co.x,2)),
+ gettextf(text.abline.y.fmt.cy,
+ round(co.y,2))))
+
if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff
if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff
abdots$jitt.fac <- dots$jitt.fac
- adots <- pdots
- adots$col <- pdots$col.axis
- adots$lty <- pdots$lty.axis
- adots$adj <- par("adj")
+ abtdots.x$labels <- if(! is.null(text.abline.x))
+ .mpresubs(text.abline.x) else gettextf(
+ paste(text.abline.x.fmt.qx,"-cutoff = ",
+ text.abline.x.fmt.cx,sep=""),
+ cutoff.quantile.x*100,round(co.x,digits=2))
+ abtdots.x$cex <- cex.abline[1]
+ abtdots.x$col <- col.abline[1]
+ abtdots.x$font <- font.abline[1]
+ abtdots.x$srt <- NULL
+ abtdots.x$adj <- adj.abline[,1]
+ abtdots.y$labels <- if(! is.null(text.abline.y))
+ .mpresubs(text.abline.y) else gettextf(
+ paste(text.abline.y.fmt.qy,"-cutoff = ",
+ text.abline.y.fmt.cy,sep=""),
+ cutoff.quantile.y*100,round(co.y,digits=2))
+ abtdots.y$cex <- cex.abline[2]
+ abtdots.y$col <- col.abline[2]
+ abtdots.y$font <- font.abline[2]
+ abtdots.y$srt <- NULL
+ abtdots.y$adj <- adj.abline[,2]
+
tdots <- .makedotsT(dots)
tdots$cex <- cex.idn
tdots$col <- col.idn
@@ -132,13 +202,9 @@
adots$adj <- par("adj")
pdots$axes <- FALSE
- pdots$log <- dots$log
pdots$adj <- par("adj")
-
####
- co.x <- fct(cutoff.x)(data.x)
- co.y <- fct(cutoff.y)(data.y)
# print(quantile(ndata.x))
# print(co.x)
# print(fct(cutoff.x))
@@ -166,25 +232,31 @@
id0.xy <- id.n1[id.xy]
id0.x <- id.n1[id.x]
id0.y <- id.n1[id.y]
+ do.call(plot, args = c(list(x = ndata.x, y=ndata.y, type = "p"), pdots))
+ do.call(box,args=c(adots))
- do.call(plot, args = c(list(x = ndata.x,ndata.y, type = "p"), pdots))
+ pusr <- par("usr")
+ mid.x <- mean(pusr[c(1,2)])
+ mid.y <- mean(pusr[c(3,4)])
+ abtdots.y$x <- if(is.null(text.abline.y.x)) mid.x else text.abline.y.x
+ abtdots.x$y <- if(is.null(text.abline.x.y)) mid.y else text.abline.x.y
- do.call(box,args=c(adots))
+ do.call(abline, args = c(list(v=co.x), abdots[[1]]))
+ do.call(abline, args = c(list(h=co.y), abdots[[2]]))
- mid.y = 0.5*(max(ndata.y)-min(ndata.y))
- mid.x = 0.5*(max(ndata.x)-min(ndata.x))
+ if(ab.textL[1])
+ do.call(text, args = c(list(y=co.y*1.03), abtdots.y))
+# do.call(text, args = c(list(co.x-5,mid.y,paste(cutoff.quantile.y*100,"%-cutoff = ",round(co.x,digits=2)),srt=90)))
+ if(ab.textL[2])
+ do.call(text, args = c(list(x=co.x*1.03), abtdots.x,srt=90))
+# do.call(text, args = c(list(mid.x,co.y+5,paste(cutoff.quantile.x*100," %-cutoff = ",round(co.y,digits=2)))))
- do.call(abline, args = c(list(h=co.y), abdots))
- do.call(text, args = c(list(co.x-5,mid.y,paste(cutoff.quantile.y*100,"%-cutoff = ",round(co.x,digits=2)),srt=90)))
- do.call(abline, args = c(list(v=co.x), abdots))
- do.call(text, args = c(list(mid.x,co.y+5,paste(cutoff.quantile.x*100," %-cutoff = ",round(co.y,digits=2)))))
-
if(length(id.xy))
do.call(text, args = c(list(jitter(ndata.x[id.xy],factor=jitt.fac),
jitter(ndata.y[id.xy],factor=jitt.fac),
- labels=lab.pts[id.xy]), tdots))
+ labels=lab.pts[id.xy]), tdots))
#axis(side=4)
- axis(side=1)
+# axis(side=1)
return(list(id.x=id0.x, id.y= id0.y, id.xy = id0.xy,
qtx = quantile(ndata.x), qty = quantile(ndata.y),
Modified: branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-01-12 14:41:38 UTC (rev 531)
@@ -14,7 +14,7 @@
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, return.Order = FALSE,
ylab.abs = "absolute information",
ylab.rel= "relative information"){
@@ -32,9 +32,9 @@
dots["type"] <- NULL
- if(!is.null(dots[["xlab"]])) xlab0 <- dots[["xlab"]]
- dots["ylab"] <- NULL
-
+ xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
+ dots$xlab <- dots$ylab <- NULL
+
trafO <- trafo(L2Fam at param)
dims <- nrow(trafO)
dimm <- ncol(trafO)
@@ -127,7 +127,7 @@
dotsP$type <- dotsP$lty <- dotsP$col <- dotsP$lwd <- NULL
dotsP$xlab <- dotsP$ylab <- NULL
- dotsL <- .makeLowLevel(dotsP)
+ dotsL <- .makedotsLowLevel(dotsP)
dotsT <- dotsL
dotsT["main"] <- dotsT["cex.main"] <- dotsT["col.main"] <- NULL
dotsT["line"] <- NULL
@@ -326,6 +326,10 @@
dots.points))
tx <- function(xa,ya,lb,cx,ca)
text(x=xa,y=ya,labels=lb,cex=cx, col=ca)
+
+ alp.v <- rep(alpha.trsp, length.out = dims0+in1to.draw)
+
+
pL.abs <- substitute({
if(is(distr, "DiscreteDistribution")){
ICy0 <- jitter(ICy0, factor = jitter.fac0[1])
@@ -333,6 +337,10 @@
}
f1 <- log(ICy0+1)*3*cex0[1]
f1c <- log(ICy0c+1)*3*cex0[2]
+
+ if(!is.na(al0))
+ col0 <- sapply(col0, addAlphTrsp2col,alpha=al0)
+
do.pts(y0, ICy0, f1,col0[1],pch0[,1])
do.pts(y0c, ICy0c, f1c,col0[2],pch0[,2])
if(with.lab0){
@@ -342,7 +350,7 @@
pL0
}, list(ICy0 = y.d, ICy0c = y.dC,
pL0 = pL, y0 = x.d, y0c = x.dC,
- cex0 = cex.pts, pch0 = pch.pts,
+ cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v[1],
col0 = col.pts, with.lab0 = with.lab, n0 = n,
lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC],
jitter.fac0 = jitter.fac)
@@ -357,16 +365,20 @@
}
f1 <- log(ICy0+1)*3*cex0[1]
f1c <- log(ICy0c+1)*3*cex0[2]
+
+ if(!is.na(al0))
+ col0 <- sapply(col0, addAlphTrsp2col, alpha=al0[i1])
+
do.pts(y0, y0.vec, f1,col0[1],pch0[,1])
do.pts(y0c, y0c.vec, f1c,col0[2],pch0[,2])
if(with.lab0){
- text(y0, y0.vec, lab.pts0, f1/2, col0[1])
- text(y0c, y0c.vec, lab.pts0C, f1c/2, col0[2])
+ tx(y0, y0.vec, lab.pts0, f1/2, col0[1])
+ tx(y0c, y0c.vec, lab.pts0C, f1c/2, col0[2])
}
pL0
}, list(ICy0c = y.dC, ICy0 = y.d,
pL0 = pL, y0 = x.d, y0c = x.dC,
- cex0 = cex.pts, pch0 = pch.pts,
+ cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v,
col0 = col.pts, with.lab0 = with.lab,n0 = n,
lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC],
jitter.fac0 = jitter.fac
@@ -392,7 +404,7 @@
do.call(plot, args=c(list(resc$X, resc$Y, type = plty,
lty = ltyI, col = colI, lwd = lwdI,
- xlab = xlab0, ylab = ylab.abs, panel.last = pL.abs),
+ xlab = xlab, ylab = ylab.abs, panel.last = pL.abs),
dotsP1))
do.call(lines, args=c(list(resc.C$X, resc.C$Y, type = plty,
lty = lty, lwd = lwd, col = col), dotsL))
@@ -427,6 +439,7 @@
classIC.i.5 <- QFc.5%*%classIC
for(i in 1:dims0){
indi <- to.draw1[i]-1
+ i1 <- i + in1to.draw
if(!is.null(ylim))
dotsP$ylim <- ylim[,in1to.draw+i]
else dotsP$ylim <- c(0,1)
@@ -437,7 +450,7 @@
absInfoEval(resc.C$x,absInfoClass.f)
do.call(plot, args=c(list(resc$X, y.vec1, type = plty,
- lty = lty, xlab = xlab0, ylab = ylab.rel,
+ lty = lty, xlab = xlab, ylab = ylab.rel,
col = col, lwd = lwd, panel.last = pL.rel),
dotsP))
@@ -449,9 +462,9 @@
x.ticks = x.ticks,
y.ticks = y.ticks[[i+in1to.draw]])
if(with.legend)
- legend(.legendCoord(legend.location[[i+in1to.draw]],
+ legend(.legendCoord(legend.location[[i1]],
scaleX, scaleX.fct, scaleY, scaleY.fct),
- bg = legend.bg, legend = legend[[i+in1to.draw]],
+ bg = legend.bg, legend = legend[[i1]],
col = c(colI, col), lwd = c(lwdI, lwd),
lty = c(ltyI, lty), cex = legend.cex*fac.leg)
if(innerL)
Modified: branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R 2013-01-12 14:41:38 UTC (rev 531)
@@ -72,8 +72,8 @@
x <- x[is.finite(x)]
x <- pretty(x,n=length(x))
x[distr:::.isEqual01(x)&x<0.4] <- 0
+ X <- scaleX.fct(x)
xf <- prettyNum(x)
- print(xf)
i01 <- !distr:::.isEqual01(X)
xf <- xf[i01]
Xi <- X
@@ -89,6 +89,7 @@
if(is.null(xlim)){ xlim <- c(-Inf,Inf)}else{
if(is.na(xlim[1])) xlim[1] <- -Inf
if(is.na(xlim[2])) xlim[2] <- Inf }
+ x.ticks <- sort(unique(x.ticks[!is.na(x.ticks)]))
xf <- pmin(pmax(x.ticks[is.finite(x.ticks)],xlim[1]),xlim[2])
Xf <- scaleX.fct(xf)
axis(1,at=Xf,labels=xf)
@@ -101,6 +102,7 @@
if(is.null(xlim)){ xlim <- c(-Inf,Inf)}else{
if(is.na(xlim[1])) xlim[1] <- -Inf
if(is.na(xlim[2])) xlim[2] <- Inf }
+ x.ticks <- sort(unique(x.ticks[!is.na(x.ticks)]))
xf <- pmin(pmax(x.ticks[is.finite(x.ticks)],xlim[1]),xlim[2])
axis(1,at=xf,labels=xf)
if(-Inf %in% x.ticks) axis(1,at=0,labels=expression(-infinity))
@@ -114,12 +116,13 @@
Y1 <- if(!is.null(ylim)) min(1, scaleY.fct(ylim[2])) else 1
Y <- seq(Y0,Y1, length=ypts)
y <- pretty(scaleY.inv(Y),n=n)
- print(y)
Y <- distr:::.DistrCollapse(scaleY.fct(y),0*y)$supp
- y <- pretty(scaleY.inv(Y), n=length(Y))
+ y <- scaleY.inv(Y)
+ y <- y[is.finite(y)]
+ y <- pretty(y,n=length(y))
y[distr:::.isEqual01(y)&y<0.4] <- 0
+ Y <- scaleX.fct(y)
yf <- prettyNum(y)
- print(y)
Y <- scaleY.fct(y)
i01 <- !distr:::.isEqual01(Y)
yf <- yf[i01]
@@ -136,6 +139,7 @@
if(is.null(ylim)){ ylim <- c(-Inf,Inf)}else{
if(is.na(ylim[1])) ylim[1] <- -Inf
if(is.na(ylim[2])) ylim[2] <- Inf }
+ y.ticks <- sort(unique(y.ticks[!is.na(y.ticks)]))
yf <- pmin(pmax(y.ticks[is.finite(y.ticks)],ylim[1]),ylim[2])
Yf <- scaleY.fct(yf)
axis(2,at=Yf,labels=yf)
@@ -148,6 +152,7 @@
if(is.null(ylim)){ ylim <- c(-Inf,Inf)}else{
if(is.na(ylim[1])) ylim[1] <- -Inf
if(is.na(ylim[2])) ylim[2] <- Inf }
+ y.ticks <- sort(unique(y.ticks[!is.na(y.ticks)]))
yf <- pmin(pmax(y.ticks[is.finite(y.ticks)],ylim[1]),ylim[2])
axis(2,at=yf,labels=yf)
if(-Inf %in% y.ticks) axis(2,at=0,labels=expression(-infinity))
Modified: branches/robast-0.9/pkg/RobAStBase/man/comparePlot.Rd
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/man/comparePlot.Rd 2013-01-11 20:50:47 UTC (rev 530)
+++ branches/robast-0.9/pkg/RobAStBase/man/comparePlot.Rd 2013-01-12 14:41:38 UTC (rev 531)
@@ -26,7 +26,7 @@
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, return.Order = FALSE)
}
\arguments{
@@ -58,6 +58,9 @@
\code{\link[graphics]{par}}}
\item{col.inner}{character or integer code; color for the inner title}
\item{with.legend}{logical; shall a legend be plotted?}
+ \item{legend}{either \code{NULL} or a list of length (number of plotted panels)
+ of items which can be used as argument \code{legend} in
+ command \code{legend}.}
\item{legend.location}{a valid argument \code{x} for \code{\link{legend}} ---
the place where to put the legend on the last issued
plot}
@@ -81,7 +84,7 @@
missing, the cdf of the underlying observation distribution.}
\item{scaleX.inv}{the inverse function to \code{scale.fct}, i.e., an isotone,
vectorized function mapping [0,1] to the domain of the IC
- such that for any \code{x} in the domain,
+ such that for any \code{x} in the domain,\cr
\code{scaleX.inv(scaleX.fct(x))==x}; if \code{scaleX} is \code{TRUE}
and \code{scaleX.inv} is
missing, the quantile function of the underlying observation distribution.}
@@ -91,7 +94,8 @@
\item{scaleY.inv}{an isotone, vectorized function mapping for each coordinate
the range [0,1] into the range of the respective coordinate of the IC;
defaulting to the quantile function of \eqn{{\cal N}(0,1)}{N(0,1)}.}
- \item{scalen}{integer; defaults to 9; on rescaled axes, number of x and y ticks if drawn automatically;}
+ \item{scaleN}{integer; defaults to 9; on rescaled axes, number of x
+ and y ticks if drawn automatically;}
\item{x.ticks}{numeric; defaults to NULL; (then ticks are chosen automatically);
if non-NULL, user-given x-ticks (on original scale);}
\item{y.ticks}{numeric; defaults to NULL; (then ticks are chosen automatically);
@@ -116,6 +120,14 @@
\item{lab.pts}{character or NULL; labels to be plotted to the observations; if \code{NULL}
observation indices;}
\item{lab.font}{font to be used for labels}
+ \item{alpha.trsp}{alpha transparency to be added ex post to colors
+ \code{col.pch} and \code{col.lbl}; if one-dim and NA all colors are
+ left unchanged. Otherwise, with usual recycling rules \code{alpha.trsp}
+ gets shorted/prolongated to length the data-symbols to be plotted.
+ Coordinates of this vector \code{alpha.trsp} with NA are left unchanged,
+ while for the remaining ones, the alpha channel in rgb space is set
+ to the respective coordinate value of \code{alpha.trsp}. The non-NA
+ entries must be integers in [0,255] (0 invisible, 255 opaque).}
\item{jitter.fac}{jittering factor used in case of a \code{DiscreteDistribution}
for plotting points of the \code{data} argument in a jittered fashion.}
\item{which.lbs}{either an integer vector with the indices of the observations
@@ -173,7 +185,8 @@
}
\author{Peter Ruckdeschel \email{Peter.Ruckdeschel at itwm.fraunhofer.de}}
%\note{}
-\seealso{\code{\link[distrMod]{L2ParamFamily-class}}, \code{\link{IC-class}}, \code{\link[graphics]{plot}}}
+\seealso{\code{\link[distrMod]{L2ParamFamily-class}},
+ \code{\link{IC-class}}, \code{\link[graphics]{plot}}}
\examples{
if(require(ROptEst)){
@@ -185,7 +198,7 @@
comparePlot(IC1,IC2)
-data <- r(N0)(20)
+set.seed(12); data <- r(N0)(20)
comparePlot(IC1, IC2, data=data, with.lab = TRUE,
which.lbs = c(1:4,15:20),
which.Order = 1:6,
@@ -198,6 +211,22 @@
## matrix-valued ylim
comparePlot(IC1, IC2, panel.first= grid(),ylim=c(-4,4,0,4),xlim=c(-6,6))
+x <- c(data,-12,10)
+comparePlot(IC1, IC2, data=x, which.Order=10,
+ panel.first= grid(), ylim=c(-4,4,0,4), xlim=c(-6,6))
+
+Y <- Chisq(df=1)* DiscreteDistribution(c(-1,1))
+comparePlot(IC1, IC2, data=x, which.Order=10,
+ scaleX = TRUE, scaleX.fct=pnorm, scaleX.inv=qnorm,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 531
More information about the Robast-commits
mailing list