[Robast-commits] r944 - branches/robast-1.1/pkg/RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 13 01:58:33 CEST 2018
Author: ruckdeschel
Date: 2018-07-13 01:58:33 +0200 (Fri, 13 Jul 2018)
New Revision: 944
Added:
branches/robast-1.1/pkg/RobAStBase/R/internalSelectLabel.R
branches/robast-1.1/pkg/RobAStBase/R/plotUtils.R
branches/robast-1.1/pkg/RobAStBase/R/ptnorm-convtnorm.R
Modified:
branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R
branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R
branches/robast-1.1/pkg/RobAStBase/R/cutoff-class.R
branches/robast-1.1/pkg/RobAStBase/R/ddPlot.R
branches/robast-1.1/pkg/RobAStBase/R/ddPlot_utils.R
branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R
branches/robast-1.1/pkg/RobAStBase/R/internalGridHelpers.R
branches/robast-1.1/pkg/RobAStBase/R/outlyingPlot.R
branches/robast-1.1/pkg/RobAStBase/R/plotRescaledAxis.R
branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R
branches/robast-1.1/pkg/RobAStBase/R/selectorder.R
Log:
[RobAStBase] branch 1.1: R-Code
Modified: branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-12 23:57:56 UTC (rev 943)
+++ branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-12 23:58:33 UTC (rev 944)
@@ -13,7 +13,28 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL, withSubst = TRUE){
- xc <- match.call(call = sys.call(sys.parent(1)))$x
+ args0 <- list(x = x, withSweave = withSweave,
+ main = main, inner = inner, sub = sub,
+ col.inner = col.inner, cex.inner = cex.inner,
+ bmar = bmar, tmar = tmar, with.automatic.grid = with.automatic.grid,
+ with.legend = with.legend, legend = legend, legend.bg = legend.bg,
+ legend.location = legend.location, legend.cex = legend.cex,
+ withMBR = withMBR, MBRB = MBRB, MBR.fac = MBR.fac, col.MBR = col.MBR,
+ lty.MBR = lty.MBR, lwd.MBR = lwd.MBR,
+ x.vec = x.vec, scaleX = scaleX,
+ scaleX.fct = if(!missing(scaleX.fct)) scaleX.fct else NULL,
+ scaleX.inv = if(!missing(scaleX.inv)) scaleX.inv else NULL,
+ scaleY = scaleY,
+ scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN, x.ticks = x.ticks,
+ y.ticks = y.ticks, mfColRow = mfColRow, to.draw.arg = to.draw.arg,
+ withSubst = withSubst)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ plotInfo <- list(call = mc, dots=dots, args=args0)
+
+ xc <- mc$x
xcc <- as.character(deparse(xc))
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
@@ -40,7 +61,7 @@
L2Fam <- eval(x at CallL2Fam)
if(missing(scaleX.fct)){
scaleX.fct <- p(L2Fam)
- scaleX.inv <- q(L2Fam)
+ scaleX.inv <- q.l(L2Fam)
}
trafO <- trafo(L2Fam at param)
@@ -101,6 +122,12 @@
dots$panel.last <- dots$panel.first <- NULL
+ plotInfo$to.draw <- to.draw
+ plotInfo$panelFirst <- pF
+ plotInfo$panelLast <- pL
+ plotInfo$gridS <- gridS
+
+
MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
MBRB <- MBRB * MBR.fac
@@ -285,14 +312,22 @@
dotsL["cex"] <- dotsLeg["bg"] <- dotsLeg["cex"] <- NULL
dots$ylim <- NULL
+ plotInfo$resc.D <- plotInfo$resc <- vector("list", dims0)
+ plotInfo$PlotLinesD <- plotInfo$PlotUsr <- vector("list", dims0)
+ plotInfo$PlotArgs <- plotInfo$Axis <- vector("list", dims0)
+ plotInfo$MBR <- plotInfo$Legend <- plotInfo$innerTitle <- vector("list", dims0)
+
+
for(i in 1:dims0){
indi <- to.draw[i]
if(!is.null(ylim)) dots$ylim <- ylim[,i]
- fct <- function(x) sapply(x, IC1 at Map[[indi]])
+ fct <- function(x) .msapply(x, IC1 at Map[[indi]])
print(xlim[,i])
resc <-.rescalefct(x.vec, fct, scaleX, scaleX.fct,
scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
ylim[,i], dots)
+
+ plotInfo$resc[[i]] <- resc
dots <- resc$dots
dots$xlim <- xlim[,i]
dots$ylim <- ylim[,i]
@@ -310,68 +345,120 @@
}
+ plotInfo$PlotArgs[[i]] <- c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
+ xlab = .mpresubs(xlab), ylab = .mpresubs(ylab),
+ panel.first = pF[[i]],
+ panel.last = pL[[i]]), dots)
do.call(plot, args=c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
xlab = .mpresubs(xlab), ylab = .mpresubs(ylab),
panel.first = pF[[i]],
panel.last = pL[[i]]), dots))
+
+ plotInfo$PlotUsr[[i]] <- par("usr")
.plotRescaledAxis(scaleX, scaleX.fct, scaleX.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]])
+ plotInfo$Axis[[i]] <- list(scaleX, scaleX.fct, scaleX.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,]
- if(scaleY) MBR.i <- scaleY.fct(MBR.i)
+ if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i)
abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
+ plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
}
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[[i]], xlim[,i],
ylim[,i], dots)
+ plotInfo$resc.D[[i]] <- rescD
x.vecD <- rescD$X
y.vecD <- rescD$Y
dotsL$lty <- NULL
do.call(lines,args=c(list(x.vecD, y.vecD,
lty = "dotted"), dotsL))
+ plotInfo$PlotLinesD[[i]] <- c(list(x.vecD, y.vecD,
+ lty = "dotted"), dotsL)
}
do.call(title,args=c(list(main = innerT[indi]), dotsT, line = lineT,
cex.main = cex.inner, col.main = col.inner))
- if(with.legend)
+ plotInfo$innerTitle[[i]] <- c(list(main = innerT[indi]), dotsT, line = lineT,
+ cex.main = cex.inner, col.main = col.inner)
+
+ if(with.legend){
legend(.legendCoord(legend.location[[i]], scaleX, scaleX.fct,
- scaleY, scaleY.fct), bg = legend.bg,
+ scaleY, scaleY.fct[[i]]), bg = legend.bg,
legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
+ plotInfo$Legend[[i]] <- list(.legendCoord(legend.location[[i]],
+ scaleX, scaleX.fct, scaleY, scaleY.fct[[i]]), bg = legend.bg,
+ legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
+ }
}
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)
+ if (mainL){
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
-
+ plotInfo$mainL <- list(text = main, side = 3, cex = cex.main, adj = .5,
+ outer = TRUE, padj = 1.4, col = col.main)
+ }
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)
+ if (subL){
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
-
- invisible()
+ plotInfo$subL <- list(text = sub, side = 1, cex = cex.sub, adj = .5,
+ outer = TRUE, line = -1.6, col = col.sub)
+ }
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ invisible(plotInfo)
})
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,
+ function(x, y, ...,
+ cex.pts = 1, cex.pts.fun = NULL, col.pts = par("col"),
+ pch.pts = 1,
+ cex.npts = 1, cex.npts.fun = NULL, col.npts = par("col"),
+ pch.npts = 2,
+ 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, which.nonlbs = NULL,
+ attr.pre = FALSE, return.Order = FALSE){
- dots <- match.call(call = sys.call(sys.parent(1)),
+ args0 <- list(x = x, y = y, cex.pts = cex.pts, cex.pts.fun = cex.pts.fun,
+ col.pts = col.pts, pch.pts = pch.pts, cex.npts = cex.npts,
+ cex.npts.fun = cex.npts.fun, col.npts = col.npts, pch.npts = pch.npts,
+ jitter.fac = jitter.fac, with.lab = with.lab, lab.pts = lab.pts,
+ lab.font = lab.font, alpha.trsp = alpha.trsp,
+ which.lbs = which.lbs, which.Order = which.Order,
+ which.nonlbs = which.nonlbs, attr.pre = attr.pre,
+ return.Order = return.Order)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
+ plotInfo <- list(call = mc, dots=dots, args=args0)
n <- if(!is.null(dim(y))) nrow(y) else length(y)
- pch.pts <- rep(pch.pts, length.out=n)
- lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,n)
+ if(attr.pre){
+ if(missing(pch.pts)) pch.pts <- 1
+ if(!length(pch.pts)==n)
+ pch.pts <- rep(pch.pts, length.out= n)
+ if(missing(col.pts)) col.pts <- par("col")
+ if(!length(col.pts)==n)
+ col.pts <- rep(col.pts, length.out= n)
+ if(missing(cex.pts)) cex.pts <- 1
+ if(!length(cex.pts)==n)
+ cex.pts <- rep(cex.pts, length.out= n)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
+ }
L2Fam <- eval(x at CallL2Fam)
@@ -387,17 +474,60 @@
absInfo <- t(IC1) %*% QF %*% IC1
ICMap <- IC1 at Map
- sel <- .SelectOrderData(y, function(x)sapply(x, absInfo at Map[[1]]),
- which.lbs, which.Order)
+ sel <- .SelectOrderData(y, function(x).msapply(x, absInfo at Map[[1]]),
+ which.lbs, which.Order, which.nonlbs)
+ plotInfo$sel <- sel
+ plotInfo$obj <- sel$ind1
+
i.d <- sel$ind
i0.d <- sel$ind1
n <- length(i.d)
+ i.d.ns <- sel$ind.ns
+ n.ns <- length(i.d.ns)
+
+ if(attr.pre){
+ col.pts <- col.pts[sel$ind]
+ col.npts <- col.pts[sel$ind.ns]
+ pch.npts <- pch.pts[sel$ind.ns]
+ pch.pts <- pch.pts[sel$ind]
+ cex.npts <- cex.pts[sel$ind.ns]
+ cex.pts <- cex.pts[sel$ind]
+ lab.pts <- lab.pts[sel$ind]
+ }else{
+ if(missing(pch.pts)) pch.pts <- 1
+ if(!length(pch.pts)==n)
+ pch.pts <- rep(pch.pts, length.out= n)
+ if(missing(col.pts)) col.pts <- par("col")
+ if(!length(col.pts)==n)
+ col.pts <- rep(col.pts, length.out= n)
+ if(missing(cex.pts)) cex.pts <- 1
+ if(!length(cex.pts)==n)
+ cex.pts <- rep(cex.pts, length.out= n)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
+
+ if(missing(pch.npts)) pch.npts <- 1
+ if(!length(pch.npts)==n.ns)
+ pch.npts <- rep(pch.npts, length.out= n.ns)
+ if(missing(col.npts)) col.npts <- par("col")
+ if(!length(col.npts)==n.ns)
+ col.npts <- rep(col.npts, length.out= n.ns)
+ if(missing(cex.npts)) cex.npts <- 1
+ if(!length(cex.npts)==n.ns)
+ cex.npts <- rep(cex.npts, length.out= n.ns)
+ }
+
+
dots.without <- dots
dots.without$col <- dots.without$cex <- dots.without$pch <- NULL
dims0 <- .getDimsTD(L2Fam,dots[["to.draw.arg"]])
+ if(!is.null(cex.pts.fun)){
+ cex.pts.fun <- .fillList(cex.pts.fun)}
+ if(!is.null(cex.npts.fun)){
+ cex.npts.fun <- .fillList(cex.npts.fun)}
+
pL <- expression({})
if(!is.null(dots$panel.last))
pL <- .panel.mingle(dots,"panel.last")
@@ -407,38 +537,85 @@
}
dots$panel.last <- NULL
+ plotInfo$resc.dat <- plotInfo$resc.dat.ns <- vector("list", dims0)
+ plotInfo$doPts <- plotInfo$doPts.ns <- plotInfo$doLabs <- vector("list", dims0)
+ trEnv <- new.env()
+
pL <- substitute({
+ pI <- get("plotInfo", envir = trEnv0)
+
y1 <- y0s
- ICy <- sapply(y0s,ICMap0[[indi]])
- #print(xlim[,i])
- resc.dat <-.rescalefct(y0s, function(x) sapply(x,ICMap0[[indi]]),
+ ICy <- .msapply(y0s,ICMap0[[indi]])
+ resc.dat <-.rescalefct(y0s, function(x) .msapply(x,ICMap0[[indi]]),
scaleX, scaleX.fct, scaleX.inv,
scaleY, scaleY.fct[[i]], xlim[,i], ylim[,i],
dwo0)
+ pI$resc.dat[[i]] <- resc.dat
y1 <- resc.dat$X
ICy <- resc.dat$Y
+ if(is(e1, "DiscreteDistribution")){
+ if(length(ICy)) ICy <- jitter(ICy, factor = jitter.fac0) }
+ y1.ns <- y0s.ns
+ ICy.ns <- .msapply(y0s.ns,ICMap0[[indi]])
+ resc.dat.ns <-.rescalefct(y0s.ns, function(x) .msapply(x,ICMap0[[indi]]),
+ scaleX, scaleX.fct, scaleX.inv,
+ scaleY, scaleY.fct[[i]], xlim[,i], ylim[,i],
+ dwo0)
+ pI$resc.dat.ns[[i]] <- resc.dat.ns
+ y1.ns <- resc.dat.ns$X
+ ICy.ns <- resc.dat.ns$Y
if(is(e1, "DiscreteDistribution"))
- ICy <- jitter(ICy, factor = jitter.fac0)
+ {if(length(ICy.ns)) ICy.ns <- jitter(ICy.ns, factor = jitter.fac0) }
- col.pts <- if(!is.na(al0)) sapply(col0, addAlphTrsp2col,alpha=al0) else col0
+ col.pts <- if(!is.na(al0)) .msapply(col0, addAlphTrsp2col,alpha=al0) else col0
+ col.npts <- if(!is.na(al0)) .msapply(col0.ns, addAlphTrsp2col,alpha=al0) else col0.ns
- do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0,
+ cfun <- if(is.null(cexfun)) NULL else cexfun[[i]]
+ cfun.ns <- if(is.null(cexnfun)) NULL else cexnfun[[i]]
+
+ cex.l <- .cexscale(absy0,absy0,cex=cex0, fun = cfun) ##.cexscale in infoPlot.R
+ cex.l.ns <- .cexscale(absy0.ns,absy0.ns, cex=cex0.ns, fun = cfun.ns) ##.cexscale in infoPlot.R
+
+ if(length(y1)){
+ pI$doPts[[i]] <- c(list(y1, ICy, cex = cex.l,
+ col = col.pts, pch = pch0), dwo0)
+ do.call(points, args=c(list(y1, ICy, cex = cex.l,
col = col.pts, pch = pch0), dwo0))
- if(with.lab0){
+ }
+ if(length(y1.ns)){
+ pI$doPts.ns[[i]] <- c(list(y1.ns, ICy.ns, cex = cex.l.ns,
+ col = col.npts, pch = pch0.ns), dwo0)
+ do.call(points, args=c(list(y1.ns, ICy.ns, cex = cex.l.ns,
+ col = col.npts, pch = pch0.ns), dwo0))
+ }
+ if(with.lab0 && length(y0s)){
text(x = y0s, y = ICy, labels = lab.pts0,
- cex = log(absy0+1)*1.5*cex0, col = col0)
+ cex = cex.l/2, col = col0)
+ pI$doLabs[[i]] <- list(x = y0s, y = ICy, labels = lab.pts0,
+ cex = cex.l/2, col = col0)
}
+ assign("plotInfo", pI, envir = trEnv0)
pL0
- }, 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],
- al0 = alpha.trsp, jitter.fac0 = jitter.fac
+ }, list(pL0 = pL, ICMap0 = ICMap,
+ y0s = sel$data, absy0 = sel$y,
+ y0s.ns = sel$data.ns, absy0.ns = sel$y.ns,
+ dwo0 = dots.without,
+ cex0 = cex.pts, pch0 = pch.pts, col0 = col.pts,
+ cex0.ns = cex.npts, pch0.ns = pch.npts, col0.ns = col.npts,
+ with.lab0 = with.lab, lab.pts0 = lab.pts,
+ al0 = alpha.trsp, jitter.fac0 = jitter.fac,
+ cexfun=cex.pts.fun, cexnfun=cex.npts.fun,
+ trEnv0 = trEnv
))
-
- do.call("plot", args = c(list(x = x, panel.last = pL), dots))
- if(return.Order) return(i0.d)
- invisible()
+ assign("plotInfo", plotInfo, envir = trEnv)
+ ret <- do.call("plot", args = c(list(x = x, panel.last = pL), dots))
+ plotInfo <- get("plotInfo", envir = trEnv)
+ ret$dots <- ret$args <- ret$call <- NULL
+ plotInfo <- c(plotInfo, ret)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ if(return.Order) return(plotInfo)
+ return(invisible(plotInfo))
})
Modified: branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-12 23:57:56 UTC (rev 943)
+++ branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-12 23:58:33 UTC (rev 944)
@@ -16,18 +16,48 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
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,
+ pch.pts = 1,
+ cex.npts = 1, cex.npts.fun = NULL, col.npts = par("col"),
+ pch.npts = 2,
+ jitter.fac = 1, with.lab = FALSE, lab.pts = NULL,
+ lab.font = NULL, alpha.trsp = NA,
+ which.lbs = NULL, which.Order = NULL, which.nonlbs = NULL,
+ attr.pre = FALSE, return.Order = FALSE,
withSubst = TRUE){
+ args0 <- list(obj1 = obj1, obj2 = obj2, obj3 = obj3, obj4 = obj4,
+ data = data, withSweave = withSweave, forceSameModel = forceSameModel,
+ main = main, inner = inner, sub = sub, col = col, lwd = lwd,
+ lty = if(!missing(lty)) lty else NULL,
+ col.inner = col.inner, cex.inner = cex.inner,
+ bmar = bmar, tmar = tmar, with.automatic.grid = with.automatic.grid,
+ with.legend = with.legend, legend = legend, legend.bg = legend.bg,
+ legend.location = legend.location, legend.cex = legend.cex,
+ withMBR = withMBR, MBRB = MBRB, MBR.fac = MBR.fac, col.MBR = col.MBR,
+ lty.MBR = lty.MBR, lwd.MBR = lwd.MBR,
+ x.vec = x.vec, scaleX = scaleX,
+ scaleX.fct = if(!missing(scaleX.fct)) scaleX.fct else NULL,
+ scaleX.inv = if(!missing(scaleX.inv)) scaleX.inv else NULL,
+ scaleY = scaleY, scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN, x.ticks = x.ticks,
+ y.ticks = y.ticks, mfColRow = mfColRow, to.draw.arg = to.draw.arg,
+ cex.pts = cex.pts, cex.pts.fun = cex.pts.fun, col.pts = col.pts,
+ pch.pts = pch.pts, cex.npts = cex.npts, cex.npts.fun = cex.npts.fun,
+ col.npts = col.npts, pch.npts = pch.npts,
+ jitter.fac = jitter.fac, with.lab = with.lab, lab.pts = lab.pts,
+ lab.font = lab.font, alpha.trsp = alpha.trsp,
+ which.lbs = which.lbs, which.Order = which.Order,
+ which.nonlbs = which.nonlbs, attr.pre = attr.pre,
+ return.Order = return.Order, withSubst = withSubst)
.mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ plotInfo <- list(call = .mc, dots=dots, args=args0)
.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)
@@ -35,15 +65,11 @@
ncomp <- 2+ (!missing(obj3)|!is.null(obj3)) +
(!missing(obj4)|!is.null(obj4))
- if(missing(cex.pts)) cex.pts <- 1
- cex.pts <- rep(cex.pts, length.out= ncomp)
-
if(missing(col)) col <- 1:ncomp
else col <- rep(col, length.out = ncomp)
if(missing(lwd)) lwd <- rep(1,ncomp)
else lwd <- rep(lwd, length.out = ncomp)
if(!missing(lty)) rep(lty, length.out = ncomp)
- if(missing(col.pts)) col.pts <- 1:ncomp
dots["type"] <- NULL
xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
@@ -57,7 +83,7 @@
if(missing(scaleX.fct)){
scaleX.fct <- p(L2Fam)
- scaleX.inv <- q(L2Fam)
+ scaleX.inv <- q.l(L2Fam)
}
trafO <- trafo(L2Fam at param)
@@ -84,11 +110,7 @@
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)
@@ -283,11 +305,39 @@
pL <- .fillList(pL, dims0)
dotsP$panel.last <- NULL
+ plotInfo$to.draw <- to.draw
+ plotInfo$panelFirst <- pF
+ plotInfo$panelLast <- pL
+ plotInfo$gridS <- gridS
+
+
sel1 <- sel2 <- sel3 <- sel4 <- NULL
if(!is.null(data)){
n <- if(!is.null(dim(data))) nrow(data) else length(data)
- lab.pts <- rep(lab.pts, length.out=n)
+
+ if(!is.null(cex.pts.fun)){
+ cex.pts.fun <- .fillList(cex.pts.fun, dims0*ncomp)}
+ if(!is.null(cex.npts.fun)){
+ cex.npts.fun <- .fillList(cex.npts.fun, dims0*ncomp)}
+
+ if(attr.pre){
+ if(missing(pch.pts)) pch.pts <- 1
+ if(!is.matrix(pch.pts))
+ pch.pts <- t(matrix(rep(pch.pts, length.out= ncomp*n),ncomp,n))
+
+ if(missing(col.pts)) col.pts <- 1:ncomp
+ if(!is.matrix(col.pts))
+ col.pts <- t(matrix(rep(col.pts, length.out= ncomp*n),ncomp,n))
+
+ if(missing(cex.pts)) cex.pts <- 1
+ if(!is.matrix(cex.pts))
+ cex.pts <- matrix(rep(cex.pts, length.out= ncomp*n),n,ncomp)
+ }
+ if(!is.null(lab.pts))
+ lab.pts <- t(matrix(rep(lab.pts, length.out=n*ncomp),ncomp,n))
+ }
+
absInfoEval <- function(x,IC){
QF <- ID
if(is(IC,"ContIC") & dims>1 ){
@@ -295,87 +345,229 @@
QF <- QuadForm(normtype(IC))
}
absInfo.f <- t(IC) %*% QF %*% IC
- return(sapply(x, absInfo.f at Map[[1]]))
+ return(.msapply(x, absInfo.f at Map[[1]]))
}
def.sel <- function(IC){
fct.aI <- function(x) absInfoEval(x,IC)
- return(.SelectOrderData(data, fct.aI, which.lbs, which.Order))}
+ return(.SelectOrderData(data, fct.aI, which.lbs, which.Order,
+ which.nonlbs))}
sel1 <- def.sel(IC1); sel2 <- def.sel(IC2)
+ plotInfo$sel1 <- sel1
+ plotInfo$sel2 <- sel2
+ plotInfo$obj1 <- sel1$ind1
+ plotInfo$obj2 <- sel1$ind1
selAlly <- c(sel1$y,sel2$y)
+ selAlly.n <- c(sel1$y.ns,sel2$y.ns)
+ if(attr.pre){
+ col0.pts <- col.pts[1:length(sel1$ind),]
+ col0.pts[,1] <- col.pts[sel1$ind,1]
+ col0.pts[,2] <- col.pts[sel2$ind,2]
+ pch0.pts <- pch.pts[1:length(sel1$ind),]
+ pch0.pts[,1] <- pch.pts[sel1$ind,1]
+ pch0.pts[,2] <- pch.pts[sel2$ind,2]
+ cex0.pts <- cex.pts[1:length(sel1$ind),]
+ cex0.pts[,1] <- cex.pts[sel1$ind,1]
+ cex0.pts[,2] <- cex.pts[sel2$ind,2]
+ lab0.pts <- lab.pts[1:length(sel1$ind),]
+ lab0.pts[,1] <- lab.pts[sel1$ind,1]
+ lab0.pts[,2] <- lab.pts[sel2$ind,2]
+
+ col.npts <- col.pts[1:length(sel1$ind.ns),]
+ col.npts[,1] <- col.pts[sel1$ind.ns,1]
+ col.npts[,2] <- col.pts[sel2$ind.ns,2]
+ pch.npts <- pch.pts[1:length(sel1$ind.ns),]
+ pch.npts[,1] <- pch.pts[sel1$ind.ns,1]
+ pch.npts[,2] <- pch.pts[sel2$ind.ns,2]
+ cex.npts <- cex.pts[1:length(sel1$ind.ns),]
+ cex.npts[,1] <- cex.pts[sel1$ind.ns,1]
+ cex.npts[,2] <- cex.pts[sel2$ind.ns,2]
+ }
+
+
if(is(obj3, "IC")){ sel3 <- def.sel(IC3)
+ plotInfo$sel3 <- sel3
+ plotInfo$obj3 <- sel1$ind3
selAlly <- c(selAlly,sel3$y)
+ selAlly.ns <- c(selAlly,sel3$y.ns)
+ if(attr.pre){
+ col0.pts[,3] <- col.pts[sel3$ind,3]
+ pch0.pts[,3] <- pch.pts[sel3$ind,3]
+ cex0.pts[,3] <- cex.pts[sel3$ind,3]
+ lab0.pts[,3] <- lab.pts[sel3$ind,3]
+ col.npts[,3] <- col.pts[sel3$ind.ns,3]
+ pch.npts[,3] <- pch.pts[sel3$ind.ns,3]
+ cex.npts[,3] <- cex.pts[sel3$ind.ns,3]
+ }
}
if(is(obj4, "IC")){ sel4 <- def.sel(IC4)
+ plotInfo$sel4 <- sel4
+ plotInfo$obj4 <- sel1$ind4
selAlly <- c(selAlly,sel4$y)
+ selAlly.ns <- c(selAlly,sel4$y.ns)
+ if(attr.pre){
+ col0.pts[,4] <- col.pts[sel4$ind,4]
+ pch0.pts[,4] <- pch.pts[sel4$ind,4]
+ cex0.pts[,4] <- cex.pts[sel4$ind,4]
+ lab0.pts[,4] <- lab.pts[sel3$ind,4]
+ col.npts[,4] <- col.pts[sel4$ind.ns,4]
+ pch.npts[,4] <- pch.pts[sel4$ind.ns,4]
+ cex.npts[,4] <- cex.pts[sel4$ind.ns,4]
+ }
}
+ if(attr.pre){
+ col.pts <- col0.pts
+ pch.pts <- pch0.pts
+ cex.pts <- cex0.pts
+ lab.pts <- lab0.pts
+ }else{
+ n.s <- length(sel1$ind)
+ n.ns <- length(sel1$ind.ns)
+ if(missing(pch.pts)) pch.pts <- 1
+ if(!is.matrix(pch.pts))
+ pch.pts <- t(matrix(rep(pch.pts, length.out= ncomp*n.s),ncomp,n.s))
+ if(missing(pch.npts)) pch.npts <- 2
+ if(!is.matrix(pch.npts))
+ pch.npts <- t(matrix(rep(pch.npts, length.out= ncomp*n.ns),ncomp,n.ns))
+
+ if(missing(col.pts)) col.pts <- 1:ncomp
+ if(!is.matrix(col.pts))
+ col.pts <- t(matrix(rep(col.pts, length.out= ncomp*n.s),ncomp,n.s))
+ if(missing(col.npts)) col.pts <- 1:ncomp
+ if(!is.matrix(col.npts))
+ col.npts <- t(matrix(rep(col.npts, length.out= ncomp*n.ns),ncomp,n.ns))
+
+ if(missing(cex.pts)) cex.pts <- 1
+ if(!is.matrix(cex.pts))
+ cex.pts <- matrix(rep(cex.pts, length.out= ncomp*n.s),n.s,ncomp)
+ if(missing(cex.npts)) cex.npts <- 1
+ if(!is.matrix(cex.npts))
+ cex.npts <- matrix(rep(cex.npts, length.out= ncomp*n.ns),n.ns,ncomp)
+
+ if(missing(lab.pts)) lab.pts <- 1:n.s
+ if(!is.matrix(lab.pts))
+ lab.pts <- matrix(rep(lab.pts, length.out= ncomp*n.s),n.s,ncomp)
+ }
+
+
dots.points <- .makedotsLowLevel(dots)
dots.points$col <- dots.points$cex <- dots.points$pch <- NULL
alp.v <- rep(alpha.trsp,length.out = ncomp)
+ plotInfo$resc.D <- plotInfo$resc <- vector("list", ncomp*dims0)
+ plotInfo$resc.dat <- plotInfo$resc.dat.ns <- vector("list", ncomp*dims0)
+ plotInfo$doPts <- plotInfo$doPts.ns <- plotInfo$doLabs <- vector("list", ncomp*dims0)
+ plotInfo$PlotLines <- plotInfo$PlotPoints <- plotInfo$PlotUsr <- vector("list", dims0)
+ plotInfo$PlotLinesD <- plotInfo$PlotArgs <- plotInfo$Axis <- vector("list", dims0)
+ plotInfo$MBR <- plotInfo$Legend <- plotInfo$innerTitle <- vector("list", dims0)
+
+ trEnv <- new.env()
+
pL <- substitute({
- doIt <- function(sel.l,fct.l,j.l){
+
+ doIt <- function(sel.l,fct.l,j.l, trEnv1){
+ pI <- get("plotInfo", envir = trEnv1)
rescd <- .rescalefct(sel.l$data, fct.l, scaleX, scaleX.fct,
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])
+ if(is(distr, "DiscreteDistribution")){
+ if(length(rescd$Y))
+ rescd$Y <- jitter(rescd$Y, factor = jitter.fac0[j.l])
+ }
i.l <- sel.l$ind
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])
+ i.l.ns <- sel.l$ind.ns
+ n.l.ns <- length(i.l.ns)
+ pI$resc.dat[[(i-1)*ncomp+j.l]] <- rescd[i.l]
+ pI$resc.dat.ns[[(i-1)*ncomp+j.l]] <- rescd[i.l.ns]
+
+ lab.pts.l <- if(is.null(lab0)) paste(i.l) else lab0[,j.l]
+
+ col.l <- if(is.na(al0[j.l])) col0[,j.l] else
+ addAlphTrsp2col(col0[,j.l], al0[j.l])
+ col.l.ns <- if(is.na(al0[j.l])) coln0[,j.l] else
+ addAlphTrsp2col(coln0[,j.l], al0[j.l])
+
+ pch.l <- pch0[,j.l]
+ pch.l.ns <- pchn0[,j.l]
+
cfun <- if(is.null(cexfun)) NULL else cexfun[[(i-1)*ncomp+j.l]]
+ cfun.ns <- if(is.null(cexnfun)) NULL else cexnfun[[(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,
- col = col.l, pch = pch.pts.l), dwo0))
- if(with.lab0)
- text(rescd$X, rescd$Y, labels = lab.pts.l,
+ cex.l <- .cexscale(sel.l$y,selAlly,cex=cex0[,j.l], fun = cfun) ##.cexscale in infoPlot.R
+ cex.l.ns <- .cexscale(sel.l$y.ns,selAlly.ns, cex=cexn0[,j.l], fun = cfun.ns) ##.cexscale in infoPlot.R
+
+ if(length(rescd$X[i.l])){
+ pI$doPts[[(i-1)*ncomp+j.l]] <- c(list(rescd$X[i.l], rescd$Y[i.l], cex = cex.l,
+ col = col.l, pch = pch.l), dwo0)
+ do.call(points, args=c(list(rescd$X[i.l], rescd$Y[i.l], cex = cex.l,
+ col = col.l, pch = pch.l), dwo0))
+ }
+ if(length(rescd$X[i.l.ns])){
+ pI$doPts.ns[[(i-1)*ncomp+j.l]] <- c(list(rescd$X[i.l.ns], rescd$Y[i.l.ns], cex = cex.l.ns,
+ col = col.l.ns, pch = pch.l.ns), dwo0)
+ do.call(points, args=c(list(rescd$X[i.l.ns], rescd$Y[i.l.ns], cex = cex.l.ns,
+ col = col.l.ns, pch = pch.l.ns), dwo0))
+ }
+ if(length(rescd$X[i.l])){
+ if(with.lab0){
+ text(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
cex = cex.l/2, col = col.l)
+ pI$doLabs[[(i-1)*ncomp+j.l]] <- list(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
+ cex = cex.l/2, col = col.l)
+ }
+ }
+ assign("plotInfo", pI, envir = trEnv1)
}
- doIt(sel1,fct1,1); doIt(sel2,fct2,2)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 944
More information about the Robast-commits
mailing list