[Robast-commits] r1062 - branches/robast-1.1/pkg/RobAStBase branches/robast-1.1/pkg/RobAStBase/R branches/robast-1.1/pkg/RobAStBase/man branches/robast-1.2/pkg/RobAStBase branches/robast-1.2/pkg/RobAStBase/R branches/robast-1.2/pkg/RobAStBase/man pkg/RobAStBase pkg/RobAStBase/R pkg/RobAStBase/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jul 29 00:55:06 CEST 2018
Author: ruckdeschel
Date: 2018-07-29 00:55:06 +0200 (Sun, 29 Jul 2018)
New Revision: 1062
Modified:
branches/robast-1.1/pkg/RobAStBase/NAMESPACE
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/infoPlot.R
branches/robast-1.1/pkg/RobAStBase/R/selectorder.R
branches/robast-1.1/pkg/RobAStBase/man/0RobAStBase-package.Rd
branches/robast-1.1/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-1.1/pkg/RobAStBase/man/plot-methods.Rd
branches/robast-1.2/pkg/RobAStBase/NAMESPACE
branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R
branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R
branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R
branches/robast-1.2/pkg/RobAStBase/R/selectorder.R
branches/robast-1.2/pkg/RobAStBase/man/0RobAStBase-package.Rd
pkg/RobAStBase/NAMESPACE
pkg/RobAStBase/R/AllPlot.R
pkg/RobAStBase/R/comparePlot.R
pkg/RobAStBase/R/infoPlot.R
pkg/RobAStBase/R/selectorder.R
pkg/RobAStBase/man/0RobAStBase-package.Rd
Log:
[RobAStBase] (simultaneous in trunk, branch 1.1, and branch 1.2):
fixed several bugs:
+ in 0RobAStBase-package.Rd: updated Imports field, added Encoding field
+ in example to plot(IC),infoPlot: added seed for reproducibility, expanded argument list
+ in NAMESPACE: added dev.list() into imports from grDevices
+ AllPlot, comparePlot, infoPlot:
* changed default behaviour of lab.pts (as to attr.pre: now always treated as attr.pre==TRUE)
* fixed behaviour under options("newDevice"=TRUE): now only creates new plot in infoPlot.R() for relinfo-part
* bmar, tmar can now be used vectorized
* if return.Order: return ind not ind1
* in comparePlot: wrong arguments for text: it should have been cexl0, coll0, adjl0
* in infoPlot: had mixed up cex.lbs with adj.lbs
* helper .SelectOrderData is simplified now
Modified: branches/robast-1.1/pkg/RobAStBase/NAMESPACE
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/NAMESPACE 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/NAMESPACE 2018-07-28 22:55:06 UTC (rev 1062)
@@ -5,7 +5,7 @@
import("distrMod")
import("RandVar")
importFrom("startupmsg", "buildStartupMessage", "infoShow")
-importFrom("grDevices", "colorRamp", "grey", "rgb")
+importFrom("grDevices", "colorRamp", "grey", "rgb", "dev.list")
importFrom("graphics", "abline", "axis", "box", "lines", "matlines",
"matpoints", "mtext", "par", "points", "text", "title")
importFrom("stats", "complete.cases", "dbinom", "dnorm", "fft",
Modified: branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-28 22:55:06 UTC (rev 1062)
@@ -70,8 +70,8 @@
ncols <- ceiling(dims0/nrows)
yaxt0 <- xaxt0 <- rep("s",dims0)
- if(!is.null(dots$xaxt)) xaxt0 <- rep(dots$xaxt, length.out=dims0)
- if(!is.null(dots$yaxt)) yaxt0 <- rep(dots$yaxt, length.out=dims0)
+ if(!is.null(dots$xaxt)){ xaxt1 <- eval(dots$xaxt); xaxt0 <- rep(xaxt1, length.out=dims0)}
+ if(!is.null(dots$yaxt)){ yaxt1 <- eval(dots$yaxt); yaxt0 <- rep(yaxt1, length.out=dims0)}
logArg <- NULL
if(!is.null(dots[["log"]]))
@@ -182,14 +182,30 @@
w0 <- getOption("warn")
options(warn = -1)
on.exit(options(warn = w0))
- if (!withSweave)
- devNew()
-
+
opar <- par(no.readonly = TRUE)
omar <- par("mar")
- if(mfColRow){ on.exit(par(opar));
- par(mfrow = c(nrows, ncols),mar = c(bmar,omar[2],tmar,omar[4])) }
+ on.exit(par(opar))
+ if(mfColRow) par(mfrow = c(nrows, ncols)) else{
+ if(!withSweave && length(dev.list())>0) devNew()
+ }
+
+
+ wmar <- FALSE
+ if(!missing(bmar)||!missing(tmar)){
+ lpA <- max(dims0,1)
+ parArgsL <- vector("list",lpA)
+ wmar <- TRUE
+ if(missing(bmar)) bmar <- omar[1]
+ if(missing(tmar)) bmar <- omar[3]
+ bmar <- rep(bmar, length.out=lpA)
+ tmar <- rep(tmar, length.out=lpA)
+ for( i in 1:lpA)
+ parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4]))
+ plotInfo$parArgsL <- parArgsL
+ }
+
dotsT$main <- dotsT$cex.main <- dotsT$col.main <- dotsT$line <- NULL
dotsT["pch"] <- dotsT["cex"] <- NULL
@@ -235,10 +251,13 @@
}
+ if(wmar) do.call(par,args=parArgsL[[i]])
+
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), dotsP[[i]])
+
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]],
@@ -356,6 +375,8 @@
adj.lbs <- matrix(rep(adj.lbs, length.out= dims0*2),nrow=2,ncol=dims0)
}
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
+
if(attr.pre){
if(missing(pch.pts)) pch.pts <- 1
if(!length(pch.pts)==n)
@@ -374,7 +395,6 @@
if(missing(col.lbs)) col.lbs <- col.pts
if(!length(col.lbs)==n)
col.lbs <- rep(col.lbs, length.out= n)
- lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
}
@@ -399,7 +419,7 @@
sel <- .SelectOrderData(y, ICabs.f, which.lbs, which.Order, which.nonlbs)
plotInfo$sel <- sel
- plotInfo$obj <- sel$ind1
+ plotInfo$obj <- sel$ind
i.d <- sel$ind
i0.d <- sel$ind1
@@ -408,6 +428,7 @@
i.d.ns <- sel$ind.ns
n.ns <- length(i.d.ns)
+ lab.pts <- lab.pts[sel$ind]
if(attr.pre){
col.pts <- col.pts[sel$ind]
col.npts <- col.pts[sel$ind.ns]
@@ -415,7 +436,6 @@
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]
cex.lbs <- cex.lbs[sel$ind,]
col.lbs <- col.lbs[sel$ind]
}else{
@@ -428,7 +448,6 @@
if(missing(cex.pts)) cex.pts <- 1
if(!length(cex.pts)==n.s)
cex.pts <- rep(cex.pts, length.out= n.s)
- lab.pts <- if(is.null(lab.pts)) paste(1:n.s) else rep(lab.pts,length.out=n.s)
if(missing(pch.npts)) pch.npts <- 1
if(!length(pch.npts)==n.ns)
Modified: branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-28 22:55:06 UTC (rev 1062)
@@ -114,8 +114,8 @@
ncols <- ceiling(dims0/nrows)
yaxt0 <- xaxt0 <- rep("s",dims0)
- if(!is.null(dots$xaxt)) xaxt0 <- rep(dots$xaxt, length.out=dims0)
- if(!is.null(dots$yaxt)) yaxt0 <- rep(dots$yaxt, length.out=dims0)
+ if(!is.null(dots$xaxt)){ xaxt1 <- eval(dots$xaxt); xaxt0 <- rep(xaxt1, length.out=dims0)}
+ if(!is.null(dots$yaxt)){ yaxt1 <- eval(dots$yaxt); yaxt0 <- rep(yaxt1, length.out=dims0)}
logArg <- NULL
if(!is.null(dots[["log"]]))
@@ -212,29 +212,26 @@
w0 <- getOption("warn"); options(warn = -1); on.exit(options(warn = w0))
opar <- par(no.readonly = TRUE)
+ on.exit(par(opar))
omar <- par("mar")
- if(mfColRow){ on.exit(par(opar));
- par(mfrow = c(nrows, ncols),mar = c(bmar,omar[2],tmar,omar[4])) }
-# omar <- par("mar")
-# lpA <- max(dims0,1)
-# parArgsL <- vector("list",lpA)
-# bmar <- rep(bmar, length.out=lpA)
-# tmar <- rep(tmar, length.out=lpA)
-# xaxt0 <- if(is.null(dots$xaxt)) {
-# if(is.null(dots$axes)||eval(dots$axes))
-# rep(par("xaxt"),lpA) else rep("n",lpA)
-# }else rep(eval(dots$xaxt),lpA)
-# yaxt0 <- if(is.null(dots$yaxt)) {
-# if(is.null(dots$axes)||eval(dots$axes))
-# rep(par("yaxt"),lpA) else rep("n",lpA)
-# }else rep(eval(dots$yaxt),lpA)
+ if(mfColRow) par(mfrow = c(nrows, ncols)) else{
+ if(!withSweave && length(dev.list())>0) devNew()
+ }
-# for( i in 1:lpA){
-# parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4])
-# ,xaxt=xaxt0[i], yaxt= yaxt0[i]
-# )
-# }
+ wmar <- FALSE
+ if(!missing(bmar)||!missing(tmar)){
+ lpA <- max(dims0,1)
+ parArgsL <- vector("list",lpA)
+ wmar <- TRUE
+ if(missing(bmar)) bmar <- omar[1]
+ if(missing(tmar)) bmar <- omar[3]
+ bmar <- rep(bmar, length.out=lpA)
+ tmar <- rep(tmar, length.out=lpA)
+ for( i in 1:lpA)
+ parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4]))
+ plotInfo$parArgsL <- parArgsL
+ }
if(is(distr, "DiscreteDistribution")){
x.vecD <- vector("list", dims0)
@@ -277,6 +274,7 @@
n <- if(!is.null(dim(data))) nrow(data) else length(data)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
if(!is.null(cex.pts.fun)){
cex.pts.fun <- .fillList(cex.pts.fun, dims0*ncomp)}
@@ -315,8 +313,6 @@
col.lbs <- t(matrix(rep(col.lbs, length.out= ncomp*n),ncomp,n))
}
- if(!is.null(lab.pts))
- lab.pts <- matrix(rep(lab.pts, length.out=n*ncomp),n,ncomp)
absInfoEval <- function(x,IC){
QF <- ID
@@ -341,11 +337,18 @@
sel1 <- def.sel(IC1); sel2 <- def.sel(IC2)
plotInfo$sel1 <- sel1
plotInfo$sel2 <- sel2
- plotInfo$obj1 <- sel1$ind1
- plotInfo$obj2 <- sel2$ind1
+ plotInfo$obj1 <- sel1$ind
+ plotInfo$obj2 <- sel2$ind
selAlly.s <- c(sel1$y,sel2$y)
selAlly.ns <- c(sel1$y.ns,sel2$y.ns)
+ n.s <- length(sel1$ind)
+ n.ns <- length(sel1$ind.ns)
+
+ lab0.pts <- matrix(NA, n.s, ncomp)
+ lab0.pts[,1] <- lab.pts[sel1$ind]
+ lab0.pts[,2] <- lab.pts[sel2$ind]
+
if(attr.pre){
col0.pts <- col.pts[sel1$ind,]
col0.pts[,2] <- col.pts[sel2$ind,2]
@@ -356,8 +359,6 @@
cex0.pts <- cex.pts[sel1$ind,]
cex0.pts[,2] <- cex.pts[sel2$ind,2]
- lab0.pts <- lab.pts[sel1$ind,]
- lab0.pts[,2] <- lab.pts[sel2$ind,2]
cex0.lbs <- cex.lbs[sel1$ind,,,drop=FALSE]
cex0.lbs[,2,] <- cex.lbs[sel2$ind,2,]
@@ -378,15 +379,15 @@
if(is(obj3, "IC")){ sel3 <- def.sel(IC3)
plotInfo$sel3 <- sel3
- plotInfo$obj3 <- sel3$ind1
+ plotInfo$obj3 <- sel3$ind
selAlly.s <- c(selAlly.s,sel3$y)
selAlly.ns <- c(selAlly.ns,sel3$y.ns)
plotInfo$IC3abs.f <- function(x) absInfoEval(x,IC3)
+ lab0.pts[,3] <- lab.pts[sel3$ind]
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]
cex0.lbs[,3,] <- cex.lbs[sel3$ind,3,]
col0.lbs[,3] <- col.lbs[sel3$ind,3]
col.npts[,3] <- col.pts[sel3$ind.ns,3]
@@ -396,15 +397,15 @@
}
if(is(obj4, "IC")){ sel4 <- def.sel(IC4)
plotInfo$sel4 <- sel4
- plotInfo$obj4 <- sel4$ind1
+ plotInfo$obj4 <- sel4$ind
selAlly.s <- c(selAlly.s,sel4$y)
selAlly.ns <- c(selAlly.ns,sel4$y.ns)
plotInfo$IC4abs.f <- function(x) absInfoEval(x,IC4)
+ lab0.pts[,4] <- lab.pts[sel4$ind]
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[sel4$ind,4]
cex0.lbs[,4,] <- cex.lbs[sel4$ind,4,]
col0.lbs[,4] <- col.lbs[sel4$ind,4]
col.npts[,4] <- col.pts[sel4$ind.ns,4]
@@ -413,16 +414,15 @@
}
}
+ lab.pts <- lab0.pts
+
if(attr.pre){
col.pts <- col0.pts
pch.pts <- pch0.pts
cex.pts <- cex0.pts
- lab.pts <- lab0.pts
cex.lbs <- cex0.lbs
col.lbs <- col0.lbs
}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))
@@ -454,10 +454,6 @@
if(missing(col.lbs)) col.lbs <- col.pts
if(!is.matrix(col.lbs))
col.lbs <- t(matrix(rep(col.lbs, length.out= ncomp*n.s),ncomp,n.s))
-
- 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)
}
@@ -510,9 +506,9 @@
col = col.l, pch = pch.l), dwo0))
if(with.lab0){
text(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
- cex = cexl[,j.l,i], col = coll0[,j.l], adj=adjl[,j.l,i])
+ cex = cexl0[,j.l,i], col = coll0[,j.l], adj=adjl0[,j.l,i])
pI$doLabs[[(i-1)*ncomp+j.l]] <- list(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
- cex = cexl[,j.l,i], col = coll0[,j.l],adj=adjl[,j.l,i])
+ cex = cexl0[,j.l,i], col = coll0[,j.l],adj=adjl0[,j.l,i])
}
}
}
@@ -604,11 +600,7 @@
finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(yM, ylim[2,i],na.rm=TRUE)))
}
-# if(mfColRow){
-# parArgsL[[i]] <- c(parArgsL[[i]],list(mfrow = c(nrows, ncols)))
-# eval(dN)
-# if(i==1) do.call(par,args=parArgsL[[i]])
-# }else{do.call(par,args=parArgsL[[i]])}
+ if(wmar) do.call(par,args=parArgsL[[i]])
assign("plotInfo", plotInfo, envir = trEnv)
do.call(plot, args=c(list(x = resc1$X, y = y0,
Modified: branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R 2018-07-28 22:55:06 UTC (rev 1062)
@@ -112,8 +112,8 @@
in1to.draw <- (1%in%to.draw)
yaxt0 <- xaxt0 <- rep("s",dims1)
- if(!is.null(dots$xaxt)) xaxt0 <- rep(eval(dots$xaxt), length.out=dims1)
- if(!is.null(dots$yaxt)) yaxt0 <- rep(eval(dots$yaxt), length.out=dims1)
+ if(!is.null(dots$xaxt)){ xaxt1 <- eval(dots$xaxt); xaxt0 <- rep(xaxt1, length.out=dims1)}
+ if(!is.null(dots$yaxt)){ yaxt1 <- eval(dots$yaxt); yaxt0 <- rep(yaxt1, length.out=dims1)}
logArg <- NULL
if(!is.null(dots[["log"]]))
@@ -245,12 +245,24 @@
on.exit(options(warn = w0))
# opar$cin <- opar$cra <- opar$csi <- opar$cxy <- opar$din <- NULL
opar <- par(no.readonly = TRUE)
+ on.exit(par(opar))
omar <- par("mar")
- if(mfColRow){ on.exit(par(opar));
- par(mfrow = c(nrows, ncols),mar = c(bmar,omar[2],tmar,omar[4])) }
-# if (!withSweave)
-# devNew()
+
+ wmar <- FALSE
+ if(!missing(bmar)||!missing(tmar)){
+ lpA <- max(dims1,1)
+ parArgsL <- vector("list",lpA)
+ wmar <- TRUE
+ if(missing(bmar)) bmar <- omar[1]
+ if(missing(tmar)) bmar <- omar[3]
+ bmar <- rep(bmar, length.out=lpA)
+ tmar <- rep(tmar, length.out=lpA)
+ for( i in 1:lpA)
+ parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4]))
+ plotInfo$parArgsL <- parArgsL
+ }
+
.pFL <- .preparePanelFirstLast(with.automatic.grid , dims1, pF.0, pL.0,
logArg, scaleX, scaleY, x.ticks, y.ticks,
scaleX.fct, scaleY.fct)
@@ -269,33 +281,19 @@
plotInfo$gridS <- .pFL$gridS
-# omar <- par("mar")
-# lpA <- max(dims1,1)
-# parArgsL <- vector("list",lpA)
-# bmar <- rep(bmar, length.out=lpA)
-# tmar <- rep(tmar, length.out=lpA)
-# xaxt0 <- if(is.null(dots$xaxt)) {
-# if(is.null(dots$axes)||eval(dots$axes))
-# rep(par("xaxt"),lpA) else rep("n",lpA)
-# }else rep(eval(dots$xaxt),lpA)
-# yaxt0 <- if(is.null(dots$yaxt)) {
-# if(is.null(dots$axes)||eval(dots$axes))
-# rep(par("yaxt"),lpA) else rep("n",lpA)
-# }else rep(eval(dots$yaxt),lpA)
-
-# for( i in 1:lpA){
-# parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4])
-# ,xaxt=xaxt0[i], yaxt= yaxt0[i]
-# )
-# }
-
+ wmar <- FALSE
+ if(!missing(bmar)||!missing(tmar)){
+ wmar <- TRUE
+ bmar <-
+ nmar <- c(bmar[i],omar[2],tmar[i],omar[4])
+ }
trEnv <- new.env()
if(!is.null(data)){
n <- if(!is.null(dim(data))) nrow(data) else length(data)
- if(is.null(lab.pts)) lab.pts <- paste(1:n)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
if(!is.null(cex.pts.fun)){
cex.pts.fun <- .fillList(cex.pts.fun, (dims1)*2)
@@ -304,7 +302,7 @@
cex.npts.fun <- .fillList(cex.npts.fun, (dims1)*2)
}
- if(missing(adj.lbs)) cex.lbs <- c(0,0)
+ if(missing(adj.lbs)) adj.lbs <- c(0,0)
if(!is.array(adj.lbs) ||
(is.array(adj.lbs)&&!all.equal(dim(adj.lbs),c(2,2,dims1)))){
adj.lbs <- array(rep(adj.lbs, length.out= 2*dims1*2),
@@ -339,8 +337,6 @@
col.lbs <- t(matrix(rep(col.lbs, length.out= 2*n),2,n))
}
- if(!is.null(lab.pts))
- lab.pts <- rep(lab.pts, length.out=n)
sel <- .SelectOrderData(data, function(x)absInfoEval(x,absInfo.f),
which.lbs, which.Order, which.nonlbs)
@@ -375,6 +371,9 @@
plotInfo$IC <- i0.d
plotInfo$IC.class <- i0.dC
+ labC.pts <- lab.pts[sel.C$ind]
+ lab.pts <- lab.pts[sel$ind]
+
if(attr.pre){
col0.pts <- col.pts[sel$ind,1]
colC.pts <- col.pts[sel.C$ind,2]
@@ -394,10 +393,6 @@
cexC.npts <- cex.npts[sel.C$ind.ns,2]
cex.pts <- cex0.pts; cex.npts <- cex0.npts
- lab0.pts <- lab.pts[sel$ind,1]
- labC.pts <- lab.pts[sel.C$ind,2]
- lab.pts <- lab0.pts
-
cex0.lbs <- matrix(cex.lbs[sel$ind,1,],nrow=n.s,ncol=dims1)
cexC.lbs <- matrix(cex.lbs[sel.C$ind,2,],nrow=n.s,ncol=dims1)
cex.lbs <- cex0.lbs
@@ -456,12 +451,6 @@
col.lbs <- t(matrix(rep(col.lbs, length.out= 2*n.s),2,n.s))
colC.lbs <- col.lbs[,2]
col.lbs <- col.lbs[,1]
-
- if(!is.null(lab.pts)){
- lab.pts <- matrix(rep(lab.pts, length.out= 2*n.s),n.s,2)
- }
- labC.pts <- lab.pts[,2]
- lab.pts <- lab.pts[,1]
}
jitter.fac <- rep(jitter.fac, length.out=2)
@@ -756,8 +745,7 @@
dotsP[[1]] <- resc$dots
-# do.call(par, args = parArgsL[[1]])
-# plotInfo$par.abs <- parArgsL[[1]]
+ if(wmar) do.call(par, args = parArgsL[[1]])
finiteEndpoints <- rep(FALSE,4)
if(scaleX[1]){
@@ -852,6 +840,12 @@
plotInfo$relLegend <- plotInfo$relTitle <- vector("list", dims0)
plotInfo$doLabsRel <- plotInfo$doLabsCRel <- vector("list", dims0)
+ if(mfColRow){
+ if(!withSweave&&in1to.draw && length(dev.list())>0) devNew()
+ par(mfrow = c(nrows, ncols))
+ plotInfo$rel.mfrow <- c(nrows, ncols)
+ }
+
for(i in 1:dims0){
indi <- to.draw1[i]-1
i1 <- i + in1to.draw
@@ -878,12 +872,7 @@
plotInfo$relY[[i]] <- resc$Y
plotInfo$relYc[[i]] <- resc.C$Y
-# if(mfColRow){
-# parArgsL[[i+in1to.draw]] <- c(parArgsL[[i+in1to.draw]],list(mfrow = c(nrows, ncols)))
-# devNew()
-# if(i==1) do.call(par,args=parArgsL[[i+in1to.draw]])
-# } else{do.call(par,args=parArgsL[[i+in1to.draw]])}
-# plotInfo$par.rel[[i]] <- parArgsL[[i+in1to.draw]]
+ if(wmar) do.call(par, args = parArgsL[[i+in1to.draw]])
finiteEndpoints <- rep(FALSE,4)
if(scaleX[i1]){
Modified: branches/robast-1.1/pkg/RobAStBase/R/selectorder.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/selectorder.R 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/R/selectorder.R 2018-07-28 22:55:06 UTC (rev 1062)
@@ -12,11 +12,9 @@
n <- if(dimL) nrow(data) else length(data)
ind <- 1:n
- ### function evaluation
- y <- if(dimL) apply(data, 1, fct) else sapply(data,fct)
#------------------------------------------------------------------------------
- ## selected data : data.t
+ ## firt selection: selected data in first : data.s
#------------------------------------------------------------------------------
### first selection
@@ -26,67 +24,51 @@
which.lbs0 <- ind %in% which.lbs
# the remaining nb of obs after first selection
n.s <- sum(which.lbs0)
+ i.s <- 1:n.s
## produce index for shown data after first selection
- ind.s <- ind[which.lbs0]
- ## function values after first selection
- y.s <- y[ind.s]
+ ind.s <- ind1.s <- ind[which.lbs0]
+ ## first selection
+ data.s <- .SelectIndex(data,1,ind.s)
- ### ordering
- oN.s <- order(y.s)
- ## indices remaining after first selection ordered
- ## from largest function value to smallest
- ind1.s <- rev(ind[oN.s])
-
+#------------------------------------------------------------------------------
### second selection
- ## selection of ordered
- if(is.null(which.Order))
- which.Order <- 1:n.s ## if no 2nd selection performed use all remaining obs.
+#------------------------------------------------------------------------------
- ## from ranks in remaining selection pick out those in which.order
- in.t <- (n.s+1)-which.Order
- in.t <- in.t[in.t>0]
- oN.t <- oN.s[in.t] ## use largest ones in this order
- oN.t <- oN.t[!is.na(oN.t)]
+ ind2 <- ind.s
- ## remaining number of observations after 2nd selection
- n.t <- length(oN.t)
- ## observations indices after 2nd selection
- ind.t <- ind.s[oN.t]
- ind.t <- ind.t[!is.na(ind.t)]
- ## function values after 2nd selection
- y.t <- y[ind.t]
- ## data after both selections
-# data.t <- if(dimL) data[ind.t,] else data[ind.t]
-# # if needed recast it to matrix/array
-# if(dimL) dim(data.t) <- c(n.t,d1[-1])
- data.t <- .SelectIndex(data,1,ind.t)
+ ## function values only after first selection
+ ### function evaluation
+ y.s <- if(dimL) apply(data.s, 1, fct) else sapply(data.s,fct)
+ ## simpler with ranks, see distrMod:::.labelprep
+ rky.s <- n.s+1-rank(y.s)
+ y2.s <- y.s
+ sel2 <- i.s
+ data.t <- data.s
+ ## selection of ordered
+ if(!is.null(which.Order)){
+ sel2 <- i.s[rky.s %in% which.Order]
+ ind2 <- ind2[sel2]
+ y2.s <- y2.s[sel2]
+ data.t <- .SelectIndex(data.s,1,sel2)
+ }
+
+ ord2 <- order(y2.s, decreasing = TRUE)
+ ind2.s <- ind2[ord2]
+ sel2 <- sel2[ord2]
+ data.t <- .SelectIndex(data.t,1,ord2)
+ y.t <- y2.s[ord2]
#------------------------------------------------------------------------------
## data not labelled: data.ns
#------------------------------------------------------------------------------
- if(is.null(which.nonlbs)) which.nonlbs <- 1:n
- #### non selected obs' indices after 1st selection
- ind.ns0 <- ind[!which.lbs0]
- #### non selected obs' indices in 2nd selection
- ind.nt <- if(length(oN.t)) ind.s[-oN.t] else numeric(0)
- #### non selected obs' in total is the union of both non-selected ones
- ind.ns1 <- unique(sort(c(ind.ns0, ind.nt)))
- ind.ns <- ind.ns1[ind.ns1 %in% which.nonlbs]
- ## number of non-selected obs'
- n.ns <- length(ind.ns)
-
-# which.lbns0 <-ind %in% ind.ns
-# which.lbnx <- rep(which.lbns0, length.out=length(data))
-
+ ind.ns <- ind[-ind2]
+ if(length(ind.ns) && !is.null(which.nonlbs))
+ ind.ns <- ind.ns[ind.ns%in%which.nonlbs]
## non selected data
data.ns <- .SelectIndex(data,1,ind.ns)
-# data.ns <- data[which.lbnx]
- # if needed recast it to matrix
-# if(dimL) dim(data.ns) <- c(n.ns,d1[-1])
+ y.ns <- if(dimL) apply(data.ns, 1, fct) else sapply(data.ns,fct)
- y.ns <- y[ind.ns]
-
- return(list(data=data.t, y=y.t, ind=ind.t, ind1=ind1.s, data.ns=data.ns, y.ns=y.ns, ind.ns = ind.ns))
+ return(list(data=data.t, y=y.t, ind=ind2.s, ind1=ind1.s, data.ns=data.ns, y.ns=y.ns, ind.ns = ind.ns))
}
.SelectIndex <- function(data,index,selection){
Modified: branches/robast-1.1/pkg/RobAStBase/man/0RobAStBase-package.Rd
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-07-28 22:55:06 UTC (rev 1062)
@@ -13,11 +13,12 @@
Package: \tab RobAStBase \cr
Version: \tab 1.1.0 \cr
Date: \tab 2018-07-08 \cr
-Depends: \tab R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2),
-RandVar(>= 0.9.2) \cr
+Depends: \tab R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5),
+ distrMod(>= 2.5.2), RandVar(>= 0.9.2)\cr
Suggests: \tab ROptEst, RUnit (>= 0.4.26)\cr
-Imports: \tab startupmsg\cr
+Imports: \tab startupmsg, graphics, grDevices, stats\cr
ByteCompile: \tab yes \cr
+Encoding: \tab latin1 \cr
License: \tab LGPL-3 \cr
URL: \tab http://robast.r-forge.r-project.org/\cr
VCS/SVNRevision: \tab 940 \cr
Modified: branches/robast-1.1/pkg/RobAStBase/man/infoPlot.Rd
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/man/infoPlot.Rd 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/man/infoPlot.Rd 2018-07-28 22:55:06 UTC (rev 1062)
@@ -335,12 +335,13 @@
ylim = c(0,4,0,.3,0,.8), xlim=c(-6,6))
par(mfrow=c(1,1))
+set.seed(123)
data <- r(N)(20)
par(mfrow=c(1,3))
infoPlot(IC1, data=data, mfColRow = FALSE, panel.first= grid(),
with.lab = TRUE, cex.pts=2,
- which.lbs = c(1:4,15:20), which.Order = 1:6,
- return.Order = TRUE)
+ which.lbs = c(1:4,15:20), which.Order = 1:6, cex.lbs=2,
+ return.Order = TRUE,col.pts="red",col.npts="blue")
infoPlot(IC1, data=data[1:10], mfColRow = FALSE, panel.first= grid(),
with.lab = TRUE, cex.pts=0.7)
par(mfrow=c(1,1))
Modified: branches/robast-1.1/pkg/RobAStBase/man/plot-methods.Rd
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/man/plot-methods.Rd 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.1/pkg/RobAStBase/man/plot-methods.Rd 2018-07-28 22:55:06 UTC (rev 1062)
@@ -280,7 +280,7 @@
ylim=c(-3,3,-1,3), xlim=c(-2,3),
with.legend = TRUE)
-data <- r(N)(30)
+set.seed(12);data <- r(N)(30)
plot(IC2, data, panel.first= grid(),
ylim = c(-3,3,-1,3), xlim=c(-2,3),
cex.pts = 3, pch.pts = 1:2, col.pts="green",
Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-07-28 22:55:06 UTC (rev 1062)
@@ -5,7 +5,7 @@
import("distrMod")
import("RandVar")
importFrom("startupmsg", "buildStartupMessage", "infoShow")
-importFrom("grDevices", "colorRamp", "grey", "rgb")
+importFrom("grDevices", "colorRamp", "grey", "rgb", "dev.list")
importFrom("graphics", "abline", "axis", "box", "lines", "matlines",
"matpoints", "mtext", "par", "points", "text", "title")
importFrom("stats", "complete.cases", "dbinom", "dnorm", "fft",
Modified: branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R 2018-07-26 06:49:57 UTC (rev 1061)
+++ branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R 2018-07-28 22:55:06 UTC (rev 1062)
@@ -70,8 +70,8 @@
ncols <- ceiling(dims0/nrows)
yaxt0 <- xaxt0 <- rep("s",dims0)
- if(!is.null(dots$xaxt)) xaxt0 <- rep(dots$xaxt, length.out=dims0)
- if(!is.null(dots$yaxt)) yaxt0 <- rep(dots$yaxt, length.out=dims0)
+ if(!is.null(dots$xaxt)){ xaxt1 <- eval(dots$xaxt); xaxt0 <- rep(xaxt1, length.out=dims0)}
+ if(!is.null(dots$yaxt)){ yaxt1 <- eval(dots$yaxt); yaxt0 <- rep(yaxt1, length.out=dims0)}
logArg <- NULL
if(!is.null(dots[["log"]]))
@@ -182,14 +182,30 @@
w0 <- getOption("warn")
options(warn = -1)
on.exit(options(warn = w0))
- if (!withSweave)
- devNew()
-
+
opar <- par(no.readonly = TRUE)
omar <- par("mar")
- if(mfColRow){ on.exit(par(opar));
- par(mfrow = c(nrows, ncols),mar = c(bmar,omar[2],tmar,omar[4])) }
+ on.exit(par(opar))
+ if(mfColRow) par(mfrow = c(nrows, ncols)) else{
+ if(!withSweave && length(dev.list())>0) devNew()
+ }
+
+
+ wmar <- FALSE
+ if(!missing(bmar)||!missing(tmar)){
+ lpA <- max(dims0,1)
+ parArgsL <- vector("list",lpA)
+ wmar <- TRUE
+ if(missing(bmar)) bmar <- omar[1]
+ if(missing(tmar)) bmar <- omar[3]
+ bmar <- rep(bmar, length.out=lpA)
+ tmar <- rep(tmar, length.out=lpA)
+ for( i in 1:lpA)
+ parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4]))
+ plotInfo$parArgsL <- parArgsL
+ }
+
dotsT$main <- dotsT$cex.main <- dotsT$col.main <- dotsT$line <- NULL
dotsT["pch"] <- dotsT["cex"] <- NULL
@@ -235,10 +251,13 @@
}
+ if(wmar) do.call(par,args=parArgsL[[i]])
+
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), dotsP[[i]])
+
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]],
@@ -356,6 +375,8 @@
adj.lbs <- matrix(rep(adj.lbs, length.out= dims0*2),nrow=2,ncol=dims0)
}
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
+
if(attr.pre){
if(missing(pch.pts)) pch.pts <- 1
if(!length(pch.pts)==n)
@@ -374,7 +395,6 @@
if(missing(col.lbs)) col.lbs <- col.pts
if(!length(col.lbs)==n)
col.lbs <- rep(col.lbs, length.out= n)
- lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
}
@@ -399,7 +419,7 @@
sel <- .SelectOrderData(y, ICabs.f, which.lbs, which.Order, which.nonlbs)
plotInfo$sel <- sel
- plotInfo$obj <- sel$ind1
+ plotInfo$obj <- sel$ind
i.d <- sel$ind
i0.d <- sel$ind1
@@ -408,6 +428,7 @@
i.d.ns <- sel$ind.ns
n.ns <- length(i.d.ns)
+ lab.pts <- lab.pts[sel$ind]
if(attr.pre){
col.pts <- col.pts[sel$ind]
col.npts <- col.pts[sel$ind.ns]
@@ -415,7 +436,6 @@
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]
cex.lbs <- cex.lbs[sel$ind,]
col.lbs <- col.lbs[sel$ind]
}else{
@@ -428,7 +448,6 @@
if(missing(cex.pts)) cex.pts <- 1
if(!length(cex.pts)==n.s)
cex.pts <- rep(cex.pts, length.out= n.s)
- lab.pts <- if(is.null(lab.pts)) paste(1:n.s) else rep(lab.pts,length.out=n.s)
if(missing(pch.npts)) pch.npts <- 1
if(!length(pch.npts)==n.ns)
Modified: branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R
===================================================================
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1062
More information about the Robast-commits
mailing list